program Schlange(input,output);

(* BASIC aus PCI 1/89 *)

type
  MCode        = array[0..20] of byte;
  str4         = string[  4];
  str5         = string[  5];
  LStr         = string[255];
const
  Keys         : array[1..4,0..8] of byte =
                 ((225,$7E,$FF,$99,$99,$FF,$C3,$99,$7E),     (* Schlangenkopf unfreundlich *)
                  (224,$7E,$FF,$99,$99,$FF,$99,$C3,$7E),     (* Schlangenkopf freundlich   *)
                  (233,$FF,$81,$81,$81,$81,$81,$81,$FF),     (* Sperre                     *)
                  (207,$AA,$55,$AA,$55,$AA,$55,$AA,$55));    (* Begangegens Feld           *)
  Data         : MCode =
  ($01,$09,$F5,        (*       ld    bc,rout   *)
   $CD,$5A,$FC,        (*       call  0fc5ah    *)
   $E9,$00,            (*       dw    00e9h     *)
   $C9,                (*       ret             *)
   $21,$15,$F5,        (* rout: ld    hl,0f515h *)
   $01,$08,$00,        (*       ld    bc,8      *)
   $11,$00,$00,        (*       ld    de,0      *)
   $ED,$B0,            (*       ldir            *)
   $C9                 (*       ret             *)
  );
  nul          = #00;
  esc          = #$1b;
  Programm     = 'SCHLANGE.COM';      (* Name dieses Programmes *)
  MaxPunkte    = 399;                 (* Anzahl Felder - Schlange = 20*20-1 *)
var
  MProg        : MCode absolute $F500;
  as           : char;
  ah           : integer;
  x            : integer;
  y            : integer;
  z            : integer;
  p            : integer;
  pu           : integer;
  d            : integer;
  cls_dollar   : str4;
  merk         : array[1..25,1..25] of byte;
  hinder       : array[1..20,1..2] of byte;

procedure Codestart; external $F500;

procedure IniVar;
{ Variable vorbesetzen }
Begin
  cls_dollar:=esc+'H'+esc+'E';
  z:=0;
  pu:=0;
  d:=0;
End;

procedure DIM_merk;
{ Merkfelder vorbesetzen }
var
  i,j          : integer;
Begin
  for i:=1 to 25 do
      for j:=1 to 25 do merk[i,j]:=0;
End;

procedure DIM_hinder;
{ Hindernisfelder vorbesetzen }
var
  i,j          : integer;
Begin
  for i:=1 to 20 do
      for j:=1 to 2 do hinder[i,j]:=0;
End;

function INKEY_dollar:char;
{ Taste einlesen }
var
  c            : char;
Begin
  if keypressed then read(kbd,c)
                else c:=nul;
  INKEY_dollar:=c;
End;

function TAB(n:integer):LStr;
{ Auf n. Spalte setzen }
var
  i            : integer;
  mTAB         : LStr;
Begin
  mTAB:='';
  for i:=1 to n do mTAB:=mTAB+' ';
  TAB:=mTAB;
End;

function SPACE(n:integer):LStr;
{ Anzahl Leerzeichen ausgeben }
var
  i            : integer;
  mTAB         : LStr;
Begin
  mTAB:='';
  for i:=1 to n do mTAB:=mTAB+' ';
  SPACE:=mTAB;
End;

function FNloc_dollar(x,y:byte):str4;
{ Cursor setzen }
Begin
  FNloc_dollar:=esc+'Y'+chr(31+y)+chr(31+x);
End;

function FNwin_dollar(o,l,h,b:byte):LStr;
{ Fenster definieren }
Begin
  FNwin_dollar:=esc+'X'+chr(31+o)+chr(31+l)+chr(31+h)+chr(31+b);
End;

procedure l_1950;
{ Maschinencode in den oberen Bereich schieben }
Begin
  MProg:=Data;
End;

procedure l_1660;
{ Neue Zeichen definieren }
var
  i,j          : integer;
  Zeichencode  : integer;
  Charadr      : array[1..2] of byte absolute $F510;
  Tabstart     : array[1..8] of byte absolute $F515;
Begin
  for i:=1 to 4 do
  begin
    Zeichencode:=Keys[i][0];
    for j:=1 to 8 do Tabstart[j]:=Keys[i][j];
    Charadr[1]:=    lo(Zeichencode*8);
    Charadr[2]:=$b8+hi(Zeichencode*8);
    Codestart;
  end;
End;

