Исходный код модуля structures

unit structures;

interface

uses graphics,Sysutils;

const maxsize = 7;
      err = 100;//код поля куда нельзя совершить переход или ход не возможен
      motvs:array [0..1] of array [0..4] of smallint = //массив мотиваций
     ((  0, 5, 11, 10,-150),//цена хода, рубки шашки, рубки дамки, получения дамки, проигрыша
      (  0,-6,-10,-11,165));
      pe_move = 0;  //константные номера мотивов
      pe_kick = 1;
      pe_lkick = 2;
      pe_lmake = 3;
      pe_loose = 4;
      corconv : array[0..7] of array [0..7]of byte =  //x,y
      ((err,  4,err, 12,err, 20,err, 28),//записаны номера шашек шахматной доске по координатам доски
       (  0,err,  8,err, 16,err, 24,err),
       (err,  5,err, 13,err, 21,err, 29),
       (  1,err,  9,err, 17,err, 25,err),
       (err,  6,err, 14,err, 22,err, 30),
       (  2,err, 10,err, 18,err, 26,err),
       (err,  7,err, 15,err, 23,err, 31),
       (  3,err, 11,err, 19,err, 27,err));
      posconv : array[0..31] of array [0..1]of byte =
      ((1,0),(3,0),(5,0),(7,0),//записаны позиции на шахматной доске по номеру шашки
       (0,1),(2,1),(4,1),(6,1),
       (1,2),(3,2),(5,2),(7,2),
       (0,3),(2,3),(4,3),(6,3),
       (1,4),(3,4),(5,4),(7,4),
       (0,5),(2,5),(4,5),(6,5),
       (1,6),(3,6),(5,6),(7,6),
       (0,7),(2,7),(4,7),(6,7));
      idir : array[0..3] of byte = (2,3,0,1);//направления обратные указанным
      mvs : array[0..3] of array[0..31]of byte =//записаны позиции переходов в зависимости от направлений движения
      ((err,err,err,err,err,  0,  1,  2,  4,  5,  6,  7,err,  8,  9, 10, 12, 13, 14, 15,err, 16, 17, 18, 20, 21, 22, 23,err, 24, 25, 26),
       (err,err,err,err,  0,  1,  2,  3,  5,  6,  7,err,  8,  9, 10, 11, 13, 14, 15,err, 16, 17, 18, 19, 21, 22, 23,err, 24, 25, 26, 27),
       (  5,  6,  7,err,  8,  9, 10, 11, 13, 14, 15,err, 16, 17, 18, 19, 21, 22, 23,err, 24, 25, 26, 27, 29, 30, 31,err,err,err,err,err),
       (  4,  5,  6,  7,err,  8,  9, 10, 12, 13, 14, 15,err, 16, 17, 18, 20, 21, 22, 23,err, 24, 25, 26, 28, 29, 30, 31,err,err,err,err));
      smsk : array[0..31] of cardinal =//маска для установки нужного бита - через операцию OR
      ($00000001,$00000002,$00000004,$00000008,$00000010,$00000020,$00000040,$00000080,
       $00000100,$00000200,$00000400,$00000800,$00001000,$00002000,$00004000,$00008000,
       $00010000,$00020000,$00040000,$00080000,$00100000,$00200000,$00400000,$00800000,
       $01000000,$02000000,$04000000,$08000000,$10000000,$20000000,$40000000,$80000000);
      rmsk : array[0..31] of cardinal =//маска для сбрасывания нужного бита - через операцию AND
      ($fffffffe,$fffffffd,$fffffffb,$fffffff7,$ffffffef,$ffffffdf,$ffffffbf,$ffffff7f,
       $fffffeff,$fffffdff,$fffffbff,$fffff7ff,$ffffefff,$ffffdfff,$ffffbfff,$ffff7fff,
       $fffeffff,$fffdffff,$fffbffff,$fff7ffff,$ffefffff,$ffdfffff,$ffbfffff,$ff7fffff,
       $feffffff,$fdffffff,$fbffffff,$f7ffffff,$efffffff,$dfffffff,$bfffffff,$7fffffff);
      {
       X or smsk[index] - устанавливает нужный бит
       X and rmsk[index] - выключает нужный бит
       X and smsk[index] - выделяет нужный бит для проверки, если результат операции - 0, то бит погашен
       }
