const false=0; true=1;
var a: integer ;

(* Hilfsfunktion zum Auslesen von 16 Bit *)
function deek(adr);
 var r: integer ;
 begin
  r := memc [adr + 1] shl 8;
  r := r + memc [adr];
  deek := r;
 end ;

(* Hilfsfunktion zum Schreiben von 16 Bit *)
procedure doke(adr, val);
 var h,l: char ;
 begin
  h := val shr 8;
  l := val and $ff;
  memc [adr] := l;
  memc [adr + 1] := h;
 end ;

(* $ea24: sync_color_ptr *)
(* Setzt den Zeiger im Farb-RAM passend zu $d1/$d2 *)
procedure synccolorptr;
 var h: char ;
 begin
  memc [$f3] := memc [$d1];
  h := memc [$d2];
  h := (h and $03) or $d8;
  memc [$f4] := h;
 end ;

(* $e9e0: synchronize_color_transfer *)
(* Aktualisiert $f3/$f4 und setzt $ae/$af fuer *)
(* das Farb-RAM ($ac muss gesetzt sein) *)
procedure synccolortransfer;
 var h: char ;
 begin
  synccolorptr;
  memc [$ae] := memc [$ac];
  h := memc [$ad];
  h := (h and $03) or $d8;
  memc [$af] := h;
 end ;

(* $ea13: print_to_screeen *)
(* Gibt den in c enthaltenen Bildschirmcode *)
(* mit der in x gesetzten Farbe aus *)
procedure printtoscreen(c, x);
 var a: integer ; y: char ;
 begin
  (* Cursor-Blinken: $cd *)
  synccolorptr;
  y := memc [$d3];
  a := deek($d1);
  memc [a + y] := c;
  a := deek($f3);
  memc [a + y] := x;
 end ;

(* $e9f0: set_start_of_line *)
(* Setzt $d1/$d2 auf die in x angegebene Bildschirmzeile *)
procedure setstartofline(x);
 var l,h: char ;
 begin
  l := memc [$ecf0 + x];
  memc [$d1] := l;
  h := memc [$d9 + x];
  h := h and $03;
  h := h or memc [$0288];
  memc [$d2] := h;
 end ;

(* $e4da: reset_char_color *)
(* Setzt die Farbe fuer das Zeichen, auf das $f3/$f4 *)
(* plus Y-Reg zeigt auf die aktuelle Farbe *)
procedure resetcharcolor(y);
 var adr: integer ; c: char ;
 begin
  adr := deek($f3) + y;
  c := memc[$0286];
  memc[adr + y] := c;
 end ;

(* $e8cb: set_color_code *)
(* Farbcode aus in a enthaltenen ASCII-Wert *)
(* ermitteln *)
procedure setcolorcode(a);
 var x,f: char ;
 begin
  x := 0;
  f := false;
  repeat
   if a = memc [$e8da + x] then
    begin
     memc [$0286] := x;
     f := true;
    end ;
   x := x + 1;
  until f or (x > 15);
 end ;

(* $e9ff: clear_screen_line *)
(* Die in x angegebene Bildschirmzeile mit *)
(* Lerrzeichen fuellen *)
procedure clearscreenline(x);
 var adr: integer ; y: char ;
 begin
  setstartofline(x);
  synccolorptr;
  adr := deek($d1);
  for y := 0 to 39 do
   begin
    resetcharcolor(y);
    memc [adr + y] := 32;
   end ;
 end ;

(* $e56c: set_screen_pointers *)
(* Bildschirmzeiger anhand der aktuellen Zeile setzen *)
procedure setscreenptrs;
 var x: char ;
 begin
  x := memc [$d6];
  setstartofline(x);
  memc [$d5] := 39;
  synccolorptr;
 end ;

(* $e566: home_cursor *)
(* Cursor an den Bildschirmanfang setzen *)
procedure homecursor;
 begin
  memc [$d3] := 0;
  memc [$d6] := 0;
  setscreenptrs;
 end ;

(* $e544: clear_screen *)
(* Bildschirm loeschen *)
procedure clearscreen;
 var l: integer ; h,x: char ;
 begin
  h := memc [$0288] or $80;
  l := 0;
  for x := 0 to 25 do
   begin
    memc [$d9 + x] := h;
    l := l + 40;
    if l > 255 then
     begin
      h := h + 1;
      l := l and $ff;
     end ;
   end ;
   memc [$d9 + 26] := $ff;
   for x := 0 to 24 do
    clearscreenline(x);
   homecursor;
 end ;

