diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /app/mpg/1987/src/PICTURE.ELA | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'app/mpg/1987/src/PICTURE.ELA')
| -rw-r--r-- | app/mpg/1987/src/PICTURE.ELA | 521 |
1 files changed, 521 insertions, 0 deletions
diff --git a/app/mpg/1987/src/PICTURE.ELA b/app/mpg/1987/src/PICTURE.ELA new file mode 100644 index 0000000..d5e00fa --- /dev/null +++ b/app/mpg/1987/src/PICTURE.ELA @@ -0,0 +1,521 @@ +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
|