diff options
Diffstat (limited to 'app/mpg/2.2/src/GRAPHIK.Basis')
| -rw-r--r-- | app/mpg/2.2/src/GRAPHIK.Basis | 1574 |
1 files changed, 1574 insertions, 0 deletions
diff --git a/app/mpg/2.2/src/GRAPHIK.Basis b/app/mpg/2.2/src/GRAPHIK.Basis new file mode 100644 index 0000000..733297d --- /dev/null +++ b/app/mpg/2.2/src/GRAPHIK.Basis @@ -0,0 +1,1574 @@ +(**************************************************************************) +(* *) +(* 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 + |