PACKET at plot DEFINES                            (* at plot              *)
                                                  (* Datum    : 14:05:86  *) 
                  begin plot,                     (* Geaendert: 30.05:86  *) 
                  end plot,                       (* Autoren  : BJ & CW   *) 
                  clear,                          (* MPG Bielefeld        *) 
 
                  pen, 
                  background, 
                  foreground, 
                  thickness, 
                  linetype, 
 
                  move, 
                  draw, 
                  bar, circle,
                  drawing area, 
                  range, set range:
 
LET     max x   = 719, 
        max y   = 347, 
        x pixel = 720, 
        y pixel = 348, 
        x cm    = 24.5, 
        y cm    = 18.5; 
 
INT VAR thick :: 0,  (* Normale Linien *) 
        ltype :: 1,
        x max :: max x, (* Zeichenfenster *) 
        y max :: max y,
        x min :: 0, 
        y min :: 0,
        old x :: 0, 
        old y :: 0; 
 
ROW 5 ROW 4 INT CONST nibble :: ROW 5 ROW 4 INT: (* Bitmuster fuer Linien*) 
   (ROW 4 INT : ( 4369, 4369, 4369, 4369),       (* durchgezogen  *) 
    ROW 4 INT : (   17,   17,   17,   17),       (* gepunktet     *) 
    ROW 4 INT : ( 4369,    0, 4369,    0),       (* kurz gestrichelt *) 
    ROW 4 INT : ( 4369, 4369,    0,    0),       (* lang gestrichelt *) 
    ROW 4 INT : ( 4369, 4369, 4096,    1));      (* gestrichpunktet  *) 
 
PROC begin plot: 
  INT VAR return; 
  REP                              (* Fehler? Ab und zu versagt der *)
    control (-5,512+0,0,return);   (* Graphik-Aufruf !!!!!!         *)
  UNTIL return <> -1 PER;
  IF return <> 0 
    THEN errorstop ("Graphik nicht ansprechbar") 
  FI 
END PROC begin plot; 
 
PROC end plot: 
  INT VAR return; 
  pause;
  control (-5,2,0,return); 
END PROC end plot;

PROC clear: 
  begin plot 
END PROC clear; 
 
PROC pen (INT CONST backgr, foregr, thickn, linety): 
  INT VAR dummy; 
  background (backgr, dummy); 
  thickness  (thickn, dummy); 
  linetype   (linety, dummy);
  foreground (foregr, dummy)
END PROC pen; 
 
PROC background (INT CONST desired, INT VAR realized): 
  realized := 0 
END PROC background; 
 
PROC foreground (INT CONST desired, INT VAR realized): 
  IF desired < 2 OR desired = 5  (* 0 = loeschen, 1 = setzen, 5 = schwarz *)
    THEN realized := desired 
    ELSE realized := 1 
  FI; 
  IF realized = 0
    THEN INT VAR return;
                 control ( -9,0,0,return); 
                 control (-10,0,0,return) 
    ELSE linetype (ltype,return)           (* Alten Typ wiederherstellen *) 
  FI
END PROC foreground; 
 
PROC linetype (INT CONST desired, INT VAR realized): 
  IF desired > 5 
    THEN realized := 1 
    ELSE realized := desired 
  FI; 
  INT VAR return;
  ltype := realized;
  control ( -9,nibble [realized][2], nibble [realized][1], return); 
  control (-10,nibble [realized][4], nibble [realized][3], return); 
  IF realized = 1
    THEN control (-11,0,0,return) 
    ELSE control (-11,1,0,return)
  FI
END PROC linetype; 
 
PROC thickness (INT CONST desired, INT VAR realized): 
  thick := int ( real (desired) / 200.0 *    (* Angabe in 1/10 mm *)
                 real (x pixel) / x cm);     (* Unrechnung in X Punkte *)
  realized := thick * 2 + 1                  (* Rueckgabe in Punkten *)
