{$M 2048,0,0} {$B-}
program BOXES ;
uses Dos, Crt ;

{ Configure a set of games by parameters on the command line which loads it.
  Each parameter is a "word"; the first character of each is a selector and
  the rest may be data.  Para "?" hints and quits; invalid paras quit.  All
  paras have defaults if not invoked.  The last of each is the effective one.
  Full example : BOXES X8 Y0 #A4Z $21345 = Q +LogFile Y8               (8*8)
  Paras -
  'X' : Number of squares from left to right, default Xmid below, max 13.
  'Y' : Number of squares from top to bottom, default Ymid below, max 11.
  '#' : Player sequence; alphanumeric string, 1..6 characters, one per player,
  ú     letters are people, numbers are computer, default AZ.
  '$' : Computer policy string, must be anagram of 12345, default 12345.
  '=' : Completing 2 squares at once gives 2 more goes, default off (=1).
  'Q' : Quieter - only beeps for false manual moves.
  'R' : Randomize - computer's move generator initial state.
  '+' : Record parameters and games in LogFile.
  '-' : Replay with manual moves from LogFile, replacing X Y # $ = R
  More text is on the screen during a game. }

const
ProgID = 'BOXES #1005:' ;
Xmax = 13 ; Ymax = 11 ; SS = true ;
BS = char(8) ; LF = char(10) ; CR = char(13) ;
Spc = char(32) ; Out = '!' ; Psh = '@' ;
MinWhom = '0' ; MaxWhom = 'Z' ; MaxTeams = 6 ;
Time = 100 ;

type
four = 0..4 ;
sign = -1..1 ;
auma = (Aut, Man) ;
senw = (South, East, North, West) ;
cxty = 1..2*Xmax+1 ; cyty = 1..2*Ymax+1 ;
ixty = 1..Xmax ;     iyty = 1..Ymax ;
jxty = 0..Xmax+1 ;   jyty = 0..Ymax+1 ;
figs = array [jxty, jyty] of four ;
bars = array [cxty, cyty] of boolean ;
whom = MinWhom..MaxWhom ;
team = 1..MaxTeams ;
sort = string [5] ;
goes = byte {0..2} ;
data = record
  Free : bars ;
  SqNo : figs ;
  Cnts : array [four] of 0..Xmax*Ymax ;
  ToGo : goes ;
  end ;


var {"fixed"}
ExitSave : pointer ;
LogF : text ;
Sets : team ;

var {"vary"}
Regs : registers ;
Grid : array [boolean] of data ;
Next : array [four, four] of 0..4*Xmax*Ymax ;
Scrs : array [whom] of integer ;
Name : whom ;
Loss : word ;
XIL3 : ixty ; YIL3 : iyty ;

const {vary}
Xwid : ixty = 5 ;
Ywid : iyty = 5 ;
Players : string [MaxTeams] = 'AZ' ;
Two : boolean = false ;
Loud : boolean = true ;
LogW : boolean = true ;
LogN : PathStr = 'NUL' ;
Plan : sort = '12345' ;

const {fixed}
RCX : array [boolean] of word = ($0405 {?}, $0409 {û}) {cf. addr $485} ;
Plus : array [senw] of record S, E : sign end = (
  (S : +1 ; E : 0), (S : 0 ; E : +1), (S : -1 ; E : 0), (S : 0 ; E : -1) ) ;



{$F+} procedure OurExit {$F-} ;
begin Intr($10, Regs) ; Delay(500) ;
  if TextRec(LogF).Mode=fmOutput then {if LogW then} Writeln(LogF, 'û') ;
  if TextRec(LogF).Mode<>fmClosed then Close(LogF) ;
  GoToXY(1, 24) ; ExitProc := ExitSave end {OurExit} ;


procedure Stop(S : string) ;
begin Writeln(' : Quit(', S, ')') ; Halt(1) end {Stop} ;


procedure Quit(S : string) ;
begin
  if TextRec(LogF).Mode=fmOutput then Writeln(LogF) ;
  Close(LogF) ; Stop(S) end {Quit} ;


