program viergew(input,output);
{
  Nach einem BASIC Programm von:

  ######################################################
  #####                                            #####
  #####           Eberhard Fischer                 #####
  #####           Weizenkamp 37                    #####
  #####           2110 Buchholz i.d.Heide          #####
  #####           Tel.: 04181 - 38859              #####
  #####                                            #####
  #####           (c) Juni 1989                    #####
  #####                                            #####
  ######################################################

  Uebertragen nach TURBO PASCAL von Werner Cirsovius.

  Die Variablen haben etwas aussagekraeftigere Namen erhalten.

  Kompilation muss auf die Endadresse C9FF eingestellt sein!
}
const
  bell         = #$07;
  esc          = #$1b;
{
  Graphische JOYCE Zeichen - Alternativ einfach statt doppelt
}
  Doppelunten  = #129;       { #155 }
  DoppelOben   = #132;       { #158 }
  LinksUnten   = #131;       { #147 }
  LinksOben    = #134;       { #150 }
  RechtsUnten  = #137;       { #153 }
  RechtsOben   = #140;       { #156 }
  DoppelLinks  = #130;       { #151 }
  DoppelRechts = #136;       { #157 }
  DoWaagerecht = #138;       { #154 }
  DoSenkrecht  = #133;       { #149 }
  Senkrecht    = #149;
  Waagerecht   = #154;
  Kreuz        = #159;
  ChipUmriss   = #187;
  ChipGanz     = #188;
{
  Textattribute
}
  Duenn        = $01;
  Fett         = $02;
  Unter        = $04;
  DBreit       = $10;
  DHoch        = $20;
  Expo         = $40;
  Index        = $80;

type
  GX_MCode     = array[0..364] of byte;
  Strlang      = string[255];
var
{ Original code fits into $F000 }
  GX_MProg     : GX_MCode absolute $CA00;
  Spiel        : boolean;
  ChipPos      : byte;
  Spieler      : byte;
  VorSpieler   : byte;
  Runde        : integer;
  Stand        : array[1..2]        of byte;
  Name         : array[1..2]        of Strlang;
  Zaehlfeld    : array[1..43]       of byte;
  Spielfeld    : array[1..50,1..50] of byte;