END PROC thickness; 
 
PROC move (INT CONST x,y): 
  old x := x;                 (* Kein direktes move, da clipping ! *)
  old y := y 
END PROC move;

PROC draw (INT CONST x,y): 
  draw (old x,old y,x,y); 
END PROC draw; 
 
PROC draw (INT CONST x0,y0,x1,y1): 
  IF thick = 0 
    THEN line (x0,y0,x1,y1) 
    ELSE draw thick line (x0,y0,x1,y1) 
  FI; 
  move (x1,y1) 
END PROC draw; 
 
PROC draw thick line (INT CONST x1,y1,x2,y2): 
  INT VAR x0 :: x1,
          y0 :: y1,
          x  :: x2,
          y  :: y2;
  swap if neccessary;
  REAL VAR xr0 :: real(x0),                            (* Unwandlung in *)
           yr0 :: real(y0) / (x cm * real(y pixel)) *  (* 1:1-Koordinaten*)
                             (y cm * real(x pixel)),  
           xr1 :: real(x), 
           yr1 :: real(y) / (x cm * real(y pixel)) * 
                             (y cm * real(x pixel)); 
  INT VAR  line counter;
  control(-11,1,0,line counter);
  IF is vertical line
    THEN draw vertical line 
    ELSE draw line 
  FI;
  move(x1,y1).
 
  swap if neccessary: 
    IF x < x0 OR (x = x0 AND y < y0) 
      THEN INT VAR dummy :: x0; 
           x0 := x; 
           x := dummy; 
           dummy := y0; 
           y0 := y; 
           y := dummy 
    FI.

  is vertical line: 
    x = x0.
 
  draw vertical line: 
    INT VAR i;
    FOR i FROM - thick UPTO thick REP 
      INT VAR return;
      control(-11, 1,line counter,return);  (* Einheitliches Muster ! *)
      line (xr0+real(i),yr0-real(thick),xr0+real(i),yr1+real(thick)) 
    PER. 

  draw line: 
    REAL VAR m :: (yr1 - yr0) / (xr1 - xr0),
             dx :: real(thick)/sqrt(1.0+m**2), 
             dy :: m * dx,
             xn, 
             yn, 
             diff,
             dsx :: dy,
             dsy :: -dx,
             x incr :: -real(sign(dsx)), 
             y incr :: -real(sign(dsy)); 
  xr0 INCR -dx; 
  yr0 INCR -dy; 
  xr1 INCR  dx; 
  yr1 INCR  dy;
  xn := xr0 + dsx; 
  yn := yr0 + dsy; 
  REP
    control (-11, 1,line counter,return);
    line(xn,yn,xr1 - xr0 + xn,yr1 - yr0 + yn); 
    diff := (2.0*dsy *(xn - (xr0 - dy)) - 2.0 * dsx * (yn - (yr0 + dx))) 
             * real(sign(m));
    IF diff < 0.0
      THEN xn INCR x incr 
    ELIF diff > 0.0
      THEN yn INCR y incr 
      ELSE xn INCR x incr; 
           yn INCR y incr 
    FI 
  UNTIL int(xn - xr0 + dy) = 0 AND int(yn - yr0 - dx) = 0 PER

END PROC draw thick line; 

PROC line (REAL CONST x0,y0,x1,y1):   (* 1:1-Koordinaten -> Geraetek. *)
  line (int(x0),int(y0 * (x cm * real(y pixel)) / (y cm * real(x pixel))),
        int(x1),int(y1 * (x cm * real(y pixel)) / (y cm * real(x pixel))))
END PROC line ;
 