type

  step = record
    s0,s1:cardinal;
    mark:smallint;
  end;

  Gauge_imitator = record
    left,top,width,height:integer;
    status:integer;
    color:tcolor;
  end;

  board = record
    pos:cardinal;//positions
    sde:cardinal;//markers of player's side
    top:cardinal;//markers of ladyies
  end;

  PBoard = ^board;

  Pmove=integer;

  svdata = record
    boa:board;
    mv0,mv1:cardinal;
    e:byte;
  end;

  psvdata = ^svdata;

  hist = record
    boa:board;//доска
    mv0,mv1:cardinal;//ход на этой доске
    e:byte;//сторона которая делает этот ход
    p:pointer;//указатель на предыдущий элемент списка
  end;

  Phist = ^hist;

  history = class
    p:phist;
    procedure deactivate;
    procedure AddHistory(b:pboard;e:byte;mv0,mv1:cardinal);
    procedure DelHistory(b:psvdata);
    Constructor Create;
    Destructor Destroy;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

//процедуры, которые проверяют значение бита, для анализа структуры board
const
  start:board = (pos:$FFF00FFF;sde:$FFF00000;top:0);
  empty:board = (pos:0;sde:0;top:0);

function max(a,b:smallint):smallint;
function min(a,b:smallint):smallint;
procedure Trinagle(x1,y1,x2,y2,x3,y3:smallint;c:tcanvas);
procedure forsemove(mv0,mv1:cardinal;brd:Pboard);//выполнение хода на доске
function appraisemove(mv0,mv1:cardinal;brd:Pboard;n_motiv:byte):smallint;//оценка хода, без его исполнения
function CheckMove(mv:int64):boolean;//грубая проверка правильности хода (отладка)
function CheckNoWin(hh:phist):boolean;//проверяет пассивность ситуации - отсутствие результативных ходов в течении 8 пар ходов
function NumberSh(n:cardinal):word;//возвращает число фигур на доске

var
  mvs1 : array[0..3] of array[0..31]of byte;//запишем сюда позиции переходов через одну клетку, как при рубке
  deepforse : byte = 5; //глубина просчёта ходов (средняя по умолчанию)

implementation

function NumberSh(n:cardinal):word;//возвращает число фигур на доске
label nxt,tuda;
begin
  asm
    mov ecx,n;
    mov dl,$20;//счётчик
    xor ax,ax;//обнуление cx
  nxt:
    shl ecx,1;//один бит двинем в CF
    jnc tuda;
    inc ax;//если есть бит, то увеличим ax - нашли ещё одну шашку
  tuda:
    dec dl;
    jnz nxt;//если в dl не ноль то проверим следующий бит
    mov result,ax;
  end;
end;

function CheckNoWin(hh:phist):boolean;
var k:byte;
    dsk:board;
label univertest,r_true;
begin
  result:=false;//пока о ничьей речи не идёт
  for k:=1 to 16 do //восемь пар ходов без рубки
  begin
    if (hh=nil) or (hh.mv0=$10000) or (appraisemove(hh.mv0,hh.mv1,@hh.boa,0)<>0) then exit;
    if (k=1) and (NumberSh(hh.boa.pos)>4) then goto univertest;//многовато пока фигур на доске (а hh еще не изменили)
//нет достаточного количестка ходов or пока противники наносят друг другу вред - выход, т.к. игра прогрессирует, либо только началась
    hh:=hh.p;//предыдущий ход
  end;
  goto r_true;
univertest://тест для большого числа фишек на доске
  dsk:=hh.boa;//сохраним доску
  for k:=1 to 16 do //поочередное повторение ситуации на доске в течении 8-ми пар ходов
  begin
    hh:=hh.p;//предыдущий ход
    if (hh=nil) or (hh.mv0=$10000) then exit;
//нет достаточного количестка ходов or пока противники наносят друг другу вред - выход, т.к. игра прогрессирует, либо только началась
    hh:=hh.p;//снова ход стороны dsk
    if (hh=nil) or (hh.mv0=$10000) then exit;
    if (dsk.pos<>hh.boa.pos) or (dsk.sde<>hh.boa.sde) or (dsk.top<>hh.boa.top) then exit;//изменилась доска >= нет ничьей
    dsk:=hh.boa;//снова доску запомнили
  end;
r_true:
  result:=true;//ничья
