(* 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 ;
(* $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 ;
