Основной модуль программы задача о коммивояжере

unit Unit1;

interface

uses unit2, unit3,
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, StdCtrls, ExtCtrls;

const dx=400 ;dy =400;
      pop_size=100;
      b_rand = 0;
      b_crosfade = 1;
      b_mutate1 = 2;
      b_mutate2 = 4;      
      b_cros = 3;
type

  one = record
    way : array of word;
    price:real;
    birth:byte;//каким образом получен
  end;

  Pone = ^one;

  TForm1 = class(TForm)
    Panel1: TPanel;
    SpeedButton2: TSpeedButton;
    Edit2: TEdit;
    Label2: TLabel;
    SpeedButton1: TSpeedButton;
    Panel2: TPanel;
    CheckBox1: TCheckBox;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label1: TLabel;
    Edit1: TEdit;
    Timer1: TTimer;
    Panel3: TPanel;
    Label3: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    SpeedButton3: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SBRgene(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
  private
    { Private declarations }
  public
    procedure Sh;
    { Public declarations }
  end;

  vectorway = class
    pts : array of tpoint;
    way : array of word;
    price,maxprice:real;
    stat:array[0..4] of integer;
    wayfound : boolean;
    procedure randomsites(n:integer);//случайно расположить n городов
    constructor create;
    destructor destroy;
    procedure reset;
    function integrity(r:pointer):boolean;
    procedure Zerrulation;
    function Compare(r,r1:pointer):boolean;
    function CalcWay(r:pointer):real;
    procedure randomway(var t:one);
    procedure MutateType2(zz:pointer;ind1,ind2:integer);//ind1-кого, ind2-куда
    procedure LocalMin(zz:pointer;ind1,ind2,len:integer);//ind1 - индекс массива r ind2- номер точки в массиве pts, len-длина последовательног минимума
    function CrossFade(t:pone):integer;
    function Crossed(a,a1,b,b1:integer):boolean;
  end;

  sr = class(Tthread)
    suspendrequest:boolean;
    exitrequest:boolean;
    constructor Create(Suspended:boolean);
    procedure Execute; override;
  end;

var
  Form1: TForm1;
  a: vectorway;
  t: tpicture;
  popul : array[1..pop_size] of one;
  z:sr;

implementation

function min(a,b:word):word;
begin
  if a>b then result:=b else result:=a;
end;

function max(a,b:word):word;
begin
  if a<b>ind2 then k:=-1 else k:=1;
  r:=p[ind1];
  while ind1<>ind2 do
  begin
    p[ind1]:=p[ind1+k];
    ind1:=ind1+k;
  end;
  p[ind2]:=r;
end;

function vectorway.Crossed(a,a1,b,b1:integer):boolean;//переверка пересечения двух отрезков
var c,c1,d,d1,x:real;
  function inside(a:real;b,c:integer):boolean;
  begin
    if (a>min(b,c)) and (a<max(b,c)) then="" result:="true" else="" end;="" begin="" c:="(pts[a1].Y-pts[a].Y)/(pts[a1].x-pts[a].x+0.0000000001);//найдём" параметры="" прямых,="" на="" которых="" лежат="" отрезки="" d:="pts[a1].Y-c*pts[a1].X;" c1:="(pts[b1].Y-pts[b].Y)/(pts[b1].x-pts[b].x+0.0000000001);" d1:="pts[b1].Y-c1*pts[b1].X;" if="" c<="">c1 then
  begin
    x:=(d1-d)/(c-c1);//решение по x системы уравнений
    if inside(x,pts[a1].x,pts[a].x) and inside(x,pts[b1].x,pts[b].x) then result:=true;
  end;
end;

function vectorway.CrossFade(t:pone):integer;
var k,j,mxp,ex:integer;
    r:real;
  procedure excahnge(m,n:integer);
  begin
    while mt.price then
          excahnge(k+1,j)//если это ведет к ухудшению, то отмена снятия перекрестия
        else
        begin
          t.price:=r;
          t.birth:=b_crosfade;
        end;
      end;
end;

constructor sr.Create(Suspended:boolean);
begin
  inherited create(suspended);
  suspendrequest:=false;
  exitrequest:=false;
  priority:=tpIdle;
end;

function vectorway.Compare(r,r1:pointer):boolean;
var k:integer;
    p,p1:array of word;
begin
  p:=r;
  p1:=r1;
  result:=true;
  k:=min(length(p),length(p1));
  while k>0 do
  begin
    dec(k);
    if p[k]<>p1[k] then
    begin
      result:=false;
      exit;
    end;
  end;
end;

function vectorway.integrity(r:pointer):boolean;
var f:array of word;
    k,k0,mxp:integer;
label okk;
begin
  result:=false;
  f:=r;
  mxp:=length(pts)-1;
  k:=mxp;
  while k>=0 do
  begin
    k0:=mxp;
    while k0>=0 do
    begin
      if f[k0]=k then goto okk;
      dec(k0);
    end;
    exit;//тест не пройден - целостность нарушена
okk:
    dec(k);
  end;
  result:=true;
end;

procedure vectorway.LocalMin(zz:pointer;ind1,ind2,len:integer);//ind1 - индекс массива r ind2- номер точки в массиве pts, len-длина последовательног минимума
var p:array of word;
    mxp,k,j,j1:integer;
    flag:array of boolean;//если i-й элемент = true хначит он заблокирован для использования
    pos:array of word;//i-й элемент хранит позицию i-ого города
    r1,r:integer;
begin
  p:=zz;
  mxp:=length(pts);
//  setlength(flag,0);//очистка флаго-индексного массива
  setlength(flag,mxp);
  setlength(pos,mxp);
  for k:=0 to mxp-1 do pos[p[k]]:=k;//индексация для быстрого поиска - существенно для большого числа точек
  flag[ind1]:=true;//сразу блокируем указанную точку
//  flag[0]:=true;
  k:=pos[ind2];//позиция ind2 в массиве p
  j1:=p[ind1];   //обмен начальной точки
  p[ind1]:=ind2;
  p[k]:=j1;
  pos[ind2]:=ind1;
  pos[j1]:=k;
  while len>0 do //типа  for k0:=ind1 to ind1+len-2 do//заполняем координаты вектора
  begin
    r1:=2000000;//минимум расстояния
    j:=0;//номер
    k:=mxp-1;//инициализация сканера
    while k>=0 do
    begin
      if not flag[k] then//если претендент ещё не используется в векторе
      begin
        j1:=p[ind1];//номер предыдущей точки
        r:=sqr(a.pts[j1].X-a.pts[k].X)+sqr(a.pts[j1].y-a.pts[k].y);//квадрат расстояния
        if r=mxp then ind1:=0;//если ind1=mpx+1 иными словами - достигли границы массива
    dec(len);
  end;
end;

procedure vectorway.randomway(var t:one);
var k,j,j1:integer;
    a:word;
begin
  k:=length(pts)-1;
  setlength(t.way,k+1);
  t.birth:=b_rand;
  for j:=0 to k do t.way[j]:=j;//по порядку расставим
  for j:=0 to k do
  begin
    j1:=random(k);
    if j1<>j then//сам с собой не должен менятся
    begin
      a:=t.way[j];
      t.way[j]:=t.way[j1];
      t.way[j1]:=a;
    end;
  end;
end;

function vectorway.calcway(r:pointer):real;
var d:array of word;
    k,j1,j2:integer;
begin
  d:=r;
  result:=0;
  for k:=0 to length(d)-2 do
  begin
    j1:=d[k];
    j2:=d[k+1];
    result:=result+sqrt(sqr(pts[j1].X-pts[j2].X)+sqr(pts[j1].Y-pts[j2].Y));
  end;
  j1:=d[0];//между первым и последним сколько
  result:=result+sqrt(sqr(pts[j1].X-pts[j2].X)+sqr(pts[j1].Y-pts[j2].Y));
end;

constructor vectorway.create;
begin
  inherited create;
  Zerrulation;
end;

destructor vectorway.destroy;
begin
  Zerrulation;
  inherited destroy;
end;

procedure vectorway.Zerrulation;
begin
  setlength(pts,0);
  setlength(way,0);
  reset;
end;

procedure vectorway.randomsites(n:integer);//случайно расположить n городов
var k,j:integer;
label sgs;
begin
  setlength(pts,n);
  setlength(way,n);
  reset;
  for k:=0 to n-1 do
  begin
sgs:
    pts[k].X:=random(dx);
    pts[k].Y:=random(dy);
    if k>0 then
      for j:=0 to k-1 do
        if sqr(pts[j].X-pts[k].X)+sqr(pts[j].Y-pts[k].Y)<36 then goto sgs;
  end;
end;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  randomize;
  a:=vectorway.create;
  t:=tpicture.Create;
  t.Bitmap.Width:=dx;
  t.Bitmap.Height:=dy;
  z:=sr.Create(true);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  z.exitrequest:=true;
  z.Resume;
  while z.exitrequest do sleep(100); //ждем терминации
  z.Destroy;
  a.destroy;
  t.Destroy;
end;

procedure Tform1.Sh;
  procedure showcitys;
  var k:integer;
      zz:Tcanvas;
  begin
    zz:=t.bitmap.canvas;
    zz.Brush.Color:=color;
    zz.Rectangle(0,0,dx,dy);
    for k:=0 to length(a.pts)-1 do
    begin
      if k=0 then zz.Brush.Color:=clblack else zz.Brush.Color:=color;
      zz.Ellipse(a.pts[k].X-2,a.pts[k].y-2,a.pts[k].X+2,a.pts[k].y+2);
    end;
    zz.Brush.Color:=color;
    if a.wayfound then
    begin
      zz.MoveTo(a.pts[a.way[0]].x,a.pts[a.way[0]].y);
      for k:=1 to length(a.way)-1 do
        zz.LineTo(a.pts[a.way[k]].X,a.pts[a.way[k]].y);
      zz.LineTo(a.pts[a.way[0]].X,a.pts[a.way[0]].y);//к первому городу
    end;
  end;
  var aaa:real;
begin
  showcitys;
  canvas.CopyRect(rect(1,1,dx+1,dy+1),t.Bitmap.Canvas,rect(0,0,dx,dy));
  if a.wayfound then
  begin
    aaa:=a.calcway(a.way);
    label12.caption:=floattostr(aaa);
    label13.caption:=format('%f %%',[100*aaa/a.maxprice]);
    label5.Caption:=inttostr(a.stat[2]);
    label7.Caption:=inttostr(a.stat[1]);
    label9.Caption:=inttostr(a.stat[3]);
    label11.Caption:=inttostr(a.stat[4]);
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Sh;
end;

procedure TForm1.SBRgene(Sender: TObject);
var n:integer;
begin
  try
    n:=strtoint(edit1.text);
  except
    on Econverterror do n:=0;
  end;
  if n>2000 then n:=2000;
  if n<3 then n:=3;
  edit1.Text:=inttostr(n);
  a.randomsites(n);
  sh;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  if length(a.pts)<=2 then exit;
  z.Resume;
  timer1.Interval:=length(a.pts);
  if timer1.Interval<300 then timer1.Interval:=300;
  if timer1.Interval>2000 then timer1.Interval:=2000;
  timer1.Enabled:=true;
  form2.showmodal;//ждем-с
  z.suspendrequest:=true;
  while not z.suspendrequest do sleep(100);
  sh;
  timer1.Enabled:=false;
end;

procedure sr.Execute;
const Co=2;
var ng,k0,k,j,j1,mxp:integer;
    minval,maxval:integer;//минимальный и максимальный путь
    best:word;//номер лучшей особи - Элитизм
    fc:array[1..pop_size] of one;
    M,mst:integer;//число мутаций на одну особь
    r:real;
    bra:word;
    cros_count,locmin_len:integer;
//    virra: array of word;//для имитации переписи
label nxt_gen,aga,elite,nxt_genseries,fina,start;
  function getgennum:integer;
  begin
    try //установим число поколений
      result:=strtoint(form1.edit2.Text);
    except
      on Econverterror do result:=0;
    end;
    if Result<10 then result:=10;   //минимальное число поколений
  end;
begin
start:
  mxp:=length(a.pts);//число городов
  if mxp<2 then goto fina;
  mst:=1;//  round(ln(mxp)); //предел мутации на одну особь
//создадим случайную популяцию из k особей
  setlength(a.way,mxp);//резервирование места для лучшего пути - типа текущее решение задачи
  for k:=1 to pop_size do
  begin
    a.randomway(popul[k]);//создание случайных путей
    setlength(fc[k].way,mxp);//резервирование места для массива дублёра
  end;
  cros_count:=0;//число поколений до проверки лучшего варианта на перекрещивание
  locmin_len:=trunc(sqrt(mxp)); //максимальная длина цепочки локальной минимизации
//Начало поколения
  best:=1;//допустим так - первая особь самая лучшая
  if a.wayfound then//но если решение какое-то есть, то возьмём его как лучшее
    copymemory(popul[best].way,a.way,mxp*sizeof(word))
  else //иначе локальным минимумом его найдём
  begin
    a.price:=1e22;
    a.LocalMin(popul[best].way,0,0,mxp);
    popul[best].birth:=b_cros;
  end;
nxt_genseries:
  ng:=GetGenNum;//число поколений до визуализации
  m:=1+random(mst);//число мутаций в поколении на одну особь
nxt_gen:
  minval:=2000000; maxval:=0;//инициализация для поиска
  dec(cros_count);
  if cros_count<=0 then cros_count:=a.CrossFade(@popul[best]);//раз в десять поколений снятие перекрестий
  for k0:=1 to pop_size do    //по всем особям
  begin
    if k0=best then goto elite;//элитные особи не подвергаются мутациям и изменениям ген. информации
//Кросовер - локальная минимизация
    r:=random;
    if r<0.34 then
    begin
      for j1:=1 to m do//кросовер
      begin
        k:=random(mxp);
//        j:=min(2+random(mxp div 3),10);
        j:=2+random(locmin_len);
        a.LocalMin(popul[k0].way,k,popul[k0].way[k],j);
      end;
      popul[k0].birth:=b_cros;
    end else
      if r<0.67 then//Мутация 1 - сводится к одиночной перестановке
      begin
        for k:=1 to m do
        begin
          j:=random(mxp);
          j1:=random(mxp);
          if j<>j1 then
          begin
            bra:=popul[k0].way[j];
            popul[k0].way[j]:=popul[k0].way[j1];
            popul[k0].way[j1]:=bra;
          end;
        end;
        popul[k0].birth:=b_mutate1;
      end else //Мутация 2 - сводится к одиночной перекомпановке
      begin
//        for k:=1 to m do
        a.MutateType2(popul[k0].way,random(mxp),random(mxp));
        popul[k0].birth:=b_mutate2;
      end;
//Оценка особей
elite:
    r:=a.CalcWay(popul[k0].way);
    if rmaxval then maxval:=round(r);
    popul[k0].price:=r;
  end;
  maxval:=minval+((maxval-minval)*1) shr 4 ;//порог элитизма
  minval:=0;
//  maxval:=(maxval+minval) shr 1;//попалам делим
  for k:=1 to pop_size do
    if popul[k].price<=maxval then //если путь короче среднего по популяции
    begin           //то проведём выборку этой особи - Элитизм
      inc(minval);
      fc[minval].price:=popul[k].price;
      fc[Minval].birth:=popul[k].birth;
      copymemory(fc[minval].way,popul[k].way,mxp*sizeof(word));
    end;
  maxval:=minval;
  while maxval0) and (not suspendrequest) then goto nxt_gen;