end;

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

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

function CheckMove(mv:int64):boolean;//грубая проверка хода
var fin,move,k:byte;
begin
  fin:=0;
  mv:=mv shr 8;
  for k:=0 to 7 do
  begin
    move:=mv and $ff;
    mv:=mv shr 8;
    if (move and $20)<>0 then fin:=1;
  end;
  if fin=1 then result:=true else result:=false;
end;

Constructor history.Create;//создание истории
begin
  inherited Create;
end;

procedure history.Deactivate;
var h:pointer;
begin
  while p<>nil do   //удаление истории
  begin
    h:=p.p;
    Dispose(p);
    p:=h;
  end;
end;

Destructor history.Destroy;//уничтожение класса истории
begin
  Deactivate;
  inherited Destroy;
end;

procedure history.AddHistory(b:pboard;e:byte;mv0,mv1:cardinal);
var h:pointer;
begin
  h:=p;//сохраним указатель на предыдущий элемент
  New(p);//создадим новый элемент хистори
  p.boa:=b^;//запишем данные
  p.p:=h;
  p.e:=e;
  p.mv1:=mv1;
  p.mv0:=mv0;
end;

procedure history.DelHistory(b:psvdata);  //удаление одного шага историии
var h:pointer;
begin
  if p=nil then//если история пустая, то загргузка истории стартовой доской
  begin
    b.boa:=start;
    b.mv0:=$10000;
  end else begin//иначе отступление на один ход
    b.boa:=p.boa;//вот доска, какой она была ход назад
    b.e:=p.e;//вот чей ход
    b.mv0:=p.mv0;//и вот какой это ход
    b.mv1:=p.mv1;
    if p.p<>nil then//это предотвращает ошибку при BOM
    begin
      h:=p.p;
      Dispose(p);
      p:=h;
    end;
  end;
end;

//**************************************************************************************************
function appraisemove(mv0,mv1:cardinal;brd:Pboard;n_motiv:byte):smallint;//оценка хода, без его исполнения
//**************************************************************************************************
//оценка хода до выполнения без его выполнения
var pr,nxt,lady,side:byte;
    get_lady, get_ch, get_ld:byte;//стали дамкой, скоко простых шашек рубанули, сколько дамок зарубили
    mem1,mem2:cardinal;
label circ,cont,lady_del,rubka,fina;
begin
  pr:=mv0 and $1f;
  mem1:=brd.sde;//копируем поля доски для быстрых операций с ними
  mem2:=brd.top;
  asm
    xor dh,dh// mov dx,pr
    mov dl,pr;
    mov eax,mem1;//получим сторону в side
    xor cl,cl;//обнуление cl;
    bt eax,dx;
    rcl cl,1;
    mov side,cl;
    mov eax,mem2;//теперь получим lady
    xor cl,cl;//обнуление cl;
    bt eax,dx;
    rcl cl,1;
    mov lady,cl;
    mov get_lady,0;//флаг обращения шашки в дамку
    mov ax,word ptr mv0;//типа слово только хочу загрузить
    bt ax,7;//проверим флаг рубки
    jc rubka//переход если ход представляет собой рубку
    and ah,$1f;//фильтруем код поля конечной позиции шашки
    mov nxt,ah;//записываем в nxt
  end;
  if ((nxt>27) and (side=0)) or ((nxt<4) and (side=1)) then get_lady:=1;//стала ли дамкой?
  result:=motvs[n_motiv,pe_move];
  asm
    jmp fina; //идем на выход
rubka://если рубка
    mov get_ch,0;//число срубленных пешек
    mov get_ld,0;//число срубленных дамок
circ:
    mov eax,mv1; //mv:=mv shr 8;//следующая позиция
    shrd mv0,eax,8;
    shr eax,8;
    mov mv1,eax;
    mov al,byte ptr mv0;
    mov nxt,al;//получим весь байт с новой позицией
  end;
  pr:=mvs[nxt shr 6,nxt and $1f];//получили координаты атакуемой шашки
  asm
//проверим кого мы срубили дамку или пешку
    xor dh,dh
    mov dl,pr;
    mov eax,mem2;
    bt eax,dx;
    jc lady_del; //переход , если рубим дамку
    inc get_ch;
    jmp cont;
lady_del:
    inc get_ld;
