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

PACKET basis108 plot DEFINES                  (* M. Staubermann, 22.06.86 *)
                     drawing area,            (* 1.8.0: 09.11.86   *)
                     begin plot,              (* SHard 8: 07.02.87 *)
                     end plot, 
                     clear, 
                     pen,
                     move, 
                     draw, 
                     get cursor ,

                     testbit, fill, trans,
                     full screen,(* FALSE:Mit Text in den letzten 4 Zeilen *)
                     visible page, work page,
                     ctrl word,  (* Zugriff auf control word *)
                     zeichensatz ,
                     get screen ,
                     put screen :
 
LET max x        = 279 ,
    max y        = 191 ,

    hor faktor   = 11.2 ,     { xpixel/cm }
    vert faktor  = 11.29412 , { ypixel/cm }


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

    durchgehend      = 1 ,
    gepunktet        = 2 ,
    kurz gestrichelt = 3 ,
    lang gestrichelt = 4 ,
    strichpunkt      = 5 ,

    onoff bit        = 0 , 
    visible page bit = 1 ,
    work page bit    = 2 ,
    and bit          = 3 ,
    xor bit          = 4 , 
    size bit         = 5 ,
    pattern bit      = 6 ,
    color bit        = 7 ;


LET PEN         = STRUCT (INT back, fore, thick, line) ,
    POS         = STRUCT (INT x, y) ,
    ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height) ,
    BLOCK       = ROW 256 INT ;

INT CONST ctrl clr  :: -3 ,
          ctrl fill :: -4 ,
          ctrl move :: -5 ,
          ctrl draw :: -6 ,
          ctrl test :: -7 ,
          ctrl ctrl :: -8 ,
          ctrl trans:: -9 ;

ZEICHENSATZ VAR zeichen; (* 4KB *)

PEN VAR stift ;
POS VAR pos ;
INT VAR r, i, n, work page nr, visible page nr,
        line pattern, control word := 0 ;
 
visible page (0) ;
work page (0) ;

clear ;
zeichensatz ("ZEICHEN 6*10") ;

PROC zeichensatz (TEXT CONST name) :

  IF exists (name)
     THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name) ;
          zeichen := new zeichen
     ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht")
  FI

END PROC zeichensatz;


PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) : 

   x cm := 25.0 ;
   y cm := 17.0 ;
   x pixel := max x ;
   y pixel := max y

END PROC drawing area;


PROC begin plot : 
 setbit (control word, onoff bit) ;
 graphic control
ENDPROC begin plot ;
 

PROC end plot : 
 resetbit (control word, onoff bit) ;
 graphic control
ENDPROC end plot ;


PROC ctrl word (INT CONST word) :
 control word := word ;
 graphic control
ENDPROC ctrl word ;


INT PROC ctrl word :
 control word
ENDPROC ctrl word ;


PROC full screen (BOOL CONST true) :

 IF true
    THEN resetbit (control word, size bit)
    ELSE setbit (control word, size bit)
 FI ;
 graphic control

ENDPROC full screen ;