procedure l_480;
{ Rahmen aufbauen }

  procedure RahmenXY(x,y:integer);
  { Rahmenelement aufbauen }
  begin
    write(FNloc_dollar(x,y),#233);     (* Kasten ausgeben *)
    merk[x,y]:=233;
  end;

  procedure RahmenX(x:integer);
  { Rahmen aufbauen mit konstantem X }
  var
    y          : integer;
  begin
    for y:=2 to 23 do RahmenXY(x,y);
  end;

  procedure RahmenY(y:integer);
  { Rahmen aufbauen mit konstantem Y }
  var
    x          : integer;
  begin
    for x:=2 to 21 do RahmenXY(x,y);
  end;

Begin { l_480 }
  write(cls_dollar,esc,'f',esc,'0');
  write(FNwin_dollar(6,13,24,80));
  RahmenX(1);
  RahmenX(22);
  RahmenY(2);
  RahmenY(23);
End;

procedure l_400;
{ Abfrage der Schwierigkeitsstufe }
Begin
  repeat
    writeln(cls_dollar,'Welche Schwierigkeitsstufe');
    writeln('( 5=leicht bis 20=schwer ) [RETURN]');
    write('? ');
    readln(ah);
  until (ah in [5..20]);
End;

procedure l_1420;
{ Spielende }
var
  a_dollar     : char;
  j            : integer;
  f            : file;

  procedure l_1580;
  begin
    writeln(cls_dollar,esc+'e'+esc+'1');
    halt;
  end;

  procedure l_1570;
  begin
    writeln(esc+'b'+#0+esc+'c'#63);
    l_1580;
  end;

Begin { l_1420 }
  writeln(FNloc_dollar(30,20),'Anderes Bild, dasselbe Bild oder Ende ? ');
  writeln(FNloc_dollar(30,21),'[A], [D], [E]');
  pu:=pu+(ah-(MaxPunkte-(p+ah)));           (* pu:=pu+p+2*ah-MaxPunkte; *)
  write(FNloc_dollar(30,16),pu);
  if pu>100 then
  begin
    writeln(cls_dollar,'DU HAST GEWONNEN! HERZLICHEN GL]CKWUNSCH!');
    writeln('M|chtest Du ein weiteres Spiel? So warte einen Augenblick, sonst dr}cke jetzt eine Taste!');
    while INKEY_dollar<>nul do;
    j:=0;
    while INKEY_dollar=nul do
    begin
      j:=j+1;
      if j=1000 then
      begin
        assign(f,Programm);
        execute(f);
      end;
    end;
    l_1580;
  end else
(* 1520 *)
  begin
    repeat
      a_dollar:=Upcase(INKEY_dollar);
    until a_dollar in ['A','D','E'];
    case a_dollar of
      'A' : d:=0;
      'D' : d:=1;
      'E' : l_1570;
    end;
    if a_dollar in ['A','D'] then DIM_merk;
  end;
End;

procedure l_1390;
{ Spielende bei Belegung aller Felder }
var
  w            : integer;
Begin
  write(FNloc_dollar(30,30),'Sehr gut! Du bekommst einen Bonus. Bitte warten!');
  for w:=1 to 2000 do ;
  pu:=pu+ah;
  write(FNloc_dollar(30,30),SPACE(50));
  l_1420;
End;

procedure l_1030(h:integer);
{ Cursorbewegung ausfuehren }
Begin
  write(FNloc_dollar(x,y),#207);      (* Begangenes Feld ausgeben *)
    case h of
      1: y:=pred(y);
      2: y:=succ(y);
      3: x:=pred(x);
      4: x:=succ(x);
    end;
  if merk[x,y]=0 then
  begin
    write(FNloc_dollar(x,y),#224);    (* Freundliche Schlange ausgeben *)
    merk[x,y]:=h;
    p:=succ(p);
    write(FNloc_dollar(30,10),p);
    if p+ah=MaxPunkte then l_1390;
  end else
  begin
    case h of
      1: y:=succ(y);
      2: y:=pred(y);
      3: x:=succ(x);
      4: x:=pred(x);
    end;
    write(FNloc_dollar(x,y),#225);    (* Unfreundliche Schlange ausgeben *)
  end;
End;

procedure l_1230;
{ Eingegebenes Feld zuruecknehmen }
var
  h            : integer;
Begin
  h:=merk[x,y];
  if h<>5 then
  begin
    merk[x,y]:=0;
    write(FNloc_dollar(x,y),' ');
    case h of
      1: y:=succ(y);
      2: y:=pred(y);
      3: x:=succ(x);
      4: x:=pred(x);
    end;
    write(FNloc_dollar(x,y),#224);    (* Freundliche Schlange ausgeben *)
    p:=pred(p);
    write(FNloc_dollar(30,10),p);
  end;
End;

procedure l_90;
{ Spielanleitung ausgeben }
Begin
  write(cls_dollar,esc,'b',#63,esc,'c',#0);
  write(FNwin_dollar(5,5,24,80));
  writeln(TAB(30),esc,'p',' S  C  H  L  A  N  G  E ',esc,'q');
  writeln;
  writeln;
  writeln;
  writeln('Spielidee: Familie Lipka');
  writeln(']berarbeitung f}r den Joyce: Martin Nicolaus');
  writeln;
  writeln;
  writeln(esc,'p','Anleitung',esc,'q');
  writeln('Bei diesem Spiel kommt es darauf an, m|glichst viele Felder zu durchqueren.');
  writeln('Jedes Feld kann dabei nur einmal betreten werden. Gesteuert wird die Schlan-');
  writeln('ge mit den Cursortasten. Die eingegebenen Felder werden mit der Leertaste');
  writeln('zur}ck genommen.');
  writeln('Je mehr Felder durchquert werden und je h|her die Schwierigkeitsstufe ist,');
  writeln('desto gr|~er wird auch die Punktzahl. Wenn man alle Felder besetzt hat, wird');
  writeln('man mit Bonuspunkten belohnt, die sich nach der Schwierigkeitsstufe richten.');
  writeln('Wenn man aber zu wenig Felder durchquert, werden Punkte wieder abgezogen.');
  writeln('Hat man }ber 100 Punkte erreicht, so hat man gewonnen.');
  writeln('Dr}cken Sie jetzt eine beliebige Taste (au~er ALT-C)!');
  while INKEY_dollar=nul do
  begin
    z:=z+1;
    if z=60 then z:=1;
  end;
  z:=random(z);
End;

procedure l_820;
{ Statusfeld ausgeben }
Begin
  x:=2;
  y:=3;
  p:=0;
  write(FNloc_dollar(x,y),#224);     (* Freundliche Schlange ausgeben *)
  merk[x,y]:=5;
  write(FNloc_dollar(30,7),'F e l d e r :');
  write(FNloc_dollar(30,10),'0');
  write(FNloc_dollar(30,13),'P u n k t e :');
  write(FNloc_dollar(30,16),pu);
  write(FNloc_dollar(30,1),'Schwierigkeitsstufe: ',ah);
  write(FNloc_dollar(30,20),'[E]=ENDE [ ]=ZURUECK [Cursort.]=Steuerung');
End;

procedure l_930;
{ Spieldurchgang }
Begin
  repeat
    repeat until keypressed;
    read(kbd,as);
    as:=upcase(as);
    case as of
      #31 : l_1030(1);             (* ^_ : Cursor nach oben *)
      #30 : l_1030(2);             (* ^^ : Cursor nach unten *)
      #01 : l_1030(3);             (* ^A : Cursor nach links *)
      #06 : l_1030(4);             (* ^F : Cursor nach rechts *)
      'E' : l_1420;
      ' ' : l_1230;
    end;
  until as='E';
End;

procedure l_650;
{ Spielfeld belegen }
var
  a            : integer;
Begin
  if d<>1 then
  begin
    for a:=1 to ah do
    begin
      repeat
        x:=trunc(20*Random)+2;
        y:=trunc(20*Random)+3;
      until (merk[x,y]<>233);
      write(FNloc_dollar(x,y),#233);  (* Kasten ausgeben *)
      merk[x,y]:=233;
      hinder[a,1]:=x;
      hinder[a,2]:=y;
    end;
  end else
(* 750 *)
  begin
    for a:=1 to ah do
    begin
      x:=hinder[a,1];
      y:=hinder[a,2];
      write(FNloc_dollar(x,y),#233);  (* Kasten ausgeben *)
      merk[x,y]:=233;
    end;
  end;
End;

BEGIN { M A I N }
  randomize;
  l_1950;
  l_1660;
  IniVar;
  l_90;
  DIM_hinder;
  repeat
(* --- HAUPTSCHLEIFE --- *)
(* 370 *)
    DIM_merk;
    if d<>1 then l_400;
    l_480;
    l_650;
    l_820;
    l_930;
  until as<>'E';
END.