cont:
  end;
  pr:=nxt and $1f;
  if ((pr>27) and (side=0)) or ((pr<4) and (side=1)) then get_lady:=1;//проверим не станет ли шашка дамкой
  if (nxt and $20)=0 then goto circ;
  result:=get_ch*motvs[n_motiv,pe_kick]+get_ld*motvs[n_motiv,pe_lkick];//по числу скушанных противников и результат
fina:
  if (lady=0) and (get_lady=1) then
    result:=result+motvs[n_motiv,pe_lmake];//ход с обращением дамки
end;

//**************************************************************************************************
procedure forsemove(mv0,mv1:cardinal;brd:Pboard);
//**************************************************************************************************
//выполнение хода mv,на доске brd
var pr,nxt,lady,side:byte;
    mem0,mem1,mem2:cardinal;
label circ,entry,itslady,itsside,cont,cont1,store,recircl;
begin
  mem0:=brd.pos;//копируем поля доски для быстрых операций с ними
  mem1:=brd.sde;
  mem2:=brd.top;
  asm//гасим бит pr в brd.pos - удаление шашки с доски
    mov dl,byte ptr mv0;//запись кода первого игрового поля в pr и dl
    and dl,$1f;
    mov pr,dl;
    xor dh,dh// mov dx,pr
    mov dl,pr;
    mov eax,mem0;
    btr eax,dx;
    mov mem0,eax;
    mov eax,mem1;//получим сторону в side
    xor cl,cl;//обнуление cl;
    bt eax,dx;
    rcl cl,1;
    mov side,cl;
    mov eax,mem2;//теперь получим lady
    xor cl,cl;//обнуление cl;
    bt eax,dx;
    rcl cl,1;
    mov lady,cl;
    mov ax,word ptr mv0;//типа слово только хочу загрузить
    bt ax,7;//проверим флаг рубки
    jc circ//переход если ход представляет собой рубку
    and ah,$1f;//фильтруем код поля конечной позиции шашки
    mov nxt,ah;//записываем в nxt
  end;
entry:
  if ((nxt>27) and (side=0)) or ((nxt<4) and (side=1)) then lady:=1;//шашка становится дамкой или остаётся ей при прохождении крайнего поля
  asm//устанавливаем бит nxt в brd.pos - новая позиция шашки
    xor dh,dh; //mov dx,nxt
    mov dl,nxt;
    mov eax,mem0;
    bts eax,dx;
    mov mem0,eax;
    mov eax,mem2;//загрузка eax - картой дамок
    cmp lady,1;//проверить флаг lady
    jz itslady;
    btr eax,dx;
    jmp cont;
itslady:
    bts eax,dx;
cont:
    mov mem2,eax;//сохраняем карту дамок
    mov eax,mem1;//загрузка eax - картой сторон
    cmp side,1;//проверить флаг side
    jz itsside;
    btr eax,dx;
    jmp cont1;
itsside:
    bts eax,dx;
cont1:
    mov mem1,eax;//сохраняем карту сторон
    jmp store;
//если рубка
circ:
    mov eax,mv1; //mv:=mv shr 8;//следующая позиция
    shrd mv0,eax,8;
    shr eax,8;
    mov mv1,eax;
    mov al,byte ptr mv0;
    mov nxt,al;//получим весь байт с новой позицией
  end;
  pr:=mvs[nxt shr 6,nxt and $1f];//получили координаты атакуемой шашки
  asm
//гасим бит pr в brd.pos - удаление срубленной шашки с доски
    xor dh,dh//загрузим в dx номер бита
    mov dl,pr;
    mov eax,mem0;//выключим бит
    btr eax,dx;
    mov mem0,eax;
    mov al,nxt;//это проверка окончания хода  if (nxt and $20)<>0 then
    bt ax,5;//бит номер 5
    jnc recircl;
    and al,$1f;//фильтруем номер поля игровой доски
    mov nxt,al;//получение координат в nxt
    jmp entry;//переход на установки шашки на финальной позиции
  end;
recircl:
  nxt:=nxt and $1f;//получили координаты позиции ч/з которую проходит наша шашка
  if ((nxt>27) and (side=0)) or ((nxt<4) and (side=1)) then lady:=1;//проверим не станет ли она дамкой
  goto circ;
store:
  brd.pos:=mem0;//копируем поля доски обратно из временных регистров
  brd.sde:=mem1;
  brd.top:=mem2;
