PACKET picture DEFINES                            (*Autor: H.Indenbirken *)
               PICTURE,                           (*Stand: 23.02.1985    *)
               :=, CAT, nilpicture,
               draw, draw r, draw cm, draw cm r,
               move, move r, move cm, move cm r, 
               bar, circle,
               length, dim, pen, where,
               extrema, rotate, stretch, translate,
               text, picture, plot:

LET draw key      = 1,
    move key      = 2,
    text key      = 3,
    move r key    = 4,
    draw r key    = 5,
    move cm key   = 6, 
    draw cm key   = 7,
    move cm r key = 8,
    draw cm r key = 9,
    bar key       = 10,
    circle key    = 11,
    max 2 dim     = 31983,
    max 3 dim     = 31975,
    max text      = 31974,
    max bar       = 31982,
    max circle    = 31974,
    max length    = 32000;


TYPE PICTURE = STRUCT (INT dim, pen, TEXT points);


INT VAR i, read pos, key;
REAL VAR x, y, z;
TEXT VAR t, r2 :: 16*""0"", r3 :: 24*""0"", i1 :: ""0""0"", i2 :: ""0""0""0""0"";

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

OP CAT (PICTURE VAR l, PICTURE CONST r) :
  IF l.dim <> r.dim
  THEN errorstop ("OP CAT : left dimension <> right dimension")
  ELIF length (l.points) > max length - length (r.points)
  THEN errorstop ("OP CAT : Picture overflow") FI;

  l.points CAT r.points
END OP CAT;

PICTURE PROC nilpicture :
  PICTURE : (0, 1, "")
END PROC nilpicture;

PROC draw (PICTURE VAR p, TEXT CONST text) :
  draw (p, text, 0.0, 0.0, 0.0)
END PROC draw;

PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright):
  write (p, text, angle, height, bright, text key)
END PROC draw;

PROC draw (PICTURE VAR p, REAL CONST x, y, z) :
  check dim (p, 3);
  write (p, x, y, z, draw key)
END PROC draw;

PROC draw (PICTURE VAR p, REAL CONST x, y) :
  check dim (p, 2);
  write (p, x, y, draw key)
END PROC draw;

PROC draw r (PICTURE VAR p, REAL CONST x, y, z) :
  check dim (p, 3);
  write (p, x, y, z, draw r key)
END PROC draw r;

PROC draw r (PICTURE VAR p, REAL CONST x, y) :
  check dim (p, 2);
  write (p, x, y, draw r key)
END PROC draw r;

PROC draw cm (PICTURE VAR p, REAL CONST x, y) :
  write (p, x, y, draw cm key)
END PROC draw cm;

PROC draw cm r (PICTURE VAR p, REAL CONST x, y) :
  write (p, x, y, draw cm r key)
END PROC draw cm r;

PROC move (PICTURE VAR p, REAL CONST x, y, z) :
  check dim (p, 3);
  write (p, x, y, z, move key)
END PROC move;

PROC move (PICTURE VAR p, REAL CONST x, y) :
  check dim (p, 2);
  write (p, x, y, move key)
END PROC move;

PROC move r (PICTURE VAR p, REAL CONST x, y, z) :
  check dim (p, 3);
  write (p, x, y, z, move r key)
END PROC move r;

PROC move r (PICTURE VAR p, REAL CONST x, y) :
  check dim (p, 2);
  write (p, x, y, move r key)
END PROC move r;

PROC move cm (PICTURE VAR p, REAL CONST x, y) :
  write (p, x, y, move cm key)
END PROC move cm;

PROC move cm r (PICTURE VAR p, REAL CONST x, y) :
  write (p, x, y, move cm r key)
END PROC move cm r;

PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern):
  write (p, width, height, pattern, bar key)
END PROC bar;

PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern):
  write (p, radius, from, to, pattern, circle key)
END PROC circle;


PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST key) :
  IF length (p.points) < max 3 dim
  THEN p.points CAT code (key); 
       replace (r3, 1, x);
       replace (r3, 2, y);
       replace (r3, 3, z);
       p.points CAT r3
  ELSE errorstop ("Picture overflow") FI
END PROC write;

PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST key) :
  IF length (p.points) < max 2 dim
  THEN p.points CAT code (key); 
       replace (r2, 1, x);
       replace (r2, 2, y);
       p.points CAT r2
  ELSE errorstop ("Picture overflow") FI
END PROC write;

PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST n, key) :
  IF length (p.points) < max bar
  THEN p.points CAT code (key); 
       replace (r2, 1, x);
       replace (r2, 2, y);
       p.points CAT r2;
       replace (i1, 1, n);
       p.points CAT i1
  ELSE errorstop ("Picture overflow") FI
