summaryrefslogtreecommitdiff
path: root/system/std.zusatz/1.7.3/src/std printer
blob: 91a07c753e8ca216c34ffccc575ee3a06788c04b (plain)
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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
PACKET std printer DEFINES reset printer,        (* F. Klapper *)
                           new page,             (* 21.05.84   *)
                           start, 
                           printer cmd, 
                           on, 
                           off, 
                           material, 
                           papersize, 
                           limit,
                           change type, 
                           print text, 
                           x pos,
                           y pos,
                           line: 

LET begin mark cmd    = ""15"",   (* Kommandos für 'output buffer' *)
    end   mark cmd    = ""14"",
    bsp        cmd    = ""8"" , 
    printercmd cmd    = ""16"",
    begin mark code   = 15,
    end   mark code   = 14, 
    bsp        code   = 8, 
    printercmd code   = 16,

    cr                = ""13"",   (* Steuerzeichen für die Ausgabe *)
    lf                = ""10"", 
    underline char    = "_",

    inch = 2.54,                  (* Konstanten *)
    max printer cmds per line = 10;

INT CONST std length of paper :: 12 * y factor per inch,
          std width  of paper :: cm to x steps (13.2 * inch),
          std limit           :: cm to x steps (12.0 * inch), 
          std first line      :: 5, 
          std first collumn   :: cm to x steps (inch),
 
          no xpos :: - 10;       (* beliebige negative ganze Zahl *)

INT VAR first collumn,
        first line,
        xlimit,
        actual line,
        x pos steps,
        width  of paper,
        length of paper,
        x pos mode;

BOOL VAR block mode,
         underline on,   (* gibt durch on / off gesetzten Zustand an *)
         underline out;  (* gibt Zustand an der bis jetzt durch output buffer
                            ausgegebenen Stelle an                   *)
TEXT VAR buffer,
         x pos buffer,
         left margin;
 
ROW max printer cmds per line TEXT VAR cmd arry;
INT VAR cmd pointer;

  length of paper    := std length of paper;
  first line         := std first line; 
  actual line        := 0;
  buffer             := ""; 
  reset printer;
 
INT PROC cm to x steps (REAL CONST cm): 
  int ((abs (cm) * real (x factor per inch) / inch) + 0.5)
END PROC cm to x steps; 
 
INT PROC cm to y steps (REAL CONST cm): 
  int ((abs (cm) * real (y factor per inch) / inch) + 0.5)
END PROC cm to y steps; 
 
PROC start (REAL CONST x, y):
  first collumn := cm to x steps (x);
  first line    := cm to y steps (y);
  left margin   := first collumn * " "
END PROC start;
 
PROC papersize (REAL CONST w, l): 
  width of paper  := cm to x steps (w);
  length of paper := cm to y steps (l); 
END PROC papersize;

PROC limit (REAL CONST x): 
   xlimit := cm to x steps (x);
END PROC limit;
 
PROC on (TEXT CONST attribute):
  IF (attribute SUB 1) = "u"
  THEN underline on := TRUE;
       buff CAT begin mark cmd
  FI.

buff:
  IF xpos steps >= 0
  THEN x pos buffer
  ELSE buffer
  FI.
END PROC on;

PROC off (TEXT CONST attribute):
  IF (attribute SUB 1) = "u"
  THEN underline on := FALSE;
       buff CAT end mark cmd
  FI.

buff:
  IF xpos steps >= 0
  THEN x pos buffer
  ELSE buffer
  FI.
END PROC off;

PROC printer cmd (TEXT CONST cmd): 
  IF cmd pointer < max printer cmds per line
  THEN cmd pointer INCR 1;
       cmd arry (cmd pointer) := cmd;
       buff CAT printercmd cmd
  FI.

buff:
  IF xpos steps >= 0
  THEN x pos buffer
  ELSE buffer
  FI.
END PROC printer cmd; 
 
PROC material (TEXT CONST name of material):
END PROC material;
 
PROC change type (TEXT CONST name of type): 
ENDPROC change type; 

PROC reset printer :
  new page;                                   (* actual line := 0 *)
  width  of paper    := std width  of paper;
  length of paper    := std length of paper;
  first line         := std first line; 
  first collumn      := std first collumn;
  xlimit             := std limit;
  xpos mode          := 0;
  cmd pointer        := 0;
  x pos steps        := no x pos;
  buffer             := ""; 
  xpos buffer        := "";
  left margin        := first collumn * " ";
  block mode         := FALSE;
  underline on       := FALSE;
  underline out      := FALSE;
