1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
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
|
