path: root/app/mpg/1987/src/RUCTEPLT.ELA

PACKET ructerm plot  DEFINES                  (* M. Staubermann, 23.11.86 *)
                     drawing area,
                     begin plot,
                     end plot, 
                     clear, 
                     pen,
                     move, 
                     draw, 
                     get cursor ,

                     testbit, where,
                     pages ,
                     circle, ellipse, fill, box, filled box,
                     get screen ,
                     put screen :
 
LET max x        = 279 ,                {Abmessungen : 280 x 192}
    max y        = 191 ,

    hor faktor   = 11.2 ,               {***** x pixel / x cm *****}
    vert faktor  = 11.29412 ,           {***** y pixel / y cm *****}


    delete = 0 ,                        {Farbcodes}
    std    = 1 ,
    black  = 5 ,
    white  = 6 ,
    yellow = 7 ;
(*  lilac  = 8 ,

    durchgehend      = 1 ,              {Linientypen}
    gepunktet        = 2 ,
    kurz gestrichelt = 3 ,
    lang gestrichelt = 4 ,
    strichpunkt      = 5 ,
    strichpunktpunkt = 6 ;*)

LET POS = STRUCT (INT x, y) ;

POS VAR pos ;
INT VAR i ;
 
clear ;

TEXT PROC text word (INT CONST i) :
 TEXT VAR t := "  " ;
 replace (t, 1, i) ;
 t
ENDPROC text word ;

PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) : 
   x cm := 25.0;    y cm := 17.0;   {***** Horizontale und vertikale *****}
                                    {***** GrӇe in Zentimetern.     *****}
   x pixel := maxx;  y pixel := maxy{***** Koordinaten des rechten   *****}
                                    {***** oberen Punktes.           *****}
END PROC drawing area;

PROC begin plot : 
 out (""27"$")
ENDPROC begin plot ;
 
PROC end plot : 
 out (""27"%")
ENDPROC end plot ;

PROC where (INT VAR x, y) :
 REP UNTIL incharety = "" PER ;
 out (""27";") ;
 x := (incharety (1000) + incharety (1000)) ISUB 1 ;
 y := (incharety (1000) + incharety (1000)) ISUB 1
ENDPROC where ;

BOOL PROC testbit :
 TEXT VAR t ;
 REP UNTIL incharety = "" PER ;
 out (""27"-") ;
 inchar (t) ;
 bit (code (t), 0)
ENDPROC testbit ;

PROC clear :
  pos   := POS:(0, 0) ;
  out (""27"O0"27"y") ; (* Clear und Cursor (0,0) *)
END PROC clear;

PROC pen (INT CONST background, foreground, thickness, linetype):
  INT CONST farbe := abs (foreground) ;
  set linetype ;
  set colour ;
  set thickness .

set colour :
 IF farbe = std OR farbe = yellow OR farbe = white
    THEN out (""27"O21")
    ELSE out (""27"O20")
 FI ;
 IF   farbe = delete OR  farbe = black  THEN out (""27"O41") (* AND *)
 ELIF foreground < 0 AND thickness >= 0 THEN out (""27"O42") (* XOR *)
 ELIF foreground < 0{AND thickness < 0} THEN out (""27"O43") (* COPY *)
                                        ELSE out (""27"O40") (* SET *)
 FI .

set thickness :
 IF thickness > 0 AND thickness < 16
    THEN out (""27"O1" + code (thickness + 32))
 FI .

set linetype:
  IF linetype < 7 AND linetype > 0
     THEN out (""27"O3" + code (line type + 32))
     ELSE out (""27"O6" + text word (line type) + ""27"O37") ;
  FI .

END PROC pen;

PROC move (INT CONST x, y) :
 TEXT VAR cmd := ""27"v" ;
 cmd CAT text (x) ;
 cmd CAT "," ;
 cmd CAT text (y) ;
 cmd CAT ";" ;
 out (cmd) ;
 pos := POS:(x,y)
END PROC move;
 
PROC draw (INT CONST x, y) :
 TEXT VAR cmd := ""27"w" ;
 cmd CAT text (x) ;
 cmd CAT "," ;
 cmd CAT text (y) ;
 cmd CAT ";" ;
 out (cmd) ;
 pos := POS : (x, y)

END PROC draw;
 
PROC draw (TEXT CONST record, REAL CONST angle, height, width):
 TEXT VAR cmd := ""27"&"27"N" ;
 cmd CAT code (72 + int (angle / 5.0) MOD 72) ;
 cmd CAT code (int (hor faktor * width + 0.5)) ;
 cmd CAT code (int (vert faktor * height + 0.5)) ;
 out (cmd) ;
 out (record) ;
 out (""27"N"0""0""0"") ;
 move (pos.x, pos.y) .
END PROC draw;

PROC draw (TEXT CONST record) :
  draw (record, 0.0, 0.0, 0.0)
END PROC draw;

PROC get cursor (TEXT VAR t, INT VAR x, y) :
  get cursor (t, x, y, -1, -1, -1, -1)
END PROC get cursor;

PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1) :
 get cursor (t, x, y, x0, y0, x1, y1, FALSE)
ENDPROC get cursor ;

PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1,
                 BOOL CONST only one key):
  BOOL VAR hop key := FALSE ;
  t := "" ;
  check;
  init cursor;
  REP set cursor;
      get step;
      set cursor;
      move cursor
  UNTIL only one key PER .