END PROC write;

PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST n, key) :
  IF length (p.points) < max circle 
  THEN p.points CAT code (key); 
       replace (r3, 1, x);
       replace (r3, 2, y);
       replace (r3, 3, z);
       p.points CAT r3;
       replace (i1, 1, n);
       p.points CAT i1 
  ELSE errorstop ("Picture overflow") FI
END PROC write;

PROC write (PICTURE VAR p, TEXT CONST t, REAL CONST angle, height, bright,
            INT CONST key) :
  IF max text - length (p.points) >= length (t)
  THEN p.points CAT code (key);
       replace (i1, 1, length (t));
       p.points CAT i1;
       p.points CAT t;
       replace (r3, 1, angle);
       replace (r3, 2, height);
       replace (r3, 3, bright);
       p.points CAT r3
  FI;
END PROC write;

PROC check dim (PICTURE VAR p, INT CONST dim):
  IF p.dim = 0
  THEN p.dim := dim
  ELIF p.dim <> dim
  THEN errorstop ("Picture is " + text (p.dim) + " dimensional") FI
END PROC check dim;

INT PROC length (PICTURE CONST p):
  length (p.points)
END PROC length;

INT PROC dim (PICTURE CONST pic) :
  pic.dim
END PROC dim;

PROC pen (PICTURE VAR p, INT CONST pen) :
  IF pen < 0 OR pen > 16
  THEN errorstop ("pen out of range [0-16]") FI;
  p.pen := pen
END PROC pen;

INT PROC pen (PICTURE CONST p) :
  p.pen
END PROC pen;

PROC where (PICTURE CONST p, REAL VAR x, y) :
  IF p.dim = 0
  THEN x := 0.0;  y := 0.0
  ELIF p.dim = 3
  THEN errorstop ("Picture is 3 dimensional")
  ELSE x := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
       y := subtext (p.points, length (p.points)-7,  length (p.points)) RSUB 1
  FI
END PROC where;

PROC where (PICTURE CONST p, REAL VAR x, y, z) :
  IF p.dim = 0
  THEN x := 0.0;  y := 0.0;  z := 0.0
  ELIF p.dim = 2
  THEN errorstop ("Picture is 2 dimensional")
  ELSE x := subtext (p.points, length (p.points)-23, length (p.points)-16) RSUB 1;
       y := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
       z := subtext (p.points, length (p.points)-7,  length (p.points)) RSUB 1;
  FI
END PROC where;


PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, z min, z max) :
  x min := max real;  x max :=-max real;
  y min := max real;  y max :=-max real;
  z min := max real;  z max :=-max real;
  read pos := 0; 
  INT CONST pic length := length (p.points);
  WHILE read pos < pic length
  REP check position PER  .

check position :
  read pos INCR 1;
  SELECT code (p.points SUB read pos) OF
  CASE draw key : calc extrema
  CASE move key : calc extrema
  CASE move r key : calc rel extrema
  CASE draw r key : calc rel extrema
  CASE move cm key : read pos INCR 16
  CASE draw cm key : read pos INCR 16
  CASE move cm r key : read pos INCR 16
  CASE draw cm r key : read pos INCR 16
  CASE text key : read pos INCR next int + 24
  CASE bar key : read pos INCR 18
  CASE circle key : read pos INCR 26
  OTHERWISE errorstop ("wrong key code") END SELECT  . 

calc extrema :
  x := next real;  y := next real;  z := next real;
  x min := min (x min, x);  x max := max (x max, x);
  y min := min (y min, y);  y max := max (y max, y);
  z min := min (z min, z);  z max := max (z max, z)  .

calc rel extrema :
  x INCR next real;  y INCR next real;  z INCR next real;
  x min := min (x min, x);  x max := max (x max, x);
  y min := min (y min, y);  y max := max (y max, y);
  z min := min (z min, z);  z max := max (z max, z)  .

next real :
  read pos INCR 8;
  subtext (p.points, read pos-7, read pos) RSUB 1  .

next int :
  read pos INCR 2;
  subtext (p.points, read pos-1, read pos) ISUB 1  .

END PROC extrema;

PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max):
  x min := max real;  x max :=-max real;
  y min := max real;  y max :=-max real;
  read pos := 0; 
  INT CONST pic length := length (p.points);
  WHILE read pos < pic length
  REP check position PER  .