end;

procedure Trinagle(x1,y1,x2,y2,x3,y3:smallint;c:tcanvas);
begin
  c.MoveTo(x1,y1);
  c.LineTo(x2,y2);
  c.LineTo(x3,y3);
  c.LineTo(x1,y1);
end;

end.

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

unit structures;

interface

uses graphics,Sysutils;

const maxsize = 7;

err = 100;//код поля куда нельзя совершить переход или ход не возможен

motvs:array [0..1] of array [0..4] of smallint = //массив мотиваций

(( 0, 5, 11, 10,-150),//цена хода, рубки шашки, рубки дамки, получения дамки, проигрыша

( 0,-6,-10,-11,165));

pe_move = 0; //константные номера мотивов

pe_kick = 1;

pe_lkick = 2;

pe_lmake = 3;

pe_loose = 4;

corconv : array[0..7] of array [0..7]of byte = //x,y

((err, 4,err, 12,err, 20,err, 28),//записаны номера шашек шахматной доске по координатам доски

( 0,err, 8,err, 16,err, 24,err),

(err, 5,err, 13,err, 21,err, 29),

( 1,err, 9,err, 17,err, 25,err),

(err, 6,err, 14,err, 22,err, 30),

( 2,err, 10,err, 18,err, 26,err),

(err, 7,err, 15,err, 23,err, 31),

( 3,err, 11,err, 19,err, 27,err));

posconv : array[0..31] of array [0..1]of byte =

((1,0),(3,0),(5,0),(7,0),//записаны позиции на шахматной доске по номеру шашки

(0,1),(2,1),(4,1),(6,1),

(1,2),(3,2),(5,2),(7,2),

(0,3),(2,3),(4,3),(6,3),

(1,4),(3,4),(5,4),(7,4),

(0,5),(2,5),(4,5),(6,5),

(1,6),(3,6),(5,6),(7,6),

(0,7),(2,7),(4,7),(6,7));

idir : array[0..3] of byte = (2,3,0,1);//направления обратные указанным

mvs : array[0..3] of array[0..31]of byte =//записаны позиции переходов в зависимости от направлений движения

((err,err,err,err,err, 0, 1, 2, 4, 5, 6, 7,err, 8, 9, 10, 12, 13, 14, 15,err, 16, 17, 18, 20, 21, 22, 23,err, 24, 25, 26),

(err,err,err,err, 0, 1, 2, 3, 5, 6, 7,err, 8, 9, 10, 11, 13, 14, 15,err, 16, 17, 18, 19, 21, 22, 23,err, 24, 25, 26, 27),

( 5, 6, 7,err, 8, 9, 10, 11, 13, 14, 15,err, 16, 17, 18, 19, 21, 22, 23,err, 24, 25, 26, 27, 29, 30, 31,err,err,err,err,err),

( 4, 5, 6, 7,err, 8, 9, 10, 12, 13, 14, 15,err, 16, 17, 18, 20, 21, 22, 23,err, 24, 25, 26, 28, 29, 30, 31,err,err,err,err));

smsk : array[0..31] of cardinal =//маска для установки нужного бита - через операцию OR

($00000001,$00000002,$00000004,$00000008,$00000010,$00000020,$00000040,$00000080,

$00000100,$00000200,$00000400,$00000800,$00001000,$00002000,$00004000,$00008000,

$00010000,$00020000,$00040000,$00080000,$00100000,$00200000,$00400000,$00800000,

$01000000,$02000000,$04000000,$08000000,$10000000,$20000000,$40000000,$80000000);

rmsk : array[0..31] of cardinal =//маска для сбрасывания нужного бита - через операцию AND

($fffffffe,$fffffffd,$fffffffb,$fffffff7,$ffffffef,$ffffffdf,$ffffffbf,$ffffff7f,

$fffffeff,$fffffdff,$fffffbff,$fffff7ff,$ffffefff,$ffffdfff,$ffffbfff,$ffff7fff,

$fffeffff,$fffdffff,$fffbffff,$fff7ffff,$ffefffff,$ffdfffff,$ffbfffff,$ff7fffff,

$feffffff,$fdffffff,$fbffffff,$f7ffffff,$efffffff,$dfffffff,$bfffffff,$7fffffff);

