From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- system/std.graphik/1.8.7/src/Beispiel.Kreuz | 41 ++ system/std.graphik/1.8.7/src/Beispiel.Sinus | 45 ++ system/std.graphik/1.8.7/src/GRAPHIK.Picfile | 738 ++++++++++++++++++++++ system/std.graphik/1.8.7/src/GRAPHIK.Plot | 285 +++++++++ system/std.graphik/1.8.7/src/GRAPHIK.Plotter | 247 ++++++++ system/std.graphik/1.8.7/src/GRAPHIK.Server | 97 +++ system/std.graphik/1.8.7/src/GRAPHIK.Transform | 366 +++++++++++ system/std.graphik/1.8.7/src/GRAPHIK.vektor plot | 506 +++++++++++++++ system/std.graphik/1.8.7/src/HP7475.plot | 254 ++++++++ system/std.graphik/1.8.7/src/PC.plot | 758 +++++++++++++++++++++++ system/std.graphik/1.8.7/src/ZEICHENSATZ | Bin 0 -> 11776 bytes system/std.graphik/1.8.7/src/gen Graphik | 16 + system/std.graphik/1.8.7/src/gen Plotter | 16 + system/std.graphik/1.8.7/src/graphik editor | 324 ++++++++++ 14 files changed, 3693 insertions(+) create mode 100644 system/std.graphik/1.8.7/src/Beispiel.Kreuz create mode 100644 system/std.graphik/1.8.7/src/Beispiel.Sinus create mode 100644 system/std.graphik/1.8.7/src/GRAPHIK.Picfile create mode 100644 system/std.graphik/1.8.7/src/GRAPHIK.Plot create mode 100644 system/std.graphik/1.8.7/src/GRAPHIK.Plotter create mode 100644 system/std.graphik/1.8.7/src/GRAPHIK.Server create mode 100644 system/std.graphik/1.8.7/src/GRAPHIK.Transform create mode 100644 system/std.graphik/1.8.7/src/GRAPHIK.vektor plot create mode 100644 system/std.graphik/1.8.7/src/HP7475.plot create mode 100644 system/std.graphik/1.8.7/src/PC.plot create mode 100644 system/std.graphik/1.8.7/src/ZEICHENSATZ create mode 100644 system/std.graphik/1.8.7/src/gen Graphik create mode 100644 system/std.graphik/1.8.7/src/gen Plotter create mode 100644 system/std.graphik/1.8.7/src/graphik editor (limited to 'system/std.graphik/1.8.7/src') diff --git a/system/std.graphik/1.8.7/src/Beispiel.Kreuz b/system/std.graphik/1.8.7/src/Beispiel.Kreuz new file mode 100644 index 0000000..e29f24a --- /dev/null +++ b/system/std.graphik/1.8.7/src/Beispiel.Kreuz @@ -0,0 +1,41 @@ +initialisiere picfile; +zeichne die x achse; +zeichne die y achse; +zeichne die z achse; +stelle das achsenkreuz dar . + +initialisiere picfile: + PICFILE VAR p :: picture file ("KREUZ") . + +zeichne die x achse: + PICTURE VAR x achse := nilpicture; + move (x achse, -1.0, 0.0, 0.0); + draw (x achse, "-X", 0.0, 0.0, 0.0); + draw (x achse, 1.0, 0.0, 0.0); + draw (x achse, "+X", 0.0, 0.0, 0.0); + put picture (p, x achse) . + +zeichne die y achse: + PICTURE VAR y achse := nilpicture; + move (y achse, 0.0, -1.0, 0.0); + draw (y achse, "-Y", 0.0, 0.0, 0.0); + draw (y achse, 0.0, 1.0, 0.0); + draw (y achse, "+Y", 0.0, 0.0, 0.0); + put picture (p, y achse) . + +zeichne die z achse: + PICTURE VAR z achse := nilpicture; + move (z achse, 0.0, 0.0, -1.0); + draw (z achse, "-Z", 0.0, 0.0, 0.0); + draw (z achse, 0.0, 0.0, 1.0); + draw (z achse, "+Z", 0.0, 0.0, 0.0); + put picture (p, z achse) . + +stelle das achsenkreuz dar: + viewport (p, 0.0, 1.0, 0.0, 1.0); + window (p, -1.1, 1.1, -1.1, 1.1); + oblique (p, 0.25, 0.15); + plot (p) . + + + diff --git a/system/std.graphik/1.8.7/src/Beispiel.Sinus b/system/std.graphik/1.8.7/src/Beispiel.Sinus new file mode 100644 index 0000000..beac7cd --- /dev/null +++ b/system/std.graphik/1.8.7/src/Beispiel.Sinus @@ -0,0 +1,45 @@ +initialisiere picfile; +zeichne überschrift; +zeichne achsen; +zeichne sinuskurve; +wähle darstellung; +plot (p) . + +initialisiere picfile: + PICFILE VAR p :: picture file ("SINUS") . + +zeichne überschrift: + PICTURE VAR überschrift :: nilpicture; + move (überschrift, -pi/2.0, 1.0); + draw (überschrift, "sinus (x) [-pi, +pi]", 0.0, 1.0, 0.6); + put picture (p, überschrift) . + +zeichne achsen: + PICTURE VAR achsen :: nilpicture; + zeichne x achse; + zeichne y achse; + put picture (p, achsen) . + +zeichne x achse: + move (achsen, -pi, 0.0); + draw (achsen, pi, 0.0) . + +zeichne y achse: + move (achsen, 0.0, -1.0); + draw (achsen, 0.0, +1.0) . + +zeichne sinuskurve: + PICTURE VAR sinus :: nilpicture; + REAL VAR x :: -pi; + + move (sinus, x, sin (x)); + REP x INCR 0.1; + draw (sinus, x, sin (x)) + UNTIL x >= pi PER; + + put picture (p, sinus) . + +wähle darstellung: + window (p, -pi, pi, -1.0, 1.3); + viewport (p, 0.0, 0.0, 0.0, 0.0) . + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Picfile b/system/std.graphik/1.8.7/src/GRAPHIK.Picfile new file mode 100644 index 0000000..3accf52 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Picfile @@ -0,0 +1,738 @@ +PACKET picture DEFINES (*Autor: Heiko.Indenbirken *) + PICTURE, (*Stand: 12.03.1985 *) + :=, CAT, nilpicture, (*Änderung: 20.08.85/10:38 *) + draw, draw r, (*Änderung: 05.08.86/12:21 *) + move, move r, + mark, bar, circle, + length, dim, pen, where, + extrema, rotate, stretch, translate, + picture: + +LET draw key = 1, + move key = 2, + text key = 3, + move r key = 4, + draw r key = 5, + bar 2 key = 6, + bar 3 key = 7, + circle key = 8, + mark key = 9, + max length = 31974; + +LET overflow = "Picture overflow", + pen range = "pen out of range [0-16]", + dim 3 = "Picture is 3 dimensional", + dim 2 = "Picture is 2 dimensional", + dim init = "Picture isn't initialized", + wrong key = "wrong key code", + nil = "", + zero = ""0""; + +TYPE PICTURE = STRUCT (INT dim, pen, TEXT points); + + +INT VAR read pos; +REAL VAR x, y, z; +TEXT VAR r1 :: 8*zero, r2 :: 16*zero, r3 :: 24*zero, i1 :: 2*zero; + +OP := (PICTURE VAR l, PICTURE CONST r) : + CONCR (l) := CONCR (r) +END OP :=; + +OP CAT (PICTURE VAR l, PICTURE CONST r) : + check dim (l, r.dim); + IF length (l.points) > max length - length (r.points) + THEN errorstop (overflow) FI; + + l.points CAT r.points +END OP CAT; + +PICTURE PROC nilpicture : + PICTURE : (0, 1, nil) +END PROC nilpicture; + +PICTURE PROC nilpicture (INT CONST pen): + PICTURE : (0, pen, nil) +END PROC nilpicture; + +PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright): + write (p.points, 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.points, x, y, z, draw key) +END PROC draw; + +PROC draw (PICTURE VAR p, REAL CONST x, y) : + check dim (p, 2); + write (p.points, x, y, draw key) +END PROC draw; + +PROC draw r (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, 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.points, x, y, draw r key) +END PROC draw r; + +PROC move (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, x, y, z, move key) +END PROC move; + +PROC move (PICTURE VAR p, REAL CONST x, y) : + check dim (p, 2); + write (p.points, x, y, move key) +END PROC move; + +PROC move r (PICTURE VAR p, REAL CONST x, y, z) : + check dim (p, 3); + write (p.points, 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.points, x, y, move r key) +END PROC move r; + +PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern): + check dim (p, 2); + write (p.points, width, height, pattern, bar 2 key) +END PROC bar; + +PROC bar (PICTURE VAR p, REAL CONST from, to, height, INT CONST pattern): + check dim (p, 2); + write (p.points, from, to, height, pattern, bar 3 key) +END PROC bar; + +PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern): + check dim (p, 2); + write (p.points, radius, from, to, pattern, circle key) +END PROC circle; + +PROC mark (PICTURE VAR p, REAL CONST size, INT CONST no): + write (p.points, size, no, mark key) +END PROC mark; + +PROC write (TEXT VAR points, REAL CONST x, y, z, INT CONST key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r3, 1, x); + replace (r3, 2, y); + replace (r3, 3, z); + points CAT r3 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, REAL CONST x, y, INT CONST key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r2, 1, x); + replace (r2, 2, y); + points CAT r2 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, REAL CONST x, y, INT CONST n, key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r2, 1, x); + replace (r2, 2, y); + points CAT r2; + replace (i1, 1, n); + points CAT i1 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, REAL CONST x, y, z, INT CONST n, key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r3, 1, x); + replace (r3, 2, y); + replace (r3, 3, z); + points CAT r3; + replace (i1, 1, n); + points CAT i1 + ELSE errorstop (overflow) FI +END PROC write; + +PROC write (TEXT VAR points, TEXT CONST t, REAL CONST angle, height, bright, + INT CONST key) : + IF max length - length (points) >= length (t) + THEN points CAT code (key); + replace (i1, 1, length (t)); + points CAT i1; + points CAT t; + replace (r3, 1, angle); + replace (r3, 2, height); + replace (r3, 3, bright); + points CAT r3 + FI; +END PROC write; + +PROC write (TEXT VAR points, REAL CONST size, INT CONST no, key) : + IF length (points) < max length + THEN points CAT code (key); + replace (r1, 1, size); + points CAT r1; + replace (i1, 1, no); + points CAT i1; + ELSE errorstop (overflow) FI +END PROC write; + +PROC check dim (PICTURE VAR p, INT CONST dim): + IF p.dim = dim + THEN + ELIF p.dim = 0 + THEN p.dim := dim + ELSE errorstop (dimension) FI . + +dimension: + IF p.dim = 2 + THEN dim 2 + ELIF p.dim = 3 + THEN dim 3 + ELSE dim init 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; + +PICTURE PROC pen (PICTURE CONST p, INT CONST pen) : + IF pen < 0 OR pen > 16 + THEN errorstop (pen range) FI; + + PICTURE:(p.dim, pen, p.points) +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 (dim 3) + 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 (dim 2) + 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 text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) 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 text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) 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 text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) 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 text key : read pos INCR next int + 24 + CASE bar 2 key : read pos INCR 18 + CASE bar 3 key, circle key : read pos INCR 26 + CASE mark key: read pos INCR 4 + OTHERWISE errorstop (wrong key) 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; + +PROC picture (PICTURE CONST pic, TEXT VAR points, INT VAR dim, pen): + dim := pic.dim; + pen := pic.pen; + points := pic.points; +END PROC picture; + +END PACKET picture; + +PACKET picfile DEFINES (*Autor: Heiko Indenbirken *) + (*Stand: 23.02.1985 *) + PICFILE, :=, picture file, (*Änderung: 13.10.89/23:11 *) + select pen, selected pen, background, + set values, get values, + view, viewport, window, + oblique, orthographic, perspective, + extrema, + + to pic, up, down, + eof, picture no, pictures, + delete picture, insert picture, + read picture, write picture, + get picture, put picture: + + +LET no picfile = "dataspace is no PICFILE", + pen range = "pen out of range", + pos under = "Position underflow", + pos over = "Position overflow", + pic over = "PICFILE overflow"; + +LET max pics = 1024, + pic dataspace = 1103; + + +TYPE PICFILE = BOUND STRUCT (INT size, pos, background, + ROW 16 ROW 3 INT pens, + 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); + +INT VAR i; + +OP := (PICFILE VAR l, PICFILE CONST r): + 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 (no picfile) FI . + +init picfile dataspace : + r.size := 0; + r.pos := 1; + r.background := 0; + r.sizes := 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)); + r.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, 0.0), + ROW 2 REAL : (0.0, 0.0)); + r.angles := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0); + r.obliques := ROW 2 REAL : (0.0, 0.0); + r.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0); + FOR i FROM 1 UPTO 16 + REP r.pens [i] := ROW 3 INT : (1, 0, 1) 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): + IF pen < 1 OR pen > 16 + THEN errorstop (pen range) FI; + p.pens [pen] := ROW 3 INT : (colour, thickness, line type) +END PROC select pen; + +PROC selected pen (PICFILE CONST p, INT CONST pen, + INT VAR colour, thickness, line type): + IF pen < 1 OR pen > 16 + THEN errorstop (pen range) FI; + colour := p.pens [pen][1]; + thickness := p.pens [pen][2]; + line type := p.pens [pen][3]; +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 := ROW 2 ROW 2 REAL : (ROW 2 REAL : (hor min, hor max), + ROW 2 REAL : (vert min, 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 := 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)) +END PROC window; + +PROC oblique (PICFILE VAR p, REAL CONST a, b) : + p.obliques := ROW 2 REAL : (a, b); + p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0) +END PROC oblique; + +PROC orthographic (PICFILE VAR p) : + p.obliques := ROW 2 REAL : (0.0, 0.0); + p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0) +END PROC orthographic; + +PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) : + p.obliques := ROW 2 REAL : (0.0, 0.0); + p.perspectives := ROW 3 REAL : (cx, cy, 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 to pic (PICFILE VAR p, INT CONST n): + IF n < 1 + THEN errorstop (pos under) + ELIF n <= p.size+1 AND n <= max pics + THEN p.pos := n + ELSE errorstop (pos over) 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 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 (pic over) + 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 get picture (PICFILE VAR p, PICTURE VAR pic) : + IF p.pos > p.size + THEN errorstop (pos over) + ELSE pic := p.pic [p.pos]; + p.pos INCR 1; + FI +END PROC get picture; + +PROC put picture (PICFILE VAR p, PICTURE CONST pic) : + IF p.pos > max pics + THEN errorstop (pic over) + ELSE p.pic [p.pos] := pic; + + IF p.pos > p.size + THEN p.size INCR 1 FI; + p.pos INCR 1 + FI +END PROC put picture; + +END PACKET picfile + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Plot b/system/std.graphik/1.8.7/src/GRAPHIK.Plot new file mode 100644 index 0000000..5087abb --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Plot @@ -0,0 +1,285 @@ +PACKET basis plot DEFINES (* Autor: Heiko Indenbirken*) + (* Stand: 12.04.85 *) + (*Änderung: 06.08.86/10:03 *) +(* ****************** Hardwareunabhängiger Teil ********************* *) +(* *) +(* *) +(* Im Harwareunabhängigen Paket 'basis plot' werden folgende *) +(* Prozeduren definiert: *) +(* Procedure : Bedeutung *) +(* ---------------------------------------------------------------- *) +(* move : Positioniert auf (x, y,[z]) in Weltkoordinaten*) +(* draw : Zeichnet eine Linie bis zum Punkt (x, y, [z]).*) +(* move r : Positioniert (x, y, [z]) weiter *) +(* draw r : Zeichnet (x, y, [z]) weiter *) +(* *) +(* draw : Zeichnet einen Text *) +(* *) +(* mark : Marker mit (no, size) *) +(* bar : Balken mit (width, height, pattern) *) +(* bar : Balken mit (from, to, width, pattern) *) +(* circle : Kreis(segment) mit (radius, from, to, pattern)*) +(* *) +(* where : Gibt die aktuelle Stiftposition (x, y, [z]) *) +(* *) +(*************************************************************************) + + move, draw, + move r, draw r, + mark, bar, circle, + where: + +LET POS = STRUCT (REAL x, y, z); + +POS VAR pos :: POS : (0.0, 0.0, 0.0); +INT VAR h :: 0, v :: 0; + +PROC move (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + move (h, v); + pos := POS : (x, y, 0.0) +END PROC move; + +PROC move (REAL CONST x, y, z) : + transform (x, y, z, h, v); + move (h, v); + pos := POS : (x, y, z) +END PROC move; + +PROC draw (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + draw (h, v); + pos := POS : (x, y, 0.0) +END PROC draw; + +PROC draw (REAL CONST x, y, z) : + transform (x, y, z, h, v); + draw (h, v); + pos := POS : (x, y, z) +END PROC draw; + +PROC move r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC move r; + +PROC move r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC move r; + +PROC draw r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC draw r; + +PROC draw r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC draw r; + +PROC where (REAL VAR x, y) : + x := pos.x; y := pos.y +END PROC where; + +PROC where (REAL VAR x, y, z) : + x := pos.x; y := pos.y; z := pos.z +END PROC where; + +PROC draw (TEXT CONST msg, REAL CONST angle, height percent, width percent): + draw (msg, angle, height (height percent), width (width percent)) . +END PROC draw; + +PROC mark (REAL CONST size, INT CONST no): + marker (h, v, no, diagonal (size)) +END PROC mark; + +PROC bar (REAL CONST width, height, INT CONST pattern): + INT VAR diff, up, zero x, zero y; + transform (0.0, 0.0, 0.0, zero x, zero y); + transform (width*0.5, height, 0.0, diff, up); + bar (h-(diff-zero x), v, h+(diff-zero x), v+(up-zero y), pattern); + move (h, v) + +END PROC bar; + +PROC bar (REAL CONST from, to, height, INT CONST pattern): + INT VAR from h, to h, up; + transform (from, height, 0.0, from h, up); + transform (to, height, 0.0, to h, up); + bar (from h, v, to h, up, pattern); + move (h, v) + +END PROC bar; + +PROC circle (REAL CONST rad, from, to, INT CONST pattern): + circle (h, v, diagonal (rad), from, to, pattern) . + +END PROC circle; + +ENDPACKET basis plot; + +PACKET plot DEFINES plot: (*Autor: Heiko Indenbirken *) + (*Stand: 13.10.89/22:31 *) + +LET draw key = 1, + move key = 2, + text key = 3, + move r key = 4, + draw r key = 5, + bar 2 key = 6, + bar 3 key = 7, + circle key = 8, + mark key = 9; + +LET dim error = "PICTURE not initialized", + key error = "wrong key code: "; + +TEXT VAR points; +INT VAR pic length, pic pen, pic dim, read pos; +PICTURE VAR pic; + +PROC plot (PICTURE CONST pic): + init plot; + IF pic dim = 2 + THEN plot two dim pic + ELIF pic dim = 3 + THEN plot three dim pic + ELIF NOT (pic dim = 0 AND pic length = 0) + THEN errorstop (dim error) FI; + points := "" . + +init plot: + picture (pic, points, pic dim, pic pen); + pic length := length (points); + read pos := 0 . + +plot two dim pic: + WHILE read pos < pic length + REP plot two dim position PER . + +plot two dim position : + read pos INCR 1; + SELECT key 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 text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) 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 key 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 text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) END SELECT . + +key: + code (points SUB read pos) . + +END PROC plot; + +REAL PROC next real: + read pos INCR 8; + subtext (points, read pos-7, read pos) RSUB 1 . +END PROC next real; + +INT PROC next int: + read pos INCR 2; + subtext (points, read pos-1, read pos) ISUB 1 . +END PROC next int; + +TEXT PROC next text: + INT CONST text length :: next int; + read pos INCR text length; + subtext (points, read pos-text length+1, read pos) . +END PROC next text; + +PROC plot (TEXT CONST name) : + PICFILE VAR p :: old (name); + plot (p); +END PROC plot; + +PROC plot (PICFILE VAR p) : + set projektion; + disable stop; + begin plot; + clear screen; + plot pictures (p); + errorcheck; + end plot . + +set projektion: + ROW 3 ROW 2 REAL VAR size; + ROW 2 ROW 2 REAL VAR limit; + ROW 4 REAL VAR angles; + ROW 2 REAL VAR oblique; + ROW 3 REAL VAR perspective; + + get values (p, size, limit, angles, oblique, perspective); + set values (size, limit, angles, oblique, perspective) . + +clear screen: + INT VAR x0, y0, x1, y1, h max, v max; + REAL VAR x cm, y cm; + + IF background (p) > -1 + THEN clear + ELSE drawing area (x cm, y cm, h max, v max); + new values (x cm, y cm, h max, v max, x0, x1 , y0, y1); + set range (max (0, x0), max (0, y0), min (h max, x1), min (v max, y1)) + FI . + +errorcheck: + IF is error + THEN line; + put line ("Erorr at PICTURE No " + text (picture no (p))); + FI . + +END PROC plot; + +PROC plot pictures (PICFILE VAR p): + INT VAR back :: abs (background (p)), no; + enable stop; + FOR no FROM 1 UPTO pictures (p) + REP to pic (p, no); + read picture (p, pic); + + IF this picture is ok + THEN set pen of pic; + plot (pic) + FI + PER . + +this picture is ok: + pen (pic) <> 0 AND length (pic) > 0 . + +set pen of pic: + INT VAR colour, thick, type; + selected pen (p, pen (pic), colour, thick, type); + set pen (back, colour, thick, type) . + +END PROC plot pictures; + +END PACKET plot + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Plotter b/system/std.graphik/1.8.7/src/GRAPHIK.Plotter new file mode 100644 index 0000000..a55e515 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Plotter @@ -0,0 +1,247 @@ +PACKET plotter DEFINES plotter: (*Autor: Heiko Indenbirken *) + (*Stand: 13.10.89/22:31 *) + (*Änderung: 08.09.86/15:47 *) + +LET POS = STRUCT (REAL x, y, z); + +POS VAR pos :: POS : (0.0, 0.0, 0.0); +INT VAR h :: 0, v :: 0; + +PROC move (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + move (h, v); + pos := POS : (x, y, 0.0) +END PROC move; + +PROC move (REAL CONST x, y, z) : + transform (x, y, z, h, v); + move (h, v); + pos := POS : (x, y, z) +END PROC move; + +PROC draw (REAL CONST x, y) : + transform (x, y, 0.0, h, v); + draw (h, v); + pos := POS : (x, y, 0.0) +END PROC draw; + +PROC draw (REAL CONST x, y, z) : + transform (x, y, z, h, v); + draw (h, v); + pos := POS : (x, y, z) +END PROC draw; + +PROC move r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC move r; + +PROC move r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + move (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC move r; + +PROC draw r (REAL CONST x, y) : + transform (pos.x+x, pos.y+y, pos.z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z) +END PROC draw r; + +PROC draw r (REAL CONST x, y, z) : + transform (pos.x+x, pos.y+y, pos.z+z, h, v); + draw (h, v); + pos := POS : (pos.x+x, pos.y+y, pos.z+z) +END PROC draw r; + +PROC draw (TEXT CONST msg, REAL CONST angle, height percent, width percent): + draw (msg, angle, height (height percent), width (width percent)) . +END PROC draw; + +PROC mark (REAL CONST size, INT CONST no): + marker (h, v, no, diagonal (size)) +END PROC mark; + +PROC bar (REAL CONST width, height, INT CONST pattern): + INT VAR diff, up, zero x, zero y; + transform (0.0, 0.0, 0.0, zero x, zero y); + transform (width*0.5, height, 0.0, diff, up); + bar (h-(diff-zero x), v, h+(diff-zero x), v+(up-zero y), pattern); + move (h, v) + +END PROC bar; + +PROC bar (REAL CONST from, to, height, INT CONST pattern): + INT VAR from h, to h, up; + transform (from, height, 0.0, from h, up); + transform (to, height, 0.0, to h, up); + bar (from h, v, to h, up, pattern); + move (h, v) + +END PROC bar; + +PROC circle (REAL CONST rad, from, to, INT CONST pattern): + circle (h, v, diagonal (rad), from, to, pattern) . + +END PROC circle; + + +(* *) +LET draw key = 1, + move key = 2, + text key = 3, + move r key = 4, + draw r key = 5, + bar 2 key = 6, + bar 3 key = 7, + circle key = 8, + mark key = 9; + +LET dim error = "PICTURE not initialized", + key error = "wrong key code: "; + +TEXT VAR points; +INT VAR pic length, pic pen, pic dim, read pos; +PICTURE VAR pic; + +PROC plot (PICTURE CONST pic): + init plot; + IF pic dim = 2 + THEN plot two dim pic + ELIF pic dim = 3 + THEN plot three dim pic + ELIF NOT (pic dim = 0 AND pic length = 0) + THEN errorstop (dim error) FI; + points := "" . + +init plot: + picture (pic, points, pic dim, pic pen); + pic length := length (points); + read pos := 0 . + +plot two dim pic: + WHILE read pos < pic length + REP plot two dim position PER . + +plot two dim position : + read pos INCR 1; + SELECT key 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 text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) 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 key 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 text key: draw (next text, next real, next real, next real) + CASE bar 2 key: bar (next real, next real, next int) + CASE bar 3 key: bar (next real, next real, next real, next int) + CASE circle key: circle (next real, next real, next real, next int) + CASE mark key: mark (next real, next int) + OTHERWISE errorstop (key error + text (key)) END SELECT . + +key: + code (points SUB read pos) . + +END PROC plot; + +REAL PROC next real: + read pos INCR 8; + subtext (points, read pos-7, read pos) RSUB 1 . +END PROC next real; + +INT PROC next int: + read pos INCR 2; + subtext (points, read pos-1, read pos) ISUB 1 . +END PROC next int; + +TEXT PROC next text: + INT CONST text length :: next int; + read pos INCR text length; + subtext (points, read pos-text length+1, read pos) . +END PROC next text; + +PROC plotter (TEXT CONST name) : + PICFILE VAR p :: old (name); + plotter (p); +END PROC plotter; + +PROC plotter (PICFILE VAR p) : + set projektion; + disable stop; + begin plot; + clear screen; + plot pictures (p); + errorcheck; + end plot . + +set projektion: + ROW 3 ROW 2 REAL VAR size; + ROW 2 ROW 2 REAL VAR limit; + ROW 4 REAL VAR angles; + ROW 2 REAL VAR oblique; + ROW 3 REAL VAR perspective; + get values (p, size, limit, angles, oblique, perspective); + set values (size, limit, angles, oblique, perspective) . + +clear screen: + INT VAR x0, y0, x1, y1, h max, v max; + REAL VAR x cm, y cm; + + IF background (p) > -1 + THEN clear + ELSE drawing area (x cm, y cm, h max, v max); + new values (x cm, y cm, h max, v max, x0, x1 , y0, y1); + set range (max (0, x0), max (0, y0), min (h max, x1), min (v max, y1)) + FI . + +errorcheck: + IF is error + THEN line; + put line ("Erorr at PICTURE No " + text (picture no (p))); + FI . + +END PROC plotter; + +PROC plot pictures (PICFILE VAR p): + INT VAR back :: abs (background (p)), no; + enable stop; + FOR no FROM 1 UPTO pictures (p) + REP to pic (p, no); + read picture (p, pic); + + IF this picture is ok + THEN set pen of pic; + plot (pic) + FI + PER . + +this picture is ok: + pen (pic) <> 0 AND length (pic) > 0 . + +set pen of pic: + INT VAR colour, thick, type; + selected pen (p, pen (pic), colour, thick, type); + set pen (back, colour, thick, type) . + +END PROC plot pictures; + +END PACKET plotter + + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Server b/system/std.graphik/1.8.7/src/GRAPHIK.Server new file mode 100644 index 0000000..dfe5f62 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Server @@ -0,0 +1,97 @@ +PACKET multi user plotter: (* Autor : Rudolf Ruland *) + (* Stand : 24.03.86 *) + (*Änderung: 09.09.86/15:32 *) + +INT VAR c; +put ("gib Plotterkanal : "); get (c); + + server channel (c); + station only (FALSE) ; + spool duty ("Ausgabe mit dem Plotter"); + spool control task (myself); + +LET ack = 0 , + + fetch code = 11 , + param fetch code = 21 , + picfile type = 1103 ; + +INT VAR reply, old heap size, sender station; +TEXT VAR picfile name, userid, password, sendername; +PICFILE VAR picfile ; + +DATASPACE VAR ds, picfile ds; + +BOUND STRUCT (TEXT picfile name, userid, password, sendername, INT station) VAR msg; +BOUND TEXT VAR error msg ; + +spool manager (PROC plotter); + +PROC plotter : + + disable stop ; + command dialogue (FALSE); + ds := nilspace; picfile ds := nilspace; + continue (server channel) ; + check error ("Kanal belegt"); + + old heap size := heap size ; + REP + execute plot ; + + IF is error + THEN put error; + clear error; + FI ; + + IF heap size > old heap size + 4 + THEN collect heap garbage ; + old heap size := heap size + FI + PER + +ENDPROC plotter ; + + +PROC execute plot : + + enable stop ; + forget (picfile ds) ; picfile ds := nilspace ; + call (father, fetch code, picfile ds, reply) ; + IF reply = ack CAND type (picfile ds) = picfile type + THEN get picfile params; + plot picfile + FI ; + +. get picfile params : + forget (ds); ds := nilspace; + call (father, param fetch code, ds, reply); + IF reply <> ack + THEN error msg := ds; errorstop (error msg); + ELSE msg := ds; + picfile name := msg. picfile name; + userid := msg. userid; + password := msg. password; + sendername := msg. sender name; + sender station := msg. station; + FI; + +. plot picfile : + picfile := picfile ds; + plotter (picfile) . + +ENDPROC execute plot ; + + +PROC check error (TEXT CONST message) : + IF is error + THEN clear error; + rename myself (message); + IF is error THEN clear error; end (myself) FI; + pause (18000); + end (myself); + FI; +END PROC check error; + +ENDPACKET multi user plotter ; + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Transform b/system/std.graphik/1.8.7/src/GRAPHIK.Transform new file mode 100644 index 0000000..54690cc --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.Transform @@ -0,0 +1,366 @@ +PACKET transformation DEFINES transform, (* Autor: Heiko Indenbirken*) + diagonal, (* Stand: 12.04.85 *) + height, width, (*Änderung: 05.08.86/13:14 *) + set values, (*Änderung: 17.09.86/19:57 *) + get values, + new values, + projektion, + window, + viewport, + view, + oblique, + orthographic, + perspective: +(* ******************* Hardwareunabhängiger Teil ********************* *) +(* transform: Die Prozedur projeziert einen 3-dimensionalen Vektor *) +(* ---------- (x, y, z) auf einen 2-dimensionalen (h, v) *) +(* diagonal Die Prozedur berechnet die Pixel als Prozent der *) +(* ---------- Diagonalen der Zeichenfläche *) +(* height Die Prozedur berechnet die Pixel als Prozent der *) +(* ---------- Höhe der Zeichenfläche *) +(* width Die Prozedur berechnet die Pixel als Prozent der *) +(* ---------- Breite der Zeichenfläche *) +(* *) +(* set values: Mit dieser Prozedur werden die Projektionsparameter *) +(* ----------- gesetzt. *) +(* size: Weltkoordinatenbereich *) +(* ((xmin,xmax),(ymin,ymax),(zmin,zmax)) *) +(* limits: Zeichenfläche *) +(* ((h min, h max), (v min, v max)) *) +(* Bei Werten < 2.0 werden die Werte als *) +(* Prozente interpretiert, ansonsten als *) +(* cm-Grössen. *) +(* get values: Übergibt die aktuellen Werte *) +(* ----------- *) +(* new values: Berechnet die neue Projektionsmatrix *) +(* ----------- *) +(*=======================================================================*) + +BOOL VAR perspective projektion :: FALSE; +INT VAR hor pixel, vert pixel, i; +REAL VAR hor cm, vert cm, + h min limit, h max limit, v min limit, v max limit; +ROW 5 ROW 5 REAL VAR p; +ROW 3 ROW 2 REAL VAR size; +ROW 2 ROW 2 REAL VAR limits; +ROW 4 REAL VAR angles; +ROW 2 REAL VAR obliques; +ROW 3 REAL VAR perspectives; + +(* Initialisieren der Projektionsmatrizen *) +INT VAR d; +window (0.0, 1.0, 0.0, 1.0, 0.0, 1.0); +viewport (0.0, 0.0, 0.0, 0.0); +view (0.0, 0.0, 1.0); +view (0.0); +orthographic; +new values (27.46, 19.21, 274, 192, d, d, d, d); + +PROC projektion (ROW 5 ROW 5 REAL VAR matrix): + matrix := p +END PROC projektion; + +PROC oblique (REAL CONST a, b) : + set values (size, limits, angles, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0)) +END PROC oblique; + +PROC orthographic : + set values (size, limits, angles, 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, limits, angles, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy, cz)) +END PROC perspective; + +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, angles, obliques, perspectives) +END PROC window; + +PROC viewport (REAL CONST h min, h max, v min, v max) : + set values (size, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max), + ROW 2 REAL : (v min, v max)), + angles, obliques, perspectives) +END PROC view port; + +PROC view (REAL CONST alpha) : + set values (size, limits, ROW 4 REAL : (alpha, angles(2), angles (3), angles (4)), + obliques, perspectives) +END PROC view; + +PROC view (REAL CONST phi, theta): + set values (size, limits, ROW 4 REAL : (angles (1), sind (theta) * cosd (phi), + sind (theta) * sind (phi), cosd (theta)), + obliques, perspectives) +END PROC view; + +PROC view (REAL CONST x, y, z) : + set values (size, limits, ROW 4 REAL : (angles (1), x, y, z), obliques, perspectives) +END PROC view; + +PROC get values (ROW 3 ROW 2 REAL VAR act size, + ROW 2 ROW 2 REAL VAR act limits, + ROW 4 REAL VAR act angles, + ROW 2 REAL VAR act obliques, + ROW 3 REAL VAR act perspectives) : + act size := size; + act limits := limits; + act angles := angles; + act obliques := obliques; + act perspectives := perspectives; + +END PROC get values; + +PROC set values (ROW 3 ROW 2 REAL CONST new size, + ROW 2 ROW 2 REAL CONST new limits, + ROW 4 REAL CONST new angles, + ROW 2 REAL CONST new obliques, + ROW 3 REAL CONST new perspectives) : + size := new size; + limits := new limits; + angles := new angles; + obliques := new obliques; + perspectives := new perspectives + +END PROC set values; + +PROC new values (INT VAR h min range, h max range, v min range, v max range): + new values (hor cm, vert cm, hor pixel, vert pixel, + h min range, h max range, v min range, v max range) +END PROC new values; + +PROC new values (REAL CONST size hor, size vert, + INT CONST pixel hor, pixel vert, + INT VAR h min range, h max range, + v min range, v max range): + remember screensize; + calc views; + calc projektion; + calc limits; + calc projection frame; + normalize projektion; + set picture range; + set perspective mark . + +remember screensize: + hor cm := size hor; + vert cm := size vert; + hor pixel := pixel hor; + vert pixel := pixel vert . + +calc views : + calc diagonale; + calc projektion; + calc angles; + calc normale; + calc matrix; + calc alpha angle . + +calc diagonale: + REAL VAR diagonale := sqrt (angles [2] * angles [2] + + angles [3] * angles [3] + + angles [4] * angles [4]) . + +calc projektion: + REAL VAR projektion := sqrt (angles [2] * angles [2] + + angles [4] * angles [4]) . + +calc angles: + REAL VAR 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 . + +calc normale: + 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 := obliques [1] , + norm bz := obliques [2] , + norm cx := perspectives [1] / dx, + norm cy := perspectives [2] / dy, + norm cz := perspectives [3] / dz . + +calc matrix: +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)) . + +calc alpha angle: + IF angles (1) = 0.0 + THEN set alpha as y vertical + ELSE sin a := sind (angles (1)); + cos a := cosd (angles (1)) + FI . + +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 . + +calc limits : + IF limits as percent + THEN calc percent limits + ELSE calc centimeter limits FI . + +limits as percent: + limits [1][2] < 2.0 AND limits [2][2] < 2.0 . + +max limits: + h min limit := 0.0; + + v min limit := 0.0; + v max limit := real (pixel vert) . + +calc percent limits: + h min limit := real (pixel hor) * limits (1)(1)*size vert / size hor; + v min limit := limits (2)(1) * real (pixel vert); + + IF limits [1][2] = 0.0 + THEN h max limit := real (pixel hor) + ELSE h max limit := real (pixel hor) * limits [1][2]*size vert / size hor FI; + + IF limits [2][2] = 0.0 + THEN v max limit := real (pixel vert) + ELSE v max limit := limits (2)(2) * real (pixel vert) FI . + +calc centimeter limits: + h min limit := real (pixel hor) * (limits (1)(1)/size hor); + v min limit := real (pixel vert) * (limits (2)(1)/size vert); + + IF limits [1][2] = 0.0 + THEN h max limit := real (pixel hor) + ELSE h max limit := real (pixel hor) * (limits (1)(2)/size hor) FI; + + IF limits [2][2] = 0.0 + THEN v max limit := real (pixel vert) + ELSE v max limit := real (pixel vert) * (limits (2)(2)/size vert) FI . + +calc projection frame: + REAL VAR 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) . + +normalize 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 i FROM 1 UPTO 5 + REP REAL CONST p i 1 := p (i)(1); + p (i)(1) := (p i 1 * cos a - p (i)(2) * sin a) * sh; + p (i)(2) := (p i 1 * sin a + p (i)(2) * cos a) * sv + PER; + p (5)(1) := dh; + p (5)(2) := dv . + +set picture range: + h min range := int (h min limit-0.5); + h max range := int (h max limit+0.5); + v min range := int (v min limit-0.5); + v max range := int (v max limit+0.5) . + +set perspective mark: + perspective projektion := perspectives [3] <> 0.0 . + +END PROC new values; + +PROC transform (REAL CONST x, y, z, INT 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 := 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; +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; + +INT PROC diagonal (REAL CONST percent): + int (percent * 0.01 * diagonale + 0.5) . + +diagonale: + sqrt ((h max limit-h min limit) ** 2 + (v max limit-v min limit) ** 2) . + +END PROC diagonal; + +INT PROC height (REAL CONST percent): + int (percent * 0.01 * (v max limit-v min limit) + 0.5) +END PROC height; + +INT PROC width (REAL CONST percent): + int (percent * 0.01 * (h max limit-h min limit) + 0.5) +END PROC width; + +END PACKET transformation + diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot b/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot new file mode 100644 index 0000000..8bef1e4 --- /dev/null +++ b/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot @@ -0,0 +1,506 @@ +PACKET clipping DEFINES set range, (*Autor: Heiko Indenbirken *) + get range, (*Stand: 27.06.85/12:39 *) + clip: (*Änderung: 11.08.86/15:02 *) + +INT VAR x min :: 0, x max :: 1024, y min :: 0, y max :: 1024; + +PROC set range (INT CONST h min, v min, h max, v max): + IF h min >= h max OR v min >= v max + THEN errorstop ("Incorrect Range") FI; + x min := h min; x max := h max; + y min := v min; y max := v max +END PROC set range; + +PROC get range (INT VAR h min, v min, h max, v max): + h min := x min; h max := x max; + v min := y min; v max := y max +END PROC get range; + +PROC clip (INT CONST from x, from y, to x, to y, + PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw): + INT VAR x, y; + calculate parts of line; + IF both points inside + THEN draw (to x, to y) + ELIF both points outside + THEN + ELIF first point outside + THEN intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + draw (to x, to y) + ELIF second point outside + THEN intersection (from x, from y, to x, to y, to part, x, y); + draw (x, y) + ELSE intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + clip (x, y, to x, to y, PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw) + FI . + +calculate parts of line: + INT CONST from part :: part (from x, from y), + to part :: part (to x, to y) . + +both points inside: + from part = 0 AND to part = 0 . + +both points outside: + (from part AND to part) <> 0 . + +first point outside: + from part <> 0 AND to part = 0 . + +second point outside: + to part <> 0 AND from part = 0 . + +END PROC clip; + +INT PROC part (INT CONST x, y): + INT VAR index :: 0; + IF x > x max + THEN set bit (index, 0) + ELIF x < x min + THEN set bit (index, 1) FI; + + IF y > y max + THEN set bit (index, 2) + ELIF y < y min + THEN set bit (index, 3) FI; + + index + +END PROC part; + +PROC intersection (INT CONST from x, from y, to x, to y, to part, INT VAR x, y): + SELECT to part OF + CASE 1: right side + CASE 2: left side + CASE 4: up side + CASE 5: upright side + CASE 6: upleft side + CASE 8: down side + CASE 9: downright side + CASE 10: downleft side + OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT . + +right side: + y := from y + int (real (x max-from x)*(dy/dx)); + x := x max . + +left side: + y := from y + int (real (x min-from x)*(dy/dx)); + x := x min . + +up side: + x := from x + int (real (y max-from y)*(dx/dy)); + y := y max . + +down side: + x := from x + int (real (y min-from y)*(dx/dy)); + y := y min . + +upright side: + right side; + IF y > y max + THEN up side FI . + +downright side: + right side; + IF y < y min + THEN down side FI . + +upleft side: + left side; + IF y > y max + THEN up side FI . + +downleft side: + left side; + IF y < y min + THEN down side FI . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC intersection; + +END PACKET clipping; + +PACKET thick line DEFINES thick: (*Autor: Heiko Indenbirken *) + (*Stand: 02.07.85/15:07 *) + (*Änderung: 05.08.86/15:52 *) +PROC thick (INT CONST x0, y0, x1, y1, thick, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF is point + THEN draw point + ELIF is horizontal line + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + ELSE vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + FI . + +is point: + x0 = x1 AND y0 = y1 . + +is horizontal line: + abs (x0-x1) >= abs (y0-y1) . + +draw point: + INT VAR i; + FOR i FROM -thick UPTO thick + REP line (x0-thick, y0+i, x0+thick, y0+i) PER . + +END PROC thick; + +PROC horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from x > to x + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta x; + line (x start+delta x, y start+i, x end+delta x, y end+i) + PER . + +calculate increase: + REAL VAR increase :: -dy / dx . + +calculate limit points: + INT CONST x start :: from x - thick, + x end :: to x + thick, + y start :: from y + int (increase * real (thick)), + y end :: to y - int (increase * real (thick)) . + +calculate delta x: + INT CONST delta x :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC horizontal line; + +PROC vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from y > to y + THEN vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta y; + line (x start+i, y start+delta y, x end+i, y end+delta y) + PER . + +calculate increase: + REAL VAR increase :: -dx / dy . + +calculate limit points: + INT CONST x start :: from x + int (increase * real (thick)), + x end :: to x - int (increase * real (thick)), + y start :: from y - thick, + y end :: to y + thick . + +calculate delta y: + INT CONST delta y :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC vertical line; + +END PACKET thick line; + +PACKET graphik text DEFINES draw char, (*Autor: Heiko Indenbirken *) + zeichensatz: (*Stand: 27.06.85/16:03 *) + (*Änderung: 28.06.85/19:06 *) + (*Änderung: 05.08.86/16:00 *) +LET ZEICHENSATZ = ROW 255 TEXT; +ZEICHENSATZ VAR zeichen; +INT CONST char x :: 6, char y :: 10; + +zeichensatz ("ZEICHENSATZ"); + +PROC zeichensatz (TEXT CONST name): + IF exists (name) + THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name); + zeichen := new zeichen; + ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI +END PROC zeichensatz; + +PROC draw char (INT CONST char no, INT CONST x, y, x size, y size, direction, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + TEXT CONST character :: zeichen [char no]; + INT VAR n :: 1, x0, y0, x1, y1; + INT CONST len :: length (character); + WHILE n < len + REP value (character, n, x0, y0, x1, y1); + transform (x0, y0, x, y, x size, y size, direction); + transform (x1, y1, x, y, x size, y size, direction); + line (x0, y0, x1, y1); + n INCR 4 + PER . + +END PROC draw char; + +PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1): + x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1)); + x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3)); +END PROC value; + +INT PROC val (INT CONST n): + IF n > 127 + THEN -256 OR n + ELSE n FI +END PROC val; + +PROC transform (INT VAR x, y, INT CONST x0, y0, x size, y size, direction): + INT CONST old x :: x, old y :: y; + SELECT direction OF + CASE 0: x := x0 + x vektor; y := y0 + y vektor + CASE 1: x := x0 - y vektor; y := y0 + x vektor + CASE 2: x := x0 - x vektor; y := y0 - y vektor + CASE 3: x := x0 + y vektor; y := y0 - x vektor + ENDSELECT . + +x vektor: + IF x size = 0 + THEN old x + ELSE (old x*x size) DIV char x FI . + +y vektor: + IF y size = 0 + THEN old y + ELSE (old y*y size) DIV char y FI . + +END PROC transform; + +END PACKET graphik text; + +PACKET graphik text DEFINES draw text: (*Autor: Heiko Indenbirken *) + (*Stand: 03.07.85/11:55 *) + (*Änderung: 05.08.86/16:04 *) +PROC draw text (INT CONST x pos, y pos, + TEXT CONST msg, REAL CONST angle, INT CONST height, width, + PROC (INT CONST, INT CONST, + INT CONST, INT CONST, INT CONST, INT CONST) draw char): + INT CONST dir :: int (((angle MOD 360.0)+45.0) / 90.0); + INT VAR i; + REAL VAR x :: real (x pos), y :: real (y pos), + x step :: cosd (angle)*real (width), + y step :: sind (angle)*real (width); + FOR i FROM 1 UPTO length (msg) + REP IF control char + THEN execute control char + ELSE execute normal char FI + PER . + +control char: + akt char < ""32"" . + +execute control char: + SELECT code (akt char) OF + CASE 1: home + CASE 2: right + CASE 3: up + CASE 7: out (""7"") + CASE 8: left + CASE 10: down + CASE 13: return + ENDSELECT . + +home: + x := real (x pos); + y := real (y pos) . + +right: + x INCR x step; y INCR y step . + +up: + x INCR y step; y INCR x step . + +left: + x DECR x step; y DECR y step . + +down: + x DECR y step; y DECR x step . + +return: + x := real (x pos) . + +execute normal char: + draw char (code (akt char), dir, int (x+0.5), int (y+0.5), height, width); + x INCR x step; + y INCR y step . + +akt char: + msg SUB i . + +END PROC draw text; + +END PACKET graphik text; + +PACKET comercial plot DEFINES bar, (*Autor: Heiko Indenbirken *) + circle: (*Stand: 03.04.1985 *) + (*Änderung: 03.07.85/15:37 *) +PROC bar (INT CONST from x, from y, to x, to y, pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF from x > to x + THEN bar (to x, from y, from x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELIF from y > to y + THEN bar (from x, to y, to x, from y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELSE draw frame; + fill frame with pattern + FI . + +draw frame: + line (from x, from y, from x, to y); + line (from x, to y, to x, to y); + line (to x, to y, to x, from y); + line (to x, from y, from x, from y) . + +fill frame with pattern: + SELECT pattern OF + CASE 1: fill right (from x, to x, from y, to y, 2, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 2: fill hor (from x, to x, from y, to y, 1, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 3: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 4: fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 5: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 6: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 7: fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 8: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ENDSELECT . + +END PROC bar; + +PROC fill hor (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR y :: from y; + REP line (from x, y, to x, y); + y INCR step + UNTIL y > to y PER . + +END PROC fill hor; + +PROC fill vert (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR x :: from x; + REP line (x, from y, x, to y); + x INCR step + UNTIL x > to x PER . + +END PROC fill vert; + +PROC fill right (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: from x, right :: from x, + lower :: from y, upper :: from y; +(* Ausfüllen von links unten nach rechts oben *) + WHILE t < length + REP calc start point; + calc end point; + line (left, upper, right, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN left := from x + t - height; + upper := to y + ELSE left INCR step FI . + +calc end point: + IF t < width + THEN right INCR step + ELIF t < width step + THEN lower := from y + t - width; + right := to x + ELSE lower INCR step FI . + +END PROC fill right; + +PROC fill left (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: to x, right :: to x, + lower :: from y, upper :: from y; +(* Ausfüllen von rechts unten nach links oben *) + WHILE t < length + REP calc start point; + calc end point; + line (right, upper, left, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN right := to x - t + height; + upper := to y + ELSE right DECR step FI . + +calc end point: + IF t < width + THEN left DECR step + ELIF t < width step + THEN lower := from y + t - width; + left := from x + ELSE lower INCR step FI . + +END PROC fill left; + +PROC circle (INT CONST x, y, REAL CONST rad, from, to, INT CONST pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + REAL VAR t :: from; + INT VAR last x :: x, last y :: y; + WHILE t <= to + REP calc circle; + draw step; + t INCR 1.0 + PER; + line (x rad, y rad, x, y) . + +draw step: + IF pattern = 0 + THEN line (last x, last y, x rad, y rad); + last x := x rad; + last y := y rad + ELSE line (x, y, x rad, y rad) FI . + +calc circle: + INT CONST x rad :: int (cosd (t)*rad+0.5)+x, + y rad :: int (sind (t)*rad+0.5)+y . + +END PROC circle; + +END PACKET comercial plot; + diff --git a/system/std.graphik/1.8.7/src/HP7475.plot b/system/std.graphik/1.8.7/src/HP7475.plot new file mode 100644 index 0000000..860dd03 --- /dev/null +++ b/system/std.graphik/1.8.7/src/HP7475.plot @@ -0,0 +1,254 @@ +PACKET hp7475 plot DEFINES set range, (*Autor: Heiko Indenbirken *) + get range, (*Stand: 03.09.86/15:09 *) + drawing area, + begin plot, + end plot, + clear, + + set pen, get pen, + move, + draw, + marker, + bar, circle, + where: + +(* *) +(* Hardware Anschluß des HP7475A: *) +(* 9600 Baud, 8 Bit, no parity, RTS/CTS *) +(* Leitungen 1 ----- 1 *) +(* gekreuzt: 2 --x-- 3 *) +(* 3 --x-- 2 *) +(* *) + + +LET POS = STRUCT (INT x, y); +LET RANGE = STRUCT (POS min, max); +LET PEN = STRUCT (INT back, fore, thick, line); + +LET width scale = 0.002690217391304, + height scale = 0.002728921124206; + +LET term = ";", + comma = ",", + point = ".", + zero = "0", + nil = "", + etx = ""3""; + + +POS VAR old :: POS:(0, 0); +RANGE VAR area :: RANGE:(POS:(0,0), POS:(11040, 7721)); +PEN VAR pen :: PEN : (0, 1, 0, 1); +TEXT VAR result; + +ROW 16 TEXT VAR mark := ROW 16 TEXT: +("99,0,2,-2,0,0,-4,4,0,0,4,-2,0;", +"99,0,2,-1,0,-1,-1,0,-2,1,-1,2,0,1,1,0,2,-1,1,-1,0;", +"99,0,2,-2,-3,4,0,-2,3;", +"-99,-2,0,99,4,0,-99,-2,2,99,0,-4;", +"-99,-2,-2,99,4,4,-99,-4,0,99,4,-4;", +"99,0,2,-2,-2,2,-2,2,2,-2,2;", +"-99,0,-2,99,0,4,-2,-2,4,0,-2,2;", +"-99,-2,0,99,4,0,-99,-2,2,99,0,-4,2,2,-2,2,-2,-2,2,-2;", +"-99,-2,-2,99,4,4,-4,0,4,-4;", +"-99,-2,2,99,4,0,-4,-4,4,0;", +"99,0,-2,-99,-2,4,99,2,-2,2,2;", +"99,1,1,-2,0,0,-2,2,0,0,2,1,1,-99,-4,0,99,1,-1,-99,0,-2,99,-1,-1,-99,4,0,99,-1,1;", +"-99,-2,0,99,4,0,-99,-1,1,99,-2,-2,-99,1,-1,99,0,4,-99,-1,-1,99,2,-2;", +"-99,-2,2,99,4,0,-4,-4,4,0,-4,4;", +"-99,-2,0,99,4,0;", +"-99,0,299,0,-4;"); + +ROW 5 TEXT CONST line pattern := ROW 5 TEXT:("LT;", "LT1;", "LT2;", "LT3;", "LT4;"); +ROW 8 TEXT CONST fill pattern := ROW 8 TEXT:("FT4,25,45;", "FT1,0,0;", "FT3,50,0;", + "FT3,50,90;", "FT4,50,0;", "FT3,50,-45;", + "FT3,50,45;", "FT4,50,45;"); + +PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) : + x cm := 29.7; y cm := 21.07; + x pixel := 11040; y pixel := 7721; +END PROC drawing area; + + +PROC set range (INT CONST h min, v min, h max, v max): + IF h min >= h max OR v min >= v max + THEN errorstop ("Incorrect Range") FI; + area := RANGE:(POS:(h min, v min), POS:(h max, v max)) +END PROC set range; + +PROC get range (INT VAR h min, v min, h max, v max): + h min := area.min.x; v min := area.min.y; + h max := area.max.x; v max := area.max.y +END PROC get range; + +PROC begin plot: + out ("IN;") +ENDPROC begin plot; + +PROC end plot: + TEXT VAR rec; + out ("IN;SP;PA22040,7721;DP;"); + REP pause (10); + out ("OS;"); + input (rec, ""13"", 600) + UNTIL enter pressed PER; + out ("IN;") . + +enter pressed: + (int (rec) AND 4) > 0 . + +ENDPROC end plot; + +PROC clear: + new values (29.7, 21.07, 11040, 7721, area.min.x, area.max.x, area.min.y, area.max.y); + pen := PEN : (0, 1, 0, 1); + old := area.min; + out ("DF;IP;"); (* Default *) + out ("IW" + text (area.min.x, area.min.y) + ", " + (* Clipping *) + text (area.max.x, area.max.y) + term); + out ("SP1;"); (* Pen 1 *) + out ("LT;"); (* durchgehend *) + out ("PU;PA" + text (old.x, old.y)); (* Startpunkt *) + +END PROC clear; + +PROC set pen (INT CONST back, fore, thick, type): + set colour; + set linetype . + +set colour: + IF abs (fore) >= 1 AND abs (fore) <= 6 + THEN out ("SP" + text (abs (fore)) + term); + pen.fore := abs (fore); + FI . + +set linetype: + IF type >= 1 AND type <= 5 + THEN out (line pattern [type]); + pen.line := type + ELSE out ("SP;"); + pen.line := 0 + FI . + +END PROC set pen; + +PROC get pen (INT VAR back, fore, thick, line): + back := pen.back; + fore := pen.fore; + thick := pen.thick; + line := pen.line +END PROC get pen; + +PROC move (INT CONST x, y) : + out ("PU;PA" + text (x, y) + term); + old := POS : (x, y) +END PROC move; + +PROC draw (INT CONST x, y): + out ("PD;PA" + text (x, y) + term); + old := POS : (x, y) +END PROC draw; + +PROC draw (TEXT CONST msg, REAL CONST angle, INT CONST height, width): + set angle; + set height and width; + plot msg . + +set angle: + out ("DI " + text (cosd (angle), sind (angle)) + term) . + +set height and width: + IF width = 0 AND height = 0 + THEN out ("SR;") + ELSE out ("SI" + text (real (width) * width scale, + real (height) * height scale) + term) + FI . + +plot msg: + out ("LB" + msg + etx) . + +END PROC draw; + +PROC bar (INT CONST from x, from y, to x, to y, pattern): + out ("PU;PA" + text (from x, from y) + term); + out ("LT;EA" + text (to x, to y) + term); + IF pattern > 0 AND pattern <= 8 + THEN out (fill pattern [pattern]); + out ("RA" + text (to x, to y) + term); + FI; + out ("PU;PA" + text (old.x, old.y) + term); + out (line pattern [pen.line]) . + +END PROC bar; + +PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern): + out ("LT;PU;PA" + text (x, y) + term); + IF (from MOD 360.0) = 0.0 AND (to MOD 360.0) = 0.0 + THEN out ("CI" + text (rad) + term) + ELSE out ("EW" + text (rad) + comma + text (from, to-from) + term) FI; + + IF pattern > 0 AND pattern <= 6 + THEN out (fill pattern [pattern]); + out ("WG" + text (rad) + comma + text (from, to-from) + term) + FI; + out ("PU;PA" + text (old.x, old.y) + term); + out (line pattern [pen.line]) . + +END PROC circle; + +PROC marker (INT CONST x, y, no, size): + out ("LT;PU;PA" + text (x, y) + term); + out ("DI1,0;"); + IF size = 0 + THEN out ("SI0.25,0.5;") + ELSE out ("SI" + text (real (size)*0.001, real (size)*0.002) + term) FI; + out ("UC" + mark [mark no]); + out ("PU;PA" + text (old.x, old.y) + term); + out (line pattern [pen.line]) . + +mark no: + IF no >= 1 AND no <= 16 + THEN no + ELSE 1 FI . + +END PROC marker; + +PROC where (INT VAR x, y): + x := old.x; y := old.y +END PROC where; + +TEXT PROC text (INT CONST x, y): + text (x) + comma + text (y) +END PROC text; + +TEXT PROC text (REAL CONST x, y): + text (x) + comma + text (y) +END PROC text; + +TEXT PROC text (REAL CONST x): + result := compress (text (x, 9, 4)); + + IF (result SUB 1) = point + THEN insert char (result, zero, 1) + ELIF (result SUB LENGTH result) = point + THEN result CAT zero FI; + result +END PROC text; + +PROC input (TEXT VAR rec, TEXT CONST del, INT CONST time): + enable stop; + rec := nil; + REP TEXT CONST char := incharety (time); + + IF char = nil + THEN errorstop ("Timeout after " + text (time)) + ELIF pos (del, char) > 0 + THEN LEAVE input + ELSE rec CAT char FI + + PER . + +END PROC input; + +END PACKET hp7475 plot + diff --git a/system/std.graphik/1.8.7/src/PC.plot b/system/std.graphik/1.8.7/src/PC.plot new file mode 100644 index 0000000..712f5ea --- /dev/null +++ b/system/std.graphik/1.8.7/src/PC.plot @@ -0,0 +1,758 @@ +PACKET clipping DEFINES set range, (*Autor: Heiko Indenbirken *) + get range, (*Stand: 27.06.85/12:39 *) + clip: (*Änderung: 11.08.86/15:02 *) + +INT VAR x min :: 0, x max :: 1024, y min :: 0, y max :: 1024; + +PROC set range (INT CONST h min, v min, h max, v max): + IF h min >= h max OR v min >= v max + THEN errorstop ("Incorrect Range") FI; + x min := h min; x max := h max; + y min := v min; y max := v max +END PROC set range; + +PROC get range (INT VAR h min, v min, h max, v max): + h min := x min; h max := x max; + v min := y min; v max := y max +END PROC get range; + +PROC clip (INT CONST from x, from y, to x, to y, + PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw): + INT VAR x, y; + calculate parts of line; + IF both points inside + THEN draw (from x, from y); (* Macke im SHARD *) + draw (to x, to y) + ELIF both points outside + THEN + ELIF first point outside + THEN intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + draw (to x, to y) + ELIF second point outside + THEN intersection (from x, from y, to x, to y, to part, x, y); + draw (x, y) + ELSE intersection (to x, to y, from x, from y, from part, x, y); + move (x, y); + draw (x, y); (* Macke im SHARD *) + clip (x, y, to x, to y, PROC (INT CONST, INT CONST) move, + PROC (INT CONST, INT CONST) draw) + FI . + +calculate parts of line: + INT CONST from part :: part (from x, from y), + to part :: part (to x, to y) . + +both points inside: + from part = 0 AND to part = 0 . + +both points outside: + (from part AND to part) <> 0 . + +first point outside: + from part <> 0 AND to part = 0 . + +second point outside: + to part <> 0 AND from part = 0 . + +END PROC clip; + +INT PROC part (INT CONST x, y): + INT VAR index :: 0; + IF x > x max + THEN set bit (index, 0) + ELIF x < x min + THEN set bit (index, 1) FI; + + IF y > y max + THEN set bit (index, 2) + ELIF y < y min + THEN set bit (index, 3) FI; + + index + +END PROC part; + +PROC intersection (INT CONST from x, from y, to x, to y, to part, INT VAR x, y): + SELECT to part OF + CASE 1: right side + CASE 2: left side + CASE 4: up side + CASE 5: upright side + CASE 6: upleft side + CASE 8: down side + CASE 9: downright side + CASE 10: downleft side + OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT . + +right side: + y := from y + int (real (x max-from x)*(dy/dx)); + x := x max . + +left side: + y := from y + int (real (x min-from x)*(dy/dx)); + x := x min . + +up side: + x := from x + int (real (y max-from y)*(dx/dy)); + y := y max . + +down side: + x := from x + int (real (y min-from y)*(dx/dy)); + y := y min . + +upright side: + right side; + IF y > y max + THEN up side FI . + +downright side: + right side; + IF y < y min + THEN down side FI . + +upleft side: + left side; + IF y > y max + THEN up side FI . + +downleft side: + left side; + IF y < y min + THEN down side FI . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC intersection; + +END PACKET clipping; + +PACKET thick line DEFINES thick: (*Autor: Heiko Indenbirken *) + (*Stand: 02.07.85/15:07 *) + (*Änderung: 05.08.86/15:52 *) +PROC thick (INT CONST x0, y0, x1, y1, thick, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF is point + THEN draw point + ELIF is horizontal line + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + ELSE vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + x0, y0, x1, y1, thick) + FI . + +is point: + x0 = x1 AND y0 = y1 . + +is horizontal line: + abs (x0-x1) >= abs (y0-y1) . + +draw point: + INT VAR i; + FOR i FROM -thick UPTO thick + REP line (x0-thick, y0+i, x0+thick, y0+i) PER . + +END PROC thick; + +PROC horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from x > to x + THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta x; + line (x start+delta x, y start+i, x end+delta x, y end+i) + PER . + +calculate increase: + REAL VAR increase :: -dy / dx . + +calculate limit points: + INT CONST x start :: from x - thick, + x end :: to x + thick, + y start :: from y + int (increase * real (thick)), + y end :: to y - int (increase * real (thick)) . + +calculate delta x: + INT CONST delta x :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC horizontal line; + +PROC vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + INT CONST from x, from y, to x, to y, thick): + IF from y > to y + THEN vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line, + to x, to y, from x, from y, thick) + ELSE draw line FI . + +draw line: + INT VAR i; + calculate increase; + calculate limit points; + FOR i FROM -thick UPTO thick + REP calculate delta y; + line (x start+i, y start+delta y, x end+i, y end+delta y) + PER . + +calculate increase: + REAL VAR increase :: -dx / dy . + +calculate limit points: + INT CONST x start :: from x + int (increase * real (thick)), + x end :: to x - int (increase * real (thick)), + y start :: from y - thick, + y end :: to y + thick . + +calculate delta y: + INT CONST delta y :: int (increase*real (i)) . + +dx: real (to x-from x) . +dy: real (to y-from y) . + +END PROC vertical line; + +END PACKET thick line; + +PACKET graphik text DEFINES draw char, (*Autor: Heiko Indenbirken *) + zeichensatz: (*Stand: 27.06.85/16:03 *) + (*Änderung: 28.06.85/19:06 *) + (*Änderung: 05.08.86/16:00 *) +LET ZEICHENSATZ = ROW 255 TEXT; +ZEICHENSATZ VAR zeichen; +INT CONST char x :: 6, char y :: 10; + +zeichensatz ("ZEICHENSATZ"); + +PROC zeichensatz (TEXT CONST name): + IF exists (name) + THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name); + zeichen := new zeichen; + ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI +END PROC zeichensatz; + +PROC draw char (INT CONST char no, INT CONST x, y, x size, y size, direction, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + TEXT CONST character :: zeichen [char no]; + INT VAR n :: 1, x0, y0, x1, y1; + INT CONST len :: length (character); + WHILE n < len + REP value (character, n, x0, y0, x1, y1); + transform (x0, y0, x, y, x size, y size, direction); + transform (x1, y1, x, y, x size, y size, direction); + line (x0, y0, x1, y1); + n INCR 4 + PER . + +END PROC draw char; + +PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1): + x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1)); + x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3)); +END PROC value; + +INT PROC val (INT CONST n): + IF n > 127 + THEN -256 OR n + ELSE n FI +END PROC val; + +PROC transform (INT VAR x, y, INT CONST x0, y0, x size, y size, direction): + INT CONST old x :: x, old y :: y; + SELECT direction OF + CASE 0: x := x0 + x vektor; y := y0 + y vektor + CASE 1: x := x0 - y vektor; y := y0 + x vektor + CASE 2: x := x0 - x vektor; y := y0 - y vektor + CASE 3: x := x0 + y vektor; y := y0 - x vektor + ENDSELECT . + +x vektor: + IF x size = 0 + THEN old x + ELSE (old x*x size) DIV char x FI . + +y vektor: + IF y size = 0 + THEN old y + ELSE (old y*y size) DIV char y FI . + +END PROC transform; + +END PACKET graphik text; + +PACKET graphik text DEFINES draw text: (*Autor: Heiko Indenbirken *) + (*Stand: 03.07.85/11:55 *) + (*Änderung: 05.08.86/16:04 *) +PROC draw text (INT CONST x pos, y pos, + TEXT CONST msg, REAL CONST angle, INT CONST height, width, + PROC (INT CONST, INT CONST, + INT CONST, INT CONST, INT CONST, INT CONST) draw char): + INT CONST dir :: int (((angle MOD 360.0)+45.0) / 90.0); + INT VAR i; + REAL VAR x :: real (x pos), y :: real (y pos), + x step :: cosd (angle)*real (width), + y step :: sind (angle)*real (width); + FOR i FROM 1 UPTO length (msg) + REP IF control char + THEN execute control char + ELSE execute normal char FI + PER . + +control char: + akt char < ""32"" . + +execute control char: + SELECT code (akt char) OF + CASE 1: home + CASE 2: right + CASE 3: up + CASE 7: out (""7"") + CASE 8: left + CASE 10: down + CASE 13: return + ENDSELECT . + +home: + x := real (x pos); + y := real (y pos) . + +right: + x INCR x step; y INCR y step . + +up: + x INCR y step; y INCR x step . + +left: + x DECR x step; y DECR y step . + +down: + x DECR y step; y DECR x step . + +return: + x := real (x pos) . + +execute normal char: + draw char (code (akt char), dir, int (x+0.5), int (y+0.5), height, width); + x INCR x step; + y INCR y step . + +akt char: + msg SUB i . + +END PROC draw text; + +END PACKET graphik text; + +PACKET comercial plot DEFINES bar, (*Autor: Heiko Indenbirken *) + circle: (*Stand: 03.04.1985 *) + (*Änderung: 03.07.85/15:37 *) +PROC bar (INT CONST from x, from y, to x, to y, pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + IF from x > to x + THEN bar (to x, from y, from x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELIF from y > to y + THEN bar (from x, to y, to x, from y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ELSE draw frame; + fill frame with pattern + FI . + +draw frame: + line (from x, from y, from x, to y); + line (from x, to y, to x, to y); + line (to x, to y, to x, from y); + line (to x, from y, from x, from y) . + +fill frame with pattern: + SELECT pattern OF + CASE 1: fill right (from x, to x, from y, to y, 2, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 2: fill hor (from x, to x, from y, to y, 1, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 3: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 4: fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 5: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 6: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 7: fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + CASE 8: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line); + fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line) + ENDSELECT . + +END PROC bar; + +PROC fill hor (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR y :: from y; + REP line (from x, y, to x, y); + y INCR step + UNTIL y > to y PER . + +END PROC fill hor; + +PROC fill vert (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT VAR x :: from x; + REP line (x, from y, x, to y); + x INCR step + UNTIL x > to x PER . + +END PROC fill vert; + +PROC fill right (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: from x, right :: from x, + lower :: from y, upper :: from y; +(* Ausfüllen von links unten nach rechts oben *) + WHILE t < length + REP calc start point; + calc end point; + line (left, upper, right, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN left := from x + t - height; + upper := to y + ELSE left INCR step FI . + +calc end point: + IF t < width + THEN right INCR step + ELIF t < width step + THEN lower := from y + t - width; + right := to x + ELSE lower INCR step FI . + +END PROC fill right; + +PROC fill left (INT CONST from x, to x, from y, to y, step, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + INT CONST width :: to x - from x, + height :: to y - from y, + length :: width + height, + height step :: height + step, + width step :: width + step; + + INT VAR t :: step, left :: to x, right :: to x, + lower :: from y, upper :: from y; +(* Ausfüllen von rechts unten nach links oben *) + WHILE t < length + REP calc start point; + calc end point; + line (right, upper, left, lower); + t INCR step + PER . + +calc start point: + IF t < height + THEN upper INCR step + ELIF t < height step + THEN right := to x - t + height; + upper := to y + ELSE right DECR step FI . + +calc end point: + IF t < width + THEN left DECR step + ELIF t < width step + THEN lower := from y + t - width; + left := from x + ELSE lower INCR step FI . + +END PROC fill left; + +PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) line): + REAL VAR t :: from; + INT VAR last x :: x, last y :: y; + WHILE t <= to + REP calc circle; + draw step; + t INCR 5.0 + PER; + line (x rad, y rad, x, y) . + +draw step: + IF pattern = 0 + THEN line (last x, last y, x rad, y rad); + last x := x rad; + last y := y rad + ELSE line (x, y, x rad, y rad) FI . + +calc circle: + INT CONST x rad :: int (cosd (t)*real (rad)+0.5)+x, + y rad :: int (sind (t)*real (rad)+0.5)+y . + +END PROC circle; + +END PACKET comercial plot; + +PACKET pc plot DEFINES drawing area, (*Autor: Heiko Indenbirken *) + begin plot, (*Stand: 20.05.85 *) + end plot, (*Änderung: 27.06.85/16:17 *) + clear, (*Änderung: 03.07.85/15:59 *) + (*Änderung: 06.08.86/10:03 *) + graphik, + set pen, get pen, + + move, + draw, + draw line, + marker, + bar, circle, + where: + + +LET POS = STRUCT (INT x, y); +LET PEN = STRUCT (INT back, fore, thick, line); +INT CONST back code :: -4, + modus code :: -5, + draw code :: -6, + move code :: -7, + pen code :: -8, + full line :: -1; + +INT VAR d, y, pause time :: 10, + resolution :: 4, max x :: 319, max y :: 199; +BOOL VAR is clear := FALSE; +POS VAR old :: POS : (0, 0); +PEN VAR pen :: PEN : (0, 1, 0, full line); + +PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) : + x cm := 22.0; y cm := 13.7; + x pixel := max x; y pixel := max y; +END PROC drawing area; + +PROC graphik (INT CONST modus, pause): + pause time := pause; + SELECT modus OF + CASE 0: resolution := 3; + CASE 1: resolution := 72; + max x := 639; + max y := 399 + CASE 2: resolution := 64; + max x := 639; + max y := 399 + CASE 3: resolution := 6; + max x := 639; + max y := 199 + CASE 4: resolution := 4; + max x := 319; + max y := 199 + OTHERWISE errorstop ("Nur Modi 0-4") ENDSELECT; + + set range (0, 0, max x, max y); +END PROC graphik; + +PROC begin plot : + control (modus code, resolution, 0, d); + is clear := TRUE; +ENDPROC begin plot ; + +PROC end plot : + IF pause time > 0 + THEN indicate end plot FI; + control (modus code, 3, 0, d) . + +indicate end plot: + control (pen code, full line, full line, d); + REP set indicator; + UNTIL incharety (pause time) <> "" PER . + +set indicator: + control (move code, 0, max y, d); + control (draw code, max x, max y, d) . + +ENDPROC end plot ; + +PROC clear: + INT VAR x0, x1, y0, y1; + new values (22.0, 13.7, max x, max y, x0, x1, y0, y1); + set range (x0, y0, x1, y1); + clear screen; + clear pen; + clear pos; + is clear := FALSE . + +clear screen: + IF is clear OR full screen + THEN control (modus code, resolution, 0, d) + ELSE draw frame; + clear frame + FI . + +full screen: + x0 < 10 AND x1 > (max x-10) AND + y0 < 10 AND y1 > (max y-10) . + +draw frame: + control (move code, x0, y0, d); + control (draw code, x1, y0, d); + control (draw code, x1, y1, d); + control (draw code, x0, y1, d); + control (draw code, x0, y0, d) . + +clear frame: + control (pen code, full line, 0, d); + FOR y FROM max y-y1 UPTO max y-y0 + REP control (move code, x0, y, d); + control (draw code, x1, y, d); + PER . + +clear pen: + pen := PEN : (0, 1, 0, full line); + control (pen code, full line, 1, d) . + +clear pos: + old := POS : (x0, y0); + control (move code, x0, max y-y0, d) . + +END PROC clear; + +PROC set pen (INT CONST back, fore, thick, type): + set background; + set foreground and linetype; + set thickness . + +set background: + pen.back := back; (*Hintergrund über niederwertiges *) + control (back code, 0, back no, d) .(*Byte von colour code *) + (*Höherwetiges Byte regelt die *) +back no: (*Farbpalette *) + IF back = 0 + THEN std background + ELSE back FI . + +std background: + IF resolution = 4 + THEN 16 + ELSE 15 FI . + +set foreground and linetype: (*0, 1, 2, 3 Farben: löschend,*) + pen.fore := possible colour; (*ändernd oder überschreibend *) + pen.line := type; (* in allen Linientypen. *) + control (pen code, line (type), pen.fore, d) . + +possible colour: + IF fore <= full line + THEN full line + ELIF fore > 3 OR (fore > 1 AND resolution <> 4) + THEN 1 + ELSE fore FI . + +set thickness: + pen.thick := thick DIV 10 . + +END PROC set pen; + +PROC get pen (INT VAR back, fore, thick, line): + back := pen.back; + fore := pen.fore; + thick := pen.thick; + line := pen.line +END PROC get pen; + +INT PROC line (INT CONST type): + SELECT type OF + CASE 0: 0 + CASE 1: full line + CASE 2: 21845 + CASE 3: 3855 + CASE 4: 255 + CASE 5: 4351 + OTHERWISE type END SELECT +END PROC line; + +PROC int move (INT CONST x, y): + control (move code, x, max y-y, d); +END PROC int move; + +PROC int draw (INT CONST x, y): + control (draw code, x, max y-y, d); +END PROC int draw; + +PROC draw line (INT CONST from x, from y, to x, to y): + control (move code, from x, max y-from y, d); + clip (from x, from y, to x, to y, PROC int move, PROC int draw) +END PROC draw line; + +PROC move (INT CONST x, y) : + control (move code, x, max y-y, d); + old := POS : (x, y) +END PROC move; + +PROC draw (INT CONST x, y): + IF std thickness + THEN clip (old.x, old.y, x, y, PROC int move, PROC int draw) + ELSE thick (old.x, old.y, x, y, pen.thick, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line) FI; + old := POS : (x, y) . + +std thickness: pen.thick = 0 . +END PROC draw; + +PROC draw (TEXT CONST msg, REAL CONST angle, INT CONST height, width): + control (pen code, full line, pen.fore, d); + draw text (old.x, old.y, msg, angle, y size, x size, + PROC (INT CONST, INT CONST, INT CONST, INT CONST, INT CONST, INT CONST) draw char); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . + +x size: IF width = 0 + THEN 6 + ELSE width FI . +y size: IF height = 0 + THEN 10 + ELSE height FI . + +END PROC draw; + +PROC draw char (INT CONST char, direction, x, y, INT CONST height, width): + draw char (char, x, y, width, height, direction, + PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line) +END PROC draw char; + +PROC bar (INT CONST from x, from y, to x, to y, pattern): + control (pen code, full line, pen.fore, d); + bar (from x, from y, to x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . +END PROC bar; + +PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern): + control (pen code, full line, pen.fore, d); + circle (x, y, rad, from, to, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . +END PROC circle; + +PROC marker (INT CONST x, y, no, size): + control (pen code, full line, pen.fore, d); + draw char (no, 0, x, y, size, size); + control (move code, old.x, max y-old.y, d); + control (pen code, line (pen.line), pen.fore, d) . +END PROC marker; + +PROC where (INT VAR x, y): + x := old.x; y := old.y +END PROC where; + +END PACKET pc plot + diff --git a/system/std.graphik/1.8.7/src/ZEICHENSATZ b/system/std.graphik/1.8.7/src/ZEICHENSATZ new file mode 100644 index 0000000..9866ec2 Binary files /dev/null and b/system/std.graphik/1.8.7/src/ZEICHENSATZ differ diff --git a/system/std.graphik/1.8.7/src/gen Graphik b/system/std.graphik/1.8.7/src/gen Graphik new file mode 100644 index 0000000..f70cc66 --- /dev/null +++ b/system/std.graphik/1.8.7/src/gen Graphik @@ -0,0 +1,16 @@ +TEXT VAR geraet; +page; +out ("Bitte den Namen der Hardwareanpassung (z.B. 'PC.plot') eingeben: "); +get line (geraet); +IF NOT exists (geraet) +THEN errorstop ("Endgerät nicht vorhanden") FI; + +insert ("GRAPHIK.Picfile"); +insert ("GRAPHIK.Transform"); +insert (geraet); +insert ("GRAPHIK.Plot"); + + + + + diff --git a/system/std.graphik/1.8.7/src/gen Plotter b/system/std.graphik/1.8.7/src/gen Plotter new file mode 100644 index 0000000..73d7b2f --- /dev/null +++ b/system/std.graphik/1.8.7/src/gen Plotter @@ -0,0 +1,16 @@ +TEXT VAR geraet; +page; +out ("Bitte den Namen der Hardwareanpassung (z.B. 'PC.plot') eingeben: "); +get line (geraet); +IF NOT exists (geraet) +THEN errorstop ("Endgerät nicht vorhanden") FI; + +insert ("GRAPHIK.Picfile"); +insert ("GRAPHIK.Transform"); +insert (geraet); +insert ("GRAPHIK.Plotter"); +insert ("GRAPHIK.Server") + + + + diff --git a/system/std.graphik/1.8.7/src/graphik editor b/system/std.graphik/1.8.7/src/graphik editor new file mode 100644 index 0000000..7aa6e33 --- /dev/null +++ b/system/std.graphik/1.8.7/src/graphik editor @@ -0,0 +1,324 @@ +PACKET graphic editor DEFINES graphic, (*Autor: H.Indenbirken *) + picfile, picture, (*Stand: 26.02.1985 *) + + neu zeichnen, + + UP, DOWN, T, + + pen, select pen, selected pen, background, + extrema pic, extrema picfile: + + + +LET norm cmd = ""1""27""3""10""9"epb"16"", + hop cmd = ""2""10""12""1"", + bell = ""7"", + esc = ""27""; + +PICFILE VAR p; +PICTURE VAR pic; +TEXT VAR command :: "", old command :: "", char, headline :: ""; +BOOL VAR within edit :: FALSE, new plot :: FALSE; +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; + +PROC open graphic (TEXT CONST name, DATASPACE CONST ds): + p := ds; + get values (p, size, limits, angles, oblique, perspective); + head line := ""1""15"LEN ................................ DIM PEN .."14" Picture "15""14""; + replace (head line, 32-LENGTH name DIV 2, name); + new plot := TRUE; + within edit := TRUE +END PROC open graphic; + +PROC graphic: + graphic (last param) +END PROC graphic; + +PROC graphic (TEXT CONST name) : + IF NOT exists (name) + THEN IF yes ("Soll ein neuer Picfile eingerichtet werden") + THEN graphic (new (name), name) FI + ELSE graphic (old (name), name) FI + +END PROC graphic; + +PROC graphic (DATASPACE CONST f, TEXT CONST name) : + open graphic (name, f); + reset; + kommandos bearbeiten; + within edit := FALSE . + +kommandos bearbeiten : + REP IF new plot + THEN plot (p); + new plot := FALSE + FI; + read picture (p, pic); + out head line; + inchar (command); + do command + PER . + +out head line: + replace (headline, 7, text (length (pic), 5)); + replace (headline, 50, text (dim (pic), 1)); + replace (headline, 57, text (pen (pic), 2)); + replace (headline, 72, text (picture no (p), 4)); + out (head line) . + +do command: + SELECT pos (norm cmd, command) OF + CASE 1: hop commands + CASE 2: escape commands + CASE 3: position up + CASE 4: position down + CASE 5: position direct + CASE 6: extrema pic + CASE 7: selected pen (pen (pic)); + CASE 8: out (1, 2, ""15""5"Hintergrundfarbe: " + + colour of (background (p)) + " "14"") + CASE 9: identify (pic); + OTHERWISE out (bell) ENDSELECT . + +position up : + IF is first picture (p) + THEN out (bell); + ELSE up (p) FI . + +position down : + IF eof (p) + THEN out (bell) + ELSE down (p) FI . + +position direct: + out (1, 68, ""); + edit get (command, 4, 4); + to pic (p, int (command)) . + +hop commands : + inchar (command); + SELECT pos (hop cmd, command) OF + CASE 1: to first pic (p) + CASE 2: to eof (p) + CASE 3: delete picture (p); + IF NOT new plot + THEN erase (pic) FI + CASE 4: new plot := TRUE + OTHERWISE out (bell) ENDSELECT . + +escape commands : + inchar (command); + IF command = "q" + THEN LEAVE kommandos bearbeiten + ELIF command = "f" + THEN do (old command) + ELIF command = esc + THEN kommandomodus + ELSE do (kommando auf taste (command)) FI . + +END PROC graphic; + +PROC kommandomodus: + command := ""; + disable stop; + REP get command; + do (command) + UNTIL command executed PER; + + IF new values + THEN get values (size, limits, angles, oblique, perspective); + set values (p, size, limits, angles, oblique, perspective); + new plot := new plot OR new values + FI . + +get command: + REP out (1, 2, ""15"Gib Graphikkommando: "); + edit get (command, 0, 54, "", "k", char); + out (""14""); + out (1, 2, ""5""); + + IF char = ""13"" + THEN LEAVE get command + ELIF char = ""27"k" + THEN command := old command FI + PER . + +command executed: + IF is error + THEN out (1, 1, error message); + clear error; + FALSE + ELSE old command := command; + TRUE + FI . + +END PROC kommandomodus; + +PROC out (INT CONST x, y, TEXT CONST t): + cursor (x, y); + out (t) +END PROC out; + +TEXT PROC colour of (INT CONST colour): + SELECT colour OF + CASE 0: "löschen" + CASE 1: "std" + CASE 2: "rot" + CASE 3: "blau" + CASE 4: "grün" + CASE 5: "schwarz" + CASE 6: "weiß" + OTHERWISE text (colour) ENDSELECT . +END PROC colour of; + +TEXT PROC linetype of (INT CONST linetype): + SELECT linetype OF + CASE 0: "unsichtbar" + CASE 1: "durchgehend" + CASE 2: "gepunktet" + CASE 3: "kurz gestrichelt" + CASE 4: "lang gestrichelt" + CASE 5: "strichpunkt" + OTHERWISE text (linetype) ENDSELECT . +END PROC linetype of; + +PICFILE PROC picfile : + IF NOT within edit + THEN errorstop ("Not within editmode") FI; + p +END PROC picfile; + +PICTURE PROC picture : + IF NOT within edit + THEN errorstop ("Not within editmode") FI; + pic +END PROC picture; + +PROC neu zeichnen: + new plot := TRUE +END PROC neu zeichnen; + +OP UP (INT CONST distance): + up (p, distance); + read picture (p, pic) +END OP UP; + +OP DOWN (INT CONST distance): + down (p, distance); + read picture (p, pic) +END OP DOWN; + +OP T (INT CONST n): + to pic (p, n); + read picture (p, pic) +END OP T; + +PROC pen (INT CONST n): + IF NOT new plot + THEN erase (pic) FI; + + pen (pic, n); + write picture (p, pic); + + IF NOT new plot + THEN show (pic) FI +END PROC pen; + +PROC select pen (INT CONST n, colour, thickness, linetype, BOOL CONST hidden): + select pen (p, n, colour, thickness, linetype, hidden); + new plot := TRUE +END PROC select pen; + +PROC select pen (INT CONST n, colour, thickness, linetype): + select pen (p, n, colour, thickness, linetype, FALSE); + new plot := TRUE +END PROC select pen; + +PROC selected pen (INT CONST n, INT VAR colour, thickness, linetype, + BOOL VAR hidden): + selected pen (p, n, colour, thickness, linetype, hidden); +END PROC selected pen; + +PROC selected pen (INT CONST n): + INT VAR colour, thickness, linetype; + BOOL VAR hidden; + selected pen (p, n, colour, thickness, linetype, hidden); + out (1, 2, ""5""15"PEN #" + text (n) + ": Farbe: " + colour of (colour) + + ", Dicke " + text (thickness) + ", Linientyp " + linetype of (linetype) + + hidden text + " "14"") . + +hidden text: + IF hidden + THEN ". " + ELSE ", nicht sichtbare Linien werden unterdrückt." FI . + +END PROC selected pen; + +INT PROC background: + background (p) +END PROC background; + +PROC background (INT CONST n): + new plot := n <> background (p); + background (p, n) +END PROC background; + +PROC extrema pic: + REAL VAR x min, x max, y min, y max, z min, z max; + IF dim (pic) = 2 + THEN extrema (pic, x min, x max, y min, y max); + out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) + + "] [" + text (y min) + "," + text (y max) + "] "14"") + ELSE extrema (pic, x min, x max, y min, y max, z min, z max); + out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) + + "] [" + text (y min) + "," + text (y max) + + "] [" + text (z min) + "," + text (z max) +"] "14"") + FI +END PROC extrema pic; + +PROC extrema picfile: + REAL VAR x min, x max, y min, y max, z min, z max; + extrema (p, x min, x max, y min, y max, z min, z max); + out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) + + "] [" + text (y min) + "," + text (y max) + + "] [" + text (z min) + "," + text (z max) +"] "14"") +END PROC extrema picfile; + +PROC identify (PICTURE CONST pic): + begin plot; + hidden lines (TRUE); + pen (background (p), 1, 1, 2); + plot (pic); + end plot +END PROC identify; + +PROC erase (PICTURE CONST pic): + INT VAR colour, thickness, linetype; + BOOL VAR hidden; + + selected pen (p, pen (pic), colour, thickness, linetype, hidden); + begin plot; + hidden lines (TRUE); + pen (background (p), 0, thickness, linetype); + plot (pic); + end plot +END PROC erase; + +PROC show (PICTURE CONST pic): + INT VAR colour, thickness, linetype; + BOOL VAR hidden; + + selected pen (p, pen (pic), colour, thickness, linetype, hidden); + begin plot; + hidden lines (TRUE); + pen (background (p), colour, thickness, linetype); + plot (pic); + end plot +END PROC show; + +END PACKET graphic editor; + -- cgit v1.2.3