DataMuseum.dk

top - metrics - download

    Length: 15104 (0x3b00)
    Types: TextFile
    Names: »JET80G.PAS«

└─⟦6cf793dfc⟧ Bits:30003506 JET80 Grafik og fontprogrammering
    └─⟦this⟧ »JET80G.PAS« 

TextFile

(*       Latest update 851028                                          *)

(*---------------------------------------------------------Declarations*)

TYPE     koord               = RECORD
                                 x : Integer;
                                 y : Integer;
                               END;
         str10               = String(.10.);
         str16               = String(.16.);

VAR      cirkeldata          : Array(.0..9.) Of koord;

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

(*-------------------------------------------------------------------PLOT*)
PROCEDURE plot(x,y:Integer);
BEGIN
  abs_move(x,y,False);
  Write(#192,#0);
END;

(*------------------------------------------------------------------LINJE*)
PROCEDURE linje(x1,y1,x2,y2:Integer);
BEGIN
  abs_move(x1,y1,False);
  abs_move(x2,y2,True);
END;

(*--------------------------------------------------------------REKTANGEL*)
PROCEDURE rektangel(x1,y1,x2,y2:Integer);
BEGIN
  abs_move(x1,y1,False);
  abs_move(x2,y1,True);
  abs_move(x2,y2,True);
  abs_move(x1,y2,True);
  abs_move(x1,y1,True);
END;

(*------------------------------------------------------------CIRKEL_INIT*)
PROCEDURE cirkel_init;
VAR i,x1,x2,y1,y2 : Integer;
BEGIN
  x1:=1000;
  y1:=0;
  FOR i:= 1 TO 9 DO
  BEGIN
    x2:=Round(1000*Cos(pi*i/36));
    y2:=Round(1000*Sin(pi*i/36));
    cirkeldata(.i.).x:=x2-x1;
    cirkeldata(.i.).y:=y2-y1;
    x1:=x2;
    y1:=y2;
  END;
END;

(*-----------------------------------------------------------------CIRKEL*)
PROCEDURE cirkel(x1,y1,x2,y2:Integer);
VAR tcirkel         : Array(.0..10.)Of koord;
    i,dx,dy,xc,yc,r : Integer;
    k1,k2           : Real;

PROCEDURE sek45(xk,yk,xs,ys:Integer;koord:Boolean);
VAR i : Integer;
BEGIN
  abs_move(xk,yk,False);
  IF koord THEN
    FOR i:=1 TO 9 DO
      rel_move_s(xs*tcirkel(.i.).x,ys*tcirkel(.i.).y,True)
  ELSE
    FOR i:=1 TO 9 DO
      rel_move_s(xs*tcirkel(.i.).y,ys*tcirkel(.i.).x,True);
END;

BEGIN
  dx:=0;
  dy:=0;
  xc:=Round((x2+x1)/2);
  yc:=Round((y2+y1)/2);
  k1:=(x2-x1);
  k2:=(y2-y1);
  r:=Round(Sqrt(Sqr(k1)+Sqr(k2))/2);
  FOR i:=1 TO 9 DO
  BEGIN
    tcirkel(.i.).x:=-(Abs(cirkeldata(.i.).x*r+dx) DIV 1000);
    dx:=-(Abs(cirkeldata(.i.).x*r+dx) MOD 1000);
    tcirkel(.i.).y:=(cirkeldata(.i.).y*r+dy) DIV 1000;
    dy:=(cirkeldata(.i.).y*r+dy) MOD 1000;
  END;
  sek45(xc+r,yc,1,-1,True);                        (*    0 ,  -45 *)
  sek45(xc+r,yc,1,1,True);                         (*    0 ,   45 *)
  sek45(xc,yc+r,-1,1,False);                       (*  135 ,   90 *)
  sek45(xc,yc+r,1,1,False);                        (*   90 ,   45 *)
  sek45(xc-r,yc,-1,-1,True);                       (* -135 ,  180 *)
  sek45(xc-r,yc,-1,1,True);                        (*  180 ,  135 *)
  sek45(xc,yc-r,1,-1,False);                       (*  -90 ,  -45 *)
  sek45(xc,yc-r,-1,-1,False);                      (* -135 ,  -90 *)
END;

(*----------------------------------------------------------CIRKEL_BÅGE*)
PROCEDURE cirkel_bage(x1,y1,x2,y2,x3,y3:Integer);
CONST    n                   = 20;
VAR      i                   : Integer;
         dx,dy,radie,uv,mv,
         a,x,y               : Real;

FUNCTION at(x,y:Real):Real;
VAR      v                   : Real;
BEGIN
  IF x=0 THEN
    v:=pi/2
  ELSE
    v:=ArcTan(Abs(y/x));
  IF x<0 THEN v:=pi-v;
  IF y<0 THEN v:=-v;
  at:=v;
END;

BEGIN
  dx:=x2-x1;
  dy:=y2-y1;
  radie:=Sqrt(Sqr(dx)+Sqr(dy));
  uv:=at(dx,dy);
  mv:=at((x3-x1),(y3-y1))-uv;
  IF mv < 0 THEN mv:=2*pi+mv;
  abs_move(Round(x1+radie*cos(uv)),Round(y1+radie*sin(uv)),False);
  a:=mv/n;
  FOR i:=1 TO n DO
  BEGIN
    uv:=uv+a;
    x:=x1+radie*cos(uv);
    y:=y1+radie*sin(uv);
    abs_move(Round(x),Round(y),True)
  END;
END;

(*-------------------------------------------------------SELECT_DRAW_MODE*)
PROCEDURE select_draw_mode(val:Integer);
BEGIN
  Write(Chr(32+val));
END;

(*-------------------------------------------------------SET_LINE_PATTERN*)
PROCEDURE set_line_pattern(monster:str16);
VAR  dec_pat_h,dec_pat_l,i,term : Integer;
BEGIN
  dec_pat_h:=0;
  dec_pat_l:=0;
  term:=128;
  FOR i:=1 TO 8 DO
  BEGIN
    IF monster(.i.)='1' THEN
      dec_pat_h:=dec_pat_h+term;
    term := term DIV 2;
  END;
  term:=128;
  FOR i:=9 TO 16 DO
  BEGIN
    IF monster(.i.)='1' THEN
      dec_pat_l:=dec_pat_l+term;
    term := term DIV 2;
  END;
  Write(#37,Chr(dec_pat_h),Chr(dec_pat_l));
END;

(*----------------------------------------------------------SELECT_SCREEN*)
PROCEDURE select_screen(val:Integer);
BEGIN
  Write(#27,#91,Chr(48+val),Chr(125));
END;

(*----------------------------------------------------------------CL_GRAF*)
PROCEDURE cl_graf;
BEGIN
  Write(#27,#12);
END;

(*------------------------------------------------------------------CROSS*)
PROCEDURE cross(VAR x,y:Integer; VAR tkn:Char;
                    min_x,min_y,max_x,max_y,d_min,d_max:Integer);
CONST tang_rep_tid   = 40;
VAR  x1,x2,y1,y2,d,i : Integer;
     exit            : Boolean;

PROCEDURE set_reset_haircross(x,y:Integer);
BEGIN
  abs_move(x,y,False);
  rel_move_s(5,0,True);
  rel_move_s(-5,0,False);
  rel_move_s(0,5,True);
  rel_move_s(0,-5,False);
  rel_move_s(-5,0,True);
  rel_move_s(5,0,False);
  rel_move_s(0,-5,True);
END;

BEGIN
  Write(#33);
  x1:=x;
  y1:=y;
  x2:=x;
  y2:=y;
  d:=d_min;
  exit:=False;
  set_reset_haircross(x1,y1);
  REPEAT
    i:=0;
    REPEAT
      i:=(i+1) MOD 1000 + 500 * ((i+1) DIV 1000);
    UNTIL Keypressed;
    IF i > tang_rep_tid THEN
      d:=d_min
    ELSE
      IF d<d_max THEN
        d:=d+1;
    READ(KBD,tkn);
    IF Ord(tkn)=27 THEN
    BEGIN
      READ(KBD,tkn);
      IF Ord(tkn)=91 THEN
        READ(KBD,tkn);
    END;
    CASE tkn OF
         '8'   : BEGIN
                   y2:=(y1+d);
                   IF y2>max_y THEN
                     y2:=min_y;
                 END;
         '2'   : BEGIN
                   y2:=(y1-d);
                   IF y2<min_y THEN
                     y2:=max_y;
                 END;
         '4'   : BEGIN
                   x2:=(x1-d);
                   IF x2<min_x THEN
                     x2:=max_x;
                 END;
         '6'   : BEGIN
                   x2:=(x1+d);
                   IF x2>max_x THEN
                     x2:=min_x;
                 END;
         '9'   : BEGIN
                   y2:=(y1+d);
                   IF y2>max_y THEN
                     y2:=min_y;
                   x2:=(x1+d);
                   IF x2>max_x THEN
                     x2:=min_x;
                 END;
         '3'   : BEGIN
                   y2:=(y1-d);
                   IF y2<min_y THEN
                     y2:=max_y;
                   x2:=(x1+d);
                   IF x2>max_x THEN
                     x2:=min_x;
                 END;
         '1'   : BEGIN
                   y2:=(y1-d);
                   IF y2<min_y THEN
                     y2:=max_y;
                   x2:=(x1-d);
                   IF x2<min_x THEN
                     x2:=max_x;
                 END;
         '7'   : BEGIN
                   y2:=(y1+d);
                   IF y2>max_y THEN
                     y2:=min_y;
                   x2:=(x1-d);
                   IF x2<min_x THEN
                     x2:=max_x;
                 END
         ELSE
                 exit:=True
    END;
    set_reset_haircross(x1,y1);
    set_reset_haircross(x2,y2);
    x1:=x2;
    y1:=y2;
  UNTIL exit;
  set_reset_haircross(x2,y2);
  x:=x1;
  y:=y1;
  Write(#32);
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 15 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(12));
  Close(dumpfil);
  IF Bdos(12)=49 THEN
    dumpreset_cpm
  ELSE
    dumpreset_bridos;
END;

(*Andra varianten dumpar på snabbast møjliga sætt till en fil utan att
  bearbeta data från terminalen.*)

PROCEDURE dump(filnamn:str10);

VAR      i,j                 : Integer;
         tkn                 : Byte;
         dumpfil             : FILE;
         cpm_record          : Array(.0..127.) OF Byte;

BEGIN
  dumpinit_cpm;
  dump_init;
  Assign(dumpfil,filnamn+'.DMP');
  Rewrite(dumpfil);
  FOR i:=1 TO 250 DO
  BEGIN
    FOR j:=0 TO 127 DO cpm_record(.j.):=BIOS(2);
    BlockWrite(dumpfil,cpm_record,1);
  END;
  Close(dumpfil);
  dumpreset_cpm;
END;
(*----------------------------------------------------------------------*)

«eof»