init cursor:
  POS CONST old pos :: pos ;
  REP UNTIL incharety = "" PER ;
  out (""27"5") ;
  TEXT VAR old params ;
  inchar (old params) ;
  out (""27"O5a") ; (* Strichdicke 1, XOR, Gelb *)
  INT VAR delta := 1 ;
  x := pos.x ;
  y := pos.y .

set cursor:
  IF x0 >= 0 AND y0 >= 0
  THEN move (x0, y0) ;
       draw (x, y)
  FI;
  IF x1 >= 0 AND y1 >= 0
  THEN move (x1, y1) ;
       draw (x, y)
  FI;
  out (""24"") . (* Fadenkreuz an/aus *)

get step:
  hop key := t = ""1"" ;
  t := incharety (1);
  IF t <> ""
  THEN delta INCR 1
  ELSE delta := 1 ;
       inchar (t)
  FI .

move cursor:
  IF hop key
     THEN hop mode
     ELSE single key
  FI ;
  check .

single key :
 SELECT code (t) OF
  CASE 1 : 
  CASE 2, 54 : x INCR delta (* right, '6' *)
  CASE 3, 56 : y INCR delta (* up,    '8' *) 
  CASE 8, 52 : x DECR delta (* left,  '4' *)
  CASE 10, 50 : y DECR delta(* down,  '2' *)
  CASE 55 : x DECR delta ; y INCR delta (* '7' *)
  CASE 57 : x INCR delta ; y INCR delta (* '9' *)
  CASE 49 : x DECR delta ; y DECR delta (* '1' *)
  CASE 51 : x INCR delta ; y DECR delta (* '3' *)
  OTHERWISE leave get cursor
 ENDSELECT .

hop mode :
 SELECT code (t) OF
  CASE 1 : t := "" ; x := 0 ; y := max y ;
  CASE 2, 54 : x := max x
  CASE 3, 56 : y := max y
  CASE 8, 52 : x := 0 
  CASE 10, 50 : y := 0
  CASE 55 : x := 0 ; y := max y 
  CASE 57 : x := max x ; y := max y
  CASE 49 : x := 0 ; y := 0
  CASE 51 : x := max x ; y := 0
  OTHERWISE t := ""1"" + t ; leave get cursor
 ENDSELECT .

leave get cursor:
  out (""27"O5" + old params) ;
  move (old pos.x, old pos.y);
  LEAVE get cursor  .

check :
  IF x < 0
  THEN x := 0 ; out (""7"")
  ELIF x > max x
  THEN x := max x ; out (""7"") FI ; 

  IF y < 0
  THEN y := 0 ; out (""7"")
  ELIF y > max y
  THEN y := max y ; out (""7"") FI .

END PROC get cursor;

PROC get screen (TEXT CONST name):
  IF exists (name)
     THEN get screen (old (name))
     ELSE get screen (new (name))
  FI ;
END PROC get screen;

PROC get screen (DATASPACE CONST to ds) :
  BOUND ROW 16 ROW 256 INT VAR screen := to ds ;
  INT VAR i, j ;
  REP UNTIL incharety = "" PER ;
  FOR i FROM 0 UPTO 16 REP
   out (""27"\"0""2""0"" + code (i * 2)) ;
   FOR j FROM 1 UPTO 256 REP
    screen (i)(j) := (incharety (1000) + incharety (1000)) ISUB 1
   PER ;
  PER
END PROC get screen;

PROC put screen (TEXT CONST name):
  IF exists (name)
  THEN put screen (old (name))
  ELSE errorstop ("Der Datenraum """ + name + """ existiert nicht") FI
END PROC put screen;

PROC put screen (DATASPACE CONST from ds) :
  BOUND ROW 4096 INT VAR screen :: from ds ;
  out (""27"/"0""32""0""0"") ;
  FOR i FROM 1 UPTO 4096 REP
   out (textword (screen (i)))
  PER 
END PROC put screen;

PROC pages (INT CONST bits) :
 out (""27"O7" + code (bits + 32))
ENDPROC pages ;

INT PROC pages :
 TEXT VAR t ;
 REP UNTIL incharety = "" PER ;
 out (""27"4") ;
 inchar (t) ;
 code (t) AND 7
ENDPROC pages ;

PROC circle (INT CONST radius) :
 IF radius > 0
    THEN out (""27"K" + text (radius) + ",0;") ;
 FI
ENDPROC circle ;

PROC ellipse (INT CONST x rad, y rad, REAL CONST from, to) :
 out (""27"s" + text (x rad) + "," + text (yrad) + "," +
                text (72 + int (from / 5.0) MOD 72) + "," +
                text (72 + int (to / 5.0) MOD 72) + ";")
ENDPROC ellipse ;

PROC box (INT CONST width, height) :
 out (""27"J" + text (width) + "," + text (height) + ";")
ENDPROC box ;

PROC filled box (INT CONST width, height) : (* Width max. 255 *)
 out (""27"N" + code (width) + code (height)) ; (* Groáes inverses Blank *)
 put (""0""27"&"27"O41"27"G0 "27"N"0""0""0"")   (* ausgeben *)
ENDPROC filled box ;

PROC fill (INT CONST pattern) :
 out (""27"|" + code (pattern + 32))
ENDPROC fill ;

END PACKET ructerm plot ;