ENDPROC reset printer;
 
PROC print text (TEXT CONST content, INT CONST mode):
  IF x pos steps >= 0
  THEN x pos buffer CAT content;
       x pos mode := mode MOD 4;
       block mode := FALSE
  ELSE buffer CAT content ;
       block mode := (mode MOD 4) = 3
  FI.
END PROC print text;

PROC tab and print:
  SELECT x pos mode OF
  CASE 0: fill (buffer, " ", x pos steps);
  CASE 1: fill (buffer, " ", x pos steps - outputlength (x pos buffer));
  CASE 2: fill (buffer, " ", 
                x pos steps - outputlength (xpos buffer) DIV 2);
  CASE 3: fill (buffer, " ", x pos steps);
          block (x pos buffer, xlimit - x pos steps);
  OTHERWISE
  END SELECT;
  buffer CAT x pos buffer;
  x pos buffer := "";
  x pos steps := no x pos.
END PROC tab and print;
 
INT PROC outputlength (TEXT CONST buff):
  length (buff) - chars (buff, printercmd cmd) - chars (buff, begin mark cmd)
                - chars (buff, end mark cmd) - chars (buff, bsp cmd) * 2 
END PROC outputlength;

PROC x pos (REAL CONST cm):
  IF x pos steps >= 0
  THEN tab and print
  FI;
  IF underline on
  THEN       buffer CAT end   mark cmd;
       x pos buffer CAT begin mark cmd
  FI;
  x pos steps := cm to x steps (cm)
END PROC x pos;

PROC y pos (REAL CONST cm):
  IF actual line = 0
  THEN output linefeed (first line - actual line); 
       actual line := first line 
  FI;
  output buffer;
  INT VAR y lf steps := cm to y steps (cm);
  output linefeed (y lf steps + first line - actual line);
  actual line := first line + y lf steps. 
END PROC y pos;

PROC line (REAL CONST proposed lf) :
  IF actual line = 0
  THEN output linefeed (first line - actual line); 
       actual line := first line 
  FI;
  output buffer;
  INT VAR done lf;
  convert into min y steps (proposed lf, done lf);
  output line feed (done lf);
  actual line INCR done lf;
END PROC line;

PROC convert into min y steps (REAL CONST in, INT VAR out): 
  IF in < 0.001
  THEN out := 0
  ELSE out := int (in);
       IF out < 1 THEN out := 1 FI
  FI; 
ENDPROC convert into min y steps;

PROC new page:
  IF buffer <> ""
  THEN line (1.0)
  FI;
  actual line := actual line MOD length of paper;
  IF actual line > first line 
  THEN output pagefeed (length of paper - actual line);
       actual line := 0 
  FI;
END PROC new page;

PROC output buffer:
  IF x pos steps >= 0
  THEN tab and print
  ELIF block mode
  THEN block (buffer, xlimit)
  FI ;
  TEXT VAR bsp buffer := "",
           underline buffer := "";
  INT VAR cmd pos := pos (buffer, ""1"", ""31"", 1),
          akt cmd pointer := 0,
          soon out := 0;
  out (left margin);
  put leading blanks not underlined;
  WHILE cmd pos > 0
  REP analyze cmd;
      cmd pos := pos (buffer, ""1"", ""31"", cmd pos)
  PER;
  IF underline out
  THEN fill (underline buffer, underline char, LENGTH buffer)
  FI;
  out buffer;
  out bsp buffer;
  out underline buffer;
  buffer := "";
  cmd pointer := 0.

put leading blanks not underlined:
  IF underline out
  THEN INT VAR first non blank pos := pos (buffer, ""33"", ""254"", 1);
       IF cmd pos > 0 CAND first non blank pos > 0
       THEN fill (underline buffer, " ", 
                  min (first non blank pos, cmd pos) - 1)
       ELIF cmd pos > 0
       THEN fill (underline buffer, " ", cmd pos - 1)
       ELSE fill (underline buffer, " ", first non blank pos -1)
       FI;
  FI.

analyze cmd:
  SELECT code (buffer SUB cmd pos) OF 
  CASE bsp code        : do bsp cmd
  CASE begin mark code : do begin mark cmd
  CASE end mark code   : do end   mark cmd
  CASE printercmd code : do printercmd cmd
  OTHERWISE 
  END SELECT.