//  form1.sh;//form1.Invalidate;
  if not (suspendrequest or exitrequest) then goto nxt_genseries;
fina:
  suspendrequest:=false;
  suspend;
  if exitrequest then
  begin
    exitrequest:=false;
    exit;  //это для закрытия приложения нужно быть вне процедуры execute
  end;
  goto start;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var k:integer;
begin
  k:=length(a.pts);
  if mbRight = button then//удаление
  begin
    if k>0 then setlength(a.pts,k-1);
    edit1.Text:=inttostr(k-1);    
    a.Reset;
  end;
  if mbLeft = button then//нанесение новых точек
  begin
    setlength(a.pts,k+1);
    a.reset;
    a.pts[k].X:=x-1;
    a.pts[k].y:=y-1;
    edit1.Text:=inttostr(k+1);
  end;
  Sh;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  sh;
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  form3.show;
end;

end.
</max(b,c))></b>

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

530

531

532

533

534

535

536

537

538

539

540

541

542

543

544

545

546

547

548

549

550

551

552

553

554

555

unit Unit1;

interface

uses unit2, unit3,

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, Buttons, StdCtrls, ExtCtrls;

const dx=400 ;dy =400;

pop_size=100;

b_rand = 0;

b_crosfade = 1;

b_mutate1 = 2;