procedure GoCu(XC : cxty ; YC : cyty) ;
begin GoToXY(2*XC-1, YC+1) end {GoCu} ;


procedure WrSc(XC : cxty ; YC : cyty ; C : char) ;
begin GoCu(XC, YC) ; Write(C) end {WrSc} ;


procedure Area(XCW : cxty ; YCW : cyty) ;
var XC : cxty ; YC : cyty ;
begin
  Window(1, 1, 80, 25) ; TextBackGround(Black) ; ClrScr ;
  Window(55, 1, 80, 25) ; TextBackGround(White) ; TextColor(Black) ;
  ClrScr ;
  Writeln('':1, '°±²Û ', ProgID,
    {$IFDEF TEST} '¤' {$ELSE} '”' {$ENDIF} :2, ' Û²±°') ;
  Writeln(' Read BOXES.PAS comment.') ;
  Writeln(' Complete square boxes ;') ;
  Write(' doing 2 boxes = ') ;
  if Two then Writeln('2 goes.') else Writeln('new go.') ;
  Writeln(' Move using the Key-Pad.') ;
  Writeln(' Cursor moves: 1234 6789') ;
  Writeln(' (SW S SE W ? E NW N NE);') ;
  Writeln(' to draw a line, press 5.') ;
  Writeln(' Type "0" to claim a box.') ;
  Writeln(' Type "', Psh, '" to push to DOS.') ;
  Writeln(' Type "', Out, '" to leave game.') ;
  Write('ÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜ') ;
  Write('ßßßßßßßßßßßßßßßßßßßßßßßßßß') ;
  TextBackGround(Black) ; TextColor(LightGray) ; Window(1, 1, 80, 25) ;
  WrSc(1, 1, 'Ú') ; WrSc(XCW, YCW, 'Ù') ;
  WrSc(XCW, 1, '¿') ; WrSc(1, YCW, 'À') ;
  for XC := 1 to Xwid do if XC<>Xwid then begin
    WrSc(2*XC+1, 1, 'Â') ; WrSc(2*XC+1, YCW, 'Á') end {XC} ;
  for YC := 2 to 2*Ywid do if Odd(YC) then begin WrSc(1, YC, 'Ã') ;
    for XC := 2 to Xwid do WrSc(2*XC-1, YC, 'Å') ; WrSc(XCW, YC, '´') end ;
  end {Area} ;


procedure Push(XCW : cxty ; YCW : cyty) ;
var XC : cxty ; YC : cyty ;
begin GoToXY(1, 19) {23} ;
  SwapVectors ; Exec(GetEnv('COMSPEC'), '') ; SwapVectors ;
  Area(XCW, YCW) ;
  with Grid[true] do begin
    for XC := 1 to XCW do for YC := 1 to YCW do
      if not Free[XC, YC] then WrSc(XC, YC, '+') ;
    for XC := 1 to Xwid do for YC := 1 to Ywid do
      if SqNo[XC, YC]=4 then WrSc(2*XC, 2*YC, ^O) ;
    end ;
  end {Push};


procedure ScanShow ;
const Who : array [auma] of string [3] = ('PPC', 'you') ;
var FX : whom ; Xs, Xn : four ; Q : senw ; Plyr : team ;
BX : ixty ; BY : iyty ; JX : jxty ; JY : jyty ;
begin
  with Grid[true] do begin
    {}
    FillChar(Next, SizeOf(Next), char(0)) ;
    for BX := 1 to Xwid do for BY := 1 to Ywid do begin
      Xs := SqNo[BX, BY] ;
      for Q := South to West do with Plus[Q] do
        if Free[2*BX+E, 2*BY+S] then Inc(Next[Xs, SqNo[BX+E, BY+S]]) ;
      end ;
    {}
    if Xwid<=5 then
      for JY := 0 to Ywid+1 do begin GoToXY(24, 2*JY+1) ;
      for JX := 0 to Xwid+1 do begin
        if (JY in [1..Ywid]) and (JX in [1..Xwid])
          then TextColor(White) else TextColor(LightGray) ;
        Write(SqNo[JX, JY]:4) end ;
      end {Xwid<=5} ;
    {}
    for Xs := 0 to 4 do begin GotoXY(56, 14+Xs) ;
      Write(Xs:2, ':', Cnts[Xs]:4, ';') ;
      for Xn := 0 to 4 do Write(Next[Xs, Xn]:3) ;
      Write(Spc) end {Xs} ;
    for Plyr := 1 to Sets do begin GotoXY(62, 19+Plyr) ; FX := Players[Plyr] ;
      Write(Who[auma(FX>'9')]:4, FX:2, ' :', Scrs[FX]:3, Spc, BS) end {Plyr} ;
    {}
    end {with Grid[true]} ;
  end {ScanShow} ;


