summaryrefslogtreecommitdiff
path: root/app/mpg/1987/src/GRAPHIK.Configurator
blob: 7bfdbb94afa61fcced6bb8b9ef1cd4a6b38443e9 (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
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
(**************************************************************************) 
(*                                                                        *) 
(*                        MPG - Graphik - System                          *) 
(*                                                                        *) 
(*                      Version 2.2 vom 11.11.1987                        *) 
(*                                                                        *) 
(*            (c) 1987 Beat Jegerlehner & Carsten Weinholz                *) 
(*                unter Verwendung der Standard-Graphik                   *) 
(*          "Graphik-Konfiguration" geschrieben von C.Weinholz            *) 
(*                                                                        *) 
(**************************************************************************) 
(*                                                                        *) 
(*                          Graphik-Konfiguration                         *) 
(*                                                                        *) 
(*              Erstellung eines fuer alle Engeraete gueltigen            *) 
(*                Basisgraphik-Paketes durch zusammenfuegen               *) 
(*                           von '.GCONF'-Dateien                         *) 
(*                                                                        *) 
(*            Aufruf durch 'configurate graphik', wenn insertiert         *) 
(*                      (normalerweise nicht notwendig)                   *) 
(*             Bei 'run' muss 'configurate graphik' ans Dateiende         *) 
(*                            geschrieben werden.                         *) 
(*                                                                        *) 
(**************************************************************************) 
PACKET graphik configuration DEFINES configurate graphik: 
 
LET PLOTTERCONF = STRUCT (TEXT name, station, channel, area, prep, init, end, 
                               clear, home, move, draw, pixel, foreground, 
                               background, palette, std colors, circle, box, 
                               fill, cursor, get cursor, set marker, linked,
                               BOOL editor, 
                               BOOL no plotter); 
LET max conf      = 15,
    dquote        = ""34""34"",
    interface     = "GRAPHIK.Configuration", 
    env conf file = "ENVIRONMENT.GCONF",
    packet header = "PACKET device interface DEFINES prepare, init plot, endplot, clear, home, moveto, drawto, setpixel, foreground, background, set color, stdcolors, color, colors, set palette, circle, box,fill,graphik cursor, get cursor, set marker:",
    packet end    = "END PACKET device interface", 
    target        = "TARGET VAR  plotter; initialize target ( plotter);", 
    install target= "install plotter ( plotter);", 
    init set      = "PROC initplot: IF  wsc THEN  palette :=  std palette 
                     ELSE  palette :=  empty palette FI;  initplot; set palette 
                     END PROC initplot;", 
    end set       = "BOOL VAR  we::TRUE; 
                     PROCendplot(BOOL CONSTs): we:=s 
                     END PROCendplot; 
                     PROCendplot: IF weTHEN endplotFI 
                     END PROCendplot;", 
    clear set     = "BOOL VAR  wc::TRUE; PROCclear(BOOL CONSTs): wc:=s  
                     END PROC clear; PROC clear:IF wcTHEN clearFI END PROC clear;", 
    color set     = "BOOL VAR  wsc::TRUE; TEXT VAR  palette; PROC setcolor (INT CONST no,rgb):
                     IF (no+1) <= colors THEN replace( palette,no+1,rgb)
                     FI END PROC set color;", 
    color set2    = "INT PROC colors : length ( palette) DIV 2 END PROC colors; 
                     INT PROC color (INT CONST no): IF no >= 0  AND (no+1) <= colors 
                     THEN  palette ISUB (no+1) ELSE maxint FI END PROC color;", 
    std colors    = "PROCstdcolors(BOOL CONSTs):  wsc:=s END PROCstdcolors; 
                     PROC stdcolors:IF wscTHEN palette :=  std palette;set palette FI END PROCstdcolors;", 
    foreground    = "INT VAR af::1; INT PROCforeground: af END PROCforeground; 
                     PROCforeground(INT CONSTm):  af:=m; foreground( af) END PROCforeground;",  
    background    = "INT VAR  ab::0; INT PROCbackground: ab END PROCbackground; 
                     PROCbackground(INT CONSTm):  ab:=m; background( ab) END PROCbackground;"; 

ROW max conf PLOTTERCONF VAR plotter; 
ROW max conf DATASPACE VAR global data; 
 
TEXT CONST spaces :: 20 * " ";
INT VAR inst plotter, targets, error line :: 0;
TEXT VAR errorm1, errorm2, procvalue :: "", env conf, error source :: "";
BOOL VAR errors :: FALSE; 
FILE VAR f; 
DATASPACE VAR conf ds; 
THESAURUS VAR plotconfs; 
 
PROC configurate graphik: 
   FOR inst plotter FROM 1 UPTO max conf REP 
       act plotter.name := ""; 
       act plotter.area := ""; 
       act plotter.prep := "";
       act plotter.init := ""; 
       act plotter.end  := ""; 
       act plotter.clear:= ""; 
       act plotter.home := ""; 
       act plotter.move := ""; 
       act plotter.draw := ""; 
       act plotter.pixel:= ""; 
       act plotter.foreground := ""; 
       act plotter.background := ""; 
       act plotter.palette    := ""; 
       act plotter.circle     := ""; 
       act plotter.box        := "";  
       act plotter.fill       := ""; 
       act plotter.cursor     := ""; 
       act plotter.get cursor := ""; 
       act plotter.set marker := ""; 
       act plotter.linked     := "";
       act plotter.editor     := FALSE; 
    PER; 
    env conf := "";
    inst plotter := 0; 
    plotconfs := empty thesaurus; 
    IF exists (env conf file) 
       THEN plotconfs := ALL env conf file 
    FI; 
    plotconfs := SOME (plotconfs + (all LIKE "*.GCONF") - env conf file);  
    INT VAR id :: 0; TEXT VAR conf file; 
    get (plotconfs, conf file, id); 
    WHILE id > 0 REP 
       IF exists (conf file) 
          THEN extract conf data (conf file)  
          ELSE get environment plotter
       FI;
       get (plotconfs, conf file, id); 
    PER; 
    IF inst plotter > 0 
       THEN generate interface
       ELSE errorstop ("Kein Interface erzeugt") 
    FI;
    last param (interface). 
 
    get environment plotter: 
       check sequence (conf file, "PLOTTER *,*,*,*,*,*,*;", 
                             "2|4,3,3,3,3,3,3;", 
                             "PLOTTER erwartet,"+ 
                             "Name erwartet,,"+ 
                             "Station erwartet,,"+ 
                             "Kanal erwartet,,"+ 
                             "XPixel erwartet,,"+ 
                             "YPixel erwartet,,"+ 
                             "Xcm erwartet,,"+ 
                             "Ycm erwartet,,"+ 
                             "Plotterkommando fehlerhaft"); 
       IF errors  
          THEN errorstop (errorm2) 
          ELSE TEXT VAR one int :: ""0""0"", one real :: 8 * ""0"";
               replace (one int,1,length(get var (1))); 
               env conf CAT one int;
               env conf CAT get var (1);
               replace (one int, 1, int (get var (2)));
               env conf CAT one int;
               replace (one int, 1, int (get var (3)));
               env conf CAT one int; 
               replace (one int, 1, int (get var (4)));
               env conf CAT one int; 
               replace (one int, 1, int (get var (5)));
               env conf CAT one int; 
               replace (one real, 1, real (get var (6)));
               env conf CAT one real; 
               replace (one real, 1, real (get var (7))); 
               env conf CAT one real;
       FI 
END PROC configurate graphik; 
 
PROC extract conf data (TEXT CONST conf file): 
   TEXT VAR line;
   inst plotter INCR 1; 
   IF inst plotter > max conf 
      THEN putline ("Warnung: Es koennen nicht mehr als " + text(max conf) + 
                    " Geraete konfiguriert werden"); 
           inst plotter DECR 1 
      ELSE error source := conf file; 
           conf ds := old (conf file); 
           f := sequential file (modify, conf ds); 
           set line numbers;
           IF is plotter configuration 
              THEN get name and area (line, act plotter.name, 
                                            act plotter.station, 
                                            act plotter.channel, 
                                            act plotter.area);
                   get linked    (act plotter.linked);
                   get includes;
                   putline ("""" + act plotter.name + """ wird eingelesen"); 
                   get paramless ("initplot",act plotter.init); 
                   get paramless ("endplot" ,act plotter.end); 
                   get paramless ("clear"   ,act plotter.clear); 
                   get paramless ("home"    ,act plotter.home); 
                   get paramless ("prepare" ,act plotter.prep);
                   get koord     ("moveto"  ,act plotter.move); 
                   get koord     ("drawto"  ,act plotter.draw); 
                   get koord     ("setpixel",act plotter.pixel); 
                   get var param ("foreground",act plotter.foreground); 
                   get var param ("background",act plotter.background); 
                   get paramless ("setpalette",act plotter.palette); 
                   get std colors(act plotter.std colors); 
                   get circle    (act plotter.circle); 
                   get box       (act plotter.box); 
                   get fill      (act plotter.fill); 
                   IF editor available 
                      THEN get graphik cursor (act plotter.cursor); 
                           get get cursor     (act plotter.get cursor); 
                           get set marker     (act plotter.set marker) 
                   FI;
                   push error; 
                   IF anything noted 
                      THEN f := sequential file (modify,conf file); 
                           out (""7"");note edit (f);errorstop("") 
                   FI 
              FI;  
              global data [inst plotter] := conf ds; 
              forget (conf ds) 
   FI. 
 
   is plotter configuration: 
      plotter [inst plotter].no plotter := NOT sequence found ("PLOTTER", 
                                                               line, 1,TRUE);
      NOT plotter [inst plotter].no plotter. 
 
   editor available: 
      plotter [inst plotter].editor := sequence found ("EDITOR", line, 1,TRUE); 
      IF plotter [inst plotter].editor
         THEN delete record (f); 
              check sequence (line, "EDITOR;", "2;",  
                            "EDITOR erwartet,"+ 
                            "Semikolon erwartet," + 
                            "Editorkommando fehlerhaft") 
      FI; 
      plotter [inst plotter].editor. 
 
   set line numbers: 
      INT VAR  line number;
      to line (f,1); 
      FOR line number FROM 1 UPTO lines (f)-1 REP 
          cout (line number);
          insert line number;           
          down (f)
      PER; 
      insert line number. 
 
   insert line number: 
      TEXT VAR new line;
      read record (f, new line); 
      insert char (new line, " ", 1); 
      insert char (new line, " ", 1); 
      replace (new line, 1, line number); 
      write record (f, new line). 
          
   get includes: 
      BOOL VAR include found :: sequence found ("INCLUDE",line, 1, TRUE); 
      WHILE include found REP 
         push error;
         include found := sequence found ("INCLUDE",line, line no (f), TRUE); 
         IF include found 
            THEN add to plotconfs 
         FI 
      PER. 
 
      add to plotconfs: 
         check sequence (line, "INCLUDE *;","2|4;", 
                               "INCLUDE erwartet,Dateiname erwartet," +
                               "Includekommando fehlerhaft");
         IF NOT errors CAND exists (get var (1))
            THEN IF NOT (plotconfs CONTAINS get var (1)) 
                    THEN insert (plotconfs,get var (1))
                 FI;
         ELIF NOT errors
            THEN error ("""" + get var (1) + """ existiert nicht")
         FI;
         delete record (f)
END PROC extract conf data; 
 
PROC generate interface: 
   INT VAR act conf; 
   conf ds := nilspace; 
   forget (interface,quiet); 
   proc value := ""; 
   FILE VAR f :: sequential file (output, conf ds); 
   putline (f,packet header); 
   putline (f,target); 
   generate target;
   putline (f,install target); 
   putline (f,init set);
   putline (f,end set); 
   putline (f,clear set); 
   putline (f,color set); 
   putline (f,color set 2);
   putline (f, std colors);
   putline (f,foreground); 
   putline (f,background); 
   FOR act conf FROM 1 UPTO inst plotter REP 
      FILE VAR source := sequential file (modify,global data [act conf]); 
      copy lines (f,source) 
   PER; 
   generate proc (""," initplot", TEXT PROC (INT CONST) initplotbody); 
   generate proc (""," endplot",  TEXT PROC (INT CONST) endplotbody); 
   generate proc (""," clear",    TEXT PROC (INT CONST) clearbody); 
   generate proc ("","prepare",   TEXT PROC (INT CONST) prepbody);
   proc value := " TEXT";
   generate proc (""," std palette", TEXT PROC (INT CONST) std palette body); 
   generate proc (""," empty palette", TEXT PROC (INT CONST) empty palette body);
   proc value := "";
   generate proc ("","home",     TEXT PROC (INT CONST) homebody); 
   generate proc ("INT CONST x,y","moveto", TEXT PROC (INT CONST) movebody); 
   generate proc ("INT CONST x,y","drawto", TEXT PROC (INT CONST) drawbody); 
   generate proc ("INT CONST x,y","set pixel", TEXT PROC (INT CONST) pixelbody); 
   generate proc ("INT VAR type"," foreground", TEXT PROC (INT CONST) foregroundbody); 
   generate proc ("INT VAR type"," background", TEXT PROC (INT CONST) backgroundbody); 
   generate proc ("","set palette", TEXT PROC (INT CONST) set palette body); 
   generate proc ("INT CONST x,y,rad,from,to","circle", TEXT PROC (INT CONST) circlebody); 
   generate proc ("INT CONST x1,y1,x2,y2,pattern", "box", TEXT PROC (INT CONST) box body); 
   generate proc ("INT CONST x,y,pattern","fill", TEXT PROC (INT CONST) fill body); 
   generate proc ("INT CONST x,y, BOOL CONST on","graphik cursor",TEXT PROC (INT CONST) graphik cursor body); 
   generate proc ("INT VAR x,y, TEXT VAR exit char","get cursor",TEXT PROC (INT CONST) get cursor body); 
   generate proc ("INT CONST x,y, type","set marker",TEXT PROC (INT CONST) set marker body); 
   proc value := "BOOL "; 
   generate proc ("","graphik cursor",TEXT PROC (INT CONST) editor available); 
   generate device link;
   putline (f,packet end); 
   copy (conf ds,interface);
   IF yes ("""" + interface + """ insertieren")
      THEN insert (interface)
   FI.
 
   generate target:
      INT VAR devices :: 0; 
      targets := 0;
      FOR act conf FROM 1 UPTO inst plotter REP 
         TEXT VAR linked :: plotter[act conf].linked,
                  one int:: ""0""0"";
         plotter [act conf].linked := "";
         IF NOT plotter [act conf].no plotter 
             THEN putline (f,"complete target ( plotter,""" + 
                  plotter [act conf].station + "/" + 
                  plotter [act conf].channel + "/" + 
                  plotter [act conf].name + 
                  """,""" + plotter [act conf].area + """);"); 
                  devices INCR 1; 
                  targets INCR 1;
                  replace (one int, 1, devices);
                  plotter [act conf].linked CAT one int; 
                  replace (one int, 1, targets);
                  plotter [act conf].linked CAT one int;
                  IF linked > "" 
                     THEN INT VAR x :: 1; 
                          WHILE x <=  length (linked) DIV 2 REP 
                             putline (f,"complete target ( plotter, """ + 
                             text(linked ISUB x) + "/" + 
                             text(linked ISUB (x+1)) + "/" + 
                             plotter[act conf].name + """,""" + 
                             plotter[act conf].area + """);"); 
                             targets INCR 1; 
                             replace (one int, 1, targets);
                             plotter [act conf].linked CAT one int; 
                             x INCR 2 
                          PER
                  FI
          FI 
      PER; 
      WHILE env conf <> "" REP 
         generate env target (env conf) 
      PER 
END PROC generate interface; 
 
PROC generate env target (TEXT VAR conf):
   INT VAR nlen  :: conf ISUB 1; 
   TEXT VAR tnam :: subtext (conf, 3, 2+nlen); 
   conf := subtext (conf, nlen + 3);
   putline (f,"complete target ( plotter, """ + text (conf ISUB 1) + "/" + 
              text (conf ISUB 2) + "/" + tnam + """,""" + 
              text (conf ISUB 3) + "," + text (conf ISUB 4) + "," + 
              first real + "," + text (conf RSUB 2) + """);");
   conf := subtext (conf, 17). 
 
   first real: 
      conf := subtext (conf, 9); 
      text (conf RSUB 1)
END PROC generate env target; 
 
TEXT PROC initplotbody (INT CONST no): 
   plotter [no].init 
END PROC initplotbody; 
 
TEXT PROC endplotbody (INT CONST no): 
   plotter [no].end 
END PROC endplotbody; 
 
TEXT PROC clearbody (INT CONST no): 
   plotter [no].clear 
END PROC clearbody; 
 
TEXT PROC prepbody (INT CONST no): 
   plotter [no].prep 
END PROC prepbody; 
 
TEXT PROC homebody (INT CONST no): 
   plotter [no].home 
END PROC homebody; 
 
TEXT PROC movebody (INT CONST no): 
   plotter [no].move 
END PROC movebody; 
 
TEXT PROC drawbody (INT CONST no): 
   plotter [no].draw 
END PROC drawbody; 
 
TEXT PROC pixelbody (INT CONST no): 
   plotter [no].pixel  
END PROC pixelbody; 
 
TEXT PROC std palette body (INT CONST no): 
   TEXT CONST rgb codes :: plotter [no].std colors;
   TEXT VAR body :: dquote; 
   INT VAR x; 
   FOR x FROM 1 UPTO length (rgb codes) DIV 3 REP 
      INT VAR color :: int (subtext(rgb codes, (x-1)*3+1, x*3)); 
      body CAT (text (color AND 255) + dquote);
      body CAT (text (color DIV 256) + dquote);
   PER;
   body 
END PROC std palette body;
 
TEXT PROC empty palette body (INT CONST no):
   text (length (plotter[no].std colors) DIV 3) + "*" + dquote +
   "255" + dquote + "127" + dquote
END PROC empty palette body;

TEXT PROC set palette body (INT CONST no): 
   plotter[no].palette 
END PROC set palette body; 
 
TEXT PROC foregroundbody (INT CONST no): 
   plotter [no].foreground 
END PROC foregroundbody; 
 
TEXT PROC backgroundbody (INT CONST no): 
   plotter [no].background 
END PROC backgroundbody; 
 
TEXT PROC circle body (INT CONST no): 
   plotter [no].circle 
END PROC circle body; 
 
TEXT PROC box body (INT CONST no): 
   plotter [no].box  
END PROC box body; 
 
TEXT PROC fill body (INT CONST no): 
   plotter [no].fill 
END PROC fill body; 
 
TEXT PROC graphik cursor body (INT CONST no): 
   plotter [no].cursor 
END PROC graphik cursor body; 
 
TEXT PROC get cursor body (INT CONST no): 
   plotter [no].get cursor 
END PROC get cursor body; 
 
TEXT PROC set marker body (INT CONST no): 
   plotter [no].set marker 
END PROC set marker body; 
 
TEXT PROC editor available (INT CONST no): 
   IF plotter [no].editor 
      THEN "TRUE" 
      ELSE "FALSE" 
   FI 
END PROC editor available; 

PROC generate device link:
   INT VAR actconf;
   putline (f, "INT PROC  act device :");
   putline (f, "SELECT actual plotter OF");
   FOR act conf FROM 1 UPTO inst plotter REP
      IF NOT plotter [act conf].no plotter
         THEN putline (f,"CASE " + text (plotter[act conf].linked ISUB 2) + ":");
              put (f,text (plotter[act conf].linked ISUB 1));
              IF length (plotter[act conf].linked) > 2 
                 THEN generate table 
              FI
      FI 
   PER;
   putline (f,"OTHERWISE errorstop (""Kein Endgeraet angekoppelt"");0"); 
   putline (f,"END SELECT END PROC  act device;").

   generate table: 
      INT VAR x; 
      FOR x FROM 3 UPTO length (plotter[act conf].linked) DIV 2 REP 
         put (f,"CASE"); 
         put (f,text (plotter[act conf].linked ISUB x)); 
         put (f,":"); 
         put (f, text (plotter[act conf].linked ISUB 1))
      PER 
END PROC generate device link; 

PROC generate proc (TEXT CONST params,procname,TEXT PROC (INT CONST)procbody): 
   INT VAR actconf, no plotter :: 0; 
   IF params = "" 
      THEN putline (f,procvalue + " PROC " + procname + ":") 
      ELSE putline (f,procvalue + " PROC " + procname + "(" + params + "):") 
   FI; 
   IF procvalue <> "" 
      THEN putline (f,procvalue + " VAR  d;") 
   FI; 
   putline (f,"SELECT  act device OF");  
   FOR act conf FROM 1 UPTO inst plotter REP 
       IF NOT plotter [act conf].no plotter 
          THEN putline (f, "CASE " + text (act conf-no plotter) + ":" + 
                           lowercase(plotter[act conf].name) + 
                           plotter [act conf].channel + procname) 
          ELSE no plotter INCR 1 
       FI 
   PER; 
   IF procvalue <> "" 
      THEN putline (f," OTHERWISE  d END SELECT")
      ELSE putline (f," END SELECT") 
   FI; 
   FOR act conf FROM 1 UPTO inst plotter REP                                 
       IF NOT plotter [act conf].no plotter 
          THEN putline (f,"."); 
               putline (f,lowercase(plotter[act conf].name)+ 
                          plotter[act conf].channel + procname + ":"); 
                          putline (f,procbody (act conf)) 
       FI 
   PER; 
   putline (f,"END PROC "+ procname +";") 
END PROC generate proc;      
 
PROC get name and area (TEXT CONST line, TEXT VAR name, station, channel, area): 
   push error; 
   check sequence (line, "PLOTTER *,*,*,*,*,*,*;", 
                         "2|4,3,3,3,3,3,3;", 
                         "PLOTTER erwartet,"+ 
                         "Name erwartet,,"+ 
                         "Station erwartet,,"+ 
                         "Kanal erwartet,,"+ 
                         "XPixel erwartet,,"+ 
                         "YPixel erwartet,,"+ 
                         "Xcm erwartet,,"+ 
                         "Ycm erwartet,,"+ 
                         "Plotterkommando fehlerhaft"); 
   name    := get var (1); 
   station := get var (2); 
   channel := get var (3); 
   area := ""; 
   area CAT (get var (4) + ","); 
   area CAT (get var (5) + ","); 
   area CAT (get var (6) + ","); 
   area CAT (get var (7) + ","); 
   delete record (f)
END PROC get name and area; 
 
PROC get linked (TEXT VAR keep):
   TEXT VAR line;
   IF sequence found ("LINK", line, 1, TRUE)
      THEN extract data;
           delete record (f)
   FI.  
 
   extract data: 
      TEXT VAR symbol, one int :: ""0""0"";
      INT VAR ltyp :: 2,type :: 0;(* 0 = ',' 1 = '/' 2 = Station 3 = Kanal*) 
      push error;                 (* 4 = Ende erwartet ! *)
      keep := "";
      errorm1 := line; 
      scan (line);
      next symbol (symbol);
      IF symbol <> "LINK"
         THEN error ("LINK erwartet")
      FI;
      WHILE type < 7 AND NOT errors REP 
         next symbol (symbol, type); 
         IF ltyp = 0 
            THEN IF symbol = "," 
                    THEN ltyp := 2 
                 ELIF symbol = ";" 
                    THEN ltyp := 4 
                    ELSE error ("Semikolon oder Komma erwartet") 
                 FI
         ELIF ltyp = 1 
            THEN IF symbol = "/" 
                    THEN ltyp := 3 
                    ELSE error ("'/' erwartet")
                 FI
         ELIF ltyp = 4 
            THEN IF type = 8 
                    THEN error ("Kommentarende fehlt") 
                 ELIF type = 9 
                    THEN error ("Text unzulaessig (Textende fehlt)") 
                 ELIF type <> 7 
                    THEN error ("Zeilenende nach Semikolon erwartet") 
                 FI 
         ELIF type = 3  
            THEN replace (one int, 1, int (symbol)); 
                 keep CAT one int; 
                 ltyp DECR 1;
                 IF ltyp = 2 
                    THEN ltyp := 0 
                 FI 
      FI
   PER
END PROC get linked; 
 
PROC get graphik cursor (TEXT VAR keep): 
   get proc ("graphik cursor","(INT CONST x,y, BOOL CONST on)", 
             "(2|2 x,y,2|2 on)","INT erwartet, CONST erwartet,"+ 
             "Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,"+ 
             "BOOL erwartet, CONST erwartet,"+ 
             "Formaler Parameter muss on heissen", 
             keep); 
END PROC get graphik cursor; 
 
PROC get get cursor (TEXT VAR keep): 
   get proc ("get cursor","(INT VAR x,y, TEXT VAR exit char)", 
             "(2|2 x,y,2|2 exit char)","INT erwartet, VAR erwartet,"+ 
             "Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,"+ 
             "TEXT erwartet, VAR erwartet,"+ 
             "Formaler Parameter muss exit char heissen", 
             keep); 
END PROC get get cursor; 
 
PROC get set marker (TEXT VAR keep): 
   get proc ("set marker","(INT CONST x,y,type)","(2|2 x,y,type)", 
             "INT erwartet, CONST erwartet,"+ 
             "Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,"+ 
             "Formaler Parameter muss type heissen", 
             keep); 
END PROC get set marker; 
 
PROC get std colors (TEXT VAR keep): 
   TEXT VAR line;
   push error; 
   IF sequence found ("COLORS", line, 1, TRUE)
      THEN extract data 
      ELSE error ("COLORS fehlt") 
   FI.  
 
   extract data: 
      check sequence (line, "COLORS *;","2|4;", 
                            "COLORS erwartet,"+ 
                            "Rgbcodes erwartet,Semikolon fehlt"); 
      keep := get var (1); 
      delete record (f); 
END PROC get std colors; 
 
PROC get paramless (TEXT CONST procname, TEXT VAR keep): 
   get proc (procname, "", "", "", keep) 
END PROC get paramless; 
 
PROC get var param (TEXT CONST procname, TEXT VAR keep): 
   get proc (procname, "(INT VAR type)","(2|2 type)", 
             "INT erwartet, VAR erwartet, Formaler Parameter muss type heissen", 
             keep); 
END PROC get var param; 
 
PROC get koord (TEXT CONST procname, TEXT VAR keep): 
   get proc (procname, "(INT CONST x,y)","(2|2 x,y)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen",keep) 
END PROC get koord; 
 
PROC get circle (TEXT VAR keep): 
   get proc ("circle","(INT CONST x,y,rad,from,to)","(2|2 x,y,rad,from,to)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,Formaler Parameter muss rad heissen,"+ 
             "Formaler Parameter muss from heissen,Formaler Parameter muss to heissen", 
             keep); 
END PROC get circle; 
 
PROC get box (TEXT VAR keep): 
   get proc ("box","(INT CONST x1,y1,x2,y2,pattern)","(2|2 x1,y1,x2,y2,pattern)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x1 heissen,"+ 
             "Formaler Parameter muss y1 heissen,Formaler Parameter muss x2 heissen,"+ 
             "Formaler Parameter muss y2 heissen,Formaler Parameter muss pattern heissen", 
             keep); 
END PROC get box; 
 
PROC get fill (TEXT VAR keep): 
   get proc ("fill","(INT CONST x,y,pattern)","(2|2 x,y,pattern)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen"+ 
             "Formaler Parameter muss y heissen,Formaler Parameter muss pattern heissen", 
             keep); 
END PROC get fill; 
 
PROC get proc (TEXT CONST procname, psym, ptyp, perr, 
               TEXT VAR   keep): 
   TEXT VAR line;
   push error; 
   IF sequence found ("PROC"+procname, line, 1, TRUE) 
      THEN errors := FALSE;
           get body (line,procname,psym,ptyp,perr,keep)
      ELSE error (procname + " nicht gefunden") 
   FI
END PROC get proc; 
 
PROC get body (TEXT CONST header,procname,psyms,ptypes ,perrs, TEXT VAR keep body): 
   INT VAR start, ende; 
   start := line no(f); 
   keep body := ""; 
   check sequence (header, "PROC " + procname + psyms + ":", 
                         "2|1"+ ptypes + ":", 
                         "PROC erwartet,"      + 
                          procname + " erwartet,,"+ 
                          perrs+ 
                         ",Fehler in " + procname + "-Header"); 
   IF NOT errors
      THEN get to end of proc
   FI.

   get to end of proc:
      TEXT VAR last;
      errors := FALSE; 
      IF sequence found ("END PROC " + procname,  last, line no(f),FALSE)
         THEN ende := line no (f); 
              check sequence (last, "END PROC " + procname + ";", 
                                    "2|2|1;", 
                                    "END erwartet,"+ 
                                    "PROC erwartet,"+ 
                                    "PROC heisst " + procname + 
                                    ",Semikolon fehlt"); 
              IF NOT errors 
                 THEN to line (f,start); 
                      delete record (f); 
                      INT VAR lc; 
                      FOR lc FROM start UPTO ende-2 REP 
                          TEXT VAR scratch; 
                          read record (f,scratch); 
                          scratch := subtext (scratch, 3);
                          keep body CAT (" " + scratch); 
                          delete record (f); 
                      PER; 
                      delete record (f)
              FI 
         ELSE error ("END PROC " + procname + " nicht gefunden") 
      FI 
END PROC get body; 
 
BOOL PROC sequence found (TEXT CONST sequence text, 
                          TEXT VAR   sequence line, INT CONST from line,
                          BOOL CONST evtl at): 
   BOOL VAR found :: FALSE, at char :: evtl at;
   to line (f,from line);
   col (f,1);
   WHILE NOT (found OR eof (f)) REP 
      cout (line no (f));
      to first char; 
      IF found 
         THEN read record (f, sequence line);
              error line := sequence line ISUB 1;
              sequence line := subtext (sequence line, 3); 
              scan sequence
      FI
   PER; 
   IF NOT found 
      THEN read record (f, sequence line);
           IF pos (first char, sequence line) > 0 
              THEN scan sequence 
           FI
   FI;
   found.
 
   to first char: 
      IF at char
         THEN downety (f, first char)
         ELSE down (f, first char)
      FI; 
      at char := FALSE;
      found := pattern found. 
 
   scan sequence: 
      TEXT VAR source symbols,symbols;
      scan (sequence text); 
      get symbols;
      source symbols := symbols;
      scan (sequence line); 
      get symbols; 
      found := pos (symbols,source symbols) = 1.

   get symbols: 
      TEXT VAR symbol;
      INT VAR type;
      symbols := "";
      REP 
          next symbol (symbol, type); 
          symbols CAT symbol
      UNTIL type > 6 PER. 
 
   first char: 
      sequence text SUB 1 
END PROC sequence found; 
 
PROC error (TEXT CONST emsg): 
   IF NOT eof (f) 
      THEN read record (f,errorm1); 
           errorm1 := """" + error source + """, Zeile " + 
                      text (error line) + ":"
      ELSE errorm1 := """" + error source + """, Fileende:" 
   FI; 
   errorm2 := spaces + emsg; 
   errors  := TRUE  
END PROC error; 
 
PROC push error: 
  IF errors 
     THEN note (errorm1);note line; 
          note (10* " " + errorm2); note line; 
          errors := FALSE 
  FI 
END PROC push error; 
 
 (* Hinweis: bei Fehlermeldungen statt Blank ' ' (geschuetzt) verwenden. 
             Bei verschiedenen Typen ohne trennenden Delimiter zur 
             Abgrenzung in 'seq typ' '|' verwenden. 
             '*' wird in 'seq sym' als Wildcard verwendet (Itemweise) 
             Bei Delimitern wird der 'allgemeine Fehler' (letzter i.d Liste) 
             verwendet. Jedoch muss auch fuer Delimiter ein Eintrag 
             in der Liste freigehalten werden (...,,... oder ...,dummy,...). 
*) 
 
ROW 100 STRUCT (TEXT sym, INT typ, BOOL var) VAR seqlist; 
INT VAR scanpos; 
 
TEXT PROC get var (INT CONST no): 
   INT VAR count :: 0, checkpos :: 1; 
   WHILE checkpos <= scanpos REP 
      IF seqlist[checkpos].var 
         THEN count INCR 1; 
              IF count >= no 
                 THEN LEAVE get var WITH seqlist[checkpos].sym 
              FI 
      FI; 
      checkpos INCR 1  
   PER;"" 
END PROC get var; 
 
PROC check sequence (TEXT CONST seq, seq sym, seq typ, seq err): 
   ROW 100 TEXT VAR err; 
   INT VAR checkpos,erpos, typ, error1 :: 0,error2 :: 0; 
   TEXT VAR sym; 
   scan (seq err); 
   next symbol (sym, typ); 
   erpos := 1; 
   err[erpos] := ""; 
   REP 
       SELECT typ OF 
         CASE 5: err[erpos] CAT " " 
         CASE 6: erpos INCR 1; 
                 err [erpos] := "" 
       OTHERWISE err[erpos] CAT sym 
       END SELECT; 
       next symbol (sym, typ) 
    UNTIL typ >= 7 PER; 
    scan (seq); 
    FOR scanpos FROM 1 UPTO 100 REP 
       next symbol (seqlist[scanpos].sym,seqlist[scanpos].typ); 
    UNTIL seqlist[scanpos].typ >= 7 PER; 
    SELECT seqlist[scanpos].typ OF 
      CASE 8: error ("Kommentarende fehlt") 
      CASE 9: error ("Textende fehlt") 
      OTHERWISE IF scanpos = 100 
                   THEN error ("Kommando zu schwierig") 
                FI 
    END SELECT; 
    scan (seq sym); 
    FOR checkpos FROM 1 UPTO scanpos REP 
       next symbol (sym, typ); 
       IF sym = "*" 
          THEN seqlist[checkpos].var := TRUE 
          ELSE seqlist[checkpos].var := FALSE 
       FI 
    PER; 
    scan (seq typ); 
    next symbol (sym,typ); 
    FOR checkpos FROM 1 UPTO scanpos REP 
       WHILE sym = "|" REP 
         next symbol (sym, typ) 
       PER; 
       BOOL VAR std err :: typ <> 3;  
       IF NOT std err 
          THEN typ := int(sym); 
               IF seqlist[checkpos].typ <> typ 
                  THEN error1 := checkpos 
               FI; 
       ELIF seqlist[checkpos].sym <> sym 
          THEN error1 := erpos 
       FI; 
       next symbol (sym, typ) 
    UNTIL error1 > 0 OR typ >= 7 PER; 
    scan (seq sym); 
    next symbol (sym,typ); 
    FOR checkpos FROM 1 UPTO scanpos-1 REP 
       std err := typ = 6; 
       IF (seqlist[checkpos].sym <> sym) AND (sym <> "*") 
          THEN IF std err 
                  THEN error2 := erpos 
                  ELSE error2 := checkpos 
               FI 
       FI; 
       next symbol (sym, typ) 
    UNTIL error2 > 0 PER; 
    IF error1 = 0 
       THEN error1 := error2 
    ELIF error1 = erpos 
       THEN IF (error2 <> 0) AND (error2 <> erpos) 
               THEN error1 := error2 
            FI 
    FI;  
    IF error1 > 0 
       THEN error (err [error1]) 
    FI 
END PROC check sequence; 
 
INT PROC lower pair (INT CONST upper pair): 
   INT VAR lower :: upper pair; 
   set bit (lower,5); 
   set bit (lower,13); 
   lower 
END PROC lower pair; 
 
TEXT PROC lower case (TEXT CONST uppercase): 
   TEXT VAR lower :: uppercase; 
   INT VAR x; 
   IF length(lower) MOD 2 <> 0 
      THEN lower CAT ""0"" 
   FI ; 
   FOR x FROM 1 UPTO length(lower)DIV2 REP 
      replace (lower,x,lower pair (lower ISUB x)) 
   PER; 
   lower  
END PROC lower case; 
 
PROC copy lines (FILE VAR dest, source): 
   INT VAR l; 
   input(source); 
   output(dest); 
   FOR l FROM 1 UPTO lines (source) REP 
      TEXT VAR scratch,test; 
      getline (source,scratch); 
      scratch := subtext (scratch,3);
      test := scratch; 
      change all (test," ",""); 
      IF test <> "" 
         THEN putline (dest, scratch) 
      FI 
   PER 
END PROC copy lines;

.act plotter:
   plotter[inst plotter]
 
END PACKET graphik configuration; 
configurate graphik