{

X or smsk[index] - устанавливает нужный бит

X and rmsk[index] - выключает нужный бит

X and smsk[index] - выделяет нужный бит для проверки, если результат операции - 0, то бит погашен

}

type

step = record

s0,s1:cardinal;

mark:smallint;

end;

Gauge_imitator = record

left,top,width,height:integer;

status:integer;

color:tcolor;

end;

board = record

pos:cardinal;//positions

sde:cardinal;//markers of player's side

top:cardinal;//markers of ladyies

end;

PBoard = ^board;

Pmove=integer;

svdata = record

boa:board;

mv0,mv1:cardinal;

e:byte;

end;

psvdata = ^svdata;

hist = record

boa:board;//доска

mv0,mv1:cardinal;//ход на этой доске

e:byte;//сторона которая делает этот ход

p:pointer;//указатель на предыдущий элемент списка

end;

Phist = ^hist;

history = class

p:phist;

procedure deactivate;

procedure AddHistory(b:pboard;e:byte;mv0,mv1:cardinal);

procedure DelHistory(b:psvdata);

Constructor Create;

Destructor Destroy;

private

{ Private declarations }

public

{ Public declarations }

end;

//процедуры, которые проверяют значение бита, для анализа структуры board

const

start:board = (pos:$FFF00FFF;sde:$FFF00000;top:0);

empty:board = (pos:0;sde:0;top:0);

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

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

procedure Trinagle(x1,y1,x2,y2,x3,y3:smallint;c:tcanvas);

procedure forsemove(mv0,mv1:cardinal;brd:Pboard);//выполнение хода на доске

function appraisemove(mv0,mv1:cardinal;brd:Pboard;n_motiv:byte):smallint;//оценка хода, без его исполнения

function CheckMove(mv:int64):boolean;//грубая проверка правильности хода (отладка)

function CheckNoWin(hh:phist):boolean;//проверяет пассивность ситуации - отсутствие результативных ходов в течении 8 пар ходов

function NumberSh(n:cardinal):word;//возвращает число фигур на доске

var

mvs1 : array[0..3] of array[0..31]of byte;//запишем сюда позиции переходов через одну клетку, как при рубке

deepforse : byte = 5; //глубина просчёта ходов (средняя по умолчанию)

implementation

function NumberSh(n:cardinal):word;//возвращает число фигур на доске

label nxt,tuda;

begin

asm

mov ecx,n;

mov dl,$20;//счётчик

xor ax,ax;//обнуление cx

nxt:

shl ecx,1;//один бит двинем в CF

jnc tuda;

inc ax;//если есть бит, то увеличим ax - нашли ещё одну шашку

tuda:

dec dl;

jnz nxt;//если в dl не ноль то проверим следующий бит

mov result,ax;

end;

function CheckNoWin(hh:phist):boolean;

var k:byte;

dsk:board;

label univertest,r_true;

begin

result:=false;//пока о ничьей речи не идёт

for k:=1 to 16 do //восемь пар ходов без рубки

begin

if (hh=nil) or (hh.mv0=$10000) or (appraisemove(hh.mv0,hh.mv1,@hh.boa,0)<>0) then exit;

if (k=1) and (NumberSh(hh.boa.pos)>4) then goto univertest;//многовато пока фигур на доске (а hh еще не изменили)

//нет достаточного количестка ходов or пока противники наносят друг другу вред - выход, т.к. игра прогрессирует, либо только началась

hh:=hh.p;//предыдущий ход

end;

goto r_true;

univertest://тест для большого числа фишек на доске

dsk:=hh.boa;//сохраним доску

for k:=1 to 16 do //поочередное повторение ситуации на доске в течении 8-ми пар ходов

begin

hh:=hh.p;//предыдущий ход

if (hh=nil) or (hh.mv0=$10000) then exit;

hh:=hh.p;//снова ход стороны dsk

if (hh=nil) or (hh.mv0=$10000) then exit;

if (dsk.pos<>hh.boa.pos) or (dsk.sde<>hh.boa.sde) or (dsk.top<>hh.boa.top) then exit;//изменилась доска >= нет ничьей

dsk:=hh.boa;//снова доску запомнили

end;

r_true:

result:=true;//ничья

end;

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

begin

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

end;

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

begin

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

end;

function CheckMove(mv:int64):boolean;//грубая проверка хода