procedure Noise(D : word) ;
begin if Loud then Sound(D) end {Noise} ;


procedure Mark(CX : cxty ; CY : cyty ; Mode : auma ; Real : boolean) ;
var JJ : integer ; XI : ixty ; YI : iyty ; X4 : four ;
const UD : array [auma] of integer = (+12, -12) ;
begin
  XI := CX div 2 ; YI := CY div 2 ;
  with Grid[Real] do begin
    X4 := SqNo[XI, YI] ;
    Dec(Cnts[X4]) ;
    Inc(X4) ; Inc(Cnts[X4]) ; SqNo[XI, YI] := X4 ;
    if X4=3 then begin XIL3 := XI ; YIL3 := YI end
    else if X4=4 then begin
      if Two then Inc(ToGo) else ToGo := 1 ;
      if Real then begin NoSound ;
        if SS then for JJ := -Time to Time do begin
          Noise(1500+JJ*UD[Mode]) ; Delay(1) end ;
        WrSc(CX, CY, Name) ; Inc(Scrs[Name]) ; NoSound ;
        end else Inc(Loss) ;
      end {4} ;
    end {with Grid[Real]} ;
  if Real then ScanShow ;
  end {Mark} ;


var Sqrs : integer ; Xcsr, XCW : cxty ; Ycsr, YCW : cyty ;

procedure U ; begin if Ycsr >   1 then Dec(Ycsr) else Inc(Ycsr) end {U} ;
procedure D ; begin if Ycsr < YCW then Inc(Ycsr) else Dec(Ycsr) end {D} ;
procedure L ; begin if Xcsr >   1 then Dec(Xcsr) else Inc(Xcsr) end {L} ;
procedure R ; begin if Xcsr < XCW then Inc(Xcsr) else Dec(Xcsr) end {R} ;


procedure RandomPos ;
begin Ycsr := Random(YCW)+1 ;
  repeat Xcsr := Random(XCW)+1 until Odd(Xcsr+Ycsr) end {RandomPos} ;


function FindGap(A, B : four) : boolean ;
var DX, DY : sign ; U, V : four ; BV : boolean ;
begin with Grid[true] do begin
    BV := Next[A, B]>0 ; FindGap := BV ;
    if BV then
      repeat if KeyPressed and (ReadKey=Out) then Quit('"!" in FindGap') ;
      RandomPos ; GoCu(Xcsr, Ycsr) ;
      if Free[Xcsr, Ycsr] then begin
        DX := Ord(Odd(Xcsr)) ; DY := Ord(Odd(Ycsr)) ;
        U := SqNo[(Xcsr+DX) div 2, (Ycsr+DY) div 2] ;
        V := SqNo[(Xcsr-DX) div 2, (Ycsr-DY) div 2] ;
        if ((U=A) and (V=B)) or ((U=B) and (V=A)) then EXIT ;
        end ;
      until false ;
    end ;
  end {FindGap};


function Done(Real : boolean) : boolean ;
begin with Grid[Real] do Done := Cnts[4]>=Sqrs end {Done} ;


