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

PACKET matrix plot DEFINES drawing area, 
                        begin plot, 
                        end plot, 
                        clear, 
                        pen,
                        move, 
                        draw, 
                        get cursor,

                        zeichensatz,
                        reset,
                        SCREEN, :=, 
                        get screen, put screen:
 
LET max x        = 511,                 {Bildschirm : 1-512 x 1-256}
    max x plus 1 = 512,
    max y        = 255,

    hor faktor   = 22.21739,            {***** x pixel / x cm *****}
    vert faktor  = 18.61314,            {***** y pixel / y cm *****}


    delete = 0,                         {Farbcodes}
    std    = 1,
    black  = 5,
    white  = 6,

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


LET PEN = STRUCT (INT back, fore, thick, line, BOOL hidden, action);
LET POS = STRUCT (INT x, y);
TYPE SCREEN = ROW 32 ROW 256 INT;
LET ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height);

ROW max x plus 1 INT VAR akt maxima, last maxima;
ZEICHENSATZ VAR zeichen;
SCREEN VAR screen;
PEN VAR stift :: PEN : (black, white, 0, durchgehend, FALSE, TRUE);
POS VAR pos :: POS : (0, 0), start, delta;
INT VAR i, n, diff, up right error, right error, old error,
        pattern pos :: 0, line pattern :: -1;
BOOL VAR bit set :: TRUE;
 
reset;
zeichensatz ("STD Zeichensatz");
clear (screen);

PROC reset:
  FOR i FROM 1 UPTO 512
  REP last maxima [i] := -1;
      akt maxima [i] := -1
  PER
END PROC reset;

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 := 23.0;    y cm := 13.7;   {***** Horizontale und vertikale *****}
                                    {***** Größe in Zentimetern.     *****}
   x pixel := 511;  y pixel := 255  {***** Koordinaten des rechten   *****}
                                    {***** oberen Punktes.           *****}
END PROC drawing area;

PROC begin plot : 
ENDPROC begin plot ;
 
PROC end plot : 
ENDPROC end plot ;

PROC clear :
  stift := PEN : (black, white, 0, durchgehend, FALSE, TRUE);
  pos := POS : (0, 0);

(*    Löschen der Hiddenmaxima      *);
  reset;

(*    Ausgabe der Bildmatrix auf dem Endgerät      *);
  put screen;

(*    Löschen der Bildmatrix       *);
  clear (screen)

END PROC clear;

PROC pen (INT CONST background, foreground, thickness, linetype):
  set linetype;
  stift := PEN : (background, foreground,thickness, linetype,
                  linetype <> 0, thickness < 0)  .

set linetype:
  pattern pos := 0;
  SELECT linetype OF
  CASE durchgehend      : stift.line := -1
  CASE gepunktet        : stift.line := 21845
  CASE kurz gestrichelt : stift.line := 3855
  CASE lang gestrichelt : stift.line := 255
  CASE strichpunkt      : stift.line := 4351
  OTHERWISE stift.line := linetype END SELECT;

END PROC pen;

PROC move (INT CONST x, y) :
  pattern pos := 0;
  IF stift.hidden
  THEN last maxima := akt maxima FI;
 
  pos := POS  : (x, y) 
END PROC move;
 
PROC draw (INT CONST x, y) :
  IF stift.action
  THEN IF stift.thick > 1
       THEN draw thick vektor
       ELSE vector (x-pos.x, y-pos.y) FI
  FI;
  pos := POS : (x, y)   .

draw thick vektor:
  INT CONST old pattern pos := pattern pos; 
  check direction;
  FOR diff FROM -stift.thick UPTO stift.thick
  REP draw single vektor PER  .

check direction :
  BOOL CONST x direction := abs (x-pos.x) > abs (y-pos.y);
  IF x direction
  THEN start := POS : (pos.x+stift.thick * sign (pos.x-x), pos.y); 
       delta := POS : (x+stift.thick * sign (x-pos.x)-pos.x, y-pos.y)
  ELSE start := POS : (pos.x, pos.y+stift.thick * sign (pos.y-y)); 
       delta := POS : (x-pos.x, y+stift.thick * sign (y-pos.y)-pos.y); 
  FI  .

