program GIBBON ; uses Crt, Dos ;

type
Scrn = array [0..24, -40..39] of word { 80*25 } ;
Scrp = ^Scrn ;
Player = 'A'..'B' ;

const
Other : array [player] of player = ('B', 'A') ;
Esc = #27 ; Sp = #32 ;
Bkgd = Green shl 12 ; Star = word($0F) ; Face = word($02) ;

var
Disp : Scrp ;
Scores : array [player] of integer;
Cause : string [9] ;

const QW : Real = 1.0 ;

function CpUnLk : boolean ;
begin CpUnLk := (Mem[0:$417] and $40)=0 end {CpUnLk} ;

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

function PM(R : integer) : integer ;
begin R := Abs(R) ; PM := integer(Random(2*R+1))-R end {PM} ;

procedure WSC ;
begin GotoXY(23, 2) ;
  Write(' Scores : A = ', Scores['A'], ', B = ', Scores['B'], Sp) end {WSC} ;

procedure Ink(M : player ; var S : integer ; D : integer) ;
var J, K : word ; I : integer ;
begin
  for I := 1 to Abs(D) do begin K := 2500 ;
    WSC ;
    if D>0 then Inc(S) else Dec(S) ;
    for J := 1 to 15 do begin K := K+3*D ; Sound(K) ; Await(3) end ;
    Await(50) end ;
  NoSound end {Ink} ;

function ScrLk : boolean ;
begin ScrLk := (Mem[0:$417] and $10)>0 end {ScrLk} ;