(* $e9c8: move_a_screen_line: *)
(* Kopiert eine Bildschirmzeile, auf die $ac/$ad *)
(* zeigt, in die Bildschirmzeile, auf die $d1/$d2 *)
(* zeigt ($ac muss gesetzt sein und das high byte *)
(* dazu in hbyte stehen) *)
procedure movescreenline(hbyte);
 var f,t: integer ; h,y: char ;
 begin
  h := (hbyte and $03);
  h := h or memc [$0288];
  memc [$ad] := h;
  synccolortransfer;
  for y := 0 to 39 do
   begin
    f := deek($ac);
    t := deek($d1);
    memc [t + y] := memc [f + y];
    f := deek($ae);
    t := deek($f3);
    memc [t + y] := memc [f + y];
   end ;
 end ;

(* $e8ea: scroll_screen *)
(* Scrollt den Bildschirm *)
procedure scrollscreen;
 var ac,ad,ae,af,l,h,x: char ;
 begin
  ac := memc [$ac];
  ad := memc [$ad];
  ae := memc [$ae];
  af := memc [$af];
  memc [$d6] := 23;
  (* Zeiger auf Cursor bei Eingabe (Zeile): $c9 *)
  for x := 0 to 23 do
   begin
    setstartofline(x);
    l := memc [$ecf1 + x];
    memc [$ac] := l;
    h := memc [$da + x];
    movescreenline(h);
   end ;
  clearscreenline(24);
  (* CTRL-Taste zur Verzoegerung abfragen *)
  memc [$d6] := 24;
  memc [$ac] := ac;
  memc [$ad] := ad;
  memc [$ae] := ae;
  memc [$af] := af;
 end ;

(* $e87c: go_to_next_line *)
(* Cursor um eine Zeile nach unten bewegen *)
procedure gotonextline;
 var y: char ;
 begin
  y := memc [$d6];
  if y >= 24 then
   scrollscreen
  else
   begin
    memc [$d6] := y + 1;
    setscreenptrs;
   end ;
 end ;

(* $e891: perform_return *)
(* Zeilenumbruch durchfuehren *)
procedure performreturn;
 begin
  memc [$d3] := 0;
  memc [$c7] := 0;
  (* Steuerzeichenmodus: $d4 *)
  (* Anzahl der ausstehenden Inserts: $d8 *)
  gotonextline;
 end ;

(* $e8a1: check_line_decrement *)
procedure checklinedecr;
 begin
  if memc [$d3] = 0 then
   memc [$d6] := memc [$d6] - 1;
 end ;

(* $e8b3: check_line_increment *)
(* Prueft, ob der Zeilenzaehler erhoeht werden muss *)
procedure checklineincr;
 var y: char ;
 begin
  if memc [$d3] = 39 then
   begin
    y := memc [$d6];
    if y < 25 then
     memc [$d6] := y + 1;
   end ;
 end ;

(* $e6f7: retreat_cursor2 *)
(* Wechsel in neue Zeile *)
procedure retreatcursor2;
 begin
  memc [$d6] := memc [$d6] - 1;
  gotonextline;
  memc [$d3] := 0;
 end ;

(* $e6b6: advance_cursor *)
(* Cursor ein Zeichen weiter bewegen *)
procedure advancecursor;
 var x: char ;
 begin
  checklineincr;
  x := memc [$d3];
  if x < memc [$d5] then
   memc [$d3] := x + 1
  else
   retreatcursor2;
 end ;

(* $e6a8: setup_screen_print *)
procedure setupscreenprint2;
 begin
  (* outstanding inserts: $d8 *)
  (* Direktmodus: $d4 *)
 end ;

(* $e691: setup_screen_print *)
(* Ausgabe dec in c angegebenen Bildschirmcodes *)
(* vorbereiten und durchfuehren *)
procedure setupscreenprint(c);
 var x: char ;
 begin
  (* a := a or $40 siehe shiftedchars/putchar *)
  if memc [$c7] > 0 then
   c := c or $80;
  x := memc [$0286];
  printtoscreen(c, x);
  advancecursor;
  setupscreenprint2;
 end ;

(* $e701: back_into_prev_line *)
(* Cursor in die vorangegangene Zeile bewegen *)
(* (Rueckgabewert signalisiert, ob ein Wechsel in *)
(* vorangegange Zeile moeglich war.) *)
function backintoprevline;
 begin
  if memc [$d6] = 0 then
   begin
    memc [$d3] := 0;
    setupscreenprint2;
    backintoprevline := false;
   end
  else
   begin
    memc [$d6] := memc [$d6] - 1;
    setscreenptrs;
    memc [$d3] := memc [$d5];
    backintoprevline := true;
   end ;
 end ;

