gcc/testsuite/gm2/projects/iso/run/pass/halma/halma.mod

   1 (* Copyright (C) 2010 Free Software Foundation, Inc. *)
   2 (* This file is part of GNU Modula-2.
   3
   4 GNU Modula-2 is free software; you can redistribute it and/or modify it under
   5 the terms of the GNU General Public License as published by the Free
   6 Software Foundation; either version 2, or (at your option) any later
   7 version.
   8
   9 GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY
  10 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  11 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  12 for more details.
  13
  14 You should have received a copy of the GNU General Public License along
  15 with gm2; see the file COPYING.  If not, write to the Free Software
  16 Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
  17
  18 MODULE halma ;
  19
  20 FROM STextIO IMPORT WriteString, WriteLn, WriteChar, ReadToken, SkipLine ;
  21 FROM SWholeIO IMPORT WriteCard, WriteInt ;
  22 FROM Strings IMPORT Length ;
  23 FROM Selective IMPORT Timeval, GetTimeOfDay, GetTime, InitTime, KillTime ;
  24 FROM WholeStr IMPORT StrToCard, ConvResults ;
  25 FROM SYSTEM IMPORT CARDINAL8 ;
  26
  27 CONST
  28    TwoPlayer      =            TRUE ;
  29    FourPlayer     =           FALSE ;
  30    BoardX         =              16 ;
  31    BoardY         =              16 ;
  32    BoardSize      = BoardX * BoardY ;
  33    Pieces         =              19 ;   (* total pieces per player on the board  *)
  34    PieceHeap      =            4000 ;   (* maximum moves we will examine per ply *)
  35    MaxScore       =          100000 ;
  36    MinScore       =         -100000 ;
  37    WinScore       =        MaxScore ;
  38    LooseScore     =       -WinScore ;
  39    Debugging      =           FALSE ;
  40    Thinking       =              10 ;   (* how many seconds can the program think? *)
  41    slowEvaluation =           FALSE ;
  42    HomeWeight     =          BoardX ;
  43
  44 TYPE
  45    Squares = [0..BoardSize-1] ;
  46    SoS     = SET OF Squares ;
  47    Colour  = (Blue, Red, Green, White) ;
  48
  49    Board = RECORD
  50               used  : SoS ;   (* is the square used at all? *)
  51               colour: ARRAY [0..1] OF SoS ;   (* if so which colour occupies the square? *)
  52               pieces: ARRAY [MIN(Colour)..MAX(Colour)] OF ARRAY [1..Pieces] OF CARDINAL8 ;
  53               home  : ARRAY [MIN(Colour)..MAX(Colour)] OF CARDINAL ;
  54            END ;
  55
  56    Moves = RECORD
  57               pieceHead: ARRAY [0..Pieces] OF CARDINAL ;      (* pieceHead[0] is start of peg 1 moves in the heap *)
  58               pieceList: ARRAY [0..PieceHeap] OF CARDINAL8 ;  (* pieceHead[1] is start of peg 2 moves in the heap *)
  59            END ;
  60
  61    Reachable = RECORD
  62                   no  : CARDINAL ;
  63                   prev: CARDINAL ;
  64                   dist: CARDINAL ;
  65                   list: ARRAY Squares OF CARDINAL ;
  66                END ;
  67
  68    Graph = RECORD
  69               graph: ARRAY Squares OF Reachable ;
  70            END ;
  71
  72 VAR
  73    count   : CARDINAL ;
  74    homeBase: ARRAY [MIN(Colour)..MAX(Colour)] OF SoS ;
  75
  76
  77 (*
  78    +-----------------------------------------------------------------+
  79    | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
  80    |                                                                 |
  81    | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
  82    |                                                                 |
  83    | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
  84    |                                                                 |
  85    | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
  86    |                                                                 |
  87    | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
  88    |                                                                 |
  89    | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
  90    |                                                                 |
  91    | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
  92    |                                                                 |
  93    | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
  94    |                                                                 |
  95    | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
  96    |                                                                 |
  97    |  96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111 |
  98    |                                                                 |
  99    |  80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95 |
 100    |                                                                 |
 101    |  64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79 |
 102    |---------                                                        |
 103    |  48  49 \50  51  52  53  54  55  56  57  58  59  60  61  62  63 |
 104    |           \                                                     |
 105    |  32  33  34 \35  36  37  38  39  40  41  42  43  44  45  46  47 |
 106    |               \                                                 |
 107    |  16  17  18  19| 20  21  22  23  24  25  26  27  28  29  30  31 |
 108    |                |                                                |
 109    |   0   1   2   3|  4   5   6   7   8   9  10  11  12  13  14  15 |
 110    +-----------------------------------------------------------------+
 111 *)
 112
 113
 114 (*
 115    stop -
 116 *)
 117
 118 PROCEDURE stop ;
 119 BEGIN
 120 END stop ;
 121
 122
 123 (*
 124    Min -
 125 *)
 126
 127 PROCEDURE Min (a, b: INTEGER) : INTEGER ;
 128 BEGIN
 129    IF a<b
 130    THEN
 131       RETURN( a )
 132    ELSE
 133       RETURN( b )
 134    END
 135 END Min ;
 136
 137
 138 (*
 139    assert -
 140 *)
 141
 142 PROCEDURE assert (b: BOOLEAN) ;
 143 BEGIN
 144    IF NOT b
 145    THEN
 146       WriteString('assert failed') ; WriteLn ;
 147       HALT
 148    END
 149 END assert ;
 150
 151
 152 (*
 153    initGraph - initialise, g, to empty.
 154 *)
 155
 156 PROCEDURE initGraph (VAR g: Graph) ;
 157 VAR
 158    i: CARDINAL ;
 159 BEGIN
 160    FOR i := MIN(Squares) TO MAX(Squares) DO
 161       g.graph[i].no   := 0 ;
 162       g.graph[i].prev := MAX(Squares)+1 ;
 163       g.graph[i].dist := MAX(Squares)+1
 164    END
 165 END initGraph ;
 166
 167
 168 (*
 169    isUsed - return whether a square, p, is in use on board, b.
 170 *)
 171
 172 PROCEDURE isUsed (VAR b: Board; p: CARDINAL) : BOOLEAN ;
 173 BEGIN
 174    RETURN p IN b.used
 175 END isUsed ;
 176
 177
 178 (*
 179    isColour - return TRUE if a square, p, is used and contains a
 180               piece of colour, c.
 181 *)
 182
 183 PROCEDURE isColour (VAR b: Board; p: CARDINAL; c: Colour) : BOOLEAN ;
 184 BEGIN
 185    WITH b DO
 186       IF p IN used
 187       THEN
 188          CASE c OF
 189
 190          Blue:  RETURN (NOT (p IN colour[0])) AND (NOT (p IN colour[1])) |
 191          Red :  RETURN (p IN colour[0]) AND (NOT (p IN colour[1])) |
 192          Green: RETURN (NOT (p IN colour[0])) AND (p IN colour[1]) |
 193          White: RETURN (p IN colour[0]) AND (p IN colour[1])
 194
 195          END
 196       END
 197    END ;
 198    RETURN( FALSE )
 199 END isColour ;
 200
 201
 202 (*
 203    dumpBase -
 204 *)
 205
 206 PROCEDURE dumpBase (c: Colour) ;
 207 VAR
 208    n, i: CARDINAL ;
 209 BEGIN
 210    WriteString('dumpBase(c) where ORD(c)=') ; WriteCard(ORD(c), 3) ; WriteLn ;
 211    n := 0 ;
 212    FOR i := 0 TO MAX(Squares) DO
 213       IF (n>0) AND ((n MOD 16) = 0)
 214       THEN
 215          WriteLn
 216       END ;
 217       IF i IN homeBase[c]
 218       THEN
 219          WriteChar('1')
 220       ELSE
 221          WriteChar('0')
 222       END ;
 223       INC(n)
 224    END ;
 225    WriteLn
 226 END dumpBase ;
 227
 228
 229
 230 (*
 231    addPiece - adds a piece, pos, of colour, c, to the board, b.
 232 *)
 233
 234 PROCEDURE addPiece (VAR b: Board; pos: CARDINAL; c: Colour; piece: CARDINAL) ;
 235 BEGIN
 236 (*
 237 VAR
 238    i: CARDINAL ;
 239
 240    IF pos IN homeBase[c]
 241    THEN
 242       WriteString('found ') ; WriteCard(pos, 3) ; WriteString(' in homeBase[c]') ;
 243       WriteLn ;
 244       dumpBase(c)
 245    END ;
 246 *)
 247
 248    WITH b DO
 249       INCL(used, pos) ;
 250       CASE c OF
 251
 252       Blue:  EXCL(colour[0], pos) ;
 253              EXCL(colour[1], pos) |
 254       Red :  INCL(colour[0], pos) ;
 255              EXCL(colour[1], pos) |
 256       Green: EXCL(colour[0], pos) ;
 257              INCL(colour[1], pos) |
 258       White: INCL(colour[0], pos) ;
 259              INCL(colour[1], pos)
 260
 261       END ;
 262       pieces[c][piece] := pos ;
 263       IF pos IN homeBase[c]
 264       THEN
 265          INC(home[c])
 266       END
 267    END
 268 END addPiece ;
 269
 270
 271 (*
 272    subPiece - removes a piece at, pos, from the board, b.
 273 *)
 274
 275 PROCEDURE subPiece (VAR b: Board; pos: CARDINAL; c: Colour) ;
 276 BEGIN
 277    WITH b DO
 278       EXCL(used, pos) ;
 279       IF pos IN homeBase[c]
 280       THEN
 281          DEC(home[c])
 282       END
 283    END
 284 END subPiece ;
 285
 286
 287 (*
 288    ifFreeAdd -
 289 *)
 290
 291 PROCEDURE ifFreeAdd (condition: BOOLEAN; VAR b: Board; t: INTEGER; p: CARDINAL; c: Colour; VAR m: Moves) ;
 292 BEGIN
 293    IF condition AND (NOT isUsed(b, t)) AND (NOT isRecorded(m, t, p))
 294    THEN
 295       recordMove(m, t, p)
 296    END
 297 END ifFreeAdd ;
 298
 299
 300 (*
 301    recordMove - adds tile, t, to piece, p, list of moves.
 302 *)
 303
 304 PROCEDURE recordMove (VAR m: Moves; t: INTEGER; p: CARDINAL) ;
 305 BEGIN
 306    WITH m DO
 307       pieceList[pieceHead[p]] := t ;
 308       INC(pieceHead[p])
 309    END
 310 END recordMove ;
 311
 312
 313 (*
 314    isRecorded - returns TRUE if tile, t, has been already entered as a
 315                 possible move for piece, p, on move list, m.
 316 *)
 317
 318 PROCEDURE isRecorded (VAR m: Moves; t: INTEGER; p: CARDINAL) : BOOLEAN ;
 319 VAR
 320    i, j: CARDINAL ;
 321 BEGIN
 322    WITH m DO
 323       j := pieceHead[p] ;
 324       i := pieceHead[p-1]+1 ;
 325       WHILE i<j DO
 326          IF pieceList[i] = VAL (CARDINAL8, t)
 327          THEN
 328             RETURN( TRUE )
 329          END ;
 330          INC(i)
 331       END
 332    END ;
 333    RETURN( FALSE )
 334 END isRecorded ;
 335
 336
 337 (*
 338    addSingle - adds a single move from a piece, testing all eight one square
 339                moves.
 340 *)
 341
 342 PROCEDURE addSingle (VAR b: Board; VAR m: Moves; c: Colour; p: CARDINAL) ;
 343 VAR
 344    t   : INTEGER ;
 345    x, y: INTEGER ;
 346 BEGIN
 347    WITH b DO
 348       t := VAL(INTEGER, pieces[c][p]) ;
 349       x := t MOD BoardX ;
 350       y := t DIV BoardX ;
 351       (* vertical and horizontal *)
 352
 353       ifFreeAdd(x>0, b, t-1, p, c, m) ;                                  (* -1,  0 *)
 354       ifFreeAdd(x<BoardX-1, b, t+1, p, c, m) ;                           (*  1,  0 *)
 355       ifFreeAdd(y>0, b, t-BoardX, p, c, m) ;                             (*  0, -1 *)
 356       ifFreeAdd(y<BoardY-1, b, t+BoardX, p, c, m) ;                      (*  0,  1 *)
 357
 358       (* diagonals *)
 359       ifFreeAdd((x>0) AND (y>0), b, t-(BoardX+1), p, c, m) ;             (* -1, -1 *)
 360       ifFreeAdd((x<BoardX-1) AND (y<BoardY-1), b, t+BoardX+1, p, c, m) ; (*  1,  1 *)
 361
 362       ifFreeAdd((x<BoardX-1) AND (y>0), b, t-(BoardX-1), p, c, m) ;      (*  1, -1 *)
 363       ifFreeAdd((x>0) AND (y<BoardY-1), b, t+(BoardX-1), p, c, m)        (* -1,  1 *)
 364    END
 365 END addSingle ;
 366
 367
 368 (*
 369    addMultipleV -
 370 *)
 371
 372 PROCEDURE addMultipleV (VAR b: Board; VAR m: Moves; c: Colour; p: CARDINAL; x, y, i, j: INTEGER) ;
 373 VAR
 374    t   : CARDINAL ;
 375    d, e: INTEGER ;
 376 BEGIN
 377    d := 1 ;
 378    IF i=0
 379    THEN
 380       IF j>0
 381       THEN
 382          e := (BoardY-y) DIV 2
 383       ELSIF j<0
 384       THEN
 385          e := y DIV 2
 386       END
 387    ELSIF j=0
 388    THEN
 389       IF i>0
 390       THEN
 391          e := (BoardX-x) DIV 2
 392       ELSIF i<0
 393       THEN
 394          e := x DIV 2
 395       END
 396    ELSE
 397       IF (i=1) AND (j=1)
 398       THEN
 399          e := Min((BoardX-x) DIV 2, (BoardY-y) DIV 2)
 400       ELSIF (i=-1) AND (j=1)
 401       THEN
 402          e := Min(x DIV 2, (BoardY-y) DIV 2)
 403       ELSIF (i=-1) AND (j=-1)
 404       THEN
 405          e := Min(x DIV 2, y DIV 2)
 406       ELSE
 407          (* 1, -1 *)
 408          e := Min((BoardX-x) DIV 2, y DIV 2)
 409       END
 410    END ;
 411    LOOP
 412       IF d>e
 413       THEN
 414          (* no point searching further as there is no room for the reflective jump *)
 415          RETURN
 416       END ;
 417       x := x + i ;
 418       y := y + j ;
 419       IF (x<0) OR (y<0) OR (x>=BoardX) OR (y>=BoardY)
 420       THEN
 421          RETURN
 422       END ;
 423       t := VAL(CARDINAL, y)*BoardX+VAL(CARDINAL, x) ;
 424       IF isUsed(b, t)
 425       THEN
 426          (* found pivot, keep looking for the destination *)
 427          WHILE d>0 DO
 428             x := x + i ;
 429             y := y + j ;
 430          (*
 431             IF i>=0
 432             THEN
 433                INC(x, i)
 434             ELSE
 435                DEC(x, -i)
 436             END ;
 437             IF j>=0
 438             THEN
 439                INC(y, j)
 440             ELSE
 441                DEC(y, -j)
 442             END ;
 443          *)
 444             IF (x<0) OR (y<0) OR (x>=BoardX) OR (y>=BoardY)
 445             THEN
 446                RETURN
 447             END ;
 448             t := VAL(CARDINAL, y)*BoardX+VAL(CARDINAL, x) ;
 449             IF isUsed(b, t)
 450             THEN
 451                RETURN
 452             END ;
 453             DEC(d)
 454          END ;
 455          IF NOT isRecorded(m, t, p)
 456          THEN
 457             IF Debugging
 458             THEN
 459                WriteString('adding move ') ; WriteCard(t, 0) ; WriteLn
 460             END ;
 461             recordMove(m, t, p)
 462          END ;
 463          RETURN
 464       END ;
 465       INC(d)
 466    END
 467 END addMultipleV ;
 468
 469
 470 (*
 471    addMultiple - adds moves which involve jumping.  Current peg, p, is at at position
 472                  indicated by, m.pieceList[low].
 473 *)
 474
 475 PROCEDURE addMultiple (VAR b: Board; VAR m: Moves; c: Colour; p: CARDINAL; low: CARDINAL) ;
 476 VAR
 477    t   : INTEGER ;
 478    x, y: INTEGER ;
 479 BEGIN
 480    WITH b DO
 481       WHILE low<m.pieceHead[p] DO
 482          t := VAL(INTEGER, m.pieceList[low]) ;
 483          x := t MOD BoardX ;
 484          y := t DIV BoardX ;
 485          addMultipleV(b, m, c, p, x, y, -1,  0) ;
 486          addMultipleV(b, m, c, p, x, y, -1,  1) ;
 487          addMultipleV(b, m, c, p, x, y, -1, -1) ;
 488
 489          addMultipleV(b, m, c, p, x, y,  1,  0) ;
 490          addMultipleV(b, m, c, p, x, y,  1,  1) ;
 491          addMultipleV(b, m, c, p, x, y,  1, -1) ;
 492
 493          addMultipleV(b, m, c, p, x, y,  0,  1) ;
 494          addMultipleV(b, m, c, p, x, y,  0, -1) ;
 495          INC(low)
 496       END
 497    END
 498 END addMultiple ;
 499
 500
 501 (*
 502    genMove - generate the moves for peg, p.
 503 *)
 504
 505 PROCEDURE genMove (VAR b: Board; VAR m: Moves; c: Colour; p: CARDINAL) ;
 506 BEGIN
 507    m.pieceHead[p] := m.pieceHead[p-1] ;
 508    recordMove(m, b.pieces[c][p], p) ;
 509    (* record the current position so we can ignore moving back to it *)
 510    addMultiple(b, m, c, p, m.pieceHead[p]-1) ;
 511    addSingle(b, m, c, p)
 512 END genMove ;
 513
 514
 515 (*
 516    genMoves - generate the list of moves for colour, c, on board, b.
 517               The board, b, is unaltered despite being passed by reference.
 518 *)
 519
 520 PROCEDURE genMoves (VAR b: Board; VAR m: Moves; c: Colour) ;
 521 VAR
 522    pos,
 523    peg: CARDINAL ;
 524 BEGIN
 525    m.pieceHead[0] := 0 ;
 526    FOR peg := 1 TO Pieces DO
 527       pos := b.pieces[c][peg] ;
 528       subPiece(b, pos, c) ;     (* remove this peg while jumping (so we dont jump over ourself) *)
 529       genMove(b, m, c, peg) ;
 530       addPiece(b, pos, c, peg)  (* restore the peg *)
 531    END
 532 END genMoves ;
 533
 534
 535 (*
 536    addToGraph -
 537 *)
 538
 539 PROCEDURE addToGraph (VAR g: Graph; from, to: CARDINAL) ;
 540 VAR
 541    i: CARDINAL ;
 542 BEGIN
 543    WITH g.graph[from] DO
 544       i := 0 ;
 545       WHILE i<no DO
 546          IF list[i]=to
 547          THEN
 548             RETURN
 549          ELSE
 550             INC(i)
 551          END
 552       END ;
 553       list[no] := to ;
 554       INC(no)
 555    END
 556 END addToGraph ;
 557
 558
 559 (*
 560    ifFreeRecord -
 561 *)
 562
 563 PROCEDURE ifFreeRecord (condition: BOOLEAN; VAR b: Board; t: INTEGER; p: CARDINAL;
 564                         c: Colour; VAR m: Moves; from: CARDINAL; VAR g: Graph) ;
 565 BEGIN
 566    IF condition AND (NOT isUsed(b, t)) AND (NOT isRecorded(m, t, p))
 567    THEN
 568       recordMove(m, t, p) ;
 569       addToGraph(g, from, t)
 570    END
 571 END ifFreeRecord ;
 572
 573
 574 (*
 575    recordSingle - adds a single move from a piece, testing all eight one square
 576                   moves.
 577 *)
 578
 579 PROCEDURE recordSingle (VAR b: Board; VAR m: Moves; c: Colour;
 580                         p: CARDINAL; from: CARDINAL; VAR g: Graph) ;
 581 VAR
 582    t   : INTEGER ;
 583    x, y: INTEGER ;
 584 BEGIN
 585    WITH b DO
 586       t := VAL(INTEGER, pieces[c][p]) ;
 587       x := t MOD BoardX ;
 588       y := t DIV BoardX ;
 589       (* vertical and horizontal *)
 590
 591       ifFreeRecord(x>0, b, t-1, p, c, m, from, g) ;                                  (* -1,  0 *)
 592       ifFreeRecord(x<BoardX-1, b, t+1, p, c, m, from, g) ;                           (*  1,  0 *)
 593       ifFreeRecord(y>0, b, t-BoardX, p, c, m, from, g) ;                             (*  0, -1 *)
 594       ifFreeRecord(y<BoardY-1, b, t+BoardX, p, c, m, from, g) ;                      (*  0,  1 *)
 595
 596       (* diagonals *)
 597       ifFreeRecord((x>0) AND (y>0), b, t-(BoardX+1), p, c, m, from, g) ;             (* -1, -1 *)
 598       ifFreeRecord((x<BoardX-1) AND (y<BoardY-1), b, t+BoardX+1, p, c, m, from, g) ; (*  1,  1 *)
 599
 600       ifFreeRecord((x<BoardX-1) AND (y>0), b, t-(BoardX-1), p, c, m, from, g) ;      (*  1, -1 *)
 601       ifFreeRecord((x>0) AND (y<BoardY-1), b, t+(BoardX-1), p, c, m, from, g)        (* -1,  1 *)
 602    END
 603 END recordSingle ;
 604
 605
 606 (*
 607    recordMultipleV -
 608 *)
 609
 610 PROCEDURE recordMultipleV (VAR b: Board; VAR m: Moves; c: Colour;
 611                            p: CARDINAL; x, y, i, j: INTEGER;
 612                            from: CARDINAL; VAR g: Graph) ;
 613 VAR
 614    t   : CARDINAL ;
 615    d, e: INTEGER ;
 616 BEGIN
 617    d := 1 ;
 618    IF i=0
 619    THEN
 620       IF j>0
 621       THEN
 622          e := (BoardY-y) DIV 2
 623       ELSIF j<0
 624       THEN
 625          e := y DIV 2
 626       END
 627    ELSIF j=0
 628    THEN
 629       IF i>0
 630       THEN
 631          e := (BoardX-x) DIV 2
 632       ELSIF i<0
 633       THEN
 634          e := x DIV 2
 635       END
 636    ELSE
 637       IF (i=1) AND (j=1)
 638       THEN
 639          e := Min((BoardX-x) DIV 2, (BoardY-y) DIV 2)
 640       ELSIF (i=-1) AND (j=1)
 641       THEN
 642          e := Min(x DIV 2, (BoardY-y) DIV 2)
 643       ELSIF (i=-1) AND (j=-1)
 644       THEN
 645          e := Min(x DIV 2, y DIV 2)
 646       ELSE
 647          (* 1, -1 *)
 648          e := Min((BoardX-x) DIV 2, y DIV 2)
 649       END
 650    END ;
 651    LOOP
 652       IF d>e
 653       THEN
 654          (* no point searching further as there is no room for the reflective jump *)
 655          RETURN
 656       END ;
 657       x := x + i ;
 658       y := y + j ;
 659       IF (x<0) OR (y<0) OR (x>=BoardX) OR (y>=BoardY)
 660       THEN
 661          RETURN
 662       END ;
 663       t := VAL(CARDINAL, y)*BoardX+VAL(CARDINAL, x) ;
 664       IF isUsed(b, t)
 665       THEN
 666          (* found pivot, keep looking for the destination *)
 667          WHILE d>0 DO
 668             x := x + i ;
 669             y := y + j ;
 670             IF (x<0) OR (y<0) OR (x>=BoardX) OR (y>=BoardY)
 671             THEN
 672                RETURN
 673             END ;
 674             t := VAL(CARDINAL, y)*BoardX+VAL(CARDINAL, x) ;
 675             IF isUsed(b, t)
 676             THEN
 677                RETURN
 678             END ;
 679             DEC(d)
 680          END ;
 681          IF NOT isRecorded(m, t, p)
 682          THEN
 683             IF Debugging
 684             THEN
 685                WriteString('adding move ') ; WriteCard(t, 0) ; WriteLn
 686             END ;
 687             recordMove(m, t, p) ;
 688             addToGraph(g, from, t) ;
 689             addToGraph(g, t, from)
 690          END ;
 691          RETURN
 692       END ;
 693       INC(d)
 694    END
 695 END recordMultipleV ;
 696
 697
 698 (*
 699    recordMultiple - adds moves which involve jumping.  Current peg, p, is at at position
 700                     indicated by, m.pieceList[low].
 701 *)
 702
 703 PROCEDURE recordMultiple (VAR b: Board; VAR m: Moves; c: Colour;
 704                           p: CARDINAL; low: CARDINAL; VAR g: Graph) ;
 705 VAR
 706    from: INTEGER ;
 707    x, y: INTEGER ;
 708 BEGIN
 709    WITH b DO
 710       WHILE low<m.pieceHead[p] DO
 711          from := VAL(INTEGER, m.pieceList[low]) ;
 712          x := from MOD BoardX ;
 713          y := from DIV BoardX ;
 714          recordMultipleV(b, m, c, p, x, y, -1,  0, from, g) ;
 715          recordMultipleV(b, m, c, p, x, y, -1,  1, from, g) ;
 716          recordMultipleV(b, m, c, p, x, y, -1, -1, from, g) ;
 717
 718          recordMultipleV(b, m, c, p, x, y,  1,  0, from, g) ;
 719          recordMultipleV(b, m, c, p, x, y,  1,  1, from, g) ;
 720          recordMultipleV(b, m, c, p, x, y,  1, -1, from, g) ;
 721
 722          recordMultipleV(b, m, c, p, x, y,  0,  1, from, g) ;
 723          recordMultipleV(b, m, c, p, x, y,  0, -1, from, g) ;
 724          INC(low)
 725       END
 726    END
 727 END recordMultiple ;
 728
 729
 730 (*
 731    recMove - generate the moves for peg, p.
 732 *)
 733
 734 PROCEDURE recMove (VAR b: Board; VAR m: Moves; c: Colour;
 735                    p: CARDINAL; from: CARDINAL; VAR g: Graph) ;
 736 BEGIN
 737    m.pieceHead[p-1] := 0 ;
 738    m.pieceHead[p] := 0 ;
 739    recordMove(m, from, p) ;
 740    (* record the current position so we can ignore moving back to it *)
 741    recordMultiple(b, m, c, p, m.pieceHead[p]-1, g) ;
 742    recordSingle(b, m, c, p, from, g)
 743 END recMove ;
 744
 745
 746 (*
 747    recMoves - generate the list of moves for colour, c, on board, b, and record each
 748               move in r.
 749               The board, b, is unaltered despite being passed by reference.
 750 *)
 751
 752 PROCEDURE recMoves (VAR b: Board; VAR m: Moves; c: Colour;
 753                     peg: CARDINAL; from: CARDINAL; VAR g: Graph) ;
 754 VAR
 755    pos: CARDINAL ;
 756 BEGIN
 757    pos := b.pieces[c][peg] ;
 758    subPiece(b, pos, c) ;        (* remove this peg while jumping (so we dont jump over ourself) *)
 759    initGraph(g) ;
 760    recMove(b, m, c, peg, from, g) ;
 761    addPiece(b, pos, c, peg)  (* restore the peg *)
 762 END recMoves ;
 763
 764
 765 (*
 766    WriteColour - displays the colour, c.
 767 *)
 768
 769 PROCEDURE WriteColour (c: Colour) ;
 770 BEGIN
 771    CASE c OF
 772
 773    White:  WriteString('white') |
 774    Blue :  WriteString('blue') |
 775    Green:  WriteString('green') |
 776    Red  :  WriteString('red')
 777
 778    END
 779 END WriteColour ;
 780
 781
 782 (*
 783    getFirstPos -
 784 *)
 785
 786 PROCEDURE getFirstPos (s: ARRAY OF CHAR; VAR b: Board; c: Colour) : CARDINAL ;
 787 VAR
 788    from: CARDINAL ;
 789    x   : CHAR ;
 790    y   : CARDINAL ;
 791    res : ConvResults ;
 792 BEGIN
 793    IF Length(s)>0
 794    THEN
 795       x := CAP(s[0]) ;
 796       IF x='?'
 797       THEN
 798          displayAllMoves(b, c)
 799       ELSIF (x>='A') AND (x<='P')
 800       THEN
 801          from := ORD (x) - ORD ('A') ;
 802          s[0] := '0' ;
 803          IF Length(s)>0
 804          THEN
 805             StrToCard(s, y, res) ;
 806             IF (res=strAllRight) AND ((y=0) OR (y>BoardY))
 807             THEN
 808                WriteString('Please enter a number between [1-16]') ; WriteLn
 809             ELSE
 810                from := from+(y-1)*BoardY ;
 811                IF isUsed(b, from) AND isColour(b, from, c)
 812                THEN
 813                   RETURN from
 814                ELSE
 815                   WriteString('That position is occupied by your opponent') ; WriteLn
 816                END
 817             END
 818          END
 819       ELSE
 820          WriteString('please enter a letter [A-P] followed by a number [1-16]') ; WriteLn
 821       END
 822    END ;
 823    RETURN BoardSize
 824 END getFirstPos ;
 825
 826
 827 (*
 828    getSecondPos -
 829 *)
 830
 831 PROCEDURE getSecondPos (s: ARRAY OF CHAR; VAR b: Board; c: Colour; peg: CARDINAL) : CARDINAL ;
 832 VAR
 833    from: CARDINAL ;
 834    x   : CHAR ;
 835    y   : CARDINAL ;
 836    res : ConvResults ;
 837 BEGIN
 838    IF Length(s)>0
 839    THEN
 840       x := CAP(s[0]) ;
 841       IF x='?'
 842       THEN
 843          displayMovesPeg(b, c, peg) ;
 844          displayBoardPeg(b, c, peg)
 845       ELSIF (x>='A') AND (x<='P')
 846       THEN
 847          from := ORD (x) - ORD ('A') ;
 848          s[0] := '0' ;
 849          IF Length(s)>0
 850          THEN
 851             StrToCard(s, y, res) ;
 852             IF (res=strAllRight) AND ((y=0) OR (y>BoardY))
 853             THEN
 854                WriteString('Please enter a number between [1-16]') ; WriteLn
 855             ELSE
 856                from := from+(y-1)*BoardY ;
 857                IF NOT isUsed(b, from)
 858                THEN
 859                   RETURN from
 860                ELSIF isColour(b, from, c)
 861                THEN
 862                   WriteString('That position is already occupied by another of your pegs') ; WriteLn
 863                ELSE
 864                   WriteString('That position is occupied by your opponent') ; WriteLn
 865                END
 866             END
 867          END
 868       ELSE
 869          WriteString('please enter a letter [A-P] followed by a number [1-16]') ; WriteLn
 870       END
 871    END ;
 872    RETURN BoardSize
 873 END getSecondPos ;
 874
 875
 876 (*
 877    getPeg -
 878 *)
 879
 880 PROCEDURE getPeg (VAR b: Board; c: Colour; from: CARDINAL) : CARDINAL ;
 881 VAR
 882    p: CARDINAL ;
 883 BEGIN
 884    FOR p := 1 TO Pieces DO
 885       IF b.pieces[c][p] = VAL (CARDINAL8, from)
 886       THEN
 887          RETURN p
 888       END
 889    END ;
 890    HALT ;
 891    RETURN Pieces+1
 892 END getPeg ;
 893
 894
 895 (*
 896    checkLegal -
 897 *)
 898
 899 PROCEDURE checkLegal (VAR b: Board; col: Colour; from, to: CARDINAL; peg: CARDINAL) : BOOLEAN ;
 900 VAR
 901    m   : Moves ;
 902    i, j: CARDINAL ;
 903 BEGIN
 904    IF (to=BoardSize) OR (from=BoardSize)
 905    THEN
 906       RETURN FALSE
 907    END ;
 908    genMoves(b, m, col) ;
 909    IF VAL (CARDINAL8, from) # b.pieces[col][peg]
 910    THEN
 911       RETURN FALSE
 912    END ;
 913    i := m.pieceHead[peg-1]+1 ;  (* skip the initial move *)
 914    j := m.pieceHead[peg] ;
 915    WHILE i<j DO
 916       IF VAL (CARDINAL8, to) = m.pieceList[i]
 917       THEN
 918          RETURN TRUE
 919       END ;
 920       INC(i)
 921    END ;
 922    RETURN FALSE
 923 END checkLegal ;
 924
 925
 926 (*
 927    noOfMoves - returns the number of moves held in, m.
 928 *)
 929
 930 PROCEDURE noOfMoves (VAR m: Moves) : CARDINAL ;
 931 VAR
 932    n, p, i, j: CARDINAL ;
 933 BEGIN
 934    n := 0 ;
 935    FOR p := 1 TO Pieces DO
 936       i := m.pieceHead[p-1]+1 ;  (* skip the initial move *)
 937       j := m.pieceHead[p] ;
 938       WHILE i<j DO
 939          INC(n) ;
 940          INC(i)
 941       END
 942    END ;
 943    RETURN n
 944 END noOfMoves ;
 945
 946
 947 (*
 948    askMove - returns a move entered.
 949 *)
 950
 951 PROCEDURE askMove (VAR b: Board; c: Colour; VAR peg: CARDINAL) : CARDINAL ;
 952 VAR
 953    s       : ARRAY [0..80] OF CHAR ;
 954    y,
 955    from, to: CARDINAL ;
 956    res     : ConvResults ;
 957 BEGIN
 958    LOOP
 959       WriteString('Please enter your move, from, ') ;
 960       WriteColour(c) ;
 961       WriteString(' ') ;
 962       ReadToken(s) ;
 963       SkipLine ;
 964       from := getFirstPos(s, b, c) ;
 965       IF from=BoardSize
 966       THEN
 967          WriteString('please try again...') ; WriteLn
 968       ELSE
 969          WriteString('now please enter your move, to, ') ;
 970          WriteColour(c) ;
 971          WriteString(' ') ;
 972          ReadToken(s) ;
 973          SkipLine ;
 974          peg := getPeg(b, c, from) ;
 975          to := getSecondPos(s, b, c, peg) ;
 976          IF checkLegal(b, c, from, to, peg)
 977          THEN
 978             WriteString('you are ') ;
 979             showMove(b, c, peg, from, to) ;
 980             RETURN to
 981          END
 982       END
 983    END
 984 END askMove ;
 985
 986
 987 (*
 988    opponent - returns the opponents colour.
 989 *)
 990
 991 PROCEDURE opponent (col: Colour) : Colour ;
 992 BEGIN
 993    IF col=Red
 994    THEN
 995       RETURN Blue
 996    ELSE
 997       RETURN Red
 998    END
 999 END opponent ;
1000
1001
1002 (*
1003    maximumScore - returns TRUE if the maximim score was found.
1004 *)
1005
1006 PROCEDURE maximumScore (score: INTEGER) : BOOLEAN ;
1007 BEGIN
1008    RETURN (score<=MinScore) OR (score>=MaxScore)
1009 END maximumScore ;
1010
1011
1012 (*
1013    calcScoreForPos - returns the score for Colour, c, pos, on Board, b.
1014 *)
1015
1016 PROCEDURE calcScoreForPos (VAR b: Board; c: Colour; pos: CARDINAL) : INTEGER ;
1017 VAR
1018    home,
1019    x, y: CARDINAL ;
1020 BEGIN
1021    IF c=Red
1022    THEN
1023       pos := (BoardSize-1) - pos
1024    ELSIF c=Blue
1025    THEN
1026       (* nothing to do *)
1027    ELSE
1028       HALT  (* not implemented yet *)
1029    END ;
1030    IF pos IN homeBase[c]
1031    THEN
1032       home := HomeWeight
1033    ELSE
1034       home := 0
1035    END ;
1036
1037    (* our score is dependant upon how far this piece is away from the opposite corner *)
1038    x := pos MOD BoardX ;
1039    y := pos DIV BoardY ;
1040    IF x>y
1041    THEN
1042       (* max squares from 0,0 *)
1043       RETURN BoardX-x+home
1044    ELSE
1045       RETURN BoardY-y+home
1046    END
1047 END calcScoreForPos ;
1048
1049
1050 (*
1051    calcScoreFor - returns the score for Colour, c.
1052 *)
1053
1054 PROCEDURE calcScoreFor (VAR b: Board; c: Colour) : INTEGER ;
1055 VAR
1056    score: INTEGER ;
1057    p    : CARDINAL ;
1058 BEGIN
1059    score := 0 ;
1060    FOR p := 1 TO Pieces DO
1061       INC(score, calcScoreForPos(b, c, b.pieces[c][p]))
1062    END ;
1063    RETURN score
1064 END calcScoreFor ;
1065
1066
1067 (*
1068    updateMove -
1069 *)
1070
1071 PROCEDURE updateMove (VAR b: Board; col: Colour; peg: CARDINAL; topos: CARDINAL) ;
1072 VAR
1073    frompos: CARDINAL ;
1074 BEGIN
1075    frompos := b.pieces[col][peg] ;
1076    subPiece(b, frompos, col) ;
1077    addPiece(b, topos, col, peg)
1078 END updateMove ;
1079
1080
1081 (*
1082    retractMove -
1083 *)
1084
1085 PROCEDURE retractMove (VAR b: Board; col: Colour; peg: CARDINAL; topos: CARDINAL) ;
1086 BEGIN
1087    updateMove(b, col, peg, topos)
1088 END retractMove ;
1089
1090
1091 (*
1092    calcScore - make the move and update the score.
1093 *)
1094
1095 PROCEDURE calcScore (VAR b: Board; score: INTEGER; peg: CARDINAL;
1096                      topos: CARDINAL; col: Colour) : INTEGER ;
1097 VAR
1098    i, j, k: INTEGER ;
1099 BEGIN
1100    IF slowEvaluation
1101    THEN
1102       (* compute the score by examine each peg in turn *)
1103       updateMove(b, col, peg, topos) ;
1104
1105       (* check whether one side has won *)
1106       IF b.home[Blue]=Pieces
1107       THEN
1108          RETURN MaxScore
1109       ELSIF b.home[Red]=Pieces
1110       THEN
1111          RETURN MinScore
1112       END ;
1113
1114       RETURN calcScoreFor(b, Blue) - calcScoreFor(b, Red)
1115    ELSE
1116       i := calcScoreForPos(b, col, b.pieces[col][peg]) ;
1117       updateMove(b, col, peg, topos) ;  (* move the peg *)
1118
1119       (* check whether one side has won *)
1120       IF b.home[Blue]=Pieces
1121       THEN
1122          RETURN MaxScore
1123       ELSIF b.home[Red]=Pieces
1124       THEN
1125          RETURN MinScore
1126       END ;
1127
1128       j := calcScoreForPos(b, col, topos) ;
1129       IF col=Red
1130       THEN
1131          score := score + i - j
1132       ELSE
1133          score := score - i + j
1134       END ;
1135       IF Debugging
1136       THEN
1137          k := calcScoreFor(b, Blue) - calcScoreFor(b, Red) ;
1138          IF score#k
1139          THEN
1140             HALT
1141          END
1142       END ;
1143       RETURN score
1144    END
1145 END calcScore ;
1146
1147
1148 (*
1149    alphaBeta - returns the score estimated should move, pos, be chosen.
1150                The board, b, and score is in the state _before_ move pos
1151                is made.
1152 *)
1153
1154 PROCEDURE alphaBeta (peg: CARDINAL; frompos, topos: CARDINAL;
1155                      VAR b: Board; col: Colour;
1156                      depth: CARDINAL;
1157                      alpha, beta, score: INTEGER) : INTEGER ;
1158 VAR
1159    try     : INTEGER ;
1160    i, j,
1161    n, p    : CARDINAL ;
1162    m       : Moves ;
1163    from, to: CARDINAL ;
1164    op      : Colour ;
1165 BEGIN
1166    score := calcScore(b, score, peg, topos, col) ;   (* make move and update score *)
1167    IF (depth=0) OR maximumScore(score)
1168    THEN
1169       retractMove(b, col, peg, frompos) ;
1170       INC(count) ;
1171       IF col=Red
1172       THEN
1173          RETURN score+VAL(INTEGER, depth)
1174       ELSE
1175          RETURN score-VAL(INTEGER, depth)
1176       END
1177    ELSE
1178       op := opponent(col) ;
1179       genMoves(b, m, op) ;
1180       IF op=Blue
1181       THEN
1182          (* blue to move, move is possible, continue searching *)
1183          FOR p := 1 TO Pieces DO
1184             from := b.pieces[op][p] ;
1185             i := m.pieceHead[p-1]+1 ;  (* skip the initial move *)
1186             j := m.pieceHead[p] ;
1187             WHILE i<j DO
1188                to := m.pieceList[i] ;
1189                try := alphaBeta(p, from, to,
1190                                 b, op, depth-1, alpha, beta, score) ;
1191                IF try > alpha
1192                THEN
1193                   (* found a better move *)
1194                   alpha := try
1195                END ;
1196                IF alpha >= beta
1197                THEN
1198                   retractMove(b, col, peg, frompos) ;
1199                   RETURN alpha
1200                END ;
1201                INC(i)
1202             END
1203          END ;
1204          retractMove(b, col, peg, frompos) ;
1205          RETURN alpha
1206       ELSE
1207          (* red to move, move is possible, continue searching *)
1208          FOR p := 1 TO Pieces DO
1209             from := b.pieces[op][p] ;
1210             i := m.pieceHead[p-1]+1 ;  (* skip the initial move *)
1211             j := m.pieceHead[p] ;
1212             WHILE i<j DO
1213                to := m.pieceList[i] ;
1214                try := alphaBeta(p, from, to,
1215                                 b, op, depth-1, alpha, beta, score) ;
1216                IF try < beta
1217                THEN
1218                   (* found a better move *)
1219                   beta := try
1220                END ;
1221                IF alpha >= beta
1222                THEN
1223                   (* no point searching further as Red would choose
1224                    a different previous move *)
1225                   retractMove(b, col, peg, frompos) ;
1226                   RETURN beta
1227                END ;
1228                INC(i)
1229             END
1230          END ;
1231          retractMove(b, col, peg, frompos) ;
1232          RETURN beta   (* the best score for a move Blue has found *)
1233       END
1234    END
1235 END alphaBeta ;
1236
1237
1238 (*
1239    makeMove - computer makes a move for colour, col.
1240 *)
1241
1242 PROCEDURE makeMove (VAR b: Board; col: Colour; score: INTEGER; VAR peg: CARDINAL) : INTEGER ;
1243 VAR
1244    no        : CARDINAL ;
1245    p, from,
1246    frompos,
1247    topos, to : CARDINAL ;
1248    start, end: Timeval ;
1249    try,
1250    r, best   : INTEGER ;
1251    secS, usec,
1252    secE, i, j: CARDINAL ;
1253    m         : Moves ;
1254    plies     : CARDINAL ;
1255    outOfTime : BOOLEAN ;
1256 BEGIN
1257    start := InitTime(0, 0) ;
1258    end := InitTime(0, 0) ;
1259
1260    r := GetTimeOfDay(start) ;
1261    best := MinScore-1 ;   (* worst than minimum score so we will choose a loosing move if forced *)
1262
1263    count := 0 ;
1264    i := 0 ;
1265    genMoves(b, m, col) ;
1266    no := noOfMoves(m) ;
1267    peg := Pieces+1 ;
1268    outOfTime := FALSE ;
1269    plies := 0 ;
1270    frompos := BoardSize ;
1271    topos := BoardSize ;
1272    REPEAT
1273       WriteString("I'm going to look ") ;
1274       WriteCard(plies, 0) ; WriteString(' moves ahead') ; WriteLn ;
1275
1276       FOR p := 1 TO Pieces DO
1277          from := b.pieces[col][p] ;
1278          i := m.pieceHead[p-1]+1 ;  (* skip the initial move *)
1279          j := m.pieceHead[p] ;
1280          IF (no=1) AND (i<j)
1281          THEN
1282             (* only one move and this peg can move, therefore dont bother evaluating the move, just play it *)
1283             to := m.pieceList[i] ;
1284             frompos := from ;
1285             best := 0 ;
1286             topos := to ;
1287             peg := p
1288          ELSE
1289             WHILE (i<j) AND (NOT outOfTime) DO
1290                r := GetTimeOfDay(end) ;
1291                GetTime(start, secS, usec) ;
1292                GetTime(end, secE, usec) ;
1293                outOfTime := (secE-secS > Thinking) ;
1294
1295                IF outOfTime
1296                THEN
1297                   WriteString('out of time...') ; WriteLn
1298                ELSE
1299                   to := m.pieceList[i] ;
1300                   try := alphaBeta(p, from, to,
1301                                    b, col, plies,
1302                                    MinScore, MaxScore, score) ;
1303                   IF try>best
1304                   THEN
1305                      best := try ;
1306                      topos := to ;
1307                      frompos := from ;
1308                      peg := p
1309                   END
1310                END ;
1311                INC(i)
1312             END
1313          END
1314       END ;
1315       IF (NOT outOfTime) AND (frompos<BoardSize) AND (topos<BoardSize)
1316       THEN
1317          WriteString('so far I think the best move is from') ;
1318          writePosition(frompos) ;
1319          WriteString(' to') ;
1320          writePosition(topos) ;
1321          WriteLn
1322       END ;
1323       INC(plies)
1324    UNTIL (no<2) OR outOfTime ;
1325
1326    IF best >= WinScore
1327    THEN
1328       WriteString('I think I can force a win') ; WriteLn
1329    END ;
1330    IF best <= LooseScore
1331    THEN
1332       WriteString('You should be able to force a win') ; WriteLn
1333    END ;
1334
1335    IF no=1
1336    THEN
1337       WriteString('I can only play one move, so there is little point wasting time') ; WriteLn
1338    ELSIF no=0
1339    THEN
1340       WriteString('I cannot move, so there is little point wasting time') ; WriteLn
1341    ELSE
1342       WriteString('I took ') ; WriteCard(secE-secS, 0) ;
1343       WriteString(' seconds and evaluated ') ;
1344       WriteCard(count, 0) ; WriteString(' positions,') ; WriteLn ;
1345    END ;
1346
1347    start := KillTime(start) ;
1348    end := KillTime(end) ;
1349    RETURN topos
1350 END makeMove ;
1351
1352
1353 (*
1354    test -
1355 *)
1356
1357 PROCEDURE test ;
1358 VAR
1359    b  : Board ;
1360    c  : Colour ;
1361    s  : INTEGER ;
1362    peg,
1363    to : CARDINAL ;
1364 BEGIN
1365    initBoard(b) ;
1366    c := Red ;
1367    s := 0 ;
1368    displayBoard(b) ;
1369    peg := getPeg(b, c, 4) ;
1370    displayBoardPeg(b, c, peg) ;
1371    to := 36 ;
1372    s := calcScore(b, s, peg, to, c) ;
1373
1374
1375
1376    peg := 5 ;
1377    c := opponent(c) ;
1378    peg := getPeg(b, c, 12*BoardX+15) ;
1379    to := 12*BoardX+13 ;
1380    s := calcScore(b, s, peg, to, c) ;
1381    displayBoardPeg(b, c, peg) ;
1382
1383
1384
1385    c := Red ;
1386    displayBoard(b) ;
1387    peg := getPeg(b, c, 36) ;
1388    stop ;
1389    displayBoardPeg(b, c, peg) ;
1390    to := 4 ;
1391    s := calcScore(b, s, peg, to, c) ;
1392    displayBoardPeg(b, c, peg) ;
1393
1394 END test ;
1395
1396
1397 (*
1398    displayHow -
1399 *)
1400
1401 PROCEDURE displayHow (from, to: CARDINAL; VAR rec: ARRAY OF CARDINAL; r: CARDINAL) ;
1402 VAR
1403    i: CARDINAL ;
1404 BEGIN
1405    writePosition(from) ; WriteString(' can move to ') ; writePosition(to) ; WriteString(' by: ') ;
1406    i := 0 ;
1407    WHILE (i<r) AND (i<=HIGH(rec)) DO
1408       writePosition(rec[i])
1409    END ;
1410    WriteLn
1411 END displayHow ;
1412
1413
1414 (*
1415    addToList -
1416 *)
1417
1418 PROCEDURE addToList (VAR choices: ARRAY OF CARDINAL; VAR n: CARDINAL; from: CARDINAL) ;
1419 VAR
1420    i: CARDINAL ;
1421 BEGIN
1422    i := 0 ;
1423    WHILE i<n DO
1424       IF choices[i]=from
1425       THEN
1426          RETURN
1427       END ;
1428       INC(i)
1429    END ;
1430    choices[n] := from ;
1431    INC(n)
1432 END addToList ;
1433
1434
1435 (*
1436    subBest -
1437 *)
1438
1439 PROCEDURE subBest (VAR choices: ARRAY OF CARDINAL; VAR n: CARDINAL; VAR g: Graph) : CARDINAL ;
1440 VAR
1441    b: CARDINAL ;
1442    i, j, k: CARDINAL ;
1443 BEGIN
1444    k := choices[0] ;
1445    b := g.graph[k].dist ;
1446    i := 1 ;
1447    WHILE i<n DO
1448       IF g.graph[choices[i]].dist<b
1449       THEN
1450          k := choices[i] ;
1451          b := g.graph[k].dist
1452       END ;
1453       INC(i)
1454    END ;
1455    (* remove, k, from, choices *)
1456    i := 0 ;
1457    j := 0 ;
1458    WHILE i<n DO
1459       IF i#j
1460       THEN
1461          choices[i] := choices[j] ;
1462          INC(i) ;
1463       ELSIF choices[i]#k
1464       THEN
1465          INC(i)
1466       END ;
1467       INC(j)
1468    END ;
1469    DEC(n) ;
1470    RETURN k
1471 END subBest ;
1472
1473
1474 (*
1475    dijkstra -
1476 *)
1477
1478 PROCEDURE dijkstra (from, to: CARDINAL; VAR g: Graph) ;
1479 VAR
1480    visited: SoS ;
1481    choices: ARRAY Squares OF CARDINAL ;
1482    alt,
1483    n, i   : CARDINAL ;
1484    u, v   : CARDINAL ;
1485 BEGIN
1486    g.graph[from].dist := 0 ;
1487    g.graph[from].prev := from ;
1488    visited := SoS{from} ;
1489    n := 0 ;
1490    addToList(choices, n, from) ;
1491    WHILE n#0 DO
1492       u := subBest(choices, n, g) ;
1493       IF u=to
1494       THEN
1495          RETURN
1496       ELSE
1497          WITH g.graph[u] DO
1498             i := 0 ;
1499             WHILE i<no DO
1500                v := list[i] ;
1501                IF NOT (v IN visited)
1502                THEN
1503                   INCL(visited, v) ;
1504                   addToList(choices, n, v) ;
1505                   alt := dist + 1 ;
1506                   IF alt<g.graph[v].dist
1507                   THEN
1508                      g.graph[v].dist := alt ;
1509                      g.graph[v].prev := u
1510                   END
1511                END ;
1512                INC(i)
1513             END
1514          END
1515       END
1516    END
1517 END dijkstra ;
1518
1519
1520 (*
1521    showRoute -
1522 *)
1523
1524 PROCEDURE showRoute (from, to: CARDINAL; VAR g: Graph) ;
1525 BEGIN
1526    IF from#to
1527    THEN
1528       showRoute(from, g.graph[to].prev, g)
1529    END ;
1530    IF from=to
1531    THEN
1532       WriteString(' from')
1533    ELSE
1534       WriteString(' to')
1535    END ;
1536    writePosition(to)
1537 END showRoute ;
1538
1539
1540 (*
1541    showMove - show how, peg, can move, from, to, on board, b.
1542 *)
1543
1544 PROCEDURE showMove (VAR b: Board;
1545                     c: Colour; peg: CARDINAL; from, to: CARDINAL) ;
1546 VAR
1547    m: Moves ;
1548    g: Graph ;
1549 BEGIN
1550    recMoves(b, m, c, peg, from, g) ;
1551    dijkstra(from, to, g) ;
1552    WriteString('moving peg') ;
1553    showRoute(from, to, g) ;
1554    WriteLn
1555 END showMove ;
1556
1557
1558 (*
1559    play -
1560 *)
1561
1562 PROCEDURE play ;
1563 VAR
1564    b       : Board ;
1565    c       : Colour ;
1566    s       : INTEGER ;
1567    peg,
1568    to, from: CARDINAL ;
1569 BEGIN
1570    initBoard(b) ;
1571    c := Red ;
1572    s := 0 ;
1573    displayBoard(b) ;
1574    RETURN ;   (* remove this line of code if you really want to play the game.  *)
1575    LOOP
1576       to := askMove(b, c, peg) ;
1577       s := calcScore(b, s, peg, to, c) ;
1578       displayBoard(b) ;
1579       WriteString('Current score = ') ; WriteInt(s, 0) ; WriteLn ;
1580       IF s<=MinScore
1581       THEN
1582          WriteString('Well done you win') ; WriteLn ;
1583          RETURN
1584       END ;
1585       c := opponent(c) ;
1586       to := makeMove(b, c, s, peg) ;
1587       IF peg>Pieces
1588       THEN
1589          WriteString('I cannot move') ; WriteLn
1590       ELSE
1591          from := b.pieces[c][peg] ;
1592          WriteString('I am ') ;
1593          showMove(b, c, peg, from, to) ;
1594          s := calcScore(b, s, peg, to, c) ;
1595          displayBoard(b) ;
1596          WriteString('Current score = ') ; WriteInt(s, 0) ; WriteLn ;
1597          IF s>=MaxScore
1598          THEN
1599             WriteString('Good try, but I win') ; WriteLn ;
1600             RETURN
1601          END
1602       END ;
1603       c := opponent(c)
1604    END
1605 END play ;
1606
1607
1608 (*
1609    writePosition -
1610 *)
1611
1612 PROCEDURE writePosition (x: CARDINAL) ;
1613 BEGIN
1614    WriteChar(' ') ;
1615    WriteChar(CHR(ORD('a')+x MOD BoardX)) ;
1616    WriteCard(x DIV BoardX+1, 0)
1617 END writePosition ;
1618
1619
1620 (*
1621    displayMovesForPeg -
1622 *)
1623
1624 PROCEDURE displayMovesForPeg (VAR b: Board; m: Moves; c: Colour; peg: CARDINAL) ;
1625 VAR
1626    p, i, j: CARDINAL ;
1627 BEGIN
1628    WriteString('peg at') ;
1629    writePosition(b.pieces[c][peg]) ;
1630    IF m.pieceHead[peg-1]+1<m.pieceHead[peg]
1631    THEN
1632       WriteString(' can move to ') ;
1633       i := m.pieceHead[peg-1]+1 ;  (* skip the initial move *)
1634       j := m.pieceHead[peg] ;
1635       WHILE i<j DO
1636          writePosition(m.pieceList[i]) ;
1637          WriteString(' ') ;
1638          INC(i)
1639       END ;
1640       WriteLn
1641    ELSE
1642       WriteString(' cannot move') ; WriteLn
1643    END
1644 END displayMovesForPeg ;
1645
1646
1647 (*
1648    displayMoves -
1649 *)
1650
1651 PROCEDURE displayMoves (VAR b: Board; m: Moves; c: Colour) ;
1652 VAR
1653    p, i, j: CARDINAL ;
1654 BEGIN
1655    WriteString('possible moves are ') ; WriteLn ;
1656    FOR p := 1 TO Pieces DO
1657       IF m.pieceHead[p-1]+1<m.pieceHead[p]
1658       THEN
1659          WriteString('piece at position ') ;
1660          writePosition(b.pieces[c][p]) ;
1661          WriteString(' can move to ') ;
1662          i := m.pieceHead[p-1]+1 ;  (* skip the initial move *)
1663          j := m.pieceHead[p] ;
1664          WHILE i<j DO
1665             writePosition(m.pieceList[i]) ;
1666             WriteString(' ') ;
1667             INC(i)
1668          END ;
1669          WriteLn
1670       END
1671    END
1672 END displayMoves ;
1673
1674
1675 (*
1676    displayAllMoves -
1677 *)
1678
1679 PROCEDURE displayAllMoves (VAR b: Board; c: Colour) ;
1680 VAR
1681    m: Moves ;
1682 BEGIN
1683    genMoves(b, m, c) ;
1684    displayMoves(b, m, c)
1685 END displayAllMoves ;
1686
1687
1688 (*
1689    displayMovesPeg -
1690 *)
1691
1692 PROCEDURE displayMovesPeg (VAR b: Board; c: Colour; peg: CARDINAL) ;
1693 VAR
1694    m: Moves ;
1695 BEGIN
1696    genMoves(b, m, c) ;
1697    displayMovesForPeg(b, m, c, peg)
1698 END displayMovesPeg ;
1699
1700
1701 (*
1702    initBoard -
1703 *)
1704
1705 PROCEDURE initBoard (VAR b: Board) ;
1706 BEGIN
1707    b.used := SoS {} ;
1708    b.colour[0] := SoS {} ;
1709    b.colour[1] := SoS {} ;
1710    b.home[Blue] := 0 ;
1711    b.home[Red] := 0 ;
1712    b.home[Green] := 0 ;
1713    b.home[White] := 0 ;
1714    IF TwoPlayer OR FourPlayer
1715    THEN
1716       homeBase[Blue] := SoS{0, 1, 2, 3,
1717                             16, 17, 18, 19,
1718                             32, 33, 34,
1719                             48, 49} ;
1720       IF Debugging
1721       THEN
1722          dumpBase(Blue) ;
1723          dumpBase(Red)
1724       END ;
1725
1726       homeBase[Red] := SoS{255-0, 255-1, 255-2, 255-3,
1727                            255-16, 255-17, 255-18, 255-19,
1728                            255-32, 255-33, 255-34,
1729                            255-48, 255-49} ;
1730       IF Debugging
1731       THEN
1732          dumpBase(Red) ;
1733          dumpBase(Blue)
1734       END ;
1735
1736       (* red *)
1737       addPiece(b,  0, Red, 1) ;
1738       addPiece(b,  1, Red, 2) ;
1739       addPiece(b,  2, Red, 3) ;
1740       addPiece(b,  3, Red, 4) ;
1741       addPiece(b, 16, Red, 5) ;
1742       addPiece(b, 17, Red, 6) ;
1743       addPiece(b, 18, Red, 7) ;
1744       addPiece(b, 19, Red, 8) ;
1745       addPiece(b, 32, Red, 9) ;
1746       addPiece(b, 33, Red, 10) ;
1747       addPiece(b, 34, Red, 11) ;
1748       addPiece(b, 48, Red, 12) ;
1749       addPiece(b, 49, Red, 13) ;
1750
1751       (* blue *)
1752       addPiece(b, 255-0, Blue, 1) ;
1753       addPiece(b, 255-1, Blue, 2) ;
1754       addPiece(b, 255-2, Blue, 3) ;
1755       addPiece(b, 255-3, Blue, 4) ;
1756       addPiece(b, 255-16, Blue, 5) ;
1757       addPiece(b, 255-17, Blue, 6) ;
1758       addPiece(b, 255-18, Blue, 7) ;
1759       addPiece(b, 255-19, Blue, 8) ;
1760       addPiece(b, 255-32, Blue, 9) ;
1761       addPiece(b, 255-33, Blue, 10) ;
1762       addPiece(b, 255-34, Blue, 11) ;
1763       addPiece(b, 255-48, Blue, 12) ;
1764       addPiece(b, 255-49, Blue, 13) ;
1765
1766    END ;
1767    IF TwoPlayer
1768    THEN
1769       homeBase[Blue] := homeBase[Blue] + SoS{4, 20, 35, 50, 65, 64} ;
1770       IF Debugging
1771       THEN
1772          dumpBase(Blue)
1773       END ;
1774       homeBase[Red] := homeBase[Red] + SoS{255-4, 255-20, 255-35, 255-50, 255-65, 255-64} ;
1775       IF Debugging
1776       THEN
1777          dumpBase(Red)
1778       END ;
1779 (*
1780       INCL(homeBase[Blue], 4) ;
1781       INCL(homeBase[Blue], 20) ;
1782       INCL(homeBase[Blue], 35) ;
1783       INCL(homeBase[Blue], 50) ;
1784       INCL(homeBase[Blue], 65) ;
1785       INCL(homeBase[Blue], 64) ;
1786 *)
1787       IF Debugging
1788       THEN
1789          dumpBase(Blue)
1790       END ;
1791
1792 (*
1793       INCL(homeBase[Red], 255-4) ;
1794       INCL(homeBase[Red], 255-20) ;
1795       INCL(homeBase[Red], 255-35) ;
1796       INCL(homeBase[Red], 255-50) ;
1797       INCL(homeBase[Red], 255-65) ;
1798       INCL(homeBase[Red], 255-64) ;
1799 *)
1800
1801       IF Debugging
1802       THEN
1803          dumpBase(Red)
1804       END ;
1805
1806       (* red *)
1807       addPiece(b,  4, Red, 14) ;
1808       addPiece(b, 20, Red, 15) ;
1809       addPiece(b, 35, Red, 16) ;
1810       addPiece(b, 50, Red, 17) ;
1811       addPiece(b, 65, Red, 18) ;
1812       addPiece(b, 64, Red, 19) ;
1813
1814       (* blue *)
1815       addPiece(b, 255-4, Blue, 14) ;
1816       addPiece(b, 255-20, Blue, 15) ;
1817       addPiece(b, 255-35, Blue, 16) ;
1818       addPiece(b, 255-50, Blue, 17) ;
1819       addPiece(b, 255-65, Blue, 18) ;
1820       addPiece(b, 255-64, Blue, 19) ;
1821
1822    END ;
1823    assert(b.home[Blue] = 0) ;
1824    assert(b.home[Red] = 0) ;
1825    assert(b.home[Green] = 0) ;
1826    assert(b.home[White] = 0)
1827 END initBoard ;
1828
1829
1830 (*
1831    displayBoard - displays the board.
1832 *)
1833
1834 PROCEDURE displayBoard (b: Board) ;
1835 VAR
1836    i, j: CARDINAL ;
1837 BEGIN
1838    WriteString('     a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p') ; WriteLn ;
1839    WriteString('   +------------------------------------------------+') ; WriteLn ;
1840    FOR j := BoardY TO 1 BY -1 DO
1841       WriteCard(j, 2) ;
1842       WriteString(' |') ;
1843       FOR i := 1 TO BoardX DO
1844          WriteChar(' ') ;
1845          IF isColour(b, (j-1)*BoardX+(i-1), Blue)
1846          THEN
1847             WriteChar('b')
1848          ELSIF isColour(b, (j-1)*BoardX+(i-1), Red)
1849          THEN
1850             WriteChar('r')
1851          ELSIF isColour(b, (j-1)*BoardX+(i-1), Green)
1852          THEN
1853             WriteChar('g')
1854          ELSIF isColour(b, (j-1)*BoardX+(i-1), White)
1855          THEN
1856             WriteChar('w')
1857          ELSE
1858             WriteChar(' ')
1859          END ;
1860          WriteChar(' ')
1861       END ;
1862       WriteString('| ') ;
1863       WriteCard(j, 2) ;
1864       WriteLn
1865    END ;
1866    WriteString('   +------------------------------------------------+') ; WriteLn ;
1867    WriteString('     a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p') ; WriteLn
1868 END displayBoard ;
1869
1870
1871 (*
1872    emitSpecialIf -
1873 *)
1874
1875 PROCEDURE emitSpecialIf (normal, special: CHAR; i, j, x, y: CARDINAL) ;
1876 BEGIN
1877    IF (x=i) AND (y=j)
1878    THEN
1879       WriteChar(special)
1880    ELSE
1881       WriteChar(normal)
1882    END
1883 END emitSpecialIf ;
1884
1885
1886 (*
1887    displayBoardPeg - displays the board with all moves by peg illustrated.
1888 *)
1889
1890 PROCEDURE displayBoardPeg (b: Board; c: Colour; peg: CARDINAL) ;
1891 VAR
1892    x, y,
1893    i, j: CARDINAL ;
1894    m   : Moves ;
1895 BEGIN
1896    genMoves(b, m, c) ;
1897    x := b.pieces[c][peg] MOD BoardX+1 ;
1898    y := b.pieces[c][peg] DIV BoardX+1 ;
1899    WriteString('     a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p') ; WriteLn ;
1900    WriteString('   +------------------------------------------------+') ; WriteLn ;
1901    FOR j := BoardY TO 1 BY -1 DO
1902       WriteCard(j, 2) ;
1903       WriteString(' |') ;
1904       FOR i := 1 TO BoardX DO
1905          WriteChar(' ') ;
1906          IF isColour(b, (j-1)*BoardX+(i-1), Blue)
1907          THEN
1908             emitSpecialIf('b', 'x', i, j, x, y)
1909          ELSIF isColour(b, (j-1)*BoardX+(i-1), Red)
1910          THEN
1911             emitSpecialIf('r', 'x', i, j, x, y)
1912          ELSIF isColour(b, (j-1)*BoardX+(i-1), Green)
1913          THEN
1914             emitSpecialIf('g', 'x', i, j, x, y)
1915          ELSIF isColour(b, (j-1)*BoardX+(i-1), White)
1916          THEN
1917             emitSpecialIf('w', 'x', i, j, x, y)
1918          ELSE
1919             IF isRecorded(m, ((j-1)*BoardX)+(i-1), peg)
1920             THEN
1921                CASE c OF
1922
1923                Blue :  WriteChar('B') |
1924                Red  :  WriteChar('R') |
1925                Green:  WriteChar('G') |
1926                White:  WriteChar('W')
1927
1928                END
1929             ELSE
1930                WriteChar(' ')
1931             END
1932          END ;
1933          WriteChar(' ')
1934       END ;
1935       WriteString('| ') ;
1936       WriteCard(j, 2) ;
1937       WriteLn
1938    END ;
1939    WriteString('   +------------------------------------------------+') ; WriteLn ;
1940    WriteString('     a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p') ; WriteLn
1941 END displayBoardPeg ;
1942
1943
1944 BEGIN
1945    (* test *)
1946    play
1947 END halma.
1948 (*
1949  * Local variables:
1950  *  compile-command: "gm2 -g -fiso halma.mod"
1951  * End:
1952  *)