procedure DoIt(Me : player) ;
const Tri : array [-1..+1] of char = (#7, #4, #7) ;
KMe : array [player] of shortint = (+1, -1) ;
LoX = -39 ; HiX = +39 ; HiY = 0 ; LoY = 24 ;  MidY = (HiY+LoY) div 2 ;
Brick = '²' ; Mine = char($EB) ;
TgtX = HiX div 2 ; TgtY = (HiY + 2*LoY) div 3 ;
var P, Q, X, Y, XO, YO : integer ; KXS, XR, XS, YR, YS : real ; C : char ;
KK, K : shortint ; DstW, SrcW, W, WW : word ;
begin GotoXY(3, 1) ; Write(' GIBBON [mode ', LastMode, '] ') ;
  GotoXY(40, 1) ; Write(' Keys - Numbers 0123456789 as controls ') ; WSC ;
  DstW := Bkgd + ((Blink+Yellow) shl 8) + word(Other[Me]) ;
  SrcW := Bkgd + (    Yellow     shl 8) + word(Me) ;
  for Y := HiY to LoY do Disp^[Y, -40] := 0 ;
  GoToXY(22, 1) ; Write(Sp, Me, '''s target : ', Other[Me], Sp) ;
  for KK := 1 to 9 do Disp^[LoY, PM(35)] := (Green shl 12)+word(Mine) ;
  Cause := 'Quit' ; K := KMe[Me] ;
  for KK := 1 to 12 do Disp^[MidY+PM(10), K*LoX] := (Green shl 12)+word(Brick) ;
  for X := 1 downto -1 do if X<>0 then begin P := PM(10) ;
    for Q := MidY + PM((HiY-LoY) div 4) to LoY do
      Disp^[Q, P*X] := (Cyan shl 12)+(Brown shl 8)+word(Brick) end;
  YO := TgtY+PM(LoY-TgtY) ; XO := TgtX+PM((HiX-TgtX)*9 div 10) ;
  for Q := YO to LoY do
    Disp^[Q, K*XO] := (Red shl 12)+(Brown shl 8)+word(Brick) ;
  Disp^[YO, K*XO] := DstW ;
  Disp^[LoY, K*LoX] := SrcW ;
  X := 0 ; Y := (4*HiY+LoY) div 5 ;
if ScrLk then begin X := PM(35) ; Y :=  Y + PM(((HiY-LoY) div 7)-1) ;
end else repeat GoToXY(K*X+41, Y+1) ; C := ReadKey ;
    case C of
      Esc : Exit ;
      ^C  : HALT ;
      '1' : begin X := K*LoX ; Y := LoY end ;
      '2' : if Y<LoY then Inc(Y) ;
      '3' : begin X := K*HiX ; Y := LoY end ;
      '4' : if K*X>LoX then Dec(X, K) ;
      '5' : begin X := 0 ; Y := (HiY+LoY) div 2 end ;
      '6' : if K*X<HiX then Inc(X, K) ;
      '7' : begin X := K*LoX ; Y := HiY end ;
      '8' : if Y>HiY then Dec(Y) ;
      '9' : begin X := K*HiX ; Y := HiY end ;
      end ;
    until C='0' ;

  Cause := 'Miss' ;
  XS := (X-LoX)*0.0109 ; YS := (LoY-Y)*0.02 ; Q := 0 ;
  X := LoX ; XR := X ; Y := LoY-1 ; YR := Y ;
  repeat
    if (X>=LoX) and (X<=HiX) and (Y>=HiY) and (Y<=LoY) then begin
      W := Disp^[Y, K*X] ; C := char(Lo(W)) ;
      Sound(Abs(Round(5000.0*YS))) ; Disp^[Y, K*X] := Bkgd+(White shl 8)+Face ;
      Await(1) ; KXS := K*XS ; NoSound ; Await(2) ;
      if C=Mine then begin
        Disp^[Y, K*X] := Bkgd+((Blink+LightRed) shl 8)+word($0F) ;
        for WW := 50 to 10000 do Sound(WW) ;
        XS := -XS ; YS := Abs(YS)*1.17 ; Ink(Me, Scores[Me], -5) ;
        Disp^[LoY, PM(35)] := (Green shl 12)+word(Mine) ; end ;
      Disp^[Y, K*X] := Bkgd+(Red shl 8)+word(Tri[Ord(KXS<0)-Ord(KXS>0)]) ;
      if C=Brick then begin Sound(2000) ; XS := -XS ; Dec(Scores[Me]) ;
        WSC ;
        if (X=XO) and (Y>YO) then begin
          Disp^[Y, K*X] := (Red shl 12)+(Brown shl 8)+word(Brick) ;
          WW := Disp^[YO, K*X] ; Disp^[YO, K*X] := Bkgd ;
          Inc(YO) ; Disp^[YO, K*X] := WW ;
          end ;
        Await(25) ; (* NoSound *) end ;
      if W=DstW then begin
        Disp^[Y, K*X] := Bkgd+((Blink+LightRed) shl 8)+word($0F) ;
        Cause := 'Hit!' ; Ink(Me, Scores[Me], +25) ;
        Disp^[Y, K*X] := Bkgd+((Blink+White) shl 8)+Star ; Exit end ;
      if W=SrcW then begin
        Disp^[Y, K*X] := Bkgd+((Blink+LightRed) shl 8)+word($0F) ;
        Cause := 'Self' ; Ink(Me, Scores[Me], -50) ;
        Disp^[Y, K*X] := Bkgd+((Blink+White) shl 8)+Star ; Exit end ;
      end ;
    XR := XR + XS ; YR := YR - YS ; YS := YS - 0.0052 ;
    if (Round(Y)>=LoY) and (YS<0) then begin Sound(1500) ; Await(33) ;
      YS := Abs(YS)*0.93 ; Inc(Q) end ;
    if X>HiX then XS := -Abs(XS) ;
    X := Round(XR) ; Y := Round(YR) ;
    until ((X<LoX) and (XS<0)) or (Q>40) ;
  if X<LoX then begin X := Round(XR-XS) ; Y := Round(YR+YS) end ;
  if (X>=LoX) and (X<=HiX) and (Y>=HiY) and (Y<=LoY) then
    Disp^[Y, K*X] := Bkgd+(White shl 8)+word('*') ;
  Sound(1111) ; Await(100) ; NoSound ; end {DoIt} ;

var
Xdos : Scrn ;
Time : longint absolute $0:$046C ;
T : longint ; DT : integer ;
Regs : registers ;
Ben, MyGo : char ;
SC, TA : byte ;


BEGIN TA := TextAttr ;
if LastMode=Mono then Disp := {mono} Ptr($B000, 0)
  else Disp := {colo} Ptr($B800, 0) ;
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} ;
Xdos := Disp^ ;

repeat
for MyGo := 'A' to 'B' do Scores[MyGo] := 0 ;
MyGo := 'A' ;
repeat
  while KeyPressed do Ben := ReadKey ;
  TextAttr := (Bkgd shr 8)+Yellow ; ClrScr ;
  TextAttr := (Bkgd shr 8)+Blue ;

  if CpUnLk then repeat T := Time ; Await(20000.0/18.2) ; DT := (Time-T) ;
    if DT=0 then DT := 1 ; QW := (20.0*QW)/DT ;
    Writeln(DT:5, QW:10:3) ; Await(500) until Abs(DT-20)<2 ;

  DoIt(MyGo) ;

  GotoXY(3, 2) ; Write(' Result : ', MyGo, #32, Cause, Sp) ; WSC;
  NoSound ; Await(250) ; GotoXY(54, 2) ; Write(' ANY to run, Esc to quit ') ;
  MyGo := Other[MyGo] ; Delay(250) ;
  until (not ScrLk) and (ReadKey=Esc) ;
while KeyPressed do Write(ReadKey) ;

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

TextMode(LastMode) ;
Regs.AH := $02 ; Intr($10, Regs) {Set cursor Pos} ;
Regs.AH := $01 ; Regs.CH := SC ; Intr($10, Regs) {Set cursor Size} ;
TextAttr := TA ; Disp^ := Xdos ;
END.