check position :
  read pos INCR 1;
  SELECT code (p.points SUB read pos) OF
  CASE draw key : calc extrema
  CASE move key : calc extrema
  CASE move r key : calc rel extrema
  CASE draw r key : calc rel extrema
  CASE move cm key : read pos INCR 16
  CASE draw cm key : read pos INCR 16
  CASE move cm r key : read pos INCR 16
  CASE draw cm r key : read pos INCR 16
  CASE text key : read pos INCR next int + 24
  CASE bar key : read pos INCR 18
  CASE circle key : read pos INCR 26
  OTHERWISE errorstop ("wrong key code") END SELECT  . 

calc extrema :
  x := next real;  y := next real;
  x min := min (x min, x);  x max := max (x max, x);
  y min := min (y min, y);  y max := max (y max, y)  .

calc rel extrema :
  x INCR next real;  y INCR next real;
  x min := min (x min, x);  x max := max (x max, x);
  y min := min (y min, y);  y max := max (y max, y)  .

next real :
  read pos INCR 8;
  subtext (p.points, read pos-7, read pos) RSUB 1  .

next int :
  read pos INCR 2;
  subtext (p.points, read pos-1, read pos) ISUB 1  .

END PROC extrema;

PROC rotate (PICTURE VAR p, REAL CONST angle) :
  REAL CONST s :: sind( angle ), c := cosd( angle );
  transform (p, ROW 4 ROW 3 REAL : 
               (ROW 3 REAL : ( 1.0,  0.0,  0.0 ),
                ROW 3 REAL : ( 0.0,   c ,   s  ),
                ROW 3 REAL : ( 0.0,  -s ,   c  ),
                ROW 3 REAL : ( 0.0,  0.0,  0.0 )))
END PROC rotate;

PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) :
  REAL CONST s   :: sind ( theta ), c   :: cosd ( theta ),
             s p :: sind (  phi  ), s l :: sind ( lambda ),
             ga  :: cosd (  phi  ), c l :: cosd ( lambda ),
             be  :: s p * s l,      al  :: s p * c l, c1 :: 1.0 - c;
  transform (p, ROW 4 ROW 3 REAL : 
               (ROW 3 REAL : ( al*al*c1 + c , be*al*c1+ga*s, ga*al*c1-be*s ),
                ROW 3 REAL : ( al*be*c1-ga*s, be*be*c1 + c , ga*be*c1+al*s ),
                ROW 3 REAL : ( al*ga*c1+be*s, be*ga*c1-al*s, ga*ga*c1 + c  ),
                ROW 3 REAL : (      0.0     ,      0.0     ,      0.0    )))
END PROC rotate; 
 
PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) : 
  stretch (pic, sx, sy, 1.0) 
END PROC stretch;

PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) :
  transform (p, ROW 4 ROW 3 REAL : 
               (ROW 3 REAL : ( sx, 0.0, 0.0),
                ROW 3 REAL : (0.0,  sy, 0.0),
                ROW 3 REAL : (0.0, 0.0,  sz),
                ROW 3 REAL : (0.0, 0.0, 0.0)))
END PROC stretch;

PROC translate (PICTURE VAR p, REAL CONST dx, dy) : 
  translate (p, dx, dy, 0.0) 
END PROC translate;

PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) :
  transform (p, ROW 4 ROW 3 REAL : 
               (ROW 3 REAL : (1.0, 0.0, 0.0),
                ROW 3 REAL : (0.0, 1.0, 0.0),
                ROW 3 REAL : (0.0, 0.0, 1.0),
                ROW 3 REAL : ( dx,  dy,  dz)))
END PROC translate;

PROC transform (PICTURE VAR p, ROW 4 ROW 3 REAL CONST a) :
  INT CONST pic length := length (p.points);
  INT VAR begin pos;
  read pos := 0; 
  x := 0.0; y := 0.0; z := 0.0;
  IF p.dim = 2
  THEN transform 2 dim pic
  ELSE transform 3 dim pic FI  .
 
transform 2 dim pic:
  WHILE read pos < pic length
  REP transform 2 dim position PER  .

transform 2 dim position:
  read pos INCR 1;
  SELECT code (p.points SUB read pos) OF
  CASE draw key : transform 2 dim point 
  CASE move key : transform 2 dim point 
  CASE move r key : transform 2 dim point 
  CASE draw r key : transform 2 dim point 
  CASE move cm key : read pos INCR 16
  CASE draw cm key : read pos INCR 16
  CASE move cm r key : read pos INCR 16
  CASE draw cm r key : read pos INCR 16
  CASE text key : read pos INCR next int + 24
  CASE bar key : read pos INCR 18
  CASE circle key : read pos INCR 26
  OTHERWISE errorstop ("wrong key code") END SELECT  . 