PROC line (INT CONST x0,y0,x1,y1):      (* Normale Linie mit clipping *)
  REAL VAR dx :: real(xmax - xmin) / 2.0, 
           dy :: real(ymax - ymin) / 2.0, 
           rx0 :: real(x0-x min) - dx, 
           ry0 :: real(y0-y min) - dy, 
           rx1 :: real(x1-x min) - dx, 
           ry1 :: real(y1-y min) - dy; 
  INT VAR  cx0, 
           cy0, 
           cx1, 
           cy1; 
  calculate cells; 
  IF (cx0*cx1 = 1) OR (cy0 * cy1 = 1)
    THEN                                  (* Linie ausserhalb *)
    ELSE do clipping           
  FI.
 
  do clipping: 
    IF cx0 <> 0 
      THEN REAL VAR next x :: real(cx0) * dx; 
           ry0 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx0) + ry0;
           rx0 := next x 
    FI; 
    calculate cells; 
    IF cy0 <> 0 
      THEN REAL VAR next y :: real(cy0) * dy; 
           rx0 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry0) + rx0; 
           ry0 := next y 
    FI; 
    IF cx1 <> 0 
      THEN next x := real(cx1) * dx; 
           ry1 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx1) + ry1;
           rx1 := next x 
    FI; 
    calculate cells; 
    IF cy1 <> 0 
      THEN next y := real(cy1) * dy; 
           rx1 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry1) + rx1; 
           ry1 := next y 
    FI; 
    IF (rx1 = rx0) AND (ry1 = ry0) 
      THEN LEAVE line 
    FI; 
    draw std line (int (rx0+dx) + x min,int (ry0+dy) + y min, 
                   int (rx1+dx) + x min,int (ry1+dy) + y min).
     
    calculate cells: 
      cx0 := 0; 
      cy0 := 0; 
      cx1 := 0; 
      cy1 := 0; 
      IF abs(rx0) > dx 
        THEN cx0 := sign(rx0) 
      FI;
      IF abs(rx1) > dx 
        THEN cx1 := sign(rx1) 
      FI;
      IF abs(ry0) > dy 
        THEN cy0 := sign(ry0) 
      FI;
      IF abs(ry1) > dy 
        THEN cy1 := sign(ry1) 
      FI 
  
END PROC line; 
 
PROC draw std line (INT CONST x0,y0,x1,y1):   (* Terminallinie ziehen *) 
  INT VAR return; 
  control(-7,x0,max y - y0,return);  (* move *) 
  control(-6,x1,max y - y1,return)   (* draw *)
END PROC draw std line; 
 
PROC drawing area (REAL VAR x c, y c, INT VAR x pix, y pix):
  x pix := x pixel; 
  y pix := y pixel; 
  x c   := x cm; 
  y c   := y cm 
END PROC drawing area; 
 
PROC range (INT CONST hmin,hmax,vmin,vmax):    (* Zeichenflaeche setzen *)
  x min := max (0, min (max x,h min)); 
  x max := max (0, min (max x,h max)); 
  y min := max (0, min (max y,v min)); 
  y max := max (0, min (max y,v max)) 
END PROC range;
 
PROC set range ( INT CONST hmin, hmax, vmin, vmax): 
    range( hmin, hmax, vmin, vmax ) 
ENDPROC set range; 

(* Textausgabe von C. Indenbirken *)
(* Erweitert um stufenlose Rotierbarkeit der Zeichen *)
 
LET ZEICHENSATZ = ROW 255 TEXT;
ZEICHENSATZ VAR zeichen;
INT CONST char x :: 6, char y :: 10;

zeichensatz ("ZEICHENSATZ");

PROC zeichensatz (TEXT CONST name):
  IF exists (name)
  THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
       zeichen := new zeichen;
  ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
END PROC zeichensatz;