PROC fill (INT CONST muster) :
(********************************************************************)
(*                                                                  *)
(*    FILL (muster nummer)                                          *)
(*         Füllt eine beliebig (sichtbar) umrandete Fläche mit      *)
(*         dem angegebenen Muster.                                  *)
(*                                                                  *)
(*    Das Muster ist eine 8 x 8 Matrix, die sich auf allen pos MOD 8*)
(*    -Adressen wiederholt.                                         *)
(*    Im NAND-Modus wird mit dem inversen Muster gefüllt, die Fläche*)
(*    muß dann aber mit unsichtbaren Pixels begrenzt werden.        *)
(*                                                                  *)
(*    Folgende Muster sind möglich:                                 *)
(*    0 = 'solid' (alles gefüllt)                                   *)
(*    1 = 'lrs2'  (jeder zweite Punkt, Zeilenweise versetzt)        *)
(*    2 = 'row4'  (jede 4. Zeile wird gefüllt)                      *)
(*    3 = 'row2'  (jede 2. Zeile wird gefüllt)                      *)
(*    4 = 'col4'  (jede 4. Spalte wird gefüllt)                     *)
(*    5 = 'col2'  (jede 2. Spalte wird gefüllt)                     *)
(*    6 = 'grid4' (jede 4. Spalte/Zeile wird gefüllt)               *)
(*    7 = 'grid2' (jede 2. Spalte/Zeile wird gefüllt)               *)
(*    8 = 'ls4'   (Schraffur links unten --> rechts oben, jede 4.)  *)
(*    9 = 'rs4'   (Schraffur rechts unten --> links oben, jede 4.)  *)
(*   10 = 'lrs4'  (Schräges Gitter wie 8 und 9 zusammen)            *)
(*   11 = 'point2'(In jeder 2. Zeile jeder 2. Punkt)                *)
(*   12 = 'wall4' (Mauer, ein Ziegelstein 4 Pixel hoch)             *)
(*   13 = 'basket'(Korb/Netz)                                       *)
(*   14 = 'wave4' (Wellenlinie 4 Pixel hoch)                        *)
(*   15 = 'wave8' (Wellenlinie 8 Pixel hoch)                        *)
(*                                                                  *)
(*   Falls die zu füllende Fläche zu komplex wird, kann es vorkommen,*)
(*   daß der interne Stack überläuft. In diesem Fall wird nicht die *)
(*   gesamte Fläche gefüllt wird.                                   *)
(*                                                                  *)
(********************************************************************)
 control (ctrl fill, muster, 0, r)

ENDPROC fill ;


PROC trans (INT CONST from, to) :
(********************************************************************)
(*                                                                  *)
(*    TRANS (from page, to page)                                    *)
(*          Kopiert den Inhalt der Graphikseite 'from page' in die  *)
(*          Seite 'to page'. Folgende Seitennummern sind möglich:   *)
(*                                                                  *)
(*    0 : Seite 0 kann mit 'visible page (0)' angezeigt werden      *)
(*    1 : Seite 1 kann mit 'visible page (1)' angezeigt werden      *)
(*    2 : Seite 2 kann nicht sichtbar werden (Hilfsspeicher-Seite)  *)
(*    3 : Ähnlich Seite 2, wird aber bei 'FILL' noch als Arbeits-   *)
(*        seite benutzt (wird dann überschrieben!)                  *)
(*                                                                  *)
(********************************************************************)

 control (ctrl trans, from, to, r)
ENDPROC trans ;


BOOL PROC testbit (INT CONST x, y) :
(********************************************************************)
(*                                                                  *)
(*    TEST (x pos, y pos) --> Byte                                  *)
(*          Testet den Status eines bestimmten Pixels.              *)
(*                                                                  *)
(*    Die Pixelposition wird mit xpos/ypos beschrieben.             *)
(*    Als Result wird zurückgeliefert:                              *)
(*        255, falls xpos/ypos außerhalb des sichtbaren Fensters    *)
(*        liegt.                                                    *)
(*        Bit 0 = 1: Pixel sichtbar                                 *)
(*        Bit 0 = 0: Pixel unsichtbar                               *)
(*        Bit 7 = 1: Pixelfarbe ist hell (gelb)                     *)
(*        Bit 7 = 0: Pixelfarbe ist dunkel (violett)                *)
(*                                                                  *)
(********************************************************************)

 control (ctrl test, x, y, r) ;
 bit (r, 0)
ENDPROC testbit ;


PROC clear :
(********************************************************************)
(*                                                                  *)
(*    CLR (seite, muster)                                           *)
(*        Füllt die angegebene Seite mit dem angegebenen Muster     *)
(*                                                                  *)
(*    Bit 7 des Musters bestimmt die Farbe (0 = dunkel, 1 = hell)   *)
(*    Die anderen 7 Bits werden Spalten- und Zeilenweise wiederholt.*)
(*    (128 löscht die Seite mit unsichtbaren Punkten)               *)
(*                                                                  *)
(********************************************************************)

  pos   := POS : (0, 0) ;
  stift := PEN : (std, std, std, durchgehend) ;
  pen (std, std, std, durchgehend) ; (* Standard pen *)
  control (ctrl clr, work page nr, control word AND 128, r) ;

