program Schlange(input,output);

(* BASIC aus PCI 1/89 *)

(*
  Aenderungen:

(1) Alle ESCape-Sequenzen als Zeichenkette
(2) PCW Maschinencode zusammengefasst
(3) Maschinecode Basisadresse von $F500 auf $C000 gesetzt
(4) Unterprogramme "vernuenftig" benannt
-
(5) Uebersicht geschaffen

*)

type
  KStr         = string[  6];
  LStr         = string[255];
  FeldWert     = (frei,belegt,Spieler,rauf,runter,links,rechts);
const
  MaxPunkte    = 399;                 (* Anzahl Felder - Schlange = 20*20-1 *)
  nul          = #00;
  esc          = #$1b;
(* PCW Cursortasten *)
  CUP          = ^_;
  CDW          = ^^;
  CLF          = ^A;
  CRG          = ^F;
(* Neue PCW Zeichen *)
  Sperre       = #233;
  Besetzt      = #207;
  SpielerGut   = #224;
  SpielerBoese = #225;

  Programm     = 'SCHLANGE.COM';      (* Name dieses Programmes *)
var
  as           : char;
  ah,
  x,
  y,
  z,
  p,
  pu,
  d            : integer;
  inv_ein,                                     (* Invers einschalten *)
  inv_aus,                                     (* Invers ausschalten *)
  cur_ein,                                     (* Cursor einschalten *)
  cur_aus,                                     (* Cursor ausschalten *)
  sz_ein,                                      (* Statuszeile einschalten *)
  sz_aus,                                      (* Statuszeile ausschalten *)
  cls_dollar,                                  (* Bildschirm loeschen *)
  scr_ein,                                     (* Bildschirm invertiert *)
  scr_aus      : KStr;                         (* Bildschirm normal *)
  merk         : array[1..25,1..25] of FeldWert;
  hinder       : array[1..20,1..2] of byte;

(* +++++++++++++++ Anfang PCW spezifischer Code +++++++++++++++ *)

procedure Codestart; external $C000;

procedure ZeichenNeu;
{ Neue Zeichen definieren }
type
  MCode        = array[0..20] of byte;