PROC draw char (INT CONST char no,REAL CONST x, y,REAL CONST x size, 
                y size, direction):
  TEXT CONST character :: zeichen [char no];
  INT VAR n :: 1, x0, y0, x1, y1;
  INT CONST len :: length (character);
  REAL CONST sindir :: sind(direction),
             cosdir :: cosd(direction);
  WHILE n < len
  REP value (character, n, x0, y0, x1, y1);
  REAL VAR xr0 :: real(x0),
           yr0 :: real(y0),
           xr1 :: real(x1), 
           yr1 :: real(y1);
      transform (xr0, yr0, x, y, x size, y size, sindir,cosdir);
      transform (xr1, yr1, x, y, x size, y size, sindir,cosdir);
      draw (int(xr0),int(yr0 * (x cm * real(y pixel)) / 
                     (y cm * real(x pixel))),
            int(xr1),int(yr1 * (x cm * real(y pixel)) / 
                     (y cm * real(x pixel))));
       n INCR 4 
  PER  .

END PROC draw char;

PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1):
  x0 := val (code (char SUB n));    y0 := val (code (char SUB n+1));
  x1 := val (code (char SUB n+2));  y1 := val (code (char SUB n+3));
END PROC value;

INT PROC val (INT CONST n):
  IF n > 127
  THEN -256 OR n
  ELSE n FI
END PROC val;

PROC transform (REAL VAR x, y,REAL CONST x0, y0,REAL CONST x size, y size, 
                sindir,cosdir):
  REAL CONST old x :: x, old y :: y;
  REAL CONST dx :: x size / real(char x) * old x * cosdir - 
                   y size / real(char y) * old y * sindir, 
             dy :: y size / real(char y) * old y * cosdir + 
                   x size / real(char x) * old x * sindir;

  x := x0 + dx; 
  y := y0 + dy
END PROC transform; 

PROC draw text (REAL CONST x pos, y pos,TEXT CONST msg, REAL CONST angle, 
                REAL CONST height, width): 
  INT VAR i;
  REAL VAR x :: x pos, y :: y pos,
           x step :: cosd (angle)*width,
           y step :: sind (angle)*width;
  FOR i FROM 1 UPTO length (msg)
  REP IF control char
      THEN execute control char
      ELSE execute normal char FI
  PER  .

control char:
  akt char < ""32""  .

execute control char:
  SELECT code (akt char) OF
  CASE  1: home
  CASE  2: right
  CASE  3: up
  CASE  7: out (""7"")
  CASE  8: left
  CASE 10: down
  CASE 13: return
  ENDSELECT  .

home:
  x := x pos;
  y := y pos  .

right:
  x INCR x step;  y INCR y step  . 

up:
  x INCR y step;  y INCR x step  . 

left:
  x DECR x step;  y DECR y step  .

down:
  x DECR y step;  y DECR x step  . 

return:
  x := x pos  .

execute normal char:
  draw char (code (akt char), x, y, height, width,
             angle);
  x INCR x step;
  y INCR y step  .

akt char:
  msg SUB i  .

END PROC draw text; 
 
PROC draw (TEXT CONST msg):
   draw (msg,0.0,5.0,5.0)
END PROC draw;
 
PROC draw (TEXT CONST msg,REAL CONST angle,REAL CONST heigth,width):
    REAL CONST  xr :: real(old x), 
                yr :: real(old y) / (x cm * real(y pixel)) * 
                                    (y cm * real(x pixel)); 
    draw text (xr,yr,msg,angle,heigth * real(x pixel) / x cm / 10.0, 
                               width  * real(x pixel) / x cm / 10.0)
                                    (* heigth  mm --> x punkte *)
END PROC draw; 
 
PROC draw (TEXT CONST msg , REAL CONST winkel, INT CONST hoehe, breite): 
      draw ( msg, winkel, real(hoehe), real(breite) )
ENDPROC draw; 
 
PROC bar ( INT CONST xmin, ymin, xmax, ymax, pattern ) : 
     (* zur Zeit leer *) 
ENDPROC bar; 
 
PROC circle ( INT CONST x,y, rad, REAL CONST from, to, INT CONST pattern):
     (* zur Zeit leer *) 
ENDPROC circle; 
 
END PACKET at plot