draw single vektor :
  pattern pos := old pattern pos;
  IF x direction
  THEN pos := POS : (start.x, start.y+diff);
       vector (delta.x, delta.y+diff)
  ELSE pos := POS : (start.x+diff, start.y+diff);
       vector (delta.x+diff, delta.y)
  FI .
 
END PROC draw;
 
PROC vector (INT CONST dx , dy) :
  IF dx >= 0
  THEN IF   dy >  dx THEN vector (pos.y, pos.x, dy, dx, 1, 1)
       ELIF dy >   0 THEN vector (pos.x, pos.y, dx, dy, 1, 1)
 
       ELIF dy > -dx THEN vector (pos.x, pos.y, dx, -dy, 1,-1)
       ELSE               vector (pos.y, pos.x, -dy, dx,-1, 1) FI

  ELSE IF   dy > -dx THEN vector (pos.y, pos.x, dy, -dx, 1,-1)
       ELIF dy >   0 THEN vector (pos.x, pos.y, -dx, dy,-1, 1)
 
       ELIF dy >  dx THEN vector (pos.x, pos.y, -dx, -dy,-1,-1)
       ELSE               vector (pos.y, pos.x, -dy, -dx,-1,-1) FI
  FI .
 
ENDPROC vector ;
 
PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
  prepare first step ;
  point;
  FOR i FROM 1 UPTO dx
  REP do one step PER  .

prepare first step :
  up right error := dy - dx;
  right error := dy;
  old error := 0  .

do one step:
  IF right is better
    THEN do right step
    ELSE do up right step
  FI .
 
right is better :
  abs (old error + right error) < abs (old error + up right error)  .
 
do upright step :
  x pos INCR right ;
  y pos INCR up ;
  point ;
  old error INCR upright error .
 
do right step :
  x pos INCR right ;
  point ;
  old error INCR right error .
 
point :
  IF visible (pos) 
  THEN SELECT (pos.x+1) MOD 16 OF
       CASE  0: set bit (block [byte],  8)
       CASE  1: set bit (block [byte],  7)
       CASE  2: set bit (block [byte],  6)
       CASE  3: set bit (block [byte],  5)
       CASE  4: set bit (block [byte],  4)
       CASE  5: set bit (block [byte],  3)
       CASE  6: set bit (block [byte],  2)
       CASE  7: set bit (block [byte],  1)
       CASE  8: set bit (block [byte],  0)
       CASE  9: set bit (block [byte], 15)
       CASE 10: set bit (block [byte], 14)
       CASE 11: set bit (block [byte], 13)
       CASE 12: set bit (block [byte], 12)
       CASE 13: set bit (block [byte], 11)
       CASE 14: set bit (block [byte], 10)
       CASE 15: set bit (block [byte],  9)
       END SELECT;
  FI  .

block:
  screen [(255-pos.y) DIV 8 + 1]  .

byte:
  pos.x DIV 16 + ((255-pos.y) AND 7) * 32 + 1  .

END PROC vector;
 
BOOL PROC visible (POS CONST pos) :
  IF pos.x < 0 OR pos.x > max x OR pos.y < 0 OR pos.y > max y
  THEN FALSE
  ELSE pattern AND hidden FI  .

pattern:
  bit set := bit (line pattern, pattern pos);
  pattern pos := (pattern pos+1) AND 15;
  bit set  .

hidden:
  IF akt maxima [pos.x+1] < pos.y 
  THEN akt maxima [pos.x+1] := pos.y FI; 

  pos.y > last maxima [pos.x+1]  .

END PROC visible;

PROC draw (TEXT CONST record, REAL CONST angle, height, width):
{**** Hier werden Texte mit dem Winkel 'angle',der Höhe 'height' und *****}
{**** der Breite 'width' gezeichnet. Falls die Hardware dieses       *****}
{**** bereits ermöglicht, so müssen die Variable 'zeichen' und die   *****}
{**** Prozedur Zeichensatz gelöscht werden. Der Datenraum            *****}
{**** 'STD Zeichensatz' wird in diesem Fall nicht benötigt.          *****}
  BOOL CONST horizontal :: NOT (abs (angle) MOD 180.0 > 45.0 AND abs (angle) MOD 180.0 < 135.0);
  INT CONST x fak :: character width, x step :: character x step,
            y fak :: character height, y step :: character y step;
  INT VAR x pos :: pos.x, y pos :: pos.y, 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 int (hor faktor * width+0.5)
  ELSE zeichen.width FI  .