procedure Draw(Mode : auma ; Real : boolean) ;
const HB : array [auma] of string [6] = (^H'ÍÍÍ'^H^H, ^H'ÄÄÄ'^H^H) ;
const VB : array [auma] of string [2] = (   'º'^H,       '³'^H   ) ;
begin with Grid[Real] do begin
    Dec(ToGo) ; Free[Xcsr, Ycsr] := false ;
    if Real then begin
      GoCu(Xcsr, Ycsr) ; Write(Name, BS) ; if SS then Delay(200) end ;
    if Odd(Ycsr) then begin
      if Real then Write(HB[Mode]) ;
      if Ycsr>2      then Mark(Xcsr, Ycsr-1, Mode, Real) ;
      if Ycsr<2*Ywid then Mark(Xcsr, Ycsr+1, Mode, Real) ;
      end {HzBar} else begin
      if Real then Write(VB[Mode]) ;
      if Xcsr>2      then Mark(Xcsr-1, Ycsr, Mode, Real) ;
      if Xcsr<2*Xwid then Mark(Xcsr+1, Ycsr, Mode, Real) ;
      end {VtBar} ;
    if Done(Real) then ToGo := 0 ;
    end ;
  end {Draw} ;


procedure GetBar(XI : ixty ; YI : iyty ; Real : boolean) ;
var Q : senw ;
begin
  with Grid[Real] do
    for Q := South to West do with Plus[Q] do begin
    Xcsr := 2*XI+E ; Ycsr := 2*YI+S ; if Free[Xcsr, Ycsr] then EXIT ;
    end ;
  end {GetBar} ;


procedure Get3bar(Real : boolean) ;
var IX : ixty ; IY : iyty ;
begin
  with Grid[Real] do begin
    if SqNo[XIL3, YIL3]=3 then begin GetBar(XIL3, YIL3, Real) ; EXIT end ;
    for IX := 1 to Xwid do for IY := 1 to Ywid do
      if SqNo[IX, IY]=3 then begin GetBar(IX, IY, Real) ; EXIT end ;
    end ;
  Quit('Fail in Get3bar') end {Get3bar} ;


procedure FindLoss ;
begin GoCu(Xcsr, Ycsr) ; Grid[false] := Grid[true] ;
  Loss := 0 ; Draw(Aut, false) ;
  with Grid[false] do begin Inc(ToGo) ;
    while (Cnts[3]>0) and (ToGo>0) do
      begin Get3bar(false) ; Draw(Aut, false) end ;
    end ;
  end {FindLoss} ;


procedure GiveLeast ;
var XC, XM : cxty ; YC, YM : cyty ; Best : word ; Ct : integer ;
begin
  Best := Sqrs+1 ;
  for XC := 1 to XCW do for YC := 1 to YCW do
    if Odd(XC+YC) and (Best>1) and Grid[true].Free[XC, YC] then begin
    if KeyPressed and (ReadKey=Out) then Quit('"!" in GiveLeast') ;
    Xcsr := XC ; Ycsr := YC ; FindLoss ;
    if Loss<Best then Ct := 0 ;
    if Loss=Best then Inc(Ct) ;
    if (Loss<Best)
      or ((Loss=Best) and ((XC=1) or (XC=XCW) or (YC=1) or (YC=YCW)))
      then begin Best := Loss ; XM := XC ; YM := YC end ;
    GoToXY(56, 12) ;
    if SS then
      Write(Loss:4, ',', XC:3, YC:3, ';', Best:4, ',', XM:3, YM:3, Spc) ;
    end {and Free} ;
  GoToXY(55, 12) ; Write('ßßßßßßßßßßßßßßßßßßßßßßßßßß') ;
  GoToXY(40, 1) ; Write(Ct:4, Best:4, Ct div Best : 4) ;
  GoCu(XM, YM) ; Xcsr := XM ; Ycsr := YM ;
  end {GiveLeast} ;


procedure ChooseMove(Pref : sort) ;
var K : 1..5 ; XT : cxty ; YT : cyty ;
begin
  if Grid[true].Cnts[3]>0 then begin Get3bar(true) ;
    { start JRK strategy }
    XT := Xcsr ; YT := Ycsr ; FindLoss ;
    GoToXY(66, 12) ; Write(Loss:3, Spc) ;
    GoCu(Xcsr, Ycsr) ; Delay(100) ;
    if (Loss=2) and (Grid[true].Cnts[4]<Sqrs-2) then Delay(800) else begin
      Xcsr := XT ; Ycsr := YT end ;
    { end JRK strategy }
    EXIT end ;
  if Random(Ywid)=0 then if FindGap(1, 4) then EXIT ;
  if Random(Xwid)=0 then if FindGap(0, 4) then EXIT ;
  for K := 1 to 5 do case Pref[K] of
    '1' : if FindGap(0, 1) then EXIT ;
    '2' : if FindGap(0, 0) then EXIT ;
    '3' : if FindGap(0, 4) then EXIT ;
    '4' : if FindGap(1, 1) then EXIT ;
    '5' : if FindGap(1, 4) then EXIT ;
    else Quit('Policy error') ;
    end {case} ;
  GiveLeast ; EXIT ;
  end {ChooseMove} ;


procedure GoProc(Mode : auma) ;
procedure Hoot ; begin Write(^G) end {Hoot} ;
var Ch : char ;
begin with Grid[true] do begin
    Sound(3000) ; GoToXY(1, 1) ; Write(Name, ' to move') ; ToGo := 1 ; NoSound ;
    repeat
      if Two then begin GoToXY(9, 1) ; Write(ToGo:2) end ;
      case Mode of
        Aut : begin ChooseMove(Plan) ; Draw(Aut, true) ;
          if KeyPressed and (ReadKey=Out) then Quit('"!" in GoProc Aut') ;
          end {Aut} ;
        Man : begin GoCu(Xcsr, Ycsr) ;
          if LogW then begin
            while not KeyPressed do begin
              Noise(20*Ord(Name)) ; Delay(5) ; NoSound ; Delay(100) end ;
            Ch := ReadKey ; Write(LogF, Ch) ; if Ch='5' then Writeln(LogF) ;
            end {LogW} else Read(LogF, Ch) ;
          case Ch of
            LF, CR : ;
            Out : begin ToGo := 0 ; Sqrs := 0 end ;
            Spc : begin Dec(Scrs[Name]) ;
              ChooseMove(Plan) ; Draw(Man, true) end ;
            '0' : if Cnts[3]=0 then Hoot else begin
              Get3bar(true) ; Draw(Man, true) end ;
            '1' : begin D ; L end ;
            '2' : begin D ; D end ;
            '3' : begin R ; D end ;
            '4' : begin L ; L end ;
            '5' : if Free[Xcsr, Ycsr] then Draw(Man, true) else Hoot ;
            '6' : begin R ; R end ;
            '7' : begin U ; L end ;
            '8' : begin U ; U end ;
            '9' : begin R ; U end ;
            Psh : Push(XCW, YCW) ;
            'û' : HALT ;
            else Hoot end {Ch} ;
          end {Man} ;
        end {case auma};
      until ToGo=0 ;
    GoToXY(1, 1) ; Write('':12) ;
    end ;
  end {GoProc} ;


function Eval(var S : string ; M : byte) : byte ;
var T : longint ; J : integer ;
begin Val(S, T, J) ; if (J>0) or (T<1) or (T>M) then Stop('#') ;
  Eval := T end {Eval} ;


var
FcM, FcN : team ; FX : whom ;
SMax : integer ; Para : word ; Ch : char ; St : string ;
CharHt : byte absolute $0:$0485 ;


BEGIN ;
DirectVideo := false ; ClrEol ; Write(ProgID, Spc, ParamStr(0)) ;
for Para := 1 to ParamCount do begin
  St := ParamStr(Para) ; Write(Spc, St) ;
  Ch := UpCase(St[1]) ; Delete(St, 1, 1) ;
  if St[1]=':' then Delete(St, 1, 1) ;
  case Ch of
    'X' : Xwid := Eval(St, Xmax) ;
    'Y' : Ywid := Eval(St, Ymax) ;
    '#' : begin Players := St ; if Players='' then Stop('') end ;
    '$' : begin Plan := St ; if Length(St)<>5 then Stop('$<>5') end ;
    '=' : Two := true { completing 2 squares gives 2 goes! } ;
    'Q' : Loud := false ;
    'R' : Randomize ;
    '+', '-' : begin LogW := Ch='+' ; LogN := St end ;
    '?' : begin Writeln(CR, LF, 'Xn Yn #àd $12345 = Q ñlogfile ?') ;
      Writeln('For more, LIST BOXES.PAS.') ; Halt end ;
    else Stop('Unknown') ;
    end {Ch} ;
  end {Para} ;

Delay(1000) ; Write(' : ', CharHt, ' : ') ;

Assign(LogF, LogN) ;
if LogW then begin ReWrite(LogF) ;
  Writeln(LogF, ProgID) ;
  Writeln(LogF, Players) ;
  Writeln(LogF, Ord(Two)+1, Xwid:4, Ywid:4, RandSeed:12) ;
  Writeln(LogF, Plan) ; Writeln(LogF, '---') end
else begin Reset(LogF) ;
  Readln(LogF, St) ; if St<>ProgID then Quit('Wrong version in LogF') ;
  Readln(LogF, Players) ;
  Readln(LogF, Smax, Xwid, Ywid, RandSeed) ; Two := boolean(Smax-1) ;
  Readln(LogF, Plan) ; Readln(LogF) end ;

XCW := 2*Xwid+1 ; YCW := 2*Ywid+1 ;
Sets := Length(Players) ;
for FcM := 1 to Sets do begin
  Players[FcM] := UpCase(Players[FcM]) ;
  if not (Players[FcM] in ['0'..'9', 'A'..'Z']) then Quit('Illegal Player') ;
  for FcN := 1 to FcM do
    if (FcN<>FcM) and (Players[FcN]=Players[FcM]) then Quit('Double Player') ;
  end ;

ExitSave := ExitProc ;
ExitProc := @OurExit ;

Regs.AH := $0F ; Intr($10, Regs) { Get mode & page } ;
Regs.AH := $03 ; Intr($10, Regs) { Get Cursor } ;
Para := Regs.CX ; Regs.CX := RCX[LastMode=mono] {cf. addr $485} ;
Regs.AH := $01 ; Intr($10, Regs) { Set Cursor } ;
Regs.CX := Para ;

repeat
  Area(XCW, YCW) ;

  with Grid[true] do begin
    FillChar(Free, SizeOf(Free), char(true)) ;
    FillChar(SqNo, SizeOf(SqNo), char(4)) ;
    for Xcsr := 1 to Xwid do for Ycsr := 1 to Ywid do SqNo[Xcsr, Ycsr] := 0 ;
    for Name := MinWhom to MaxWhom do Scrs[Name] := 0 ;
    FillChar(Cnts, SizeOf(Cnts), char(0)) ;
    Sqrs := Xwid*Ywid ; Cnts[0] := Sqrs ;

    ScanShow ; RandomPos ; FcN := 1 ;

    repeat
      Name := Players[FcN] ; GoProc(auma(Name>'9')) ;
      if FcN=Sets then FcN := 1 else Inc(FcN) ;
      until Done(true) ;

    SMax := 0 ;
    for FcN := 1 to Sets do begin FX := Players[FcN] ;
      if SMax<Scrs[FX] then SMax := Scrs[FX] ;
      end {FcN} ;
    TextBackGround(White) ; TextColor(Black) ;
    for FcN := 1 to Sets do begin FX := Players[FcN] ;
      if SMax=Scrs[FX] then begin GoToXY(75, 19+FcN) ; Write('û') end ;
      end {FcN} ;

    end {with Grid[true]} ;

  if LogW then Writeln(LogF) ;
  TextBackGround(Black) ; TextColor(LightGray) ; Delay(1000) ;
  repeat
    GoToXY(66, 12) ; Write('ßßßß') ;
    GoToXY(1, 1) ; Write('Continue ? ') ; Ch := ReadKey ; Write(Ch) ;
    if Ch=Psh then Push(XCW, YCW) ;
    until Ch<>Psh ;

  until Ch=Out ;

{ExitProc}
END.