(* $e72a: unshifted_chars *)
procedure unshiftedchars(ch, pos);
 (* $e731 *)
 procedure putchar(ch);
  var c: char ;
  begin
   if ch < 96 then
    (* ASCII 32-63 -> unveraendert *)
    (* ASCII 64-95 -> Bildschirmcode 0-31 *)
    c := ch and $3f
   else
    (* ASCII 96-127 -> Bildschirmcode 64-95 *)
    c := ch and $df;
   (* quotetest *)
   setupscreenprint(c);
  end ;
 (* $e773 *)
 procedure addspace(y);
  var a: integer ; v : char ;
  begin
   a := deek($d1);
   memc [a + y] := 32;
   v := memc [$0286];
   a := deek($f3);
   memc [a + y] := v;
   setupscreenprint2;
  end ;
 (* $e74c *)
 procedure delete(pos);
  var a: integer ; p, v: char ;
  begin
   if pos > 0 then
    begin
     checklinedecr;
     memc [$d3] := pos - 1;
     synccolorptr;
     p := pos - 1;
     repeat
      a := deek($d1);
      v := memc [a + p + 1];
      memc [a + p] := v;
      a := deek($f3);
      v := memc [a + p + 1];
      memc [a + p] := v;
      p := p + 1;
     until p = memc [$d5];
     addspace(p);
    end
   else
    if backintoprevline then
     begin
      p := memc [$d5];
      addspace(p);
     end
  end ;
  (* $e792 *)
  (* identisch mit advancecursor/retreatcursor2 *)
  procedure cursorright;
   var x: char ;
   begin
    checklineincr;
    x := memc [$d3];
    if x < memc [$d5] then
     memc [$d3] := x + 1
    else
     begin
      memc [$d6] := memc [$d6] - 1;
      gotonextline;
      memc [$d3] := 0;
     end ;
    setupscreenprint2;
   end ;
 (* $e72a *)
 begin
  if ch = 13 then
   performreturn
  else if ch >= 32 then
   putchar(ch)
  else
   (* $d8 = 0 ? num of outstanding inserts *)
   case ch of
    20: delete(pos);
    (* $d4: Direktmodus *)
    18: memc [$c7] := 18;
    19: homecursor;
    29: cursorright;
    17: begin
         gotonextline;
         setupscreenprint2;
        end
    else
     setcolorcode(ch)
     (* graphic_text_control *)
   end ;
 end ;

(* $e7d4: shifted_chars *)
procedure shiftedchars(ch, pos);
 (* $e7dc *)
 procedure putchar(ch);
  var c: char ;
  begin
   (* ASCII 160-191 -> Bildschirmcode 96-127 *)
   c := ch or $40;
   setupscreenprint(c);
  end ;
 (* $e7ee *)
 procedure insert;
  var a: integer ; p, v: char ;
  begin
   p := memc [$d5];
   synccolorptr;
   repeat
    a := deek($d1);
    v := memc [a + p - 1];
    memc [a + p] := v;
    a := deek($f3);
    v := memc [a + p - 1];
    memc [a + p] := v;
    p := p - 1;
   until p = memc [$d3];
   (* addspace *)
   a := deek($d1);
   memc [a + p] := 32;
   v := memc [$0286];
   a := deek($f3);
   memc [a + p] := v;
   (* $d8: outstanding inserts *)
   setupscreenprint2;
  end ;
 (* $e832 *)
 procedure cursorup;
  var y: char ;
  begin
   y := memc [$d6];
   if y > 0 then
    begin
     memc [$d6] := y - 1;
     setscreenptrs;
    end ;
   setupscreenprint2;
  end ;
 (* $e854 *)
 procedure cursorleft(pos);
  var f: char ;
  begin
   if pos = 0 then
    f := backintoprevline
   else
    begin
     checklinedecr;
     memc [$d3] := pos - 1;
    end ;
   setupscreenprint2;
  end ;
(* $e7d4 *)
 begin
  ch := ch and $7f;
  if ch = 13 then
   performreturn
  else if ch >= 32 then
   putchar(ch)
  else
   (* $d4: Direktmodus *)
   case ch of
    20: insert;
    (* $d8: outstanding inserts *)
    17: cusorup;
    18: memc [$c7] := 0;
    29: cursorleft(pos);
    19: begin
         clearscreen;
         setupscreenprint2;
        end
    else
     setcolorcode(ch or $80)
     (* set_graphics_text_mode *)
   end ;
 end ;

(* $e716: output_to_screen *)
procedure outputtoscreen(ch);
 var p: char ;
 begin
  p := memc [$d3];
  if ch < 128 then
   unshiftedchars(ch, p)
  else
   shiftedchars(ch, p);
 end ;

(* main *)
begin
 clearscreen;
end .