END PROC clear;


PROC pen (INT CONST background, foreground, thickness, linetype) :
(********************************************************************)
(*                                                                  *)
(*    CTRL (flags, linienmuster)                                    *)
(*         Setzt verschiedene Graphikmodi.                          *)
(*                                                                  *)
(*    Die Bits im ersten Parameter sind folgendermaßen zugeordnet.  *)
(*                                                                  *)
(*    Bit 0 :                                                       *)
(*     0 = Textmodus einschalten, Graphikmodus ausschalten          *)
(*     1 = Graphikmodus einschalten, Textmodus ausschalten          *)
(*    Bit 1 :                                                       *)
(*     0 = Seite 0 als sichtbare Seite wählen                       *)
(*     1 = Seite 1 als sichtbare Seite wählen                       *)
(*    Bit 2 :                                                       *)
(*     0 = Seite 0 als bearbeitete Seite wählen                     *)
(*     1 = Seite 1 als bearbeitete Seite wählen                     *)
(*    Bit 3, 4 : Verknüpfung Patternbit: 0           1              *)
(*        0           OR              setzen     unverändert        *)
(*        1         NAND             löschen     unverändert        *)
(*        2          XOR         invertieren     unverändert        *)
(*        3         COPY             löschen     setzen             *)
(*    Bit 5 :                                                       *)
(*     0 = Der gesmate Bildschirm zeigt die Graphikseite ('full')   *)
(*     1 = In den letzten 32 Graphikzeilen erscheint die Textseite  *)
(*    Bit 6 :                                                       *)
(*     0 = Das im zweiten Parameter übergebene Wort wird als 16-Bit *)
(*         Linienmuster eingestellt. Modus siehe Bit 3/4.           *)
(*     1 = Das alte (bzw. voreingestellte) Linienmuster wird benutzt*)
(*    Bit 7 :                                                       *)
(*     0 = Als Punkthelligkeit wird 'dunkel' (bzw. Violett) eingest.*)
(*     1 = Als Punkthelligkeit word 'hell' (bzw. Gelb) eingestellt  *)
(*    Bit 8..11 :                                                   *)
(*     0 = Default-Strichdicke (1)                                  *)
(*     1..15 = Strichdicke (Es werden 2*s-1 Linien parallel ge-     *)
(*             zeichnet.)                                           *)
(*                                                                  *)
(*    Der zweite Parameter enthält das 16-Bit Linienmuster. Dieses  *)
(*    wird beim zeichnen einer Linie zyklisch Bitweise abgetastet.  *)
(*    Je nach Status des Bits im Linienmuster wird eine Punkt-      *)
(*    aktion ausgeführt, deren Wirkung im 1. Parameter mit den Bits *)
(*    3 und 4 spezifiziert wird.                                    *)
(*                                                                  *)
(********************************************************************)

  INT CONST farbe := abs (foreground) ;
  set thickness ;
  set linetype ;
  set colour ;
  graphic control ;
  stift := PEN : (background, foreground, abs (thickness), linetype) .

set colour :
 IF farbe = std OR farbe = yellow OR farbe = white
    THEN set bit (control word, color bit)
    ELSE reset bit (control word, color bit)
 FI ;
 IF farbe = delete OR farbe = black
    THEN set   bit (control word, and bit) ; (* RESET *)
         reset bit (control word, xor bit)
 ELIF foreground < 0 AND thickness >= 0
    THEN set   bit (control word, xor bit) ; (* XOR *)
         reset bit (control word, and bit)
 ELIF foreground < 0 (* AND thickness < 0 *)
    THEN set   bit (control word, xor bit) ; (* COPY *)
         set   bit (control word, and bit) 
    ELSE reset bit (control word, xor bit) ; (* SET *)
         reset bit (control word, and bit)
 FI .

