program newscrab(Input, Output, Board);
{
Compressed dict? Also, do hsort on fly when checking?
5-bit coding?
record for 'bestxxx' then keep best .
Undo - for scrabble-challenge games. Or read board off net...
Encrypt. See list in jacket pocket!
Seems to have left-most bias on initial move - doesn't take advantage
of 2*L squares on right? [try ntolsey on an empty board...]
}
const
XMIN = 1; XMAX = 15; { The Scrabble board is 15 by 15 }
YMIN = 1; YMAX = 15;
ALETTER = 'a'; ZLETTER = 'z';
MAXTILES = 7; { A player's rack can hold this many tiles }
wc2 = 92; (* have another 13 somewhere *)
wc3 = 966;
wc4 = 4146;
wc5 = 8991;
wc6 = 15452;
wc7 = 22144;
wc8 = 25269;
wc9 = 24268;
wc10 = 21092;
wc11 = 15674;
wc12 = 10605;
wc13 = 6539;
wc14 = 3692;
wc15 = 1896;
type
direction = (horizontal, vertical);
{ This program uses the fact that Scrabble
boards are symmetrical in X=Y. This lets
use write all the code to place words as
if we only ever place them horizontally;
When we want to place vertical words we
simply flip the board over and start again. }
letter = ALETTER..{ZLETTER+2}'~'; { | }
tile = letter; tileset = set of letter;
score = -1..maxint;
freq = 0..12;
tileindex = 0..maxtiles;
{ This is used as an index into the player's rack.
0 means no tiles are held/remain to be placed. }
xtilepos = 1..15; { Although the board is 15 by 15... }
ytilepos = 1..15;
xtilerange = 0..16; { We keep our data in a 17 by 17 array, }
ytilerange = 0..16; { to simplify the coding of certain cases }
{ at the edge of the board. }
xytilearray = array [xtilerange, ytilerange] of tile;
xyletterarray = array [xtilerange, ytilerange] of letter;
rack = array [1..MAXTILES] of tile;
letterrack = packed array [1..MAXTILES] of letter;
allowed = array [xtilerange, ytilerange] of xtilerange;
{ Pre-compute how many tiles may be placed starting at each position,
and store them in min[] and max[] }
choicearray = array [xtilerange, ytilerange] of tileset;
scorearray = array [xtilerange, ytilerange] of score;
{ Choice[x,y] says whether a tile can be placed there - constrained
by vertical abutment; VScore[x,y] gives the score of the word
going through x,y vertically except for bonuses AND THE LETTER
AT x,y ITSELF!
}
{
t2 = packed array [1..2] of char;
t3 = packed array [1..3] of char;
t4 = packed array [1..4] of char;
t5 = packed array [1..5] of char;
t6 = packed array [1..6] of char;
t7 = packed array [1..7] of char;
t8 = packed array [1..8] of char;
t9 = packed array [1..9] of char;
t10 = packed array [1..10] of char;
t11 = packed array [1..11] of char;
t12 = packed array [1..12] of char;
t13 = packed array [1..13] of char;
t14 = packed array [1..14] of char;
t15 = packed array [1..15] of char;
r15 = 0..15;
}
t2 = packed array [1..4] of char;
t3 = packed array [1..6] of char;
t4 = packed array [1..8] of char;
t5 = packed array [1..10] of char;
t6 = packed array [1..12] of char;
t7 = packed array [1..14] of char;
t8 = packed array [1..16] of char;
t9 = packed array [1..18] of char;
t10 = packed array [1..20] of char;
t11 = packed array [1..22] of char;
t12 = packed array [1..24] of char;
t13 = packed array [1..26] of char;
t14 = packed array [1..28] of char;
t15 = packed array [1..30] of char;
r15 = 0..30;
factor = 0..3;
factors = record
letterfactor: factor;
wordfactor: factor;
end;
factorarray = array [xtilerange, ytilerange] of factors;
var
Dict,
Board: text;
Axis: direction;
move: integer;
realmove: integer;
empty: boolean;
cantmove: boolean;
BestScore: score;
bestaxis: direction;
bestt: rack;
besttl: letterrack;
bestcount: tileindex;
bestlength: xtilerange;
bestx: xtilepos;
besty: ytilepos;
bestword: t15;
HeldTile: rack;
HeldLetter: letterrack;
LastTile: tileindex;
VScore: scorearray;
Special: factorarray;
Min, Max: allowed;
BoardTile: xytilearray; { The main playing area, which holds the game
so far. }
ApparentBoardLetter: xyletterarray;
{ **** Note the vital distinction between the tile board and the letter
board. If a letter played is a blank, the tile board will record the
letter it has been defined to be. The letter board will record a
BLANKLETTER.
}
Choice: choicearray;
BlankTileHeld: boolean;
BLANKLETTER: letter;
FREELETTER: letter;
BLANKTILE: tile; { Arbitrarily defined to be the letter after Z }
FREETILE: tile;
ATILE: tile;
EVERYHELDTILE, EVERYTILE: tileset;
{ Dynamically initialised set-constant containing all
letters A to Z. Used when placing a BLANKTILE. }
letterscore: array [letter] of score;
letterfreq: array [letter] of freq;
s2: t2; s3: t3; s4: t4; s5: t5; s6: t6; s7: t7;
s8: t8; s9: t9; s10: t10; s11: t11; s12: t12; s13: t13;
s14: t14; s15: t15;
a2: packed array [1 .. wc2 ] of t2;
a3: packed array [1 .. wc3 ] of t3;
a4: packed array [1 .. wc4 ] of t4;
a5: packed array [1 .. wc5 ] of t5;
a6: packed array [1 .. wc6 ] of t6;
a7: packed array [1 .. wc7 ] of t7;
a8: packed array [1 .. wc8 ] of t8;
a9: packed array [1 .. wc9 ] of t9;
a10: packed array [1 .. wc10 ] of t10;
a11: packed array [1 .. wc11 ] of t11;
a12: packed array [1 .. wc12 ] of t12;
a13: packed array [1 .. wc13 ] of t13;
a14: packed array [1 .. wc14 ] of t14;
a15: packed array [1 .. wc15 ] of t15;
procedure hsort(var word: t15; len: r15); {Mindless bubble sort!}
var
i, j: r15;
c: char;
begin
for i := 1 to len do begin
for j := i to len do begin
if word[j] < word[i] then begin
c := word[i]; word[i] := word[j]; word[j] := c;
end;
end;
end;
end {hsort};
procedure InitDict;
var
x: t15;
c, len: r15;
w: integer;
begin
reset(dict, '2 ');
len := 1;
{ No 1-letter words! }
len := len+1;
for w := 1 to wc2 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a2[w][c] := x[c];
end;
writeln('dict a2 read from ', a2[1], ' to ', a2[wc2]);
close(dict);
reset(dict, '3 ');
len := len+1;
for w := 1 to wc3 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a3[w][c] := x[c];
end;
writeln('dict a3 read from ', a3[1], ' to ', a3[wc3]);
close(dict);
reset(dict, '4 ');
len := len+1;
for w := 1 to wc4 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a4[w][c] := x[c];
end;
writeln('dict a4 read from ', a4[1], ' to ', a4[wc4]);
close(dict);
reset(dict, '5 ');
len := len+1;
for w := 1 to wc5 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a5[w][c] := x[c];
end;
writeln('dict a5 read from ', a5[1], ' to ', a5[wc5]);
close(dict);
reset(dict, '6 ');
len := len+1;
for w := 1 to wc6 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a6[w][c] := x[c];
end;
writeln('dict a6 read from ', a6[1], ' to ', a6[wc6]);
close(dict);
reset(dict, '7 ');
len := len+1;
for w := 1 to wc7 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a7[w][c] := x[c];
end;
writeln('dict a7 read from ', a7[1], ' to ', a7[wc7]);
close(dict);
reset(dict, '8 ');
len := len+1;
for w := 1 to wc8 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a8[w][c] := x[c];
end;
writeln('dict a8 read from ', a8[1], ' to ', a8[wc8]);
close(dict);
reset(dict, '9 ');
len := len+1;
for w := 1 to wc9 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a9[w][c] := x[c];
end;
writeln('dict a9 read from ', a9[1], ' to ', a9[wc9]);
close(dict);
reset(dict, '10');
len := len+1;
for w := 1 to wc10 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a10[w][c] := x[c];
end;
writeln('dict a10 read from ', a10[1], ' to ', a10[wc10]);
close(dict);
reset(dict, '11');
len := len+1;
for w := 1 to wc11 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a11[w][c] := x[c];
end;
writeln('dict a11 read from ', a11[1], ' to ', a11[wc11]);
close(dict);
reset(dict, '12');
len := len+1;
for w := 1 to wc12 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a12[w][c] := x[c];
end;
writeln('dict a12 read from ', a12[1], ' to ', a12[wc12]);
close(dict);
reset(dict, '13');
len := len+1;
for w := 1 to wc13 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a13[w][c] := x[c];
end;
writeln('dict a13 read from ', a13[1], ' to ', a13[wc13]);
close(dict);
reset(dict, '14');
len := len+1;
for w := 1 to wc14 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a14[w][c] := x[c];
end;
writeln('dict a14 read from ', a14[1], ' to ', a14[wc14]);
close(dict);
reset(dict, '15');
len := len+1;
for w := 1 to wc15 do begin
for c := 1 to len do begin
read(dict, x[c]); x[c+len] := x[c];
end;
readln(dict);
hsort(x, len);
for c := 1 to len*2 do a15[w][c] := x[c];
end;
writeln('dict a15 read from ', a15[1], ' to ', a15[wc15]);
close(dict);
end {InitDict};
procedure InitBoard;
var
x: xtilerange; y: ytilerange;
n: integer; {xtilerange Union ytilerange}
{lfact, wfact: integer;}
ch: char;
t: tileindex;
procedure SetScoreAndFreq(ch: char; sc: score; fr: freq);
begin
letterscore[ch] := sc; letterfreq[ch] := fr;
end;
begin
SetScoreAndFreq('a', 1, 9);
SetScoreAndFreq('b', 3, 2);
SetScoreAndFreq('c', 3, 2);
SetScoreAndFreq('d', 2, 4);
SetScoreAndFreq('e', 1, 12);
SetScoreAndFreq('f', 4, 2);
SetScoreAndFreq('g', 2, 3);
SetScoreAndFreq('h', 4, 2);
SetScoreAndFreq('i', 1, 9);
SetScoreAndFreq('j', 8, 1);
SetScoreAndFreq('k', 5, 1);
SetScoreAndFreq('l', 1, 4);
SetScoreAndFreq('m', 3, 2);
SetScoreAndFreq('n', 1, 6);
SetScoreAndFreq('o', 1, 8);
SetScoreAndFreq('p', 3, 2);
SetScoreAndFreq('q', 10, 1);
SetScoreAndFreq('r', 1, 6);
SetScoreAndFreq('s', 1, 4);
SetScoreAndFreq('t', 1, 6);
SetScoreAndFreq('u', 1, 4);
SetScoreAndFreq('v', 4, 2);
SetScoreAndFreq('w', 4, 2);
SetScoreAndFreq('x', 8, 1);
SetScoreAndFreq('y', 4, 2);
SetScoreAndFreq('z', 10, 1);
SetScoreAndFreq(BLANKLETTER, 0, 2);
for x := XMIN-1 to XMAX+1 do
for y := YMIN-1 to YMAX+1 do begin
ApparentBoardLetter[x, y] := FREELETTER;
BoardTile[x, y] := FREETILE;
special[x, y].letterfactor := 1;
special[x, y].wordfactor := 1;
end;
special[8, 8].wordfactor := 2;
special[1, 1].wordfactor := 3;
special[8, 1].wordfactor := 3;
special[15, 1].wordfactor := 3;
special[1, 8].wordfactor := 3;
special[15, 8].wordfactor := 3;
special[1, 15].wordfactor := 3;
special[8, 15].wordfactor := 3;
special[15, 15].wordfactor := 3;
for n := 1 to 4 do begin
special[1+n, 1+n].wordfactor := 2;
special[15-n, 1+n].wordfactor := 2;
special[1+n, 15-n].wordfactor := 2;
special[15-n, 15-n].wordfactor := 2;
end;
special[6, 2].letterfactor := 3;
special[10, 2].letterfactor := 3;
special[2, 6].letterfactor := 3;
special[6, 6].letterfactor := 3;
special[10, 6].letterfactor := 3;
special[14, 6].letterfactor := 3;
special[2, 10].letterfactor := 3;
special[6, 10].letterfactor := 3;
special[10, 10].letterfactor := 3;
special[14, 10].letterfactor := 3;
special[6, 14].letterfactor := 3;
special[10, 14].letterfactor := 3;
special[ 1, 4].letterfactor := 2;
special[ 1, 12].letterfactor := 2;
special[15, 4].letterfactor := 2;
special[15, 12].letterfactor := 2;
special[ 4, 1].letterfactor := 2;
special[12, 1].letterfactor := 2;
special[ 4, 15].letterfactor := 2;
special[12, 15].letterfactor := 2;
special[ 7, 7].letterfactor := 2;
special[ 7, 9].letterfactor := 2;
special[ 9, 7].letterfactor := 2;
special[ 9, 9].letterfactor := 2;
special[ 8, 4].letterfactor := 2;
special[ 8, 12].letterfactor := 2;
special[ 4, 8].letterfactor := 2;
special[12, 8].letterfactor := 2;
special[ 7, 3].letterfactor := 2;
special[ 9, 3].letterfactor := 2;
special[ 3, 7].letterfactor := 2;
special[ 3, 9].letterfactor := 2;
special[13, 7].letterfactor := 2;
special[13, 9].letterfactor := 2;
special[ 7, 13].letterfactor := 2;
special[ 9, 13].letterfactor := 2;
{
for y := YMIN to YMAX do begin
for x := XMIN to XMAX do begin
lfact := special[x, y].letterFactor;
if lfact > 1 then Write(lfact:1) else begin
wfact := special[x, y].wordFactor;
if wfact = 2 then Write('D') else if wfact = 3 then Write('T')
else Write('.')
end;
end;
WriteLn;
end;
WriteLn;
}
LastTile := 0;
if not eof(Board) then begin
if Axis = Horizontal then begin
for y := YMIN to YMAX do begin
for x := XMIN to XMAX do begin
Read(Board, ch); {Write(ch);}
if ch = '.' then ch := FREELETTER else empty := false;
if (ch in ['A'..'Z']) then begin
ch := CHR(ORD(ch)+32);
BoardTile[x,y] := ch;
ApparentBoardLetter[x, y] := BLANKLETTER;
if letterfreq[BLANKLETTER] = 0 then begin
WriteLn('ILLEGAL BOARD! Too many letter blanks (', ch, ''')!');
end else begin
letterfreq[BLANKLETTER] := letterfreq[BLANKLETTER]-1;
end;
end else if ch = FREELETTER then begin
BoardTile[x,y] := FREELETTER;
ApparentBoardLetter[x, y] := FREETILE;
end else begin
BoardTile[x,y] := ch;
ApparentBoardLetter[x, y] := ch;
if letterfreq[ch] = 0 then begin
WriteLn('ILLEGAL BOARD! Too many letter ', ch, '''s!');
end else begin
letterfreq[ch] := letterfreq[ch]-1;
end;
end;
if ch <> FREELETTER then begin
special[x, y].letterfactor := 1;
special[x, y].wordfactor := 1;
end;
end;
ReadLn(Board); {WriteLn;}
end;
end else begin
for x := XMIN to XMAX do begin
for y := YMIN to YMAX do begin
Read(Board, ch); {Write(ch);}
if ch = '.' then ch := FREELETTER else empty := false;
if (ch in ['A'..'Z']) then begin
ch := CHR(ORD(ch)+32);
BoardTile[x,y] := ch;
ApparentBoardLetter[x, y] := BLANKLETTER;
end else if ch = FREELETTER then begin
BoardTile[x,y] := FREELETTER;
ApparentBoardLetter[x, y] := FREETILE;
end else begin
BoardTile[x,y] := ch;
ApparentBoardLetter[x, y] := ch;
end;
if ch <> FREELETTER then begin
special[x, y].letterfactor := 1;
special[x, y].wordfactor := 1;
end;
end;
ReadLn(Board); {WriteLn;}
end;
end;
if not eof(Board) then begin
while not eoln(Board) do begin
Read(Board, ch);
LastTile := LastTile+1;
if ch = ' ' then ch := BLANKLETTER;
HeldLetter[LastTile] := ch;
end;
ReadLn(Board);
end;
if not eof(Board) then begin
Readln(Board, move);
end;
end else begin
{ Empty board. (Must place first word over centre square) }
end;
{write('Tiles = ');}
EVERYHELDTILE := [];
if LastTile > 0 then for t := 1 to LastTile do begin
HeldTile[t] := HeldLetter[t];
EVERYHELDTILE := EVERYHELDTILE + [HeldTile[t]];
{Write(HeldLetter[t]);}
end;
{WriteLn;}
end {InitBoard};
function CheckW(var userword: t15; len: r15; anag: boolean;
var where: integer): boolean;
var
lo, mid, hi: integer; Check2: boolean;
i, alen: r15; s, a: char;
begin
Check2 := false;
alen := len; mid := -1;
if (not(anag)) then len := len*2;
case alen of
1: begin end;
2: begin
for lo := 1 to len do s2[lo] := userword[lo];
lo := 1; hi := wc2;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s2[i]; a := a2[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
3: begin
for lo := 1 to len do s3[lo] := userword[lo];
lo := 1; hi := wc3;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s3[i]; a := a3[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
4: begin
for lo := 1 to len do s4[lo] := userword[lo];
lo := 1; hi := wc4;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s4[i]; a := a4[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
5: begin
for lo := 1 to len do s5[lo] := userword[lo];
lo := 1; hi := wc5;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s5[i]; a := a5[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
6: begin
for lo := 1 to len do s6[lo] := userword[lo];
lo := 1; hi := wc6;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s6[i]; a := a6[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
7: begin
for lo := 1 to len do s7[lo] := userword[lo];
lo := 1; hi := wc7;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s7[i]; a := a7[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
{ ------------------------------------------ Speed up failed searches
i := 0;
repeat
i := i+1;
ch := a7[lo][i]; This can all be done
if ch = a7[hi][i] then begin much more efficiently in C
if ch <> s7[i] then begin using pointers...
check2 := false;
goto 999; ->%return
end;
end else begin
i := len; ->%exit
end;
until i = len;
----------------------------------------------------------------------- }
end;
end;
8: begin
for lo := 1 to len do s8[lo] := userword[lo];
lo := 1; hi := wc8;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s8[i]; a := a8[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
9: begin
for lo := 1 to len do s9[lo] := userword[lo];
lo := 1; hi := wc9;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s9[i]; a := a9[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
10: begin
for lo := 1 to len do s10[lo] := userword[lo];
lo := 1; hi := wc10;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s10[i]; a := a10[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
11: begin
for lo := 1 to len do s11[lo] := userword[lo];
lo := 1; hi := wc11;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s11[i]; a := a11[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
12: begin
for lo := 1 to len do s12[lo] := userword[lo];
lo := 1; hi := wc12;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s12[i]; a := a12[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
13: begin
for lo := 1 to len do s13[lo] := userword[lo];
lo := 1; hi := wc13;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s13[i]; a := a13[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
14: begin
for lo := 1 to len do s14[lo] := userword[lo];
lo := 1; hi := wc14;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s14[i]; a := a14[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
15: begin
for lo := 1 to len do s15[lo] := userword[lo];
lo := 1; hi := wc15;
while (lo <= hi) do begin
mid := (lo + hi) div 2;
i := 0;
repeat
i := i+1;
s := s15[i]; a := a15[mid][i];
until (s <> a) or (i = len);
if (s < a) then begin
hi := mid-1;
end else if (s > a) then begin
lo := mid+1;
end else begin
check2 := true; lo := 1; hi := 0;
end;
end;
end;
end;
where := mid;
{
if Check2 then begin
writeln('Successful check of ', userword:len);
end;
}
CheckW := Check2
end {CheckW};
function Check(var userword: t15; len: integer): boolean;
var
word: t15;
i: r15;
where: integer;
begin
for i := 1 to len do begin
word[i+len] := userword[i];
word[i] := userword[i];
end;
hsort(word, len);
Check := CheckW(word, len, false, where);
end {Check};
function CheckAnag(var w: t15; len: r15; var w1, w2: integer;
var outword: t15): boolean;
{TO DO - this is a bodge: outword is assigned here; it shouldn't
be -- there may be multiple 'outword's so they should
be extracted outside. }
var CheckAnag2: boolean; i: r15;
begin
{ Returns first one. We then have to search back and forward
for extra matches. TO DO...}
hsort(w, len);
CheckAnag2 := CheckW(w, len, true, w1); w2 := w1;
if CheckAnag2 then case len of
2: for i := 1 to len do outword[i] := a2[w1][i+len];
3: for i := 1 to len do outword[i] := a3[w1][i+len];
4: for i := 1 to len do outword[i] := a4[w1][i+len];
5: for i := 1 to len do outword[i] := a5[w1][i+len];
6: for i := 1 to len do outword[i] := a6[w1][i+len];
7: for i := 1 to len do outword[i] := a7[w1][i+len];
8: for i := 1 to len do outword[i] := a8[w1][i+len];
9: for i := 1 to len do outword[i] := a9[w1][i+len];
10: for i := 1 to len do outword[i] := a10[w1][i+len];
11: for i := 1 to len do outword[i] := a11[w1][i+len];
12: for i := 1 to len do outword[i] := a12[w1][i+len];
13: for i := 1 to len do outword[i] := a13[w1][i+len];
14: for i := 1 to len do outword[i] := a14[w1][i+len];
15: for i := 1 to len do outword[i] := a15[w1][i+len];
end;
CheckAnag := CheckAnag2;
end {CheckAnag};
function SpellCheckVertical(x: xtilepos; YPos: ytilepos; Try: tile): boolean;
{ Places letter Try at (x,y) and sees if it forms a valid word. If so,
returns TRUE and the score of the rest of the word NOT COUNTING the
placed letter itself. This allows the caller to calculate double-letter/
double-word scores more efficiently than we could. }
var w: t15; y, y1, y2: ytilepos; yy: 1..16;
begin
y1 := YPos; y2 := YPos; yy := 1;
while ApparentBoardLetter[x,y1-1] <> FREELETTER do y1 := y1-1;
while ApparentBoardLetter[x,y2+1] <> FREELETTER do y2 := y2+1;
if y1 < YPos then for y := y1 to YPos-1 do begin
w[yy] := ApparentBoardLetter[x,y]; yy := yy+1;
end;
w[yy] := Try; yy := yy+1;
if y2 > YPos then for y := YPos+1 to y2 do begin
w[yy] := ApparentBoardLetter[x,y]; yy := yy+1;
end;
SpellCheckVertical := Check(w, yy-1);
end {SpellCheckVertical};
procedure ConstrainPlacements(Board: xytilearray;
BoardLetter: xyletterarray;
var Choice: choicearray;
var VScore: scorearray;
var Min, Max: allowed;
HeldTile: rack;
LastTile: tileindex);
{ This procedure is the high-level harness which takes the board before a
horizontal move and marks all the positions which are restricted by the
adjacent vertical words, i.e. certain tiles cannot be placed in certain
free squares because they abut with other tiles above or below to form a
non-existent word. This level of pruning dramatically reduces the search
time when generating possible words. }
{ It also works out how many letters may be placed horizontally starting
at each position. The info learned about vertical abutment is used to
help clip long words short! Answers written to min[], max[]. }
{ STILL TO DO: When placing wild letters next to fixed letters, check
in a di-/tri-graph table whether they are valid combinations. Will
trim even more off round the edges... }
var
ThisTile: tile; ThisLet: letter;
DebugTileSet: tileset; {}t: tileindex;{} {Also debug}
WildLetter: letter;
XPos: xtilepos; YPos: ytilepos;
EachTile: tileindex;
c: -1..7; xx: 0..16; { For horizontal placement ode }
x: xtilepos; y: ytilepos;
minxy, maxxy: -1..7;
{ VScore records the score of words formed by vertical abutment when
placing a word horizontally. It would be simpler if VScore were a
3-D array, also indexed by the letters A-Z, recording the individual
scores of placing each of those letters in the particular square.
However, a vast space-saving can be had by omitting this index
and calculating the score on the fly each time. To do this reasonably
efficiently, VScore holds the total value of all the other tiles in
the vertical word except the tile being placed. The tile can be
placed only if Choice[x,y] says it can. As double-word and
double-letter scores are only significant for tiles being placed
(not tiles already down) we can calculate the full value of such
vertical words as follows:
1) Take VScore[x,y] which already contains the sum of all the
other letters in the vertical word.
2) Add the score for the tested letter at x,y multiplied by
any letter bonus allowed for the single letter at x,y.
3) Multiply the result by any word bonus allowed for x,y.
}
function ScoreVertical(x: xtilepos; YPos: ytilepos): Score;
var y, y1, y2: ytilepos; vtot: score;
begin
vtot := 0;
y1 := YPos; y2 := YPos;
while ApparentBoardLetter[x,y1-1] <> FREELETTER do y1 := y1-1;
while ApparentBoardLetter[x,y2+1] <> FREELETTER do y2 := y2+1;
if y1 < ymin then writeln('y1 < ymin');
if y2 > ymax then writeln('y2 > ymin');
if y1 < YPos then for y := y1 to YPos-1 do begin
vtot := vtot + letterscore[ApparentBoardLetter[x,y]];
end;
if y2 > YPos then for y := YPos+1 to y2 do begin
vtot := vtot + letterscore[ApparentBoardLetter[x,y]];
end;
ScoreVertical := vtot;
end {ScoreVertical};
begin
BlankTileHeld := FALSE;
DebugTileSet := [];
for EachTile := 1 to LastTile do begin
if HeldTile[EachTile] = BLANKTILE then BlankTileHeld := TRUE;
DebugTileSet := DebugTileSet+[HeldTile[EachTile]];
end;
if (move = 1) and empty then begin
{ Initial board - lets start horizontally only! }
for YPos := YMIN to YMAX do begin
for XPos := XMIN to XMAX do begin
Choice[XPos,YPos] := [];
VScore[XPos,YPos] := -1; { -1 means illegal to place a tile here }
Min[XPos,YPos] := 0;
Max[XPos,YPos] := 0;
end;
end;
for x := 8 downto 2 do begin
Min[x,8] := 9-x; Max[x,8] := 7;
VScore[x,8] := 0;
VScore[8,8] := 0;
if BlankTileHeld then begin
Choice[x,8] := EVERYHELDTILE;
{ ??? Looking at this today (1999), this looks the wrong way round... }
end else begin
Choice[x,8] := EVERYTILE;
end;
end;
end else begin
for YPos := YMIN to YMAX do begin {Try every Y position}
for XPos := XMIN to XMAX do begin {Try every X Position}
Choice[XPos,YPos] := [];
VScore[XPos,YPos] := -1; { -1 means illegal to place a tile here }
ThisTile := Board[XPos,YPos];
if ThisTile=FREETILE then begin {Tile present test}
if (Board[XPos,YPos-1]=FREETILE)
and (Board[XPos,YPos+1]=FREETILE) then begin {Adjacency test}
{ Unconstrained }
{ When holding blank can place any VALID letter here }
if blanktileheld then begin
Choice[XPos,YPos] := EVERYTILE;
end else begin
Choice[XPos,YPos] := EVERYHELDTILE;
end;
VScore[XPos,YPos] := 0; { 0 means doesn't form vertical word }
end else begin {Adjacency test}
{ Will abut vertically to form a word... }
VScore[XPos,YPos] := ScoreVertical(XPos, YPos);
{ Evaluate once as it is the same for all 'ch' }
if BlankTileHeld then begin {Constrained, but holding a blank test}
{ Loop over 'a' to 'z' if blank held. }
for WildLetter := ALETTER to ZLETTER do begin {Try all if blank}
ThisTile := WildLetter;
if SpellCheckVertical(XPos, YPos, ThisTile) then begin
Choice[XPos,YPos] := Choice[XPos,YPos]+[ThisTile];
end;
end {Try all if blank};
end else begin {Constrained, but holding a blank test}
for EachTile := 1 to LastTile do begin {Try each tile}
ThisTile := HeldTile[EachTile];
ThisLet := HeldLetter[EachTile];
if ThisTile<>BLANKTILE then begin {Placing blank test}
if SpellCheckVertical(XPos, YPos, ThisTile) then begin
{Test word}
Choice[XPos,YPos] := Choice[XPos,YPos]+[ThisTile];
{Note: this means that
VerticalScore(x,y)=(VScore[XPos,YPos]+tileval*lfact)*wfact
where tileval can be 0 if a blank is being used,
and lfact & wfact are the bonus scores for the tile
(x, y) on which the character is to be placed.
}
end {Test word};
end else begin {Placing blank test}
{ Done outside the loop for efficiency }
end {Placing blank test};
end {Try each tile};
end {Constrained, but holding a blank test};
{ Note that for consistency's sake, we should set the score
to -1 again if NONE of the letters fitted... - but no-one
will be looking anyway! }
end {Adjacency test};
end else begin {Tile present test}
Choice[XPos,YPos] := [Board[XPos,YPos]];
{ No choice - tile already down! (should VScore be set to -1?)}
end {Tile present test};
end {Try every X position};
end {Try every Y position};
{ Now work out horizontal constraints. }
for y := YMIN to YMAX do begin
for x := XMIN to XMAX do begin
xx := x; c:= 0;
if BoardLetter[x-1,y] <> FREELETTER then begin { Hence why 0 to 16 }
{ This starting point subsumed by one to the left of it. }
minxy := 0; maxxy := 0;
end else begin
minxy := 0; maxxy := -1;
xx := x;
while (c >= 0) and (c < LastTile) do begin
while (xx <= XMAX) and
(BoardLetter[xx,y] <> FREELETTER) do xx := xx+1;
{ xx points to next free letter }
if xx > XMAX then begin
c := -1; { to force loop exit }
end else begin
c := c+1; { Place a tile }
if (minxy = 0) and
((BoardLetter[xx-1,y] <> FREELETTER) or
{ | <- THIS CASE ONLY SIGNIFICANT ON 1ST TILE
(could be neater code!)}
(BoardLetter[xx,y-1] <> FREELETTER) or
(BoardLetter[xx,y+1] <> FREELETTER) or
(BoardLetter[xx+1,y] <> FREELETTER)) then begin
{ As soon as abutment found, note no. of tiles placed. }
minxy := c;
end;
xx := xx+1;
maxxy := c;
end;
end;
end;
{ TO DO: Remember a max of 1 horizontally with no left or right
partners is actually a vertical! - and should not be counted. }
if minxy = 0 then maxxy := 0;
{ If couldn't place any then max invalid }
if maxxy < 0 then maxxy := 0; { -1 flag from above needs patching }
if (minxy = 1) and (BoardLetter[x,y] = FREELETTER) then begin
if (BoardLetter[x-1,y] = FREELETTER) and
(BoardLetter[x+1,y] = FREELETTER) then begin
if maxxy > 1 then minxy := 2;
end;
end;
min[x,y] := minxy; max[x,y] := maxxy;
end;
end;
end;
{}
for y := YMIN to YMAX do begin
for x := XMIN to XMAX do begin
write(ApparentBoardLetter[x,y]);
end;
write(' ');
for x := XMIN to XMAX do begin
write(min[x,y]:1);
end;
write(' ');
for x := XMIN to XMAX do begin
write(max[x,y]:1);
end;
write(' ');
for x := XMIN to XMAX do begin
if (Choice[x,y] <> DebugTileSet) then begin
write('*');
end else begin
write(ApparentBoardLetter[x,y]);
end;
end;
writeln
end;
for y := YMIN to YMAX do begin
for t := 1 to 4 do begin
for x := XMIN to XMAX do begin
if (Choice[x,y] <> DebugTileSet)
and (HeldTile[t] in Choice[x,y]) then begin
write(HeldLetter[t]);
end else begin
write(ApparentBoardLetter[x,y]);
end;
end;
Write(' ');
end;
writeln;
end;
writeln;
for y := YMIN to YMAX do begin
for t := 5 to 7 do begin
for x := XMIN to XMAX do begin
if (Choice[x,y] <> DebugTileSet)
and (HeldTile[t] in Choice[x,y]) then begin
write(HeldLetter[t]);
end else begin
write(ApparentBoardLetter[x,y]);
end;
end;
Write(' ');
end;
writeln;
end;
{}
end {ConstrainPlacements};
function Place(var Tiles: rack; var TileLetter: letterrack;
last: tileindex; x: xtilerange; y: ytilerange;
var word: t15;
var length: xtilerange;
var totscore: score): boolean;
label 99;
var w: r15; t: tileindex; htot, vtot: score; wfact: score;
place2: boolean;
begin
length := 0;
t := 0; w := 0; totscore := 0; vtot := 0; htot := 0; wfact := 1;
{ TODO: Clipping against validity mask goes here! - also di-/tri-gram checks }
repeat
if ApparentBoardLetter[x,y] = FREELETTER then begin
if t = last then begin
{ End of word }
end else begin
t := t+1;
w := w+1;
word[w] := Tiles[t];
if not(word[w] in ['a'..'z']) then begin
WriteLn('Internal error 3: ', word[w]);
end;
if not (Tiles[t] in Choice[x,y]) then begin
Place := false;
totscore := 0;
goto 99;
end;
if VScore[x,y] > 0 then begin
{ TO DO: Only add vscore if forms a word vertically.
This is too cheap a test as it would go wrong if
there were a single blank lying above a letter -
The score would appear 0 so the value of the
letter itself would not be added. (best to check word length?)}
vtot := vtot+( (VScore[x,y]+(letterscore[TileLetter[t]]
*special[x,y].letterfactor))
*special[x,y].wordfactor
);
end;
wfact := wfact*special[x,y].wordfactor;
htot := htot + letterscore[TileLetter[t]]*special[x,y].letterfactor;
end;
end else begin
w := w+1;
word[w] := BoardTile[x,y]; {Was ApparentBoardLetter...}
if not(word[w] in ['a'..'z']) then begin
WriteLn('Internal error 2: ', word[w]);
end;
htot := htot + letterscore[word[w]];
end;
x := x + 1;
until ((t = last) and (ApparentBoardLetter[x,y] = FREELETTER)) or
(x > XMAX);
htot := htot*wfact; if last = 7 then htot := htot + 50;
totscore := htot+vtot;
length := w;
Place2 := Check(word, w);
Place := Place2;
99:
end {Place};
{ VAR because temp being updated ..........}
function PlaceAnag(var Tiles: rack; var TileLetter: letterrack;
var outrack: rack; var outlet: letterrack;
last: tileindex; x: xtilerange; y: ytilerange;
var word: t15;
var length: xtilerange;
var totscore: score): boolean;
var
ix: xtilerange;
w1, w2: integer;
i, w: r15;
t: tileindex;
outword, wordlet: t15;
where: array [tileindex] of xtilerange;
begin
ix := x;
PlaceAnag := false;
length := 0; totscore := 0;
t := 0; w := 0;
{ TODO: Clipping against validity mask goes here! - also di-/tri-gram checks }
repeat
if ApparentBoardLetter[x,y] = FREELETTER then begin
if t = last then begin
{ End of word }
end else begin
t := t+1;
w := w+1;
word[w] := Tiles[t];
wordlet[w] := TileLetter[t];
where[t] := w;
end;
end else begin
w := w+1;
word[w] := BoardTile[x,y]; {Was ApparentBoardLetter...}
wordlet[w] := ApparentBoardLetter[x,y];
end;
x := x + 1;
until ((t = last) and (ApparentBoardLetter[x,y] = FREELETTER)) or
(x = XMAX+1);
{ If anagram of built word exists, try to fit it. If fits,
return equivalent of 'old' Place() }
if CheckAnag(word, w, w1, w2, outword) then begin
if w1<>w2 then begin
writeln('Warning: words temporarily ignored!');
end;
{ ***TO DO: assign outword from anagdict[w1]
word outword
abCDe -> DeCab lowercase: tiles; uppercase: board
t 12 3 12345
t = 3; where[1] = 4
where[2] = 5
where[3] = 2
tiles in = abe --- tiles out = eab !!!
ditto outrack - but harder to infer blank pos if present?
SO: take blanks out a level! }
t := 0;
for i := 1 to w do begin
if ApparentBoardLetter[ix+i-1,y] = FREELETTER then begin
t := t+1;
outrack[t] := outword[i];
outlet[t] := outword[i];
end;
end;
{ Do a similar loop to see if already-placed letters have moved... }
PlaceAnag := Place(outrack, outlet, last, ix, y, word, length, totscore);
end;
end {PlaceAnag};
procedure CheckOne(var t: rack; var tl: letterrack; N: tileindex;
x: xtilepos; y: ytilepos);
var
ot: rack; otl: letterrack;
ThisScore: score; length: xtilerange;
xx: xtilerange; yy: ytilerange; ch: char; nexttl: tileindex;
word: t15;
begin
{ Try placing words of triallength at (x,y) from TryTile }
if PlaceAnag(t, tl, ot, otl, N, x, y, word, length, thisscore) then begin
{ Should be... while PlaceAnag() ... }
{ SO CURRENT VERSION SHUFFLES T & TL FOR YOU!!! }
if ThisScore > BestScore then begin
bestt := ot; besttl := otl; bestcount := N; bestaxis := axis;
bestword := word; bestlength := length;
if Axis = horizontal then begin
bestx := x; besty := y;
end else begin
bestx := y; besty := x;
end;
{ *** }
nexttl := 0;
Write('Placing ');
for nexttl := 1 to N do begin
if tl[nexttl] = BLANKLETTER then begin {BUG: was FREELETTER}
Write('(Blank ', t[nexttl], ')');
end else Write(t[nexttl]);
end;
Write(' to give ', word:length);
if Axis = Horizontal then begin
Write(' across at ', x, ', ', y);
end else begin
Write(' down at ', y, ', ', x);
end;
WriteLn(' scoring ', ThisScore);
nexttl := 0;
for xx := x to x+length-1 do begin
if (ApparentBoardLetter[xx,y]=FREELETTER) AND
((ApparentBoardLetter[xx,y-1]<>FREELETTER) or
(ApparentBoardLetter[xx,y+1]<>FREELETTER)) then begin
Write(' (Also forms ');
ch := word[xx-x+1];
yy := y;
while ApparentBoardLetter[xx,yy-1] <> FREELETTER do yy := yy-1;
while yy < y do begin
Write(ApparentBoardLetter[xx,yy]);
yy := yy+1;
end;
Write(CHR(ORD(ch)-32));
yy := y;
while ApparentBoardLetter[xx,yy+1] <> FREELETTER do begin
yy := yy+1;
Write(ApparentBoardLetter[xx,yy]);
end;
WriteLn(')');
end;
end;
{ *** }
BestScore := ThisScore;
end;
end else begin
end;
end {CheckOne};
procedure Perms(var t: rack; var tl: letterrack; N: tileindex);
var x: xtilepos; y: ytilepos;
begin
for y := YMIN to YMAX do begin
for x := XMIN to XMAX-N+1 do begin
if (min[x,y] <= N) and (N <= max[x,y]) then CheckOne(t, tl, n, x, y);
end;
end;
end {Perms};
procedure PermNofM(var T: rack; var L: letterrack; N, M: tileindex);
var C0, C1, C2, C3, C4, C5, C6, C7: tileindex; OT: rack; OL: letterrack;
begin
C0 := 0;
if N>=1 then for C1 := C0+1 to M do begin
OT[1] := T[C1];
OL[1] := L[C1];
if N>=2 then for C2 := C1+1 to M do begin
OT[2] := T[C2];
OL[2] := L[C2];
if N>=3 then for C3 := C2+1 to M do begin
OT[3] := T[C3];
OL[3] := L[C3];
if N>=4 then for C4 := C3+1 to M do begin
OT[4] := T[C4];
OL[4] := L[C4];
if N>=5 then for C5 := C4+1 to M do begin
OT[5] := T[C5];
OL[5] := L[C5];
if N>=6 then for C6 := C5+1 to M do begin
OT[6] := T[C6];
OL[6] := L[C6];
if N>=7 then for C7 := C6+1 to M do begin
OT[7] := T[C7];
OL[7] := L[C7];
Perms(OT, OL, N);
end else begin
Perms(OT, OL, N);
end;
end else begin
Perms(OT, OL, N);
end;
end else begin
Perms(OT, OL, N);
end;
end else begin
Perms(OT, OL, N);
end;
end else begin
Perms(OT, OL, N);
end;
end else begin
Perms(OT, OL, N);
end;
end;
end {PermMofN};
procedure PlaceHorizontalWords(var HeldTile: rack;
LastTile: tileindex);
var
N: tileindex;
begin
{ It MIGHT be better to do the x=1 to 15, y=1 to 15 loop out
here and the combs/perms inside it - then the comb/perm
generators can do high-level clipping early on when they
know that a word can't be placed on a site because of limitations
and thus save a factorial no. of tests rather than just one! -
it depends on the relative costs of spell-checking vs comb
generation. If this were to be done, the blank generation
should also be done at that level. }
if LastTile > 0 then begin
N := 0;
repeat
N := N+1;
PermNofM(HeldTile, HeldLetter, N, LastTile);
until (N = LastTile);
end;
end {PlaceHorizontalWords};
procedure Initialise;
var
XPos: 0..16; YPos: 0..16;
begin
ATILE := 'a';
BLANKLETTER := 123{letter(123)}
{SUCC(ZLETTER)}; { Constants which I am not willing }
BLANKTILE := BLANKLETTER;
FREELETTER := SUCC(BLANKLETTER); { to describe as literals }
FREETILE := FREELETTER;
EVERYTILE := ['a'..'z'];
for YPos := YMIN-1 to YMAX+1 do begin
for XPos := XMIN-1 to XMAX+1 do begin
BoardTile[XPos,YPos] := FREETILE;
ApparentBoardLetter[XPos,YPos] := FREELETTER;
end {all Xs};
end {all Ys};
end {Initialise};
procedure PlaceBest;
var
x: xtilepos; y: ytilepos;
nexttl, htile: tileindex; ch: char;
tile: letter;
begin
{ Or... can't move? }
WriteLn('****************************');
Write('My move: place ');
x := bestx; y := besty;
if bestaxis = vertical then begin
for nexttl := 1 to bestcount do begin
while ApparentBoardLetter[x,y] <> FREELETTER do y := y+1;
ch := besttl[nexttl];
htile := 0;
repeat
htile := htile+1;
until HeldLetter[htile] = ch;
{Assert: Never tries to place a letter not held - of course, can't
trust human players to be so honest... }
HeldTile[htile] := FREETILE;
HeldLetter[htile] := FREELETTER;
if besttl[nexttl] = BLANKLETTER then begin
ch := CHR(ORD(bestt[nexttl])-32);
tile := bestt[nexttl];
end else begin
ch := bestt[nexttl];
tile := ch;
end;
Write(ch);
ApparentBoardLetter[x,y] := besttl[nexttl];
BoardTile[x,y] := tile;
special[x, y].letterfactor := 1;
special[x, y].wordfactor := 1;
{ to do: check validity of freq[] }
letterfreq[besttl[nexttl]] := letterfreq[besttl[nexttl]]-1;
if y < YMAX then y := y+1;
end;
WriteLn(' at ', bestx, ',', besty, ' down to make ', bestword:bestlength,
' (scoring ', bestscore, ')');
end else begin
for nexttl := 1 to bestcount do begin
while ApparentBoardLetter[x,y] <> FREELETTER do begin
x := x+1;
end;
ch := besttl[nexttl];
htile := 0;
repeat
htile := htile+1;
until HeldLetter[htile] = ch;
{Assert: Never tries to place a letter not held - of course, can't
trust human players to be so honest... }
HeldTile[htile] := FREETILE;
HeldLetter[htile] := FREELETTER;
if besttl[nexttl] = BLANKLETTER then begin
ch := CHR(ORD(bestt[nexttl])-32);
tile := bestt[nexttl];
end else begin
ch := bestt[nexttl];
tile := ch;
end;
Write(ch);
ApparentBoardLetter[x,y] := besttl[nexttl];
BoardTile[x,y] := tile;
special[x, y].letterfactor := 1;
special[x, y].wordfactor := 1;
if letterfreq[besttl[nexttl]] = 0 then begin
WriteLn;
WriteLn('Too many copies of: ', besttl[nexttl]);
WriteLn;
end else letterfreq[besttl[nexttl]] := letterfreq[besttl[nexttl]]-1;
if X < XMAX then x := x+1;
end;
WriteLn(' at ', bestx, ',', besty, ' across to make ', bestword:bestlength,
' (scoring ', bestscore, ')');
end;
end {PlaceBest};
procedure TakeTiles;
var
ch: char;
nexttl, htile: tileindex;
begin
if LastTile > 0 then begin
for nexttl := 1 to LastTile do begin
if HeldTile[nexttl] = FREETILE then begin
{ Shuffle up the remaining letters }
htile := nexttl;
if htile < LastTile then repeat
htile := htile+1;
if (HeldTile[nexttl] = FREETILE) and
(HeldTile[htile] <> FREETILE) then begin
HeldTile[nexttl] := HeldTile[htile];
HeldTile[htile] := FREETILE;
HeldLetter[nexttl] := HeldLetter[htile];
HeldLetter[htile] := FREELETTER;
end;
until htile = LastTile;
end;
end;
LastTile := LastTile - bestcount;
end;
if LastTile <> 7 then begin
Write('May I have ', 7-LastTile, ' tile');
if LastTile <> 6 then Write('s');
WriteLn(' please?');
repeat
{ Pick a tile at random from remaining set }
if not eoln(input) then begin
read(input, ch);
LastTile := LastTile+1;
if ch = ' ' then begin
HeldLetter[LastTile] := BLANKLETTER;
HeldTile[LastTile] := BLANKTILE;
end else begin
HeldLetter[LastTile] := ch;
HeldTile[LastTile] := ch;
end;
end;
until (LastTile = 7) or eoln(input);
ReadLn(input);
end;
end {TakeTiles};
procedure WriteBoard;
var
ch: char;
x: xtilepos; y: ytilepos;
htile: tileindex;
begin
for y := 1 to 15 do begin
for x := 1 to 15 do begin
if ApparentBoardLetter[x,y] = BLANKLETTER then begin
ch := CHR(ORD(BoardTile[x,y])-32);
end else if ApparentBoardLetter[x,y] = FREELETTER then begin
ch := '.';
end else ch := ApparentBoardLetter[x,y];
Write(Board, ch);
end;
WriteLn(Board);
end;
if LastTile > 0 then for htile := 1 to LastTile do begin
ch := HeldLetter[htile];
if ch = BLANKLETTER then ch := ' ';
Write(Board, ch);
end;
WriteLn(Board);
WriteLn(Board, move+1);
end {WriteBoard};
begin
cantmove := false;
empty := true;
LastTile := 0;
move := 0;
realmove := 0;
InitDict;
repeat
BestScore := 0;
for Axis := horizontal to vertical do begin
if (move <> 0) or ((move = 0) and (Axis = horizontal)) then begin
if realmove = 0 then begin
Reset(board);
end else begin
Reset(board, 'board');
end;
Initialise;
InitBoard;
if LastTile > 0 then begin
ConstrainPlacements(BoardTile, ApparentBoardLetter,
Choice, VScore, Min, Max,
HeldTile, LastTile);
PlaceHorizontalWords(HeldTile, LastTile);
end;
end;
end;
Axis := horizontal;
if realmove = 0 then begin
Reset(board);
end else begin
Reset(board, 'board');
end;
Initialise;
InitBoard;
if BestScore > 0 then begin
PlaceBest;
end;
TakeTiles;
ReWrite(Board, 'board');
WriteBoard;
if (BestScore = 0) and (move <> 0) then begin
{ Stuck - swap some tiles }
if LastTile > 0 then begin
WriteLn('Couldn''t move!');
cantmove := true;
end;
end;
move := move+1;
realmove := realmove+1;
until cantmove;
end {NewScrab}.