const
  links        : array[1..2] of char = (^A,'a');
  rechts       : array[1..2] of char = (^F,'s');
  setzen       : array[1..2] of char = (^M,' ');
  Chip         : array[1..2] of char = (ChipUmriss,ChipGanz);
  GX_Data      : GX_MCode =(
  {0000}  $fd,$e1,$d1,$c1,$e1,$61,$c1,$fd,$e5,$79,$32,$6d,$cb,$2d,$25,$22,
  {0010}  $6f,$cb,$eb,$7e,$b7,$c8,$4f,$06,$00,$32,$6e,$cb,$23,$11,$9b,$cb,
  {0020}  $ed,$b0,$01,$2b,$ca,$cd,$5a,$fc,$e9,$00,$c9,$3a,$6e,$cb,$47,$21,
  {0030}  $9b,$cb,$7e,$c5,$e5,$6f,$26,$00,$29,$29,$29,$11,$00,$b8,$19,$11,
  {0040}  $7b,$cb,$01,$08,$00,$ed,$b0,$21,$01,$01,$22,$71,$cb,$3a,$6d,$cb,
  {0050}  $1f,$dc,$7c,$ca,$1f,$dc,$8e,$ca,$1f,$dc,$76,$ca,$1f,$1f,$dc,$9e,
  {0060}  $ca,$1f,$dc,$c9,$ca,$1f,$dc,$ef,$ca,$1f,$dc,$ec,$ca,$cd,$18,$cb,
  {0070}  $e1,$c1,$23,$10,$bd,$c9,$21,$82,$cb,$36,$ff,$c9,$f5,$21,$7b,$cb,
  {0080}  $06,$08,$7e,$cb,$3f,$a6,$77,$23,$10,$f8,$f1,$cb,$87,$c9,$f5,$21,
  {0090}  $7b,$cb,$06,$08,$7e,$cb,$3f,$b6,$77,$23,$10,$f8,$f1,$c9,$f5,$3e,
  {00a0}  $02,$32,$71,$cb,$dd,$21,$7b,$cb,$0e,$08,$06,$08,$dd,$7e,$00,$1f,
  {00b0}  $dd,$cb,$00,$1e,$dd,$cb,$10,$1e,$dd,$cb,$00,$2e,$dd,$cb,$10,$1e,
  {00c0}  $10,$ed,$dd,$23,$0d,$20,$e3,$f1,$c9,$3e,$02,$32,$72,$cb,$11,$82,
  {00d0}  $cb,$cd,$dc,$ca,$3a,$71,$cb,$3d,$c8,$11,$92,$cb,$21,$08,$00,$19,
  {00e0}  $06,$08,$1a,$1b,$77,$2b,$77,$2b,$10,$f8,$af,$c9,$af,$18,$02,$3e,
  {00f0}  $02,$32,$72,$cb,$11,$8a,$cb,$cd,$02,$cb,$3a,$71,$cb,$3d,$c8,$11,
  {0100}  $9a,$cb,$cd,$0e,$cb,$21,$fc,$ff,$19,$01,$08,$00,$ed,$b8,$af,$12,
  {0110}  $1b,$12,$1b,$12,$1b,$12,$1b,$c9,$21,$7b,$cb,$ed,$4b,$71,$cb,$ed,
  {0120}  $5b,$6f,$cb,$d5,$e5,$15,$05,$05,$cc,$44,$cb,$14,$cd,$44,$cb,$14,
  {0130}  $04,$04,$cc,$44,$cb,$e1,$11,$10,$00,$19,$d1,$1c,$0d,$20,$e4,$ed,
  {0140}  $53,$6f,$cb,$c9,$7b,$fe,$5a,$d0,$7a,$fe,$20,$d0,$c5,$d5,$e5,$16,
  {0150}  $00,$07,$17,$17,$17,$6f,$7a,$ce,$b6,$67,$7e,$23,$66,$6f,$eb,$29,
  {0160}  $29,$19,$29,$eb,$e1,$01,$08,$00,$ed,$b0,$d1,$c1,$c9);

procedure script(m,x,y:byte;var schrift:Strlang); external $CA00;
{Aufruf des Maschinen-Codes}

procedure MCLaden;
{MC Lader}
Begin
  GX_MProg:=GX_Data;
End;

procedure CursorEin;
{Cursor ein}
Begin
  write(esc,'e');
End;

procedure CursorAus;
{Cursor aus}
Begin
  write(esc,'f');
End;

procedure FeldInitialisieren;
{Felder initialisieren - entspricht ERASE in BASIC}
var
  i,j          : byte;
Begin
  for i:=1 to 43 do Zaehlfeld[i]:=0;
  for i:=1 to 50 do
    for j:=1 to 50 do Spielfeld[i,j]:=0;
End;

function strings(x:byte;c:char):Strlang;
{Simulation der BASIC Funktion STRING$}
var
  i            : byte;
  st           : Strlang;
Begin
  st:='';
  for i:=1 to x do st:=st+c;
  strings:=st;
End;

procedure uppers(var s:Strlang);
{Simulation der BASIC Funktion UPPER$}
var
  i            : byte;
Begin
  for i:=1 to length(s) do s[i]:=upcase(s[i]);
End;

procedure inkeys(var ch:char);
{Zeichen einlesen, Abbruch testen}
Begin
  repeat until keypressed;
  read(kbd,ch);
  if (ch=^C) then
  begin
    CursorEin;
    clrscr;
    halt;
  end;
End;

procedure at(x,y:byte;s:Strlang);
{Text an Cursorposition ausgeben}
begin
  gotoxy(x,y);
  write(s);
end;

procedure Spielerklaerungen;
{Spielerklaerungen}
var
  ch           : char;
