path: root/system/std.zusatz/1.7.3/src/std printer

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 ;