From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- app/mpg/1987/src/ATPLOT.ELA | 438 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 438 insertions(+) create mode 100644 app/mpg/1987/src/ATPLOT.ELA (limited to 'app/mpg/1987/src/ATPLOT.ELA') diff --git a/app/mpg/1987/src/ATPLOT.ELA b/app/mpg/1987/src/ATPLOT.ELA new file mode 100644 index 0000000..4799ab0 --- /dev/null +++ b/app/mpg/1987/src/ATPLOT.ELA @@ -0,0 +1,438 @@ +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 -- cgit v1.2.3