diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /system/std.zusatz/1.7.3/src/std printer | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'system/std.zusatz/1.7.3/src/std printer')
| -rw-r--r-- | system/std.zusatz/1.7.3/src/std printer | 434 |
1 files changed, 434 insertions, 0 deletions
diff --git a/system/std.zusatz/1.7.3/src/std printer b/system/std.zusatz/1.7.3/src/std printer new file mode 100644 index 0000000..f00fa80 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer @@ -0,0 +1,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 fr '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 fr 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 ;
|