var fin,move,k:byte;

begin

fin:=0;

mv:=mv shr 8;

for k:=0 to 7 do

begin

move:=mv and $ff;

mv:=mv shr 8;

if (move and $20)<>0 then fin:=1;

end;

if fin=1 then result:=true else result:=false;

end;

Constructor history.Create;//создание истории

begin

inherited Create;

end;

procedure history.Deactivate;

var h:pointer;

begin

while p<>nil do //удаление истории

begin

h:=p.p;

Dispose(p);

p:=h;

end;

Destructor history.Destroy;//уничтожение класса истории

begin

Deactivate;

inherited Destroy;

end;

procedure history.AddHistory(b:pboard;e:byte;mv0,mv1:cardinal);

var h:pointer;

begin

h:=p;//сохраним указатель на предыдущий элемент

New(p);//создадим новый элемент хистори

p.boa:=b^;//запишем данные

p.p:=h;

p.e:=e;

p.mv1:=mv1;

p.mv0:=mv0;

end;

procedure history.DelHistory(b:psvdata); //удаление одного шага историии

var h:pointer;

begin

if p=nil then//если история пустая, то загргузка истории стартовой доской

begin

b.boa:=start;

b.mv0:=$10000;

end else begin//иначе отступление на один ход

b.boa:=p.boa;//вот доска, какой она была ход назад

b.e:=p.e;//вот чей ход

b.mv0:=p.mv0;//и вот какой это ход

b.mv1:=p.mv1;

if p.p<>nil then//это предотвращает ошибку при BOM

begin

h:=p.p;

Dispose(p);

p:=h;

end;

//**************************************************************************************************

function appraisemove(mv0,mv1:cardinal;brd:Pboard;n_motiv:byte):smallint;//оценка хода, без его исполнения

//**************************************************************************************************

//оценка хода до выполнения без его выполнения

var pr,nxt,lady,side:byte;

get_lady, get_ch, get_ld:byte;//стали дамкой, скоко простых шашек рубанули, сколько дамок зарубили

mem1,mem2:cardinal;

label circ,cont,lady_del,rubka,fina;

begin

pr:=mv0 and $1f;

mem1:=brd.sde;//копируем поля доски для быстрых операций с ними

mem2:=brd.top;

asm

xor dh,dh// mov dx,pr

mov dl,pr;

mov eax,mem1;//получим сторону в side

xor cl,cl;//обнуление cl;

bt eax,dx;

rcl cl,1;

mov side,cl;

mov eax,mem2;//теперь получим lady

xor cl,cl;//обнуление cl;

bt eax,dx;

rcl cl,1;

mov lady,cl;

mov get_lady,0;//флаг обращения шашки в дамку

mov ax,word ptr mv0;//типа слово только хочу загрузить

bt ax,7;//проверим флаг рубки

jc rubka//переход если ход представляет собой рубку

and ah,$1f;//фильтруем код поля конечной позиции шашки

mov nxt,ah;//записываем в nxt

end;

if ((nxt>27) and (side=0)) or ((nxt<4) and (side=1)) then get_lady:=1;//стала ли дамкой?

result:=motvs[n_motiv,pe_move];

asm

jmp fina; //идем на выход

rubka://если рубка

mov get_ch,0;//число срубленных пешек

mov get_ld,0;//число срубленных дамок

circ:

mov eax,mv1; //mv:=mv shr 8;//следующая позиция

shrd mv0,eax,8;

shr eax,8;

mov mv1,eax;

mov al,byte ptr mv0;

mov nxt,al;//получим весь байт с новой позицией

end;

pr:=mvs[nxt shr 6,nxt and $1f];//получили координаты атакуемой шашки

asm

//проверим кого мы срубили дамку или пешку

xor dh,dh

mov dl,pr;

mov eax,mem2;

bt eax,dx;

jc lady_del; //переход , если рубим дамку

inc get_ch;

jmp cont;

lady_del:

inc get_ld;

cont:

end;

pr:=nxt and $1f;

if ((pr>27) and (side=0)) or ((pr<4) and (side=1)) then get_lady:=1;//проверим не станет ли шашка дамкой

if (nxt and $20)=0 then goto circ;

result:=get_ch*motvs[n_motiv,pe_kick]+get_ld*motvs[n_motiv,pe_lkick];//по числу скушанных противников и результат