character x step:
  IF horizontal
  THEN IF width <> 0.0
       THEN int (cosd (angle) * hor faktor * width+0.5)
       ELSE int (cosd (angle) * real (zeichen.width)+0.5) FI
  ELSE IF width <> 0.0
       THEN int (cosd (angle) * vert faktor * width+0.5)
       ELSE int (cosd (angle) * real (zeichen.height)+0.5) FI 
  FI  .

character height:
  IF height <> 0.0
  THEN int (vert faktor * height+0.5)
  ELSE zeichen.height FI  .

character y step:
  IF horizontal
  THEN IF height <> 0.0
       THEN int (sind (angle) * vert faktor * height+0.5)
       ELSE int (sind (angle) * real (zeichen.height)+0.5) FI 
  ELSE IF height <> 0.0
       THEN int (sind (angle) * hor faktor * height+0.5)
       ELSE int (sind (angle) * real (zeichen.width)+0.5) FI 
  FI  .

draw character i:
  IF code (record SUB i) < 32
  THEN steuerzeichen
  ELSE normale zeichen FI  .

steuerzeichen:
  SELECT code (record SUB i) OF
  CASE  7: out (""0""7""16"")
  CASE 13: x pos := pos.x;  y pos := pos.y
  END SELECT  .

normale zeichen:
  TEXT CONST char :: zeichen.char [code (record SUB i)];
  IF horizontal
  THEN draw horizontal
  ELSE draw vertical FI  .

draw vertical:
  n := 3;
  IF char <> ""
  THEN pos := POS : (((char ISUB 2)*y fak) DIV zeichen.height + x pos,
                    -((char ISUB 1)*x fak) DIV zeichen.width + y pos)
  FI;
  WHILE n <= length (char) DIV 2
  REP IF (char ISUB n) < 0 OR (char ISUB n+1) < 0
      THEN pos := POS : (((char ISUB n+1)*y fak) DIV zeichen.height + x pos,
                        -((char ISUB n  )*x fak) DIV zeichen.width + y pos) 
      ELSE vector (-((char ISUB n+1)*y fak) DIV zeichen.height + x pos-pos.x,
                    ((char ISUB n  )*x fak) DIV zeichen.width + y pos-pos.y)
      FI;
      n INCR 2
  PER;
  x pos INCR x step;
  y pos INCR y step  .

draw horizontal:
  n := 3;
  IF char <> ""
  THEN pos := POS : (-((char ISUB 1)*x fak) DIV zeichen.width + x pos,
                     -((char ISUB 2)*y fak) DIV zeichen.height + y pos)
  FI;
  WHILE n <= length (char) DIV 2
  REP IF (char ISUB n) < 0 OR (char ISUB n+1) < 0
      THEN pos := POS : (-((char ISUB n  )*x fak) DIV  zeichen.width + x pos,
                         -((char ISUB n+1)*y fak) DIV zeichen.height + y pos)
      ELSE vector (((char ISUB n  )*x fak) DIV zeichen.width + x pos-pos.x,
                   ((char ISUB n+1)*y fak) DIV zeichen.height + y pos-pos.y)
      FI;
      n INCR 2
  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) :
  t := "";
  x := 0;
  y := 0
END PROC get cursor;

OP := (SCREEN VAR l, SCREEN CONST r):
  CONCR (l) := CONCR (r)
END OP :=;

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 ds):
  BOUND SCREEN VAR ds screen :: ds;
  ds screen := screen
END PROC get screen;

PROC get screen (SCREEN VAR ds screen):
  ds screen := screen
END PROC get screen;

PROC get screen:
  FOR i FROM 1 UPTO 32
  REP block in (screen [i], -1, i-1, n) 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 ds):
  BOUND SCREEN VAR ds screen :: ds;
  screen := ds screen;
  put screen
END PROC put screen;

PROC put screen (SCREEN VAR ds screen):
  screen := ds screen;
  put screen
END PROC put screen;

PROC put screen:
  FOR i FROM 1 UPTO 32
  REP block out (screen [i], -1, i-1, n) PER
END PROC put screen;

PROC clear (SCREEN VAR screen):
  FOR i FROM 1 UPTO 256
  REP screen [1] [i] := 0 PER;
  FOR i FROM 2 UPTO 32
  REP screen [i] := screen [1] PER
END PROC clear;

END PACKET matrix plot;