b_mutate2 = 4;

b_cros = 3;

type

one = record

way : array of word;

price:real;

birth:byte;//каким образом получен

end;

Pone = ^one;

TForm1 = class(TForm)

Panel1: TPanel;

SpeedButton2: TSpeedButton;

Edit2: TEdit;

Label2: TLabel;

SpeedButton1: TSpeedButton;

Panel2: TPanel;

CheckBox1: TCheckBox;

Label4: TLabel;

Label5: TLabel;

Label6: TLabel;

Label7: TLabel;

Label8: TLabel;

Label9: TLabel;

Label10: TLabel;

Label11: TLabel;

Label1: TLabel;

Edit1: TEdit;

Timer1: TTimer;

Panel3: TPanel;

Label3: TLabel;

Label12: TLabel;

Label13: TLabel;

SpeedButton3: TSpeedButton;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure FormPaint(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

procedure SBRgene(Sender: TObject);

procedure FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Timer1Timer(Sender: TObject);

procedure SpeedButton3Click(Sender: TObject);

private

{ Private declarations }

public

procedure Sh;

{ Public declarations }

end;

vectorway = class

pts : array of tpoint;

way : array of word;

price,maxprice:real;

stat:array[0..4] of integer;

wayfound : boolean;

procedure randomsites(n:integer);//случайно расположить n городов

constructor create;

destructor destroy;

procedure reset;

function integrity(r:pointer):boolean;

procedure Zerrulation;

function Compare(r,r1:pointer):boolean;

function CalcWay(r:pointer):real;

procedure randomway(var t:one);

procedure MutateType2(zz:pointer;ind1,ind2:integer);//ind1-кого, ind2-куда

procedure LocalMin(zz:pointer;ind1,ind2,len:integer);//ind1 - индекс массива r ind2- номер точки в массиве pts, len-длина последовательног минимума

function CrossFade(t:pone):integer;

function Crossed(a,a1,b,b1:integer):boolean;

end;

sr = class(Tthread)

suspendrequest:boolean;

exitrequest:boolean;

constructor Create(Suspended:boolean);

procedure Execute; override;

end;

var

Form1: TForm1;

a: vectorway;

t: tpicture;

popul : array[1..pop_size] of one;

z:sr;

implementation

function min(a,b:word):word;

begin

if a>b then result:=b else result:=a;

end;

function max(a,b:word):word;

begin

if a<b>ind2 then k:=-1 else k:=1;

r:=p[ind1];

while ind1<>ind2 do

begin

p[ind1]:=p[ind1+k];

ind1:=ind1+k;

end;

p[ind2]:=r;

end;

function vectorway.Crossed(a,a1,b,b1:integer):boolean;//переверка пересечения двух отрезков

var c,c1,d,d1,x:real;

function inside(a:real;b,c:integer):boolean;

begin

if (a>min(b,c)) and (a<max(b,c)) then="" result:="true" else="" end;="" begin="" c:="(pts[a1].Y-pts[a].Y)/(pts[a1].x-pts[a].x+0.0000000001);//найдём" параметры="" прямых,="" на="" которых="" лежат="" отрезки="" d:="pts[a1].Y-c*pts[a1].X;" c1:="(pts[b1].Y-pts[b].Y)/(pts[b1].x-pts[b].x+0.0000000001);" d1:="pts[b1].Y-c1*pts[b1].X;" if="" c<="">c1 then

begin

x:=(d1-d)/(c-c1);//решение по x системы уравнений

if inside(x,pts[a1].x,pts[a].x) and inside(x,pts[b1].x,pts[b].x) then result:=true;

end;

function vectorway.CrossFade(t:pone):integer;

var k,j,mxp,ex:integer;

r:real;

procedure excahnge(m,n:integer);

begin

while mt.price then

excahnge(k+1,j)//если это ведет к ухудшению, то отмена снятия перекрестия

else

begin

t.price:=r;

t.birth:=b_crosfade;

end;

constructor sr.Create(Suspended:boolean);

begin

inherited create(suspended);

suspendrequest:=false;

exitrequest:=false;

priority:=tpIdle;

end;

function vectorway.Compare(r,r1:pointer):boolean;

var k:integer;

p,p1:array of word;

begin

p:=r;

p1:=r1;

result:=true;

k:=min(length(p),length(p1));

while k>0 do

begin

dec(k);

if p[k]<>p1[k] then

begin

result:=false;

exit;

end;

function vectorway.integrity(r:pointer):boolean;

var f:array of word;

k,k0,mxp:integer;

label okk;

begin

result:=false;

f:=r;

mxp:=length(pts)-1;

k:=mxp;

while k>=0 do

begin

k0:=mxp;

while k0>=0 do

begin

if f[k0]=k then goto okk;

dec(k0);

end;

exit;//тест не пройден - целостность нарушена

okk:

dec(k);

end;

result:=true;

end;

procedure vectorway.LocalMin(zz:pointer;ind1,ind2,len:integer);//ind1 - индекс массива r ind2- номер точки в массиве pts, len-длина последовательног минимума

var p:array of word;

mxp,k,j,j1:integer;

flag:array of boolean;//если i-й элемент = true хначит он заблокирован для использования

pos:array of word;//i-й элемент хранит позицию i-ого города

r1,r:integer;

begin

p:=zz;

mxp:=length(pts);

// setlength(flag,0);//очистка флаго-индексного массива

setlength(flag,mxp);

setlength(pos,mxp);

for k:=0 to mxp-1 do pos[p[k]]:=k;//индексация для быстрого поиска - существенно для большого числа точек

flag[ind1]:=true;//сразу блокируем указанную точку

// flag[0]:=true;

k:=pos[ind2];//позиция ind2 в массиве p

j1:=p[ind1]; //обмен начальной точки

p[ind1]:=ind2;

p[k]:=j1;

pos[ind2]:=ind1;

pos[j1]:=k;

while len>0 do //типа for k0:=ind1 to ind1+len-2 do//заполняем координаты вектора

begin

r1:=2000000;//минимум расстояния

j:=0;//номер

k:=mxp-1;//инициализация сканера

while k>=0 do

begin

if not flag[k] then//если претендент ещё не используется в векторе

begin

j1:=p[ind1];//номер предыдущей точки

r:=sqr(a.pts[j1].X-a.pts[k].X)+sqr(a.pts[j1].y-a.pts[k].y);//квадрат расстояния

if r=mxp then ind1:=0;//если ind1=mpx+1 иными словами - достигли границы массива

dec(len);

end;

procedure vectorway.randomway(var t:one);

var k,j,j1:integer;

a:word;

begin

k:=length(pts)-1;

setlength(t.way,k+1);

t.birth:=b_rand;

for j:=0 to k do t.way[j]:=j;//по порядку расставим

for j:=0 to k do

begin

j1:=random(k);

if j1<>j then//сам с собой не должен менятся

begin

a:=t.way[j];

t.way[j]:=t.way[j1];

t.way[j1]:=a;

end;

function vectorway.calcway(r:pointer):real;

var d:array of word;

k,j1,j2:integer;

begin

d:=r;

result:=0;

for k:=0 to length(d)-2 do

begin

j1:=d[k];

j2:=d[k+1];

result:=result+sqrt(sqr(pts[j1].X-pts[j2].X)+sqr(pts[j1].Y-pts[j2].Y));

end;

j1:=d[0];//между первым и последним сколько

result:=result+sqrt(sqr(pts[j1].X-pts[j2].X)+sqr(pts[j1].Y-pts[j2].Y));

end;

constructor vectorway.create;

begin

inherited create;

Zerrulation;

end;

destructor vectorway.destroy;

begin

Zerrulation;

inherited destroy;

end;

procedure vectorway.Zerrulation;

begin

setlength(pts,0);

setlength(way,0);

reset;

end;

procedure vectorway.randomsites(n:integer);//случайно расположить n городов

var k,j:integer;

label sgs;

begin

setlength(pts,n);

setlength(way,n);

reset;

for k:=0 to n-1 do

begin

sgs:

pts[k].X:=random(dx);

pts[k].Y:=random(dy);

if k>0 then

for j:=0 to k-1 do

if sqr(pts[j].X-pts[k].X)+sqr(pts[j].Y-pts[k].Y)<36 then goto sgs;

end;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

begin

randomize;

a:=vectorway.create;

t:=tpicture.Create;

t.Bitmap.Width:=dx;

t.Bitmap.Height:=dy;

z:=sr.Create(true);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

z.exitrequest:=true;

z.Resume;

while z.exitrequest do sleep(100); //ждем терминации

z.Destroy;

a.destroy;

t.Destroy;

end;

procedure Tform1.Sh;

procedure showcitys;

var k:integer;

zz:Tcanvas;

begin

zz:=t.bitmap.canvas;

zz.Brush.Color:=color;

zz.Rectangle(0,0,dx,dy);

for k:=0 to length(a.pts)-1 do

begin

if k=0 then zz.Brush.Color:=clblack else zz.Brush.Color:=color;

zz.Ellipse(a.pts[k].X-2,a.pts[k].y-2,a.pts[k].X+2,a.pts[k].y+2);

end;

zz.Brush.Color:=color;

if a.wayfound then

begin

zz.MoveTo(a.pts[a.way[0]].x,a.pts[a.way[0]].y);

for k:=1 to length(a.way)-1 do

zz.LineTo(a.pts[a.way[k]].X,a.pts[a.way[k]].y);

zz.LineTo(a.pts[a.way[0]].X,a.pts[a.way[0]].y);//к первому городу

end;

var aaa:real;

begin

showcitys;

canvas.CopyRect(rect(1,1,dx+1,dy+1),t.Bitmap.Canvas,rect(0,0,dx,dy));

if a.wayfound then

begin

aaa:=a.calcway(a.way);

label12.caption:=floattostr(aaa);

label13.caption:=format('%f %%',[100*aaa/a.maxprice]);

label5.Caption:=inttostr(a.stat[2]);

label7.Caption:=inttostr(a.stat[1]);

label9.Caption:=inttostr(a.stat[3]);

label11.Caption:=inttostr(a.stat[4]);

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

Sh;

end;

procedure TForm1.SBRgene(Sender: TObject);

var n:integer;

begin

try

n:=strtoint(edit1.text);

except

on Econverterror do n:=0;

end;

if n>2000 then n:=2000;

if n<3 then n:=3;

edit1.Text:=inttostr(n);

a.randomsites(n);

sh;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

if length(a.pts)<=2 then exit;

z.Resume;

timer1.Interval:=length(a.pts);

if timer1.Interval<300 then timer1.Interval:=300;

if timer1.Interval>2000 then timer1.Interval:=2000;

timer1.Enabled:=true;

form2.showmodal;//ждем-с

z.suspendrequest:=true;

while not z.suspendrequest do sleep(100);

sh;

timer1.Enabled:=false;

end;

procedure sr.Execute;

const Co=2;

var ng,k0,k,j,j1,mxp:integer;

minval,maxval:integer;//минимальный и максимальный путь

best:word;//номер лучшей особи - Элитизм

fc:array[1..pop_size] of one;

M,mst:integer;//число мутаций на одну особь

r:real;

bra:word;

cros_count,locmin_len:integer;

// virra: array of word;//для имитации переписи

label nxt_gen,aga,elite,nxt_genseries,fina,start;

function getgennum:integer;

begin

try //установим число поколений

result:=strtoint(form1.edit2.Text);

except

on Econverterror do result:=0;

end;

if Result<10 then result:=10; //минимальное число поколений

end;

begin

start:

mxp:=length(a.pts);//число городов

if mxp<2 then goto fina;

mst:=1;// round(ln(mxp)); //предел мутации на одну особь

//создадим случайную популяцию из k особей

setlength(a.way,mxp);//резервирование места для лучшего пути - типа текущее решение задачи

for k:=1 to pop_size do

begin

a.randomway(popul[k]);//создание случайных путей

setlength(fc[k].way,mxp);//резервирование места для массива дублёра

end;

cros_count:=0;//число поколений до проверки лучшего варианта на перекрещивание

locmin_len:=trunc(sqrt(mxp)); //максимальная длина цепочки локальной минимизации

//Начало поколения

best:=1;//допустим так - первая особь самая лучшая

if a.wayfound then//но если решение какое-то есть, то возьмём его как лучшее

copymemory(popul[best].way,a.way,mxp*sizeof(word))

else //иначе локальным минимумом его найдём

begin

a.price:=1e22;

a.LocalMin(popul[best].way,0,0,mxp);

popul[best].birth:=b_cros;

end;

nxt_genseries:

ng:=GetGenNum;//число поколений до визуализации

m:=1+random(mst);//число мутаций в поколении на одну особь

nxt_gen:

minval:=2000000; maxval:=0;//инициализация для поиска

dec(cros_count);

if cros_count<=0 then cros_count:=a.CrossFade(@popul[best]);//раз в десять поколений снятие перекрестий

for k0:=1 to pop_size do //по всем особям

begin

if k0=best then goto elite;//элитные особи не подвергаются мутациям и изменениям ген. информации

//Кросовер - локальная минимизация

r:=random;

if r<0.34 then

begin

for j1:=1 to m do//кросовер

begin

k:=random(mxp);

// j:=min(2+random(mxp div 3),10);

j:=2+random(locmin_len);

a.LocalMin(popul[k0].way,k,popul[k0].way[k],j);

end;

popul[k0].birth:=b_cros;

end else

if r<0.67 then//Мутация 1 - сводится к одиночной перестановке

begin

for k:=1 to m do

begin

j:=random(mxp);

j1:=random(mxp);

if j<>j1 then

begin

bra:=popul[k0].way[j];

popul[k0].way[j]:=popul[k0].way[j1];

popul[k0].way[j1]:=bra;

end;

popul[k0].birth:=b_mutate1;

end else //Мутация 2 - сводится к одиночной перекомпановке

begin

// for k:=1 to m do

a.MutateType2(popul[k0].way,random(mxp),random(mxp));

popul[k0].birth:=b_mutate2;

end;

//Оценка особей

elite:

r:=a.CalcWay(popul[k0].way);

if rmaxval then maxval:=round(r);

popul[k0].price:=r;

end;

maxval:=minval+((maxval-minval)*1) shr 4 ;//порог элитизма

minval:=0;

// maxval:=(maxval+minval) shr 1;//попалам делим

for k:=1 to pop_size do

if popul[k].price<=maxval then //если путь короче среднего по популяции

begin //то проведём выборку этой особи - Элитизм

inc(minval);

fc[minval].price:=popul[k].price;

fc[Minval].birth:=popul[k].birth;

copymemory(fc[minval].way,popul[k].way,mxp*sizeof(word));

end;

maxval:=minval;

while maxval0) and (not suspendrequest) then goto nxt_gen;

// form1.sh;//form1.Invalidate;

if not (suspendrequest or exitrequest) then goto nxt_genseries;

fina:

suspendrequest:=false;

suspend;

if exitrequest then

begin

exitrequest:=false;

exit; //это для закрытия приложения нужно быть вне процедуры execute

end;

goto start;

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var k:integer;

begin

k:=length(a.pts);

if mbRight = button then//удаление

begin

if k>0 then setlength(a.pts,k-1);

edit1.Text:=inttostr(k-1);

a.Reset;

end;

if mbLeft = button then//нанесение новых точек

begin

setlength(a.pts,k+1);

a.reset;

a.pts[k].X:=x-1;

a.pts[k].y:=y-1;

edit1.Text:=inttostr(k+1);

end;

Sh;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

sh;

end;

procedure TForm1.SpeedButton3Click(Sender: TObject);

begin

form3.show;

end;

end.

</max(b,c))></b>

Комментирование закрыто.