set thickness :
 control word := (control word AND 255) + 256 * abs (thickness) .

set linetype:
  reset bit (control word, pattern bit) ;    (* Pattern neu definieren *)
  SELECT linetype OF
   CASE durchgehend      : line pattern := -1
   CASE gepunktet        : line pattern := 21845
   CASE kurz gestrichelt : line pattern := 3855
   CASE lang gestrichelt : line pattern := 255
   CASE strichpunkt      : line pattern := 4351
   OTHERWISE             : line pattern := line type
  END SELECT .

END PROC pen;


PROC move (INT CONST x, y) :
(********************************************************************)
(*                                                                  *)
(*    MOVE (x pos, y pos)                                           *)
(*         Setzt den (unsichtbaren) Graphikcursor auf xpos/ypos.    *)
(*                                                                  *)
(*    Der nächste 'draw' zeichnet eine Linie beginnend bei xpos/ypos*)
(*                                                                  *)
(********************************************************************)

  control (ctrl move, x, y, r) ;
  pos := POS:(x, y) 

END PROC move;

 
PROC draw (INT CONST x, y) :
(********************************************************************)
(*                                                                  *)
(*    DRAW (x pos, y pos)                                           *)
(*         Zeichnet eine Linie zur angegebeben Position xpos/ypos.  *)
(*                                                                  *)
(*    Die eingestellten Parameter Helligkeit, Linientyp, Bitver-    *)
(*    knüpfung und Dicke werden beachtet.                           *)
(*    Der nächste 'draw' zeichnet eine Linie beginnend bei xpos/ypos*)
(*                                                                  *)
(********************************************************************)

  control (ctrl draw, x, y, r) ;
  pos := POS : (x, y) .

END PROC draw;


PROC draw (TEXT CONST record, REAL CONST angle, height, width):
{  x fak  =  width *  hor faktor / max  width
   y fak  = heigth * vert faktor / max height
   x'     = x fak * ( x * cos phi + y * sin phi) + x pos
   y'     = y fak * (-x * sin phi + y * cos phi) + y pos
   x step = x fak * max  width * cos phi
   y step =-y fak * max height * sin phi }

  REAL CONST sin a :: sind (angle) ,
             cos a :: cosd (angle) ,
             x fak :: character width ,
             y fak :: character height ;
  INT CONST  xstep :: character x step ,
             ystep :: character y step ;

  REAL VAR x off r, y off r ;
  INT VAR x pos := pos.x ,
          y pos := pos.y ,
          x off, y off, i ;

  POS VAR old pos := pos;
  FOR i FROM 1 UPTO length (record) REP
    draw character i
  PER ;
  pos := old pos .

character width:
  IF width = 0.0
     THEN 1.0
     ELSE hor faktor * width / real (zeichen.width)
  FI .

character x step:
  int (hor faktor * width * cos a + 0.5) .

character height:
  IF height = 0.0
    THEN 1.0
    ELSE vert faktor * height / real (zeichen.height)
  FI .

character y step:
  int (- vert faktor * height * sin a + 0.5) .

draw character i:
  IF code (record SUB i) < 32
     THEN steuerzeichen
     ELSE normale zeichen
  FI .
 
steuerzeichen:
  SELECT code (record SUB i) OF
    CASE  2 : x pos INCR x step ; y pos INCR y step
    CASE  3 : x pos DECR x step
    CASE  7 : out (""7"")
    CASE  8 : x pos DECR x step ; y pos DECR y step
    CASE 10 : y pos INCR y step
    CASE 13: x pos := pos.x ;  y pos := pos.y
  END SELECT  .