transform 2 dim point:
  begin pos := read pos+1;
  x := next real;  y := next real;
  transform (a, x, y, z); 
  replace (r2, 1, x);
  replace (r2, 2, y);
  replace (p.points, begin pos, r2)  .

transform 3 dim pic:
  WHILE read pos < pic length
  REP transform 3 dim position PER  .

transform 3 dim position :
  read pos INCR 1;
  SELECT code (p.points SUB read pos) OF
  CASE draw key : transform 3 dim point 
  CASE move key : transform 3 dim point 
  CASE move r key : transform 3 dim point 
  CASE draw r key : transform 3 dim point 
  CASE move cm key : read pos INCR 16
  CASE draw cm key : read pos INCR 16
  CASE move cm r key : read pos INCR 16
  CASE draw cm r key : read pos INCR 16
  CASE text key : read pos INCR next int + 24
  CASE bar key : read pos INCR 18
  CASE circle key : read pos INCR 26
  OTHERWISE errorstop ("wrong key code") END SELECT  . 

transform 3 dim point:
  begin pos := read pos+1;
  x := next real;  y := next real; z := next real;
  transform (a, x, y, z); 
  replace (r3, 1, x);
  replace (r3, 2, y);
  replace (r3, 3, z);
  replace (p.points, begin pos, r3)  .

next real :
  read pos INCR 8;
  subtext (p.points, read pos-7, read pos) RSUB 1  .

next int :
  read pos INCR 2;
  subtext (p.points, read pos-1, read pos) ISUB 1  .

END PROC transform;

PROC transform (ROW 4 ROW 3 REAL CONST a, REAL VAR x, y, z) :
  REAL CONST ox :: x, oy :: y, oz :: z;
  x := ox*a(1)(1) + oy*a(2)(1) + oz*a(3)(1) + a(4)(1);
  y := ox*a(1)(2) + oy*a(2)(2) + oz*a(3)(2) + a(4)(2);
  z := ox*a(1)(3) + oy*a(2)(3) + oz*a(3)(3) + a(4)(3)
END PROC transform;

TEXT PROC text (PICTURE CONST pic):
  replace (i2, 1, pic.dim);
  replace (i2, 2, pic.pen);
  i2 + pic.points
END PROC text;

PICTURE PROC picture (TEXT CONST text):
  PICTURE : (text ISUB 1, text ISUB 2, subtext (text, 5))
END PROC picture;

PROC plot (PICTURE CONST p) :
  INT CONST pic length := length (p.points);
  read pos := 0;
  IF p.dim = 2
  THEN plot two dim pic
  ELSE plot three dim pic FI  .

plot two dim pic:
  WHILE read pos < pic length
  REP plot two dim position PER  .

plot two dim position :
  read pos INCR 1;
  SELECT code (p.points SUB read pos) OF
  CASE draw key : draw (next real, next real)
  CASE move key : move (next real, next real)
  CASE move r key : move r (next real, next real)
  CASE draw r key : draw r (next real, next real)
  CASE move cm key : move cm (next real, next real)
  CASE draw cm key : draw cm (next real, next real)
  CASE move cm r key : move cm r (next real, next real)
  CASE draw cm r key : draw cm r (next real, next real)
  CASE text key : draw (next text, next real, next real, next real)
  CASE bar key : bar (next real, next real, next int) 
  CASE circle key : circle (next real, next real, next real, next int) 
  OTHERWISE errorstop ("wrong key code") END SELECT  . 

plot three dim pic:
  WHILE read pos < pic length
  REP plot three dim position PER  .

plot three dim position :
  read pos INCR 1;
  SELECT code (p.points SUB read pos) OF
  CASE draw key : draw (next real, next real, next real)
  CASE move key : move (next real, next real, next real)
  CASE move r key : move r (next real, next real, next real)
  CASE draw r key : draw r (next real, next real, next real)
  CASE move cm key : move cm (next real, next real)
  CASE draw cm key : draw cm (next real, next real)
  CASE move cm r key : move cm r (next real, next real)
  CASE draw cm r key : draw cm r (next real, next real)
  CASE text key : draw (next text, next real, next real, next real)
  CASE bar key : bar (next real, next real, next int) 
  CASE circle key : circle (next real, next real, next real, next int) 
  OTHERWISE errorstop ("wrong key code") END SELECT  . 

next real :
  read pos INCR 8;
  subtext (p.points, read pos-7, read pos) RSUB 1  .

next int :
  read pos INCR 2;
  subtext (p.points, read pos-1, read pos) ISUB 1  .

next text :
  INT CONST text length :: next int;
  read pos INCR text length;
  subtext (p.points, read pos-text length+1, read pos)  .
 
END PROC plot;

END PACKET picture