do bsp cmd:
  fill (bsp buffer, " ", cmd pos - 2);
  cmd pos DECR 1;
  bsp buffer CAT (buffer SUB cmd pos);
  delete char (buffer, cmd pos);
  delete char (buffer, cmd pos).

do begin mark cmd:
  IF NOT underline out
  THEN underline out := TRUE;
       fill (underline buffer, " ", cmd pos -1);
       delete char (buffer, cmd pos)
  FI.

do end mark cmd:
  IF underline out
  THEN underline out := FALSE;
       fill (underline buffer, underline char, cmd pos - 1);
       delete char (buffer, cmd pos)
  FI.

do printercmd cmd:
  IF akt cmd pointer < cmd pointer
  THEN akt cmd pointer INCR 1;
       out subtext (buffer, soon out + 1, cmd pos - 1);
       soon out := cmd pos - 1;
       delete char (buffer, cmd pos);
       out (cmd arry (akt cmd pointer))
  FI.

out buffer:
  (* out (left margin) steht schon weiter oben *)
  outsubtext (buffer, soon out + 1).

out bsp buffer:
  IF bsp buffer <> ""
  THEN out (cr);
       out (left margin);
       out (bsp buffer)
  FI.

out underline buffer:
  IF underline buffer <> ""
  THEN out (cr);
       out (left margin);
       out (underline buffer)
  FI.
END PROC output buffer;

PROC fill (TEXT VAR buff, TEXT CONST char, INT CONST len):
  buff CAT (len - outputlength (buff)) * char
END PROC fill;

PROC output linefeed (INT CONST min y steps):
  IF min y steps > 0
    THEN out (cr);
         out (min y steps * lf)
  FI
ENDPROC output linefeed ;

PROC output pagefeed (INT CONST rest) :
  out (cr) ;
  rest TIMESOUT lf
ENDPROC output pagefeed ;

(********************* B L O C K **********************************)
LET blank = " " ,
    enumeration list = "-).:" ;

INT VAR to insert,
        nr of blanks ,
        nr of big spaces ,
        begin ;

TEXT VAR small space ,
         big space ;

BOOL VAR right := TRUE ;

PROC block (TEXT VAR blockline, INT CONST len):
  to insert := len - outputlength (blockline);
  nr of blanks := 0; begin:=0;
  IF to insert <= 0 THEN LEAVE block FI;
  IF to insert > (xlimit DIV 3 ) THEN LEAVE block FI;
  mark the variable blanks;
  IF nr of blanks <= 0 THEN LEAVE block FI;
  right := NOT right;
  compute spaces;
  insert spaces.

mark the variable blanks:
  skip blanks ;
  begin := pos(blockline,blank,begin+1);
  IF (pos (enumeration  list, (blockline SUB (begin-1))) > 0 )
    THEN skip blanks ;
         begin := pos(blockline,blank,begin+1);
  FI;
  WHILE begin > 0 REP
     IF single blank gap
       THEN change (blockline,begin,begin,""0""); 
            nr of blanks INCR 1;
       ELSE skip blanks
     FI;
     begin := pos(blockline,blank,begin+1);
  ENDREP.

single  blank gap :
  ((blockline SUB (begin+1)) <> blank).

skip blanks :
  begin := pos (blockline, ""33"", ""254"", begin+1) .

compute spaces:
  INT VAR steps :=  to insert ;
  INT VAR small :=  steps DIV nr of blanks;
  nr of big spaces  :=  steps MOD nr of blanks;
  small space := (small+1) * blank ;
  big space := small space ;
  big space CAT blank .

insert spaces:
  IF right THEN insert big spaces on right side
           ELSE insert big spaces on left side
  FI.

insert big spaces on right side:
  INT VAR nr of small spaces := nr of blanks - nr of big spaces;
  INT VAR i;
  FOR i FROM 1 UPTO nr of small spaces REP
      change (blockline, ""0"",small space)
  ENDREP;
  changeall (blockline,""0"",big space).

insert big spaces on left side:
  INT VAR j;
  FOR j FROM 1 UPTO nr of big spaces REP
     change (blockline,""0"",big space)
  ENDREP;
  changeall (blockline,""0"",small space).
ENDPROC block;

INT PROC chars (TEXT CONST text, char) :
  INT VAR how many := 0 ,
  cmd pos := pos (text, char) ;
  WHILE cmd pos > 0 REP
    how many INCR 1 ;
    cmd pos := pos (text, char, cmd pos+1)
  PER ;
  how many
ENDPROC chars ;

ENDPACKET std printer ;