Begin
  at(25,2,' ****  V I E R    G E W I N N T  **** ');
  at(6,5,'Spielerkl{rung :');
  at(5,6,'=================');
  at(3,7,'Es  ist die  Version  eines  oft umgesetzten  Strategiespiels, indem  man  versucht,');
  at(3,8,'durch  Einwerfen von  Spielsteinen in  ein Raster, eine senkrechte  oder waagerechte');
  at(3,9,'Vierer-Reihe zu bekommen. Es ist f}r zwei Spieler ausgelegt, wobei f}r jeden Spieler');
  at(3,10,'eine separate Steuerung zur Verf}gung steht.');
  at(3,12,'Diese ist f}r Spieler 1 auf die Cursortasten und Return gelegt.');
  at(3,14,'F}r Spieler 2 wurden die Tasten A / S und Space vorgesehen.');
  at(3,16,'Man  steuert nun  den  Spielchip  auf die  Reihe, in  die man  diesen  einwerfen');
  at(3,17,'m|chte und dr}ckt Feuer. Zum Unterscheiden werden die Chips in Form eines hohlen');
  at(3,18,'Kreises '+ChipUmriss+' sowie des ausgef}llten Kreises '+ChipGanz+' ausgegeben.');
  at(3,19,'Wer zuerst eine oben genannte Reihe erreicht ist Sieger des Spiels.');
  at(3,21,'Das Spiel kann jederzeit mit der STOP-TASTE abgebrochen werden.');
  at(3,23,'Sollte  auf  die  Eingabe  nach dem  Namen der  Mitspieler verzichtet werden,');
  at(3,24,'wird nach bet{tigen der RETURN-TASTE automatisch eine Definition vorgenommen.');
  at(26,29,'Weiter ? Bitte Leertaste dr}cken');
  MCLaden;
  repeat
    inkeys(ch);
  until(ch=' ');
  clrscr;
End;

procedure TexteSchreiben(sn:byte;texts:Strlang;x,y:byte);
var
  loktext       : Strlang;
{Texte schreiben
  sn definiert den Modus des Textes:
    00000001 Duenn
    00000010 Fett
    00000100 Unterstreichen
    00010000 Doppelte Breite
    00100000 Doppelte Hoehe
    01000000 Exponenten
    10000000 Indizes

  Im Programm wird aktuell verwendet:
     16 - 0x10 - 00010000b - Doppeltbreit
     49 - 0x31 - 00110001b - Doppelthoch+Doppeltbreit+Duenn
    112 - 0x70 - 01110000b - Exponent+Doppelthoch+Doppeltbreit
    115 - 0x73 - 01110011b - Exponent+Doppelthoch+Doppeltbreit+Fett+Duenn
    167 - 0xa7 - 10100111b - Index+Doppelthoch+Unterstrichen+Fett+Duenn
}
Begin
  loktext:=texts;
  script(sn,x,y,loktext);
End;

procedure Bildaufbau;
{Bildaufbau}
var
  spalte,zeile : byte;
  szz,sz       : byte;

  procedure SpielerName(p:byte);
  {Eingabe Spieler 1 oder 2}
  begin
    at(52,4*(p-1)+10,' Name Spieler '+chr(p+ord('0'))+' : ');
    CBREAK:=false;
    readln(Name[p]);
    CBREAK:=true;
  end;

  procedure Bearbeiten(p:byte);
  {Bearbeiten Spieler 1 oder 2}
  begin
    Name[p]:=copy(Name[p],1,12);
    if (Name[p]='') then Name[p]:='Spieler '+chr(ord('0')+p)
                    else uppers(Name[p]);
  end;

  procedure Waagerechte(Links,Rechts,Linie:char);
  {Zieht Linie oben oder unten}
  Begin
    spalte:=10;
    at(spalte,zeile,Links);
    at(spalte+40,zeile,Rechts);
    spalte:=spalte+1;
    for sz:=1 to 9 do
    begin
      at(spalte,zeile,strings(3,DoWaagerecht)+Linie+strings(3,DoWaagerecht));
      spalte:=spalte+4;
    end;
  End;