const
  Keys         : array[1..4,0..8] of byte =
                 ((224,$7E,$FF,$99,$99,$FF,$99,$C3,$7E),     (* Schlangenkopf freundlich   *)
                  (225,$7E,$FF,$99,$99,$FF,$C3,$99,$7E),     (* Schlangenkopf unfreundlich *)
                  (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,$C0,        (*       ld    bc,rout   *)
   $CD,$5A,$FC,        (*       call  0fc5ah    *)
   $E9,$00,            (*       dw    00e9h     *)
   $C9,                (*       ret             *)
   $21,$15,$C0,        (* rout: ld    hl,0f515h *)
   $01,$08,$00,        (*       ld    bc,8      *)
   $11,$00,$00,        (*       ld    de,0      *)
   $ED,$B0,            (*       ldir            *)
   $C9                 (*       ret             *)
  );
var
  i,j          : integer;
  Zeichencode  : integer;
  MProg        : MCode absolute $C000;
  Charadr      : array[1..2] of byte absolute $C010;
  Tabstart     : array[1..8] of byte absolute $C015;
Begin
  MProg:=Data;
  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;

(* --------------- Ende PCW spezifischer Code --------------- *)

procedure Bildschirmkontrollen;
{ Bildschirmkontrollen vorbesetzen }
Begin
  inv_ein:=esc+'p';
  inv_aus:=esc+'q';
  cls_dollar:=esc+'H'+esc+'E';
  cur_ein:=esc+'e';
  cur_aus:=esc+'f';
  sz_ein:=esc+'1';
  sz_aus:=esc+'0';
  scr_ein:=esc+'b'+#63+esc+'c'+#0;
  scr_aus:=esc+'b'+#0+esc+'c'+#63;
End;

function FNloc_dollar(x,y:byte):KStr;
{ 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 VariableEinstellen;
{ Variable vorbesetzen }
Begin
  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]:=frei;
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:char;
{ Taste einlesen }
var
  c            : char;
Begin
  if keypressed then read(kbd,c)
                else c:=nul;
  INKEY:=c;
End;

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

procedure RahmenAufbau;
{ Rahmen aufbauen }

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

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

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

Begin { RahmenAufbau }
  write(cls_dollar,cur_aus,sz_aus);
  write(FNwin_dollar(6,13,24,80));
  RahmenX(1);
  RahmenX(22);
  RahmenY(2);
  RahmenY(23);
End;

procedure SchwierigkeitsstufeLesen;
{ 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 Spielende;
{ Spielende }
var
  a_dollar     : char;
  j            : integer;
  f            : file;

  procedure ProgrammBeenden;
  begin
    writeln(cls_dollar,cur_ein,sz_ein);
    halt;
  end;

  procedure ProgrammEnde;
  begin
    write(scr_aus);
    ProgrammBeenden;
  end;

Begin { Spielende }
  writeln(FNloc_dollar(30,20),'Anderes Bild, dasselbe Bild oder Ende ? ');
  writeln(FNloc_dollar(30,21),'[A], [D], [E]');
  pu:=pu+p+2*ah-MaxPunkte;           (* pu:=pu+(ah-(MaxPunkte-(p+ah))); *)
  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<>nul do;
    j:=0;
    while INKEY=nul do
    begin
      j:=j+1;
      if j=1000 then
      begin
        assign(f,Programm);
        execute(f);
      end;
    end;
    ProgrammBeenden;
  end else
  begin
    repeat
      a_dollar:=Upcase(INKEY);
    until a_dollar in ['A','D','E'];
    case a_dollar of
      'A' : d:=0;
      'D' : d:=1;
      'E' : ProgrammEnde;
    end;
    if a_dollar in ['A','D'] then DIM_merk;
  end;
End;

procedure BonusSetzen;
{ 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));
  Spielende;
End;

procedure Bewegung(h:FeldWert);
{ Cursorbewegung ausfuehren }
Begin
  write(FNloc_dollar(x,y),Besetzt);         (* Begangenes Feld ausgeben *)
    case h of
      rauf:   y:=pred(y);
      runter: y:=succ(y);
      links:  x:=pred(x);
      rechts: x:=succ(x);
    end;
  if merk[x,y]=frei then
  begin
    write(FNloc_dollar(x,y),SpielerGut);    (* Freundliche Schlange ausgeben *)
    merk[x,y]:=h;
    p:=succ(p);
    write(FNloc_dollar(30,10),p);
    if p+ah=MaxPunkte then BonusSetzen;
  end else
  begin
    case h of
      rauf:   y:=succ(y);
      runter: y:=pred(y);
      links:  x:=succ(x);
      rechts: x:=pred(x);
    end;
    write(FNloc_dollar(x,y),SpielerBoese);  (* Unfreundliche Schlange ausgeben *)
  end;
End;

procedure FeldZurueck;
{ Eingegebenes Feld zuruecknehmen }
var
  h            : FeldWert;
Begin
  h:=merk[x,y];
  if h<>Spieler then
  begin
    merk[x,y]:=frei;
    write(FNloc_dollar(x,y),' ');
    case h of
      rauf:   y:=succ(y);
      runter: y:=pred(y);
      links:  x:=succ(x);
      rechts: x:=pred(x);
    end;
    write(FNloc_dollar(x,y),SpielerGut);    (* Freundliche Schlange ausgeben *)
    p:=pred(p);
    write(FNloc_dollar(30,10),p);
  end;
End;

procedure Spielanleitung;
{ Spielanleitung ausgeben }
Begin
  write(cls_dollar,scr_ein);
  write(FNwin_dollar(5,5,24,80));
  writeln(SPACE(30),inv_ein,' S  C  H  L  A  N  G  E ',inv_aus);
  writeln;
  writeln;
  writeln;
  writeln('Spielidee: Familie Lipka');
  writeln(']berarbeitung f}r den Joyce: Martin Nicolaus');
  writeln;
  writeln;
  writeln(inv_ein,'Anleitung',inv_aus);
  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=nul do
  begin
    z:=succ(z);
    if z=60 then z:=1;
  end;
  z:=random(z);
End;

procedure Spielstand;
{ Statusfeld ausgeben }
Begin
  x:=2;
  y:=3;
  p:=0;
  write(FNloc_dollar(x,y),SpielerGut);     (* Freundliche Schlange ausgeben *)
  merk[x,y]:=Spieler;
  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 Spieldurchgang;
{ Spieldurchgang }
Begin
  repeat
    repeat until keypressed;
    read(kbd,as);
    as:=upcase(as);
    case as of
      CUP : Bewegung(rauf);     (* ^_ : Cursor nach oben *)
      CDW : Bewegung(runter);   (* ^^ : Cursor nach unten *)
      CLF : Bewegung(links);    (* ^A : Cursor nach links *)
      CRG : Bewegung(rechts);   (* ^F : Cursor nach rechts *)
      'E' : Spielende;
      ' ' : FeldZurueck;
    end;
  until as='E';
End;

procedure SpielfeldAufbau;
{ 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]<>belegt);
      write(FNloc_dollar(x,y),Sperre);  (* Sperre ausgeben *)
      merk[x,y]:=belegt;
      hinder[a,1]:=x;
      hinder[a,2]:=y;
    end;
  end else
  begin
    for a:=1 to ah do
    begin
      x:=hinder[a,1];
      y:=hinder[a,2];
      write(FNloc_dollar(x,y),Sperre);  (* Sperre ausgeben *)
      merk[x,y]:=belegt;
    end;
  end;
End;

BEGIN { M A I N }
  randomize;
  ZeichenNeu;
  Bildschirmkontrollen;
  VariableEinstellen;
  Spielanleitung;
  DIM_hinder;
  repeat

(* --- HAUPTSCHLEIFE --- *)

    DIM_merk;
    if d<>1 then SchwierigkeitsstufeLesen;
    RahmenAufbau;
    SpielfeldAufbau;
    Spielstand;
    Spieldurchgang;
  until as<>'E';
END.