normale zeichen:
  TEXT CONST char :: zeichen.char [code (record SUB i)] ;
  INT CONST char len :: LENGTH char DIV 2 ;
  IF char len < 2
     THEN LEAVE normale zeichen
  FI ;
  x off r := real ((char ISUB 1) AND 15) ;
  y off r := real ((char ISUB 2) AND 15) ;
  move (int (0.5 + x fak * (x off r * cos a + y off r * sin a)) + x pos,
        int (0.5 + y fak * (x off r *-sin a + y off r * cos a)) + y pos) ;

  n := 3 ;
  WHILE n <= char len REP
    x off := char ISUB n ;
    n INCR 1 ;
    y off := char ISUB n+1 ;
    n INCR 1 ;
    BOOL CONST to draw := ((x off OR y off) AND 16384) = 0 ;
    x off r := real (x off AND 15) ;
    y off r := real (y off AND 15) ;
    IF to draw
      THEN
      draw (int (0.5 + x fak * (x off r * cos a + y off r * sin a)) + x pos,
            int (0.5 + y fak * (x off r *-sin a + y off r * cos a)) + y pos)
      ELSE
      move (int (0.5 + x fak * (x off r * cos a + y off r * sin a)) + x pos,
            int (0.5 + y fak * (x off r *-sin a + y off r * cos a)) + y pos)
    FI
  PER ;

  x pos INCR x step ;
  y pos INCR y step .

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 ;
  graphic control .

init cursor:
  control (ctrl ctrl, 17 + (control word AND 134), -1, r) ;
  INT VAR delta := 1 ;
  x := pos.x ;
  y := pos.y .

set cursor:
  IF x0 >= 0 AND y0 >= 0
  THEN control (ctrl move, x0, y0, r);
       control (ctrl draw, x, y, r)
  FI;
  IF x1 >= 0 AND y1 >= 0
  THEN control (ctrl move, x1, y1, r);
       control (ctrl draw, x, y, r)
  FI;
  control (ctrl move, x - 4, y, r);
  control (ctrl draw, x + 4, y, r);
  control (ctrl move, x, y + 4, r);
  control (ctrl draw, x, y - 4, r)  .

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:
  control (ctrl move, pos.x, pos.y, r);
  graphic control ;
  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;


.graphic control :
 control (ctrl ctrl, control word, line pattern, r) .


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


PROC get screen (DATASPACE CONST to ds, INT CONST screen nr) :
(********************************************************************)
(*                                                                  *)
(*    BLOCKIN/BLOCKOUT (0, seiten nummer * 16 + block)              *)
(*         512 Bytes in/aus dem Graphikspeicher transportieren.     *)
(*                                                                  *)
(*    Der zweite Parameter sollte zwischen 0..63 liegen. Als Seiten *)
(*    sind also sowohl die 'displayable' 0 und 1, sowie 'temporary' *)
(*    2 und 3 erlaubt.                                              *)
(*                                                                  *)
(********************************************************************)

  INT CONST page :: screen nr * 16 ; 
  BOUND ROW 16 BLOCK VAR screen := to ds ;
  FOR i FROM 0 UPTO 15 REP
   blockin (screen (i+1), 0, page + i, r)
  PER

END PROC get screen;


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


PROC put screen (DATASPACE CONST from ds, INT CONST screen nr) :

  BOUND ROW 16 BLOCK VAR screen :: from ds ;
  INT CONST page :: screen nr * 16 ;
  FOR i FROM 0 UPTO 15 REP
   block out (screen (i+1), 0, page + i, r)
  PER 

END PROC put screen;


PROC work page (INT CONST nr) :

 work page nr := nr ;
 IF bit (nr, 0)
    THEN setbit (control word, work page bit)
    ELSE reset bit (control word, work page bit)
 FI ;
 graphic control

ENDPROC work page ;


PROC visible page (INT CONST nr) :

 visible page nr := nr ;
 IF bit (nr, 0)
    THEN setbit (control word, visible page bit)
    ELSE reset bit (control word, visible page bit)
 FI ;
 graphic control

ENDPROC visible page ;


INT PROC visible page :
 visible page nr
ENDPROC visible page ;


INT PROC work page :
 work page nr
ENDPROC work page ;


END PACKET basis108 plot ;