Begin {Bildaufbau}
  TexteSchreiben(Expo+DHoch+DBreit+Fett+Duenn,' * VIER GEWINNT * ',28,2);
{
  Reihe oben
}
  zeile:=6;
  Waagerechte(LinksOben,RechtsOben,DoppelOben);
{
  Reihe senkrecht
}
  for szz:=1 to 19 do
  begin
    spalte:=10;
    zeile:=zeile+1;
    at(spalte,zeile,DoSenkrecht);
    at(spalte+40,zeile,DoSenkrecht);
    spalte:=spalte+4;
    for sz:=1 to 8 do
    begin
      at(spalte,zeile,Senkrecht+'   '+Senkrecht);
      spalte:=spalte+4;
    end;
  end;
{
  Reihe unten
}
  zeile:=zeile+1;
  Waagerechte(LinksUnten,RechtsUnten,Doppelunten);
{
  Reihe waagerecht
}
  zeile:=6;
  for szz:=1 to 9 do
  begin
    spalte:=10;
    zeile:=zeile+2;
    at(spalte,zeile,DoppelLinks);
    at(spalte+40,zeile,DoppelRechts);
    spalte:=spalte+1;
    for sz:=1 to 9 do
    begin
      at(spalte,zeile,strings(3,Waagerecht)+Kreuz+strings(3,Waagerecht));
      spalte:=spalte+4;
    end;
  end;
{
  Spielernamen einlesen
}
  if (Name[1]='') then
  begin
    SpielerName(1);
    SpielerName(2);
    at(52,10,strings(35,' '));
    at(52,14,strings(35,' '));
  end;
  Bearbeiten(1);
  Bearbeiten(2);
End;

procedure Tabelle;
{Tabelle}
var
  rd           : string[6];

  procedure StandSpieler(sp,y:byte);
  var
    Korrektur  : byte;
  begin
    TexteSchreiben(DHoch+DBreit+Duenn,Name[sp]+strings(12-length(Name[sp]),' '),54,y);
    if (Stand[sp]<10) then Korrektur:=2
                      else Korrektur:=0;
    str(Stand[sp],rd);
    TexteSchreiben(DHoch+DBreit+Duenn,rd,80+Korrektur,y);
  end;

Begin {Tabelle}
  str(Runde,rd);
  TexteSchreiben(DHoch+DBreit+Duenn,'Runde : '+rd,54,9);
  TexteSchreiben(DHoch+DBreit+Duenn,'=== GEWONNEN ===',54,15);
  StandSpieler(1,18);
  StandSpieler(2,20);
End;

procedure SpielLauf;
var
  Schuss       : boolean;
  Lauf         : boolean;
  ts           : char;
  a,t,y        : byte;
  sz,szz       : byte;
  sx1,sy1      : byte;
  sx,sy        : byte;
  sz1,sz2,sz3  : byte;

  procedure SenkrechteReihenauswerten;
  begin
    t:=0;
    szz:=7;
    while (szz<=43) do
    begin
      sz:=0;
      while (sz<=Zaehlfeld[szz]) do
      begin
        if (Spielfeld[szz,sz]<1) then t:=0
           else if (Spielfeld[szz,sz]<>VorSpieler) then t:=0
                                                   else t:=t+1;
        if (t>3) then Lauf:=false;
        sz:=sz+2;
      end;
      szz:=szz+4;
    end;
  end;

  procedure WaagerechteReihenauswerten;
  begin
    t:=0;
    sz:=0;
    while (sz<=Zaehlfeld[a]) do
    begin
      szz:=7;
      while (szz<=43) do
      begin
        if (Spielfeld[szz,sz]<>VorSpieler) then t:=0
                                           else t:=t+1;
        if (t>3) then Lauf:=false;
        szz:=szz+4;
      end;
      sz:=sz+2;
    end;
  end;

  procedure Diagonaleauswerten(start,step:integer);
  begin
    sx1:=start;
    sy1:=0;
    sx:=sx1;
    sy:=sy1;
    for sz1:=1 to 7 do
    begin
      if (Zaehlfeld[sx1]>=1) then
      begin
        for sz2:=1 to 7 do
        begin
          if (Spielfeld[sx1,sy1]>=1) then
          begin
            t:=0;
            for sz3:=1 to 4 do
            begin
              if (Spielfeld[sx,sy]<>VorSpieler) then t:=0
                                                else t:=t+1;
              sx:=sx+step*4;
              sy:=sy+2;
              if (t>3) then Lauf:=false;
            end;
          end;
          sx:=sx1;
          sy1:=sy1+2;
          sy:=sy1;
        end;
      end;
      sx1:=sx1+step*4;
      sx:=sx1;
      sy1:=0;
      sy:=sy1;
    end;        
  end;

