(**************************************************************************) (* *) (* MPG - Graphik - System *) (* *) (* Version 2.2 vom 23.09.1987 *) (* *) (* (c) 1987 Beat Jegerlehner & Carsten Weinholz *) (* unter Verwendung der Standard-Graphik *) (* "Graphik-Basis" geschrieben von C.Weinholz/EUMEL-Std *) (* *) (**************************************************************************) (* *) (* Paket I: Endgeraet-unabhaengige Graphikroutinen *) (* *) (* 1. Transformation (Umsetzung 3D -> 2D), *) (* Clipping und Normierung *) (* 2. PICTURE - Verwaltung *) (* (geanderte Standard-Version) *) (* 3. PICFILE - Verwaltung *) (* (geanderte Standard-Version) *) (* 4. Endgeraet - Verwaltung *) (* *) (**************************************************************************) (* Urversion : 10.09.87 *) (* Aenderungen: 23.09.87, Carsten Weinholz *) (* OP := (PICFILE VAR, PICFILE CONST) hinzugefuegt *) (* TEXT PROC text (PICTURE CONST) *) (* wg. Heapueberlauf geaendert *) (* *) (**************************************************************************) (****************************** transformation ****************************) PACKET transformation DEFINES transform, set values, get values, new values, drawing area, set drawing area, window, viewport, view, oblique, orthographic, perspective, clipped line: BOOL VAR new limits :: TRUE, values new :: TRUE, perspective projektion :: FALSE; REAL VAR display hor, display vert, (* Anzahl der Pixel *) size hor, size vert, (* Groesse des Bildschirms *) size hor d, size vert d, h min limit, h max limit, v min limit, v max limit, h min, h max, v min, v max, relation; ROW 5 ROW 5 REAL VAR p ; ROW 3 ROW 2 REAL VAR size d ; ROW 2 ROW 2 REAL VAR limits d ; ROW 4 REAL VAR angles d ; ROW 2 REAL VAR oblique d ; ROW 3 REAL VAR perspective d ; INT VAR i, j; PROC init transformation rows: size d := ROW 3 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0), ROW 2 REAL : (0.0, 1.0), ROW 2 REAL : (0.0, 1.0)); limits d := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, relation), ROW 2 REAL : (0.0, 1.0)); angles d := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0); oblique d := ROW 2 REAL : (0.0, 0.0); perspective d := ROW 3 REAL : (0.0, 0.0, 0.0); set values (size d, limits d, angles d, oblique d, perspective d); END PROC init transformation rows; BOOL OP = (ROW 3 ROW 2 REAL CONST l, r): FOR i FROM 1 UPTO 3 REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2] THEN LEAVE = WITH FALSE FI PER; TRUE END OP =; BOOL OP = (ROW 2 ROW 2 REAL CONST l, r): FOR i FROM 1 UPTO 2 REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2] THEN LEAVE = WITH FALSE FI PER; TRUE END OP =; BOOL OP = (ROW 2 REAL CONST l, r): l [1] = r [1] AND l [2] = r [2] END OP =; BOOL OP = (ROW 3 REAL CONST l, r): l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3] END OP =; BOOL OP = (ROW 4 REAL CONST l, r): l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3] AND l [4] = r [4] END OP =; PROC oblique (REAL CONST a, b) : set values (size d, limits d, angles d, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0)) END PROC oblique; PROC orthographic : set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (0.0, 0.0, 0.0)) END PROC orthographic; PROC perspective (REAL CONST cx, cy, cz) : set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy,-cz)) END PROC perspective; PROC window (BOOL CONST dev) : new limits := dev END PROC window; PROC window (REAL CONST x min, x max, y min, y max) : window (x min, x max, y min, y max, 0.0, 1.0) END PROC window; PROC window (REAL CONST x min, x max, y min, y max, z min, z max) : set values (ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max), ROW 2 REAL : (y min, y max), ROW 2 REAL : (z min, z max)), limits d, angles d, oblique d, perspective d) END PROC window; PROC viewport (REAL CONST h min, h max, v min, v max) : set values (size d, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max), ROW 2 REAL : (v min, v max)), angles d, oblique d, perspective d) END PROC view port; PROC view (REAL CONST alpha) : set values (size d, limits d, ROW 4 REAL : (alpha, angles d(2), angles d (3), angles d (4)), oblique d, perspective d) END PROC view; PROC view (REAL CONST phi, theta) : set values (size d, limits d, ROW 4 REAL : (angles d(1), sind (theta) * cosd (phi), sind (theta) * sind (phi), cosd (theta)), oblique d, perspective d) END PROC view; PROC view (REAL CONST x, y, z) : set values (size d, limits d, ROW 4 REAL : (angles d (1), x, y, z), oblique d, perspective d) END PROC view; PROC drawing area (REAL VAR min h, max h, min v, max v): min h := h min limit; max h := h max limit; min v := v min limit; max v := v max limit END PROC drawing area; PROC set drawing area (REAL CONST new size hor,new size vert, new display hor,new display vert): size hor := new size hor; size vert:= new size vert; display hor := new display hor; display vert:= new display vert; relation := size hor/size vert; new limits := TRUE; init transformation rows END PROC set drawing area; BOOL PROC new values: IF values new THEN values new := FALSE; TRUE ELSE FALSE FI END PROC new values; PROC get values (ROW 3 ROW 2 REAL VAR size, ROW 2 ROW 2 REAL VAR limits, ROW 4 REAL VAR angles, ROW 2 REAL VAR oblique, ROW 3 REAL VAR perspective) : size := size d; limits := limits d; angles := angles d; oblique := oblique d; perspective := perspective d; END PROC get values; PROC set values (ROW 3 ROW 2 REAL CONST size, ROW 2 ROW 2 REAL CONST limits, ROW 4 REAL CONST angles, ROW 2 REAL CONST oblique, ROW 3 REAL CONST perspective) : IF NOT same values THEN values new := TRUE; copy values; set views; check perspective projektion; calc limits; change projektion FI . same values: size hor d = size hor AND size vert d = size vert AND size d = size AND limits d = limits AND angles d = angles AND oblique d = oblique AND perspective d = perspective . copy values : size hor d := size hor; size vert d := size vert; size d := size; limits d := limits; angles d := angles; oblique d := oblique; perspective d := perspective . set views : REAL VAR diagonale := sqrt (angles [2] * angles [2] + angles [3] * angles [3] + angles [4] * angles [4]), projektion := sqrt (angles [2] * angles [2] + angles [4] * angles [4]), sin p, cos p, sin t, cos t, sin a, cos a; IF diagonale = 0.0 THEN sin p := 0.0; cos p := 1.0; sin t := 0.0; cos t := 1.0 ELIF projektion = 0.0 THEN sin p := angles [3] / diagonale; cos p := projektion / diagonale; sin t := 0.0; cos t := 1.0 ELSE sin p := angles [3] / diagonale; cos p := projektion / diagonale; sin t := angles [2] / projektion; cos t := angles [4] / projektion FI; REAL VAR sin p sin t := sin p * sin t, sin p cos t := sin p * cos t, cos p sin t := cos p * sin t, cos p cos t := cos p * cos t, dx := size [1][2] - size [1][1], dy := size [2][2] - size [2][1], dz := size [3][2] - size [3][1], norm az := oblique [1] , norm bz := oblique [2] , norm cx := perspective [1] / dx, norm cy := perspective [2] / dy, norm cz := perspective [3] / dz; p := ROW 5 ROW 5 REAL : (ROW 5 REAL : ( cos t / dx - cos p sin t / dx * norm az , - sin p sin t / dx - cos p sin t / dx * norm bz, 0.0, - cos p sin t / dx * norm cz, 0.0 ), ROW 5 REAL : ( - sin p / dy * norm az, cos p / dy - sin p / dy * norm bz, 0.0, - sin p / dy * norm cz, 0.0 ), ROW 5 REAL : ( sin t / dz + cos p cos t / dz * norm az, + sin p cos t / dz + cos p cos t / dz * norm bz, 0.0, cos p cos t / dz * norm cz, 0.0 ), ROW 5 REAL : (- norm cx, - norm cy, 0.0, 1.0, 0.0 ), ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0)); IF angles (1) = 0.0 THEN set alpha as y vertical ELSE sin a := sind (angles (1)); cos a := cosd (angles (1)) FI; FOR j FROM 1 UPTO 5 REP REAL CONST p j 1 := p (j)(1); p (j)(1) := p j 1 * cos a - p (j)(2) * sin a; p (j)(2) := p j 1 * sin a + p (j)(2) * cos a PER . set alpha as y vertical : REAL VAR r := sqrt (p(2)(1)**2 + p(2)(2)**2); IF r = 0.0 THEN sin a := 0.0; cos a := 1.0 ELSE sin a :=-p(2)(1)/r; cos a := p(2)(2)/r FI . check perspective projektion: perspective projektion := perspective [3] <> 0.0 . calc limits : IF new limits THEN calc two dim extrema; IF all limits smaller than 2 THEN prozente ELSE zentimeter FI FI . calc two dim extrema : h min := max real; h max :=-max real; v min := max real; v max :=-max real; extrema (size [1][1], size [2][1], size [3][1], h min, h max, v min, v max); extrema (size [1][2], size [2][1], size [3][1], h min, h max, v min, v max); extrema (size [1][2], size [2][2], size [3][1], h min, h max, v min, v max); extrema (size [1][1], size [2][2], size [3][1], h min, h max, v min, v max); extrema (size [1][1], size [2][1], size [3][2], h min, h max, v min, v max); extrema (size [1][2], size [2][1], size [3][2], h min, h max, v min, v max); extrema (size [1][2], size [2][2], size [3][2], h min, h max, v min, v max); extrema (size [1][1], size [2][2], size [3][2], h min, h max, v min, v max) . all limits smaller than 2 : limits (1)(2) < 2.0 AND limits (2)(2) < 2.0 . prozente : h min limit := display hor * limits (1)(1)/relation; h max limit := display hor * limits (1)(2)/relation; v min limit := limits (2)(1) * display vert; v max limit := limits (2)(2) * display vert . zentimeter : h min limit := display hor * (limits (1)(1)/size hor); h max limit := display hor * (limits (1)(2)/size hor); v min limit := display vert * (limits (2)(1)/size vert); v max limit := display vert * (limits (2)(2)/size vert) . change projektion : REAL VAR sh := (h max limit - h min limit) / (h max - h min), sv := (v max limit - v min limit) / (v max - v min), dh := h min limit - h min*sh, dv := v min limit - v min*sv; FOR j FROM 1 UPTO 5 REP p (j)(1) := p (j)(1) * sh; p (j)(2) := p (j)(2) * sv PER; p (5)(1) := dh; p (5)(2) := dv. END PROC set values; PROC transform (REAL CONST x, y, z, INT VAR h, v) : disable stop; IF perspective projektion THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0); h := int ((x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (4)(1))*w + p (5)(1)); v := int ((x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (4)(2))*w + p (5)(2)) ELSE h := int (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (5)(1)); v := int (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (5)(2)); FI; IF is error THEN h := -1; v := -1; clear error FI END PROC transform; PROC extrema (REAL CONST x, y, z, REAL VAR h min, h max, v min, v max): REAL VAR h, v; IF perspective projektion THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0); h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) +p (4)(1))*w; v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) +p (4)(2))*w ELSE h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1)); v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2)) FI; IF h < h min THEN h min := h ELIF h > h max THEN h max := h FI; IF v < v min THEN v min := v ELIF v > v max THEN v max := v FI END PROC extrema; BOOL PROC clipped line (REAL VAR x0,y0,x1,y1): REAL VAR dx :: (display hor - 1.0) / 2.0, dy :: (display vert- 1.0) / 2.0, rx0 :: x0 - dx, ry0 :: y0 - dy, rx1 :: x1 - dx, ry1 :: y1 - dy; INT VAR cx0, cy0, cx1, cy1; calculate cells; IF (cx0*cx1 = 1) OR (cy0 * cy1 = 1) THEN FALSE ELIF (x0 = x1) AND (y0 = y1) THEN cx0 = 0 AND cy0 = 0 ELSE do clipping FI. do clipping: IF cx0 <> 0 THEN REAL VAR next x :: real(cx0) * dx; ry0 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx0) + ry0; rx0 := next x FI; calculate cells; IF cy0 <> 0 THEN REAL VAR next y :: real(cy0) * dy; rx0 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry0) + rx0; ry0 := next y FI; IF cx1 <> 0 THEN next x := real(cx1) * dx; ry1 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx1) + ry1; rx1 := next x FI; calculate cells; IF cy1 <> 0 THEN next y := real(cy1) * dy; rx1 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry1) + rx1; ry1 := next y FI; IF (rx1 = rx0) AND (ry1 = ry0) THEN FALSE ELSE x0 := rx0+dx; y0 := ry0+dy; x1 := rx1+dx; y1 := ry1+dy; TRUE FI. calculate cells: cx0 := 0; cy0 := 0; cx1 := 0; cy1 := 0; IF abs(rx0) > dx THEN cx0 := sign(rx0) FI; IF abs(rx1) > dx THEN cx1 := sign(rx1) FI; IF abs(ry0) > dy THEN cy0 := sign(ry0) FI; IF abs(ry1) > dy THEN cy1 := sign(ry1) FI. END PROC clipped line; END PACKET transformation; (******************************** picture ********************************) 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: 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 read pos; REAL VAR x, y, z; TEXT VAR r2 :: 16*""0"", r3 :: 24*""0"", i1 :: ""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) : (* X-Rotation *) 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 yrotate (PICTURE VAR p, REAL CONST angle): (* Y-Rotation *) REAL CONST s :: sind (angle), c :: cosd (angle); transform (p, ROW 4 ROW 3 REAL : (ROW 3 REAL : ( c , 0.0, -s ), ROW 3 REAL : ( 0.0, 1.0, 0.0 ), ROW 3 REAL : ( s , 0.0, c ), ROW 3 REAL : ( 0.0, 0.0, 0.0 ))) END PROC yrotate; PROC zrotate (PICTURE VAR p, REAL CONST angle): (* Z-Rotation *) REAL CONST s :: sind (angle), c :: cosd (angle); transform (p, ROW 4 ROW 3 REAL : (ROW 3 REAL : ( c , s , 0.0 ), ROW 3 REAL : ( -s , c , 0.0 ), ROW 3 REAL : ( 0.0, 0.0, 1.0 ), ROW 3 REAL : ( 0.0, 0.0, 0.0 ))) END PROC zrotate; PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) : IF phi <> 0.0 THEN rotate (p, phi) FI; IF theta <> 0.0 THEN yrotate (p, theta) FI; IF lambda <> 0.0 THEN zrotate (p, lambda) FI 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): TEXT VAR result :: ""0""0""0""0""; (* 23.09.87 -cw- *) replace (result, 1, pic.dim); (* wegen Heap-Ueberlauf *) replace (result, 2, pic.pen); result CAT pic.points; result END PROC text; PICTURE PROC picture (TEXT CONST text): PICTURE : (text ISUB 1, text ISUB 2, subtext (text, 5)) END PROC picture; END PACKET picture; (******************************** picfile *********************************) PACKET picfile DEFINES (* Autor: H.Indenbirken *) (* Stand: 23.02.1985 *) PICFILE, :=, picture file, select pen, selected pen, background, set values, get values, view, viewport, window, oblique, orthographic, perspective, extrema, put, get, to first pic, to eof, to pic, up, down, is first picture, eof, picture no, pictures, delete picture, insert picture, read picture, write picture, put picture: LET max pics = 1024, pic dataspace = 1102; TYPE PICFILE = BOUND STRUCT (INT size, pos, background, ROW 16 ROW 3 INT pens, ROW 16 BOOL hidden, ROW 3 ROW 2 REAL sizes, ROW 2 ROW 2 REAL limits, ROW 4 REAL angles, ROW 2 REAL obliques, ROW 3 REAL perspectives, ROW max pics PICTURE pic); TEXT VAR i text :: ""0""0"", r text :: ""0""0""0""0""0""0""0""0""; INT VAR i; OP := (PICFILE VAR dest, PICFILE CONST source): EXTERNAL 260 END OP := ; OP := (PICFILE VAR p, DATASPACE CONST d) : IF type (d) = pic dataspace THEN CONCR (p) := d ELIF type (d) < 0 THEN type (d, pic dataspace) ; CONCR (p) := d ; init picfile dataspace ; ELSE errorstop ("dataspace is no PICFILE") FI . init picfile dataspace : r.size := 0; r.pos := 0; r.background := 0; r.sizes [1][1] := 0.0; r.sizes [1][2] := 1.0; r.sizes [2][1] := 0.0; r.sizes [2][2] := 1.0; r.sizes [3][1] := 0.0; r.sizes [3][2] := 1.0; r.limits [1][1] := 0.0; r.limits [1][2] := 1.0; r.limits [2][1] := 0.0; r.limits [2][2] := 1.0; r.angles [1] := 0.0; r.angles [2] := 0.0; r.angles [3] := 0.0; r.angles [4] := 0.0; r.obliques [1] := 0.0; r.obliques [2] := 0.0; r.perspectives [1] := 0.0; r.perspectives [2] := 0.0; r.perspectives [3] := 0.0; FOR i FROM 1 UPTO 16 REP r.pens [i][1] := 1; r.pens [i][2] := 0; r.pens [i][3] := 1; r.hidden [i] := TRUE PER. r : CONCR (CONCR (p)). END OP :=; DATASPACE PROC picture file (TEXT CONST name) : IF exists (name) THEN old (name) ELSE new (name) FI END PROC picture file; PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type, BOOL CONST hidden): IF pen < 1 OR pen > 16 THEN errorstop ("pen out of range") FI; p.pens [pen][1] := colour; p.pens [pen][2] := thickness; p.pens [pen][3] := line type; p.hidden [pen] := hidden END PROC select pen; PROC selected pen (PICFILE CONST p, INT CONST pen, INT VAR colour, thickness, line type, BOOL VAR hidden): IF pen < 1 OR pen > 16 THEN errorstop ("pen out of range") FI; colour := p.pens [pen][1]; thickness := p.pens [pen][2]; line type := p.pens [pen][3]; hidden := p.hidden [pen] END PROC selected pen; INT PROC background (PICFILE CONST p): p.background END PROC background; PROC background (PICFILE VAR p, INT CONST colour): p.background := colour END PROC background; PROC get values (PICFILE CONST p, ROW 3 ROW 2 REAL VAR size, ROW 2 ROW 2 REAL VAR limits, ROW 4 REAL VAR angles, ROW 2 REAL VAR oblique, ROW 3 REAL VAR perspective) : size := p.sizes; limits := p.limits; angles := p.angles; oblique := p.obliques; perspective := p.perspectives; END PROC get values; PROC set values (PICFILE VAR p, ROW 3 ROW 2 REAL CONST size, ROW 2 ROW 2 REAL CONST limits, ROW 4 REAL CONST angles, ROW 2 REAL CONST oblique, ROW 3 REAL CONST perspective) : p.sizes := size; p.limits := limits; p.angles := angles; p.obliques := oblique; p.perspectives := perspective; END PROC set values; PROC view (PICFILE VAR p, REAL CONST alpha): p.angles [1] := alpha END PROC view; PROC view (PICFILE VAR p, REAL CONST phi, theta): p.angles [2] := sind (theta) * cosd (phi); p.angles [3] := sind (theta) * sind (phi); p.angles [4] := cosd (theta); END PROC view; PROC view (PICFILE VAR p, REAL CONST x, y, z): p.angles [2] := x; p.angles [3] := y; p.angles [4] := z END PROC view; PROC viewport (PICFILE VAR p,REAL CONST hor min,hor max,vert min,vert max) : p.limits [1][1] := hor min; p.limits [1][2] := hor max; p.limits [2][1] := vert min; p.limits [2][2] := vert max; END PROC viewport; PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) : window (p, x min, x max, y min, y max, 0.0, 1.0) END PROC window; PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, z min, z max) : p.sizes [1][1] := x min; p.sizes [1][2] := x max; p.sizes [2][1] := y min; p.sizes [2][2] := y max; p.sizes [3][1] := z min; p.sizes [3][2] := z max; END PROC window; PROC oblique (PICFILE VAR p, REAL CONST a, b) : p.obliques [1] := a; p.obliques [2] := b; p.perspectives [1] := 0.0; p.perspectives [2] := 0.0; p.perspectives [3] := 0.0 END PROC oblique; PROC orthographic (PICFILE VAR p) : p.obliques [1] := 0.0; p.obliques [2] := 0.0; p.perspectives [1] := 0.0; p.perspectives [2] := 0.0; p.perspectives [3] := 0.0 END PROC orthographic; PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) : p.obliques [1] := 0.0; p.obliques [2] := 0.0; p.perspectives [1] := cx; p.perspectives [2] := cy; p.perspectives [3] := cz END PROC perspective; PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) : REAL VAR dummy; extrema (p, x min, x max, y min, y max, dummy, dummy) END PROC extrema; PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) : REAL VAR new x min, new x max, new y min, new y max, new z min, new 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; FOR i FROM 1 UPTO p.size REP IF dim (p.pic [i]) = 2 THEN extrema (p.pic [i], new x min, new x max, new y min, new y max) ELSE extrema (p.pic [i], new x min, new x max, new y min, new y max, new z min, new z max) FI; x min := min (x min, new x min); x max := max (x max, new x max); y min := min (y min, new y min); y max := max (y max, new y max); z min := min (z min, new z min); z max := max (z max, new z max); PER END PROC extrema; PROC put (FILE VAR f, PICFILE CONST p): put line (f, parameter); FOR i FROM 1 UPTO p.size REP put line (f, text (p.pic [i])) PER . parameter: intern (p.size) + intern (p.pos) + intern (p.background) + intern (p.pens) + intern (p.hidden) + intern (p.sizes) + intern (p.limits) + intern (p.angles) + intern (p.obliques) + intern (p.perspectives) . END PROC put; PROC get (PICFILE VAR p, FILE VAR f): TEXT VAR record; get line (f, record); convert parameter; FOR i FROM 1 UPTO p.size REP get line (f, record); p.pic [i] := picture (record) PER . convert parameter: convert (record, p.size); convert (record, p.pos); convert (record, p.background); convert (record, p.pens); convert (record, p.hidden); convert (record, p.sizes); convert (record, p.limits); convert (record, p.angles); convert (record, p.obliques); convert (record, p.perspectives) . END PROC get; PROC to first pic (PICFILE VAR p): p.pos := 1 END PROC to first pic; PROC to eof (PICFILE VAR p): p.pos := p.size+1 END PROC to eof; PROC to pic (PICFILE VAR p, INT CONST n): IF n < 1 THEN errorstop ("Position underflow") ELIF n > p.size THEN errorstop ("Position after end of PICFILE") ELSE p.pos := n FI END PROC to pic; PROC up (PICFILE VAR p): to pic (p, p.pos-1) END PROC up; PROC up (PICFILE VAR p, INT CONST n): to pic (p, p.pos-n) END PROC up; PROC down (PICFILE VAR p): to pic (p, p.pos+1) END PROC down; PROC down (PICFILE VAR p, INT CONST n): to pic (p, p.pos+n) END PROC down; BOOL PROC is first picture (PICFILE CONST p): p.pos = 1 END PROC is first picture; BOOL PROC eof (PICFILE CONST p): p.pos >= p.size END PROC eof; INT PROC picture no (PICFILE CONST p): p.pos END PROC picture no; INT PROC pictures (PICFILE CONST p): p.size END PROC pictures; PROC delete picture (PICFILE VAR p) : INT VAR i; FOR i FROM p.pos+1 UPTO p.size REP p.pic [i-1] := p.pic [i] PER; p.pic [p.size] := nilpicture; IF p.size > 1 THEN p.size DECR 1 FI END PROC delete picture; PROC insert picture (PICFILE VAR p) : INT VAR i; IF p.size >= max pics THEN errorstop ("PICFILE overflow") ELSE p.size INCR 1; FOR i FROM p.size DOWNTO p.pos+1 REP p.pic [i] := p.pic [i-1] PER; p.pic [p.pos] := nilpicture; FI END PROC insert picture; PROC read picture (PICFILE VAR p, PICTURE VAR pic) : pic := p.pic (p.pos) . END PROC read picture; PROC write picture (PICFILE VAR p, PICTURE CONST pic) : p.pic (p.pos) := pic . END PROC write picture; PROC put picture (PICFILE VAR p, PICTURE CONST pic) : IF p.size >= max pics THEN errorstop ("PICFILE overflow") ELSE p.size INCR 1; p.pic [p.size] := pic; FI END PROC put picture; TEXT PROC intern (INT CONST n): replace (i text, 1, n); i text END PROC intern; TEXT PROC intern (ROW 16 ROW 3 INT CONST n): INT VAR i, j; TEXT VAR result :: ""; FOR i FROM 1 UPTO 16 REP FOR j FROM 1 UPTO 3 REP result CAT intern (n [i][j]) PER PER; result END PROC intern; TEXT PROC intern (ROW 16 BOOL CONST n): INT VAR i, result :: 0; FOR i FROM 1 UPTO 16 REP IF n [i] THEN set bit (result, i-1) FI PER; intern (result) END PROC intern; TEXT PROC intern (REAL CONST r): replace (r text, 1, r); r text END PROC intern; TEXT PROC intern (ROW 3 ROW 2 REAL CONST r): INT VAR i, j; TEXT VAR result :: ""; FOR i FROM 1 UPTO 3 REP FOR j FROM 1 UPTO 2 REP result CAT intern (r [i][j]) PER PER; result END PROC intern; TEXT PROC intern (ROW 2 ROW 2 REAL CONST r): INT VAR i, j; TEXT VAR result :: ""; FOR i FROM 1 UPTO 2 REP FOR j FROM 1 UPTO 2 REP result CAT intern (r [i][j]) PER PER; result END PROC intern; TEXT PROC intern (ROW 4 REAL CONST r): intern (r [1]) + intern (r [2]) + intern (r [3]) + intern (r [4]) END PROC intern; TEXT PROC intern (ROW 3 REAL CONST r): intern (r [1]) + intern (r [2]) + intern (r [3]) END PROC intern; TEXT PROC intern (ROW 2 REAL CONST r): intern (r [1]) + intern (r [2]) END PROC intern; PROC convert (TEXT VAR record, INT VAR n): n := record ISUB 1; record := subtext (record, 3) END PROC convert; PROC convert (TEXT VAR record, ROW 16 ROW 3 INT VAR n): INT VAR i, j; FOR i FROM 1 UPTO 16 REP FOR j FROM 1 UPTO 3 REP convert (record, n [i][j]) PER PER END PROC convert; PROC convert (TEXT VAR record, ROW 16 BOOL VAR n): INT VAR i, result; convert (record, result); FOR i FROM 1 UPTO 16 REP n [i] := bit (i-1, result) PER END PROC convert; PROC convert (TEXT VAR record, REAL VAR r): r := record RSUB 1; record := subtext (record, 9) END PROC convert; PROC convert (TEXT VAR record, ROW 3 ROW 2 REAL VAR r): INT VAR i, j; FOR i FROM 1 UPTO 3 REP FOR j FROM 1 UPTO 2 REP convert (record, r [i][j]) PER PER; END PROC convert; PROC convert (TEXT VAR record, ROW 2 ROW 2 REAL VAR r): INT VAR i, j; FOR i FROM 1 UPTO 2 REP FOR j FROM 1 UPTO 2 REP convert (record, r [i][j]) PER PER; END PROC convert; PROC convert (TEXT VAR record, ROW 4 REAL VAR r): convert (record, r [1]); convert (record, r [2]); convert (record, r [3]); convert (record, r [4]) END PROC convert; PROC convert (TEXT VAR record, ROW 3 REAL VAR r): convert (record, r [1]); convert (record, r [2]); convert (record, r [3]) END PROC convert; PROC convert (TEXT VAR record, ROW 2 REAL VAR r): convert (record, r [1]); convert (record, r [2]) END PROC convert; END PACKET picfile; (********************************* devices ********************************) PACKET devices DEFINES PLOTTER, select plotter, install plotter, plotters, plotter, no plotter, name, channel, station, actual plotter, drawing area, plotter info, :=, = : LET trenn = "/"; TYPE PLOTTER = STRUCT (INT station, channel, TEXT name); PLOTTER CONST noplotter :: PLOTTER : (0,0,""); PLOTTER VAR plotter id :: no plotter; TARGET VAR devices; TEXT VAR plotter set; INT VAR act plotter; OP := (PLOTTER VAR dest, PLOTTER CONST source): CONCR (dest) := CONCR (source) END OP := ; BOOL OP = (PLOTTER CONST a, b): (a.station = b.station) AND (a.channel = b.channel) AND (a.name = b.name ) END OP =; PLOTTER PROC plotter: plotter id END PROC plotter; PLOTTER PROC plotter (TEXT CONST def plotter): select target (devices, def plotter, plotter set); IF plotter set = "" THEN IF def plotter = "" THEN act plotter := 0; no plotter ELSE errorstop ("Unbekannter Plot-Id : " + def plotter); no plotter FI ELSE select;plotter id FI. select: INT VAR tp; PLOTTER VAR plotter id; plotter id.station := int(def plotter); tp := pos (def plotter, trenn) + 1; plotter id.channel := int(subtext (def plotter,tp)); plotter id.name := subtext (def plotter, pos (def plotter,trenn,tp)+1); END PROC plotter; PROC select plotter: THESAURUS VAR plotter list :: empty thesaurus; TEXT VAR plotter name; INT VAR index :: 0; get (plotters, plotter name, index); WHILE index > 0 REP insert (plotter list,plotter info (plotter name,60)); get (plotters, plotter name, index) PER; select plotter (name (plotters, link (plotter list, one(plotter list)))) END PROC select plotter; PROC select plotter (PLOTTER CONST plotter): select plotter (text (plotter.station) + trenn + text (plotter.channel) + trenn + plotter.name) END PROC select plotter; PROC select plotter (TEXT CONST def plotter): select target (devices, def plotter, plotter set); IF plotter set = "" THEN IF def plotter = "" THEN act plotter := 0; plotter id := no plotter ELSE errorstop ("Unbekannter Plot-Id : " + def plotter) FI ELSE select FI. select: INT VAR xp, yp, tp; REAL VAR xc, yc; act plotter := link (plotters, def plotter); plotter id.station := int(def plotter); tp := pos (def plotter, trenn) + 1; plotter id.channel := int(subtext (def plotter,tp)); plotter id.name := subtext (def plotter, pos (def plotter,trenn,tp)+1); drawing area (xc, yc, xp, yp); set drawing area (xc, yc, real (xp), real (yp)); END PROC select plotter; PROC install plotter (TARGET VAR new plotset): THESAURUS VAR new plotter :: target names (new plotset); INT VAR index :: 0; TEXT VAR name,set; initialize target (devices); get (new plotter,name,index); WHILE index > 0 REP select target (new plotset, name, set); complete target (devices, name, set); get (new plotter, name, index) PER END PROC install plotter; INT PROC actual plotter: act plotter END PROC actual plotter; THESAURUS PROC plotters: target names (devices) END PROC plotters; TEXT PROC name (PLOTTER CONST plotter): plotter.name END PROC name; INT PROC channel (PLOTTER CONST plotter): plotter.channel END PROC channel; INT PROC station (PLOTTER CONST plotter): plotter.station END PROC station; PROC drawing area (REAL VAR xcm, ycm, INT VAR xp, yp): IF plotter set <> "" THEN INT VAR cp; xp := int(plotter set); cp := pos (plotter set,",")+1; yp := int (subtext (plotter set,cp)); cp := pos (plotter set,",",cp)+1; xcm := real (subtext (plotter set,cp)); cp := pos (plotter set,",",cp)+1; ycm := real (subtext (plotter set,cp)) FI END PROC drawing area; PROC drawing area (REAL VAR xcm, ycm, INT VAR xp, yp,PLOTTER CONST pl): PLOTTER CONST keep :: plotter; select plotter (pl); drawing area (xcm, ycm, xp, yp); select plotter (keep) END PROC drawing area; TEXT PROC plotter info (TEXT CONST plotter id,INT CONST len): INT VAR tp :: pos (plotter id, trenn)+1; TEXT VAR plotter name :: plotter id, station :: "/Station" + text (int(plotter name),2), kanal :: " Kanal" + text (int (subtext (plottername,tp)),3); plotter name := subtext (plotter name, pos (plotter name, trenn,tp)+1) + " "; INT VAR llen :: length (plotter name + kanal + station); plotter name + (max(len-llen,0) * ".") + kanal + station END PROC plotter info; END PACKET devices