|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 6912 (0x1b00)
Types: TextFile
Names: »MINIGR.PAS«
└─⟦6cf793dfc⟧ Bits:30003506 JET80 Grafik og fontprogrammering
└─⟦this⟧ »MINIGR.PAS«
TYPE str10 = String(.10.);
(*---------------------------------------------------------ENTER_GRAPHICS*)
PROCEDURE enter_graphics;
BEGIN
Write(#27,#81);
END;
(*----------------------------------------------------------EXIT_GRAPHICS*)
PROCEDURE exit_graphics;
BEGIN
Write(#0);
END;
(*---------------------------------------------------------------ABS_MOVE*)
PROCEDURE abs_move(x,y:Integer;pen:Boolean);
VAR t_pen : Byte ABSOLUTE pen;
BEGIN
Write(Chr(120-(t_pen SHL 3)+(x AND 768) SHR 7+(y AND 256) SHR 8),
Chr(x AND 255),Chr(y AND 255));
END;
(*-------------------------------------------------------------REL_MOVE_L*)
PROCEDURE rel_move_l(x,y:Integer;pen:Boolean);
VAR t_pen : Byte ABSOLUTE pen;
BEGIN
Write(Chr(136 - t_pen SHL 3 + Abs(x) AND $300 SHR 7 + Abs(y) AND $100 SHR 8
+ x AND $8000 SHR 10 + y AND $8000 SHR 11),
Chr(Abs(x) AND 255),Chr(Abs(y) AND 255));
END;
(*-------------------------------------------------------------REL_MOVE_S*)
PROCEDURE rel_move_s(x,y:Integer;pen:Boolean);
VAR t_pen : Byte ABSOLUTE pen;
BEGIN
Write(Chr(200 - t_pen SHL 3 + Abs(x) AND $30 SHR 3 + Abs(y) AND $10 SHR 4
+ x AND $8000 SHR 10 + y AND $8000 SHR 11),
Chr((Abs(x) AND 15) SHL 4 + (Abs(y) AND 15)));
END;
(*----------------------------------------------------------------CL_GRAF*)
PROCEDURE cl_graf;
BEGIN
Write(#27,#12);
END;
(*------------------------------------------------------------DUMPA_SKARM
Gemensamma procedurer : *)
PROCEDURE dumpinit_cpm;
BEGIN
INLINE
($F3/$21/*+23/$11/$4D/$FB/$01/$0E/$00/$ED/$B0/$21/*+26/$11/
$3B/$FC/$01/$0A/$00/$ED/$B0/$FB/$C9/$3A/$F4/$FC/$B7/$CA/$4D/$FB/
$AF/$32/$F4/$FC/$DB/$22/$C9/$F5/$3E/$FF/$32/$F4/$FC/$F1/$FB/$ED/$4D);
END;
PROCEDURE dumpreset_cpm;
BEGIN
INLINE
($F3/$21/*+23/$11/$4D/$FB/$01/$10/$00/$ED/$B0/$21/*+28/$11/
$3B/$FC/$01/$10/$00/$ED/$B0/$FB/$C9/$21/$F4/$FC/$AF/$B6/$28/
$FD/$F3/$35/$ED/$5B/$F7/$FC/$1A/$21/$0E/$ED/$73/$C6/$FC/$31/
$D8/$FC/$F5/$D5/$E5/$21/$F4/$FC/$7E/$FE/$15);
END;
PROCEDURE dumpinit_bridos;
BEGIN
INLINE
($F3/$21/*+23/$11/$7C/$FA/$01/$0E/$00/$ED/$B0/$21/*+26/$11/
$23/$FB/$01/$0A/$00/$ED/$B0/$FB/$C9/$3A/$6B/$FB/$B7/$CA/$7C/$FA/
$AF/$32/$6B/$FB/$DB/$22/$C9/$F5/$3E/$FF/$32/$6B/$FB/$F1/$FB/$ED/$4D);
END;
PROCEDURE dumpreset_bridos;
BEGIN
INLINE
($F3/$21/*+23/$11/$7C/$FA/$01/$10/$00/$ED/$B0/$21/*+28/$11/
$23/$FB/$01/$10/$00/$ED/$B0/$FB/$C9/$21/$6B/$FB/$AF/$B6/$28/
$FD/$F3/$35/$ED/$5B/$6E/$FB/$1A/$E6/$7F/$ED/$73/$58/$FB/$31/
$6A/$FB/$F5/$D5/$E5/$21/$6B/$FB/$7E/$FE/$15);
END;
PROCEDURE dump_init;
BEGIN
Write(#27,'R');
END; (*END dump_init*)
(*Førsta varianten dumpar, konverterar till CPA 80 format och skriver
till filen filnamn *)
PROCEDURE dumpa_skarm(x_max,y_max,x_min,y_min : Integer; filnamn : str10);
(* CPA80 har lf3 = 24, CP80 har lf3 = 22 *)
CONST gr1 = 27; (* ESC + K *)
gr2 = 75;
lf1 = 27; (* ESC + J + argument *)
lf2 = 74;
lf3 = 24;
VAR rad : Array(.0..7,1..80.) Of Byte;
rad_nr,i : Integer;
streng : String(.80.);
dumpfil : Text;
v_mask : Byte;
h_mask : Byte;
mask : Byte;
PROCEDURE dumpa_rad;
VAR i,j,y : Integer;
slask : Byte;
BEGIN
y:=400-(rad_nr)*8;
FOR i:=7 DOWNTO 0 DO
FOR j:=1 TO 80 DO
BEGIN
slask:=Bios(2);
IF ((y+i) <= y_max) AND ((y+i) >= y_min) THEN
IF (8*j >= x_min) AND (8*(j-1) <= x_max) THEN
BEGIN
IF j = (x_min DIV 8 + 1) THEN slask:= slask AND v_mask;
IF j = (x_max DIV 8 + 1) THEN slask:= slask AND h_mask;
rad(.i,j.):=slask;
END
ELSE
rad(.i,j.):=0
ELSE
rad(.i,j.):=0;
END;
END; (*END dumpa_rad*)
PROCEDURE add_streng_to_fil;
BEGIN
Write(dumpfil,streng);
streng:='';
END; (*END add_streng_to_fil*)
PROCEDURE konvertera_rad;
VAR prev_space : Boolean;
ant_space,ant_data,j : Integer;
PROCEDURE add_data;
VAR k,l : Integer;
byt : Byte;
PROCEDURE konvertera_tkn;
VAR m : Integer;
BEGIN
byt:=0;
FOR m:=0 TO 7 DO
byt:=byt+(1 SHL m)*(rad(.m,k.) AND (1 SHL l)) DIV (1 SHL l);
END; (*END konvertera_tkn*)
BEGIN
IF Length(streng)>75 THEN add_streng_to_fil;
streng:=streng+Chr(gr1)+Chr(gr2)+Chr((8*ant_data) MOD 256)+Chr((8*ant_data) DIV 256);
FOR k:=(j-ant_data) TO (j-1) DO
FOR l:=0 TO 7 DO
BEGIN
konvertera_tkn;
streng:=streng+Chr(byt);
IF Length(streng)=80 THEN add_streng_to_fil;
END;
ant_data:=0;
END; (*END add_data*)
PROCEDURE add_space;
VAR k : Integer;
BEGIN
FOR k:=1 TO ant_space DO
BEGIN
streng:=streng+' ';
IF Length(streng)=80 THEN add_streng_to_fil;
END;
ant_space:=0;
END; (*END add_space*)
BEGIN
prev_space:=False;
ant_space:=0;
ant_data:=0;
FOR j:=1 TO 80 DO
BEGIN
IF (rad(.0,j.)+rad(.1,j.)+rad(.2,j.)+rad(.3,j.)+
rad(.4,j.)+rad(.5,j.)+rad(.6,j.)+rad(.7,j.)) = 0 THEN
BEGIN
IF (NOT prev_space) AND (ant_data <> 0) THEN add_data;
prev_space:=True;
ant_space:=ant_space+1;
END
ELSE
BEGIN
IF prev_space THEN add_space;
prev_space:=False;
ant_data:=ant_data+1;
END;
END;
j:=j+1;
IF NOT prev_space THEN add_data;
IF Length(streng)>75 THEN add_streng_to_fil;
streng:=streng+Chr(13)+Chr(lf1)+Chr(lf2)+Chr(lf3);
END; (*END konvertera_rad*)
BEGIN (*skarm_dump, huvudrutin*)
IF Bdos(12)=49 THEN
dumpinit_cpm
ELSE
dumpinit_bridos;
mask:=255;
v_mask:=mask Shl (x_min MOD 8);
h_mask:=mask Shr (7 - x_max MOD 8);
dump_init;
Assign(dumpfil,filnamn+'.dmp');
Rewrite(dumpfil);
FOR i:=1 TO 2 DO Write(dumpfil,Chr(10));
streng:='';
FOR rad_nr:=1 TO 50 DO
BEGIN
dumpa_rad;
konvertera_rad;
END;
add_streng_to_fil;
Write(dumpfil,Chr(10),#13);
Close(dumpfil);
IF Bdos(12)=49 THEN
dumpreset_cpm
ELSE
dumpreset_bridos;
END;
«eof»