Begin {SpielLauf}
  Lauf:=true;
  while Lauf do
  begin
    TexteSchreiben(Expo+DHoch+DBreit,strings(length(Name[Spieler])+20,' '),13,30);
    write(bell);
    TexteSchreiben(Expo+DHoch+DBreit,Name[Spieler]+' ist am Zug ',13,30);
{
  Pfeil bewegen
}
    Schuss:=false;
    repeat
      at(ChipPos-4,5,'    '+Chip[Spieler]+'    ');
      inkeys(ts);
      if ((ts=links[Spieler])  and (ChipPos>12)) then ChipPos:=ChipPos-4;
      if ((ts=rechts[Spieler]) and (ChipPos<45)) then ChipPos:=ChipPos+4;
      if  (ts=setzen[Spieler])                   then Schuss:=true;
    until Schuss;
{
  Chip einwerfen
}
    a:=ChipPos-5;
    y:=Zaehlfeld[a];
    if (y<19) then
    begin
      sz:=7;
      while (sz<=25-y) do
      begin
        at(ChipPos,sz,Chip[Spieler]);
        at(ChipPos,sz-2,' ');
        sz:=sz+2;
      end;
    end;
    Spielfeld[a,y]:=Spieler;
    VorSpieler:=Spieler;
    Spieler:=Spieler+1;
    if (Spieler>2) then Spieler:=1;
    if (Zaehlfeld[a]<20) then Zaehlfeld[a]:=Zaehlfeld[a]+2;
                 SenkrechteReihenauswerten;
    if Lauf then WaagerechteReihenauswerten;
    if Lauf then Diagonaleauswerten(7,1);
    if Lauf then Diagonaleauswerten(43,-1);
  end;
End;

procedure GewinnerAnzeigen;
var
  del          : integer;
  ts           : char;
Begin
{
  Gewinner anzeigen
}
  TexteSchreiben(Index+DHoch+Unter+Fett+Duenn,strings(length(Name[Spieler]),' '),13,30);
  TexteSchreiben(DHoch+DBreit+Duenn,'>>> '+ Name[VorSpieler]+' hat g e w o n n e n <<<',13,30);
  Stand[VorSpieler]:=Stand[VorSpieler]+1;
  for del:=0 to 300 do
  begin
    port[248]:=11;
    port[248]:=12;
  end;
  Tabelle;
{
  Neues Spiel abfragen
}
  TexteSchreiben(DBreit,'Neues Spiel  J - N',53,24);
  repeat
    inkeys(ts);
    ts:=upcase(ts);
  until (ts in ['J','N']);
  case ts of
    'J' : begin
            clrscr;
            Runde:=Runde+1;
          end;
    'N' : Spiel:=false;
  end;
End;

BEGIN
  Name[1]:='';
  Stand[1]:=0;
  Stand[2]:=0;
  clrscr;
  CursorAus;
  Runde:=1;
  Spielerklaerungen;
  Spiel:=true;
  while Spiel do
  begin
    FeldInitialisieren;
    ChipPos:=12;
    Spieler:=1;
    Bildaufbau;
    Tabelle;
    SpielLauf;
    GewinnerAnzeigen;
  end;
  CursorEin;
  clrscr;
END.