fina:

if (lady=0) and (get_lady=1) then

result:=result+motvs[n_motiv,pe_lmake];//ход с обращением дамки

end;

//**************************************************************************************************

procedure forsemove(mv0,mv1:cardinal;brd:Pboard);

//**************************************************************************************************

//выполнение хода mv,на доске brd

var pr,nxt,lady,side:byte;

mem0,mem1,mem2:cardinal;

label circ,entry,itslady,itsside,cont,cont1,store,recircl;

begin

mem0:=brd.pos;//копируем поля доски для быстрых операций с ними

mem1:=brd.sde;

mem2:=brd.top;

asm//гасим бит pr в brd.pos - удаление шашки с доски

mov dl,byte ptr mv0;//запись кода первого игрового поля в pr и dl

and dl,$1f;

mov pr,dl;

xor dh,dh// mov dx,pr

mov dl,pr;

mov eax,mem0;

btr eax,dx;

mov mem0,eax;

mov eax,mem1;//получим сторону в side

xor cl,cl;//обнуление cl;

bt eax,dx;

rcl cl,1;

mov side,cl;

mov eax,mem2;//теперь получим lady

xor cl,cl;//обнуление cl;

bt eax,dx;

rcl cl,1;

mov lady,cl;

mov ax,word ptr mv0;//типа слово только хочу загрузить

bt ax,7;//проверим флаг рубки

jc circ//переход если ход представляет собой рубку

and ah,$1f;//фильтруем код поля конечной позиции шашки

mov nxt,ah;//записываем в nxt

end;

entry:

if ((nxt>27) and (side=0)) or ((nxt<4) and (side=1)) then lady:=1;//шашка становится дамкой или остаётся ей при прохождении крайнего поля

asm//устанавливаем бит nxt в brd.pos - новая позиция шашки

xor dh,dh; //mov dx,nxt

mov dl,nxt;

mov eax,mem0;

bts eax,dx;

mov mem0,eax;

mov eax,mem2;//загрузка eax - картой дамок

cmp lady,1;//проверить флаг lady

jz itslady;

btr eax,dx;

jmp cont;

itslady:

bts eax,dx;

cont:

mov mem2,eax;//сохраняем карту дамок

mov eax,mem1;//загрузка eax - картой сторон

cmp side,1;//проверить флаг side

jz itsside;

btr eax,dx;

jmp cont1;

itsside:

bts eax,dx;

cont1:

mov mem1,eax;//сохраняем карту сторон

jmp store;

//если рубка

circ:

mov eax,mv1; //mv:=mv shr 8;//следующая позиция

shrd mv0,eax,8;

shr eax,8;

mov mv1,eax;

mov al,byte ptr mv0;

mov nxt,al;//получим весь байт с новой позицией

end;

pr:=mvs[nxt shr 6,nxt and $1f];//получили координаты атакуемой шашки

asm

//гасим бит pr в brd.pos - удаление срубленной шашки с доски

xor dh,dh//загрузим в dx номер бита

mov dl,pr;

mov eax,mem0;//выключим бит

btr eax,dx;

mov mem0,eax;

mov al,nxt;//это проверка окончания хода if (nxt and $20)<>0 then

bt ax,5;//бит номер 5

jnc recircl;

and al,$1f;//фильтруем номер поля игровой доски

mov nxt,al;//получение координат в nxt

jmp entry;//переход на установки шашки на финальной позиции

end;

recircl:

nxt:=nxt and $1f;//получили координаты позиции ч/з которую проходит наша шашка

if ((nxt>27) and (side=0)) or ((nxt<4) and (side=1)) then lady:=1;//проверим не станет ли она дамкой

goto circ;

store:

brd.pos:=mem0;//копируем поля доски обратно из временных регистров

brd.sde:=mem1;

brd.top:=mem2;

end;

procedure Trinagle(x1,y1,x2,y2,x3,y3:smallint;c:tcanvas);

begin

c.MoveTo(x1,y1);

c.LineTo(x2,y2);

c.LineTo(x3,y3);

c.LineTo(x1,y1);

end;

end.

Комментарии к «Исходный код модуля structures»

Понравилась статья? Есть вопросы? - пишите в комментариях.

Имя (обязательно)	Е-майл (не будет опубликован на сайте, обязательно для заполнения)
Комментарий: