program PATIENCE ;

uses Crt, Dos ;

procedure Unto(X, Y : shortint) ;
const FC = 2 ; CS = 8 ; FR = 2 ;
begin GoToXY(FC+CS*(X+2), FR+Y) end {Unto} ;

const PC = 7 ;

type
Ranktype = (Empty, Ace, Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten,
  Jack, Queen, King) ;
Suittype = (Club, Diamond, Heart, Spade) ;
Cardtype = record Rank : Ranktype ; Suit : Suittype end ;
RedOrBlack = (Rd, Bk) ;
Deck = array [1..52] of Cardtype ;
Pile = record Back, Face : byte ; Card : array [1..PC-1+13-1] of Cardtype end ;
PileSet = array [1..PC] of Pile ;
TopArr = array [Suittype] of Ranktype ;

const
Esc = #27 ; Spc = #32 ;
Hue : array [Suittype] of RedOrBlack = (Bk, Rd, Rd, Bk) ;

var
HandNo, HP : 0..52 ;
SuitVar : Suittype ;
RankVar : Ranktype ;
Pack, Hand : Deck ;
Piles : PileSet ;
TopRanks : TopArr ;

const QW : real = 1.0 ;

procedure Await(X : real) ;
begin Delay(Round(X*QW)) end {Await} ;

var
Regs : registers ;
SC, TA : byte ;

procedure Start ; begin TA := TextAttr ;
  Regs.AH := $0F ; Intr($10, Regs) {Get display} ;
  Regs.AH := $03 ; Intr($10, Regs) {Get cursor} ; SC := Regs.CH ;
  Regs.AH := $01 ; Regs.CH := SC div 2 ; Intr($10, Regs) {Set cursor Size} ;
  end {Start} ;

procedure Cease ; begin TextAttr := TA ; TextMode(LastMode) ;
  Regs.AH := $02 ; Intr($10, Regs) {Set cursor Pos} ;
  Regs.AH := $01 ; Regs.CH := SC ; Intr($10, Regs) {Set cursor Size} ;
  end {Cease} ;

procedure WriteCard(Cd : Cardtype ; Flash : boolean) ;
const
Tatr : array [RedorBlack] of byte = (LightRed, LightGray) ;
SuitSign : array [Suittype] of char = (#5, #4, #3, #6) ;
RankSign : array [Ranktype] of char =
  (Spc, 'A', '2', '3', '4', '5', '6', '7', '8', '9', 'X', 'J', 'Q', 'K') ;
begin
  with Cd do begin Write(Spc) ;
    TextAttr := Tatr[Hue[Suit]] + Ord(Flash)*Blink ;
    Write(RankSign[Rank], SuitSign[Suit]) ;
    TextAttr := TA ; Write(Spc) end ;
  end {WriteCard} ;

procedure Show ;
var C : Cardtype ; J, R : byte ;
const Rear = ' ²² ' ;
begin ClrScr ;
  Unto(-2, -1) ; Write(HandNo-HP:3) ; Unto(-1, -1) ; Write(HP:3) ;
  Unto(-2, 1) ; if HP<HandNo then Write(Rear) else Write(' °° ') ;
  Unto(-1, 1) ; if HP>0 then WriteCard(Hand[HP], false) ;
  for SuitVar := Club to Spade do if TopRanks[SuitVar]>Empty then begin
    C.Suit := SuitVar ; C.Rank := TopRanks[SuitVar] ;
    Unto(Ord(SuitVar)+1, -1) ; WriteCard(C, false) end ;
  for J := 1 to PC do with Piles[J] do
    for R := 1 to Back+Face do begin Unto(J, R) ;
    if R<=Back then Write(Rear) else WriteCard(Card[R], false) end ;
  end {Show} ;

procedure DownHand ;
var B : byte ;
begin for B := HP+1 to HandNo do Hand[B-1] := Hand[B] ;
  Dec(HandNo) ; Dec(HP) end {DownHand} ;

procedure Put(K : shortint ; TC : CardType) ;
begin with Piles[K] do begin Inc(Face) ; Card[Back+Face] := TC end ;
  end {Put} ;

procedure Flip(QQX : shortint) ;
begin if QQX>0 then with Piles[QQX] do begin Dec(Face) ;
    if (Face=0) and (Back>0) then begin Dec(Back) ; Inc(Face) end ;
    end else DownHand end {Flip} ;

procedure Rest(J, QX, QY : shortint) ;
var Z : shortint ; C : Cardtype ;
begin
  if QX>0 then with Piles[QX] do
    for Z := QY+1 to Back+Face do begin C := Card[Z] ;
    with Piles[J] do begin Inc(Face) ; Card[Back+Face] := C end ;
    Face := QY-Back end ;
  end {Rest} ;

function Shift(QX, QY : shortint ; ThisCard : Cardtype) : boolean;
var J : byte ;
begin Shift := true ;
  Unto(QX, QY) ; WriteCard(ThisCard, true) ; Await(1000) ; Write(#8#8#8'  ') ;
  if QX=-1 then
    with ThisCard do if TopRanks[Suit]=Pred(Rank) then
    begin Inc(TopRanks[Suit]) ; Flip(QX) ; EXIT end ;
  if QX>0 then with Piles[QX], ThisCard do
    if (QY=Back+Face) and (TopRanks[Suit]=Pred(Rank)) then
    begin Inc(TopRanks[Suit]) ; Flip(QX) ; EXIT end ;
  if ThisCard.Rank=King then
    for J := 1 to PC do with Piles[J] do if Face=0 then
      begin Put(J, ThisCard) ; Rest(J, QX, QY) ; Flip(QX) ; EXIT end ;
  for J := 1 to PC do with Piles[J], ThisCard do if Face>0 then
    if (Pred(Card[Back+Face].Rank)=Rank) and
    (Hue[Card[Back+Face].Suit]<>Hue[Suit]) then
      begin Put(J, ThisCard) ; Rest(J, QX, QY) ; Flip(QX) ; EXIT end ;
  Unto(QX, QY) ; WriteCard(ThisCard, true) ; Shift := False ; end {Shift} ;

function DoCh : boolean ;
var DX, ZQX, ZQY, ZQ : shortint ; C : char ;
begin DoCh := false ; ZQX := -2 ; ZQY := +1 ;
  repeat Unto(ZQX, ZQY) ; C := ReadKey ; DX := 0 ;
    case UpCase(C) of
      Esc : HALT ;
      '0' : case ZQX of
        -2 : begin
          if HP=HandNo then begin
            Sound(1500) ; Await(50) ; NoSound ; HP := 0 end ;
          Inc(HP, 3) ;
          if HP>HandNo then HP := HandNo ;
          EXIT end {0} ;
        -1 : if Shift(ZQX, ZQY, Hand[HP]) then EXIT ;
        +1..+PC : with Piles[ZQX] do if Face>0 then
          if Shift(ZQX, ZQY, Card[ZQY]) then EXIT ;
        else Write(^G^G^G'ERROR'^G^G^G) end {ZQX} ;
      '1' : ZQX := PC ;
      '2' : Inc(ZQY) ;
      '3' : ZQY := 127 ;
      '4' : if ZQX>-2 then DX := -1 ;
      '5' : (* if HandNo=0 then *)
        begin for ZQX := 1 to PC do with Piles[ZQX] do if Face>0 then
        with Card[Face+Back] do if TopRanks[Suit]=Pred(Rank) then
          begin Show ; Unto(ZQX, Face+Back) ;
          Await(500) ; Flip(ZQX) ; Inc(TopRanks[Suit]) end ;
          EXIT end ;
      '6' : if ZQX<PC then DX := +1 ;
      '7' : ZQX := -2 ;
      '8' : Dec(ZQY) ;
      '9' : ZQY := 0 ;
      'R' : Randomize ;
      else Write(^G) end {C} ;
    repeat Inc(ZQX, DX) until (ZQX<>0) and not ((HP=0) and (ZQX=-1)) ;
    if ZQX<=0 then ZQY := 1 else with Piles[ZQX] do begin
      while ZQY>Back+Face do Dec(ZQY) ; while ZQY<=Back do Inc(ZQY) ; end ;
    until C=Spc ;
  DoCh := true ;
  end {DoCh} ;

procedure DoIt ;
var W : boolean ; S : Suittype ; PMW : word ;
begin repeat Show ;
    W := true ;
    for S := Club to Spade do if TopRanks[S]<>King then W := false ;
    if W then begin
      for PMW := 100 to 1000 do begin Write('  WIN  ') ; Sound(2*PMW) end ;
      Await(2000) ; NoSound ; EXIT end ;
    until DoCh ;
  end {DoIt} ;

var
JJ, RR : byte ; Ben : char ;
Time : longint absolute $0:$046C ;
T : longint ; DT : integer ;


BEGIN Start ;
repeat
  repeat
    while KeyPressed do Ben := ReadKey ;
    ClrScr ;

    repeat T := Time ; Await(10000.0/18.2) ; DT := (Time-T) ;
      if DT=0 then DT := 1 ; QW := (10.0*QW)/DT until Abs(DT-10)<2 ;

    GoToXY(1, 3) ; Write('Set Pack : ') ; HandNo := 0 ;
    for SuitVar := Club to Spade do for RankVar := Ace to King do begin
      Inc(HandNo) ;
      with Pack[HandNo] do begin Suit := SuitVar ; Rank := RankVar end ;
      end ;

    Writeln ; Write('Set Hand : ') ; JJ := HandNo ;
    repeat RR := Random(JJ)+1 ; Hand[JJ] := Pack[RR] ; Pack[RR] := Pack[JJ] ;
      Dec(JJ) until JJ=0 ;

    Writeln ; Write ('Deal:') ;
    for SuitVar := Club to Spade do TopRanks[SuitVar] := Empty ;
    for JJ := 1 to PC do begin Writeln ;
      with Piles[JJ] do begin Back := JJ-1 ; Face := 1 ;
        for RR := 1 to JJ do begin Card[RR] := Hand[HandNo] ;
          WriteCard(Card[RR], false) ; Dec(HandNo) end ;
        Write(#13) ; for RR := 1 to Back do Write(' ²² ') ;
        end ;
      end ;
    HP := 0 ;

    ClrScr ;
    Writeln('PATIENCE [Crt ', LastMode, '] ') ;
    Write('5 = AUTO-UP, 12346789 = select,',
      ' 0 = move card, Space = resign, Esc = ABORT.') ;
    Window(1, 4, 80, 25) ;
    DoIt ;
    Window(1, 1, 80, 25) ;

    GotoXY(1, 2) ; ClrEol ; Write('ANY to run, Esc to QUIT.') ;
    until ReadKey=Esc ;
  while KeyPressed do Write(ReadKey) ;

  repeat GoToXY(1, 3) ; Write('Finished totally? (Y/N) ') ; ClrEol ;
    Ben := UpCase(ReadKey) ; Write(Ben) ; Await(1000) ;
    until Ben in ['Y', 'N'] ;
  until Ben='Y' ;

Cease ;
END.