MODULE DMP ; (*------------------------------------------------------------------------*) (* *) (* All the procedures needed for the machine dependent aspects *) (* of the GRAPHical procedures developed by Jack and myself. *) (* *) (* These particular ones are for the Houston Inst. DMP-2 *) (* *) (* Final corrections completed for MT+ Version 5.5 on 11 Jan, 1983 *) (* *) (* J.A. Koehler, Saskatoon *) (* *) (*------------------------------------------------------------------------*) (*$E-*) CONST xfactor = 7.8740; (* # of steps/mm on the Houston Instruments *) yfactor = 7.8740; (* DMP-2 plotter *) minx = 0.0; (* screen co-ords in mm. *) maxx = 254.0; miny = 0.0; maxy = 177.0; (* corresponding to 7" x 10" *) absmaxx = 10000.0; (* absolute calculation limits *) absmaxy = 10000.0; radian = 57.2958; (* degrees/radian *) (*$E+*) TYPE astringtype = string[132]; aendtype = (noend, point, square, triangle, cross, ecks, diamond, circle); alinetype = (noline, solid, dotted, dashed, dotdashed, dotdotdashed); apointtype = RECORD (* absolute position in millimeters *) x, y: REAL; END; (*$E-*) vector = -512..511; posn = -128..127; roff = PACKED ARRAY[1..64] of vector; vec = PACKED ARRAY[1..393] of posn; VAR oldend: aendtype; (* last end symbol defined *) oldline: alinetype; (* last set line type *) lastpt, (* last point called for *) oldpt, (* last point actually plotted *) oldleft, (* existing window corners in mm.*) oldright: apointtype; penlifted: BOOLEAN; (* last pen position *) oldesize, (* last set end symbol diameter *) oldrptlength, (* last set line pattern length *) oldchrheight, (* in mm *) oldchrspace, oldchrwidth, oldchrangle, (* 0 is upright *) oldstringangle: REAL; chroff: roff; chrvec: vec; EXTERNAL PROCEDURE serout( ch: CHAR); EXTERNAL PROCEDURE @hlt; EXTERNAL PROCEDURE initac; (* initializes serial output port to plot *) PROCEDURE penup; (*------------------------------------------------------------------*) (* Sets 'penlifted' to true and sends the appropriate char. *) (* to the plotter and also sends a 50 msec delay for the action *) (*------------------------------------------------------------------*) VAR i:integer; BEGIN (* penup *) penlifted := TRUE; serout('y'); for i:=1 to 22 do serout(' '); (* delay for 50 msec at 4800 baud *) END; (* penup *) PROCEDURE pendown; (*------------------------------------------------------------------*) (* Sets the 'penlifted' variable and lowers the pen of the DMP-2 *) (* and puts in a delay *) (*------------------------------------------------------------------*) VAR i:integer; BEGIN (* pendown *) penlifted := FALSE; serout('z'); for i:=1 to 22 do serout(' '); END; (* pendown *) FUNCTION isinwindow(pt: apointtype): BOOLEAN; (*------------------------------------------------------------------*) (* Returns TRUE if the 'pt' is within the window defined by *) (* 'oldleft' and 'oldright'. *) (*------------------------------------------------------------------*) BEGIN (* isinwindow *) isinwindow := (pt.x <= oldright.x) AND (pt.y <= oldright.y) AND (pt.x >= oldleft.x) AND (pt.y >= oldleft.y); END; (* isinwindow *) PROCEDURE plot(dest: apointtype; how: alinetype; endsym: aendtype); (*------------------------------------------------------------------*) (* Plots a line from the present position to 'dest' using the *) (* pattern in 'how' and the end symbol in 'endsym'. The line is *) (* constrained to stay within the current window. *) (*------------------------------------------------------------------*) VAR previous, (* pattern endpoints *) temp: apointtype; i, (* pattern loop counter *) number: INTEGER; (* # of patterns in line *) dx, (* pattern repeat spacing *) dy, len: REAL; (* line length *) PROCEDURE drawto(dest: apointtype); (*----------------------------------------------------------------*) (* Moves the pen to 'dest' with the pen specified by 'penlifted'.*) (*----------------------------------------------------------------*) VAR temp: apointtype; (* window crossing points *) oldpen: BOOLEAN; PROCEDURE plotpoint(at: apointtype); (*--------------------------------------------------------------*) (* Moves the pen to 'at'. *) (*--------------------------------------------------------------*) VAR xint, (* integer plotting values, *) yint: INTEGER; (* between 0 and 779 or 1023 *) PROCEDURE sendit(x,y:integer); (* Procedure to draw a line of dimensions (x,y) on the DMP-2 plotter *) var val:string; j,z,e,t,i,d,f: integer; BEGIN val:='pqrqrststuvuvwpw'; f:=abs(x)+abs(y); IF f<> 0 THEN BEGIN d:=abs(y)-abs(x); i:=0; IF y > 0 THEN i :=2; t := x+y; IF t >= 0 THEN i := i+2; t := y-x; IF t >= 0 THEN i := i+2; IF x < 0 THEN i := i+10 ELSE i := 8-i; IF d >= 0 THEN BEGIN t := abs(x); d := -d; END ELSE t := abs(y); e := 0; REPEAT z := t+d+e+e; IF z >= 0 THEN BEGIN e := e+d; f := f-2; serout(val[i]); END ELSE BEGIN e := e+t; f := f-1; serout(val[i-1]); END; UNTIL f <= 0; END; END; (* sendit *) BEGIN (* plotpoint *) xint := round((at.x-oldpt.x)* xfactor); yint := round((at.y-oldpt.y)* yfactor); sendit(xint,yint); oldpt := at; END; (* plotpoint *) PROCEDURE interpolate(inside, outside: apointtype; VAR crossing: apointtype); (*--------------------------------------------------------------*) (* Finds the window crossing point on the line between 'inside'*) (* and 'outside'. The result is returned in 'crossing'. *) (*--------------------------------------------------------------*) FUNCTION vertcross(left, right: apointtype; midx: REAL): REAL; (*------------------------------------------------------------*) (* Finds the vertical crossing point at 'midx' on the *) (* line between 'left' and 'right'. *) (*------------------------------------------------------------*) BEGIN (* vertcross *) vertcross := left.y + (right.y - left.y) * (midx - left.x) / (right.x - left.x); END; (* vertcross *) FUNCTION horcross(bottom, top: apointtype; midy: REAL): REAL; (*------------------------------------------------------------*) (* Finds the horizontal crossing point at 'midy' on the *) (* line between 'bottom' and 'top'. *) (*------------------------------------------------------------*) BEGIN (* horcross *) horcross := bottom.x + (top.x - bottom.x) * (midy - bottom.y) / (top.y - bottom.y); END; (* horcross *) BEGIN (* interpolate *) crossing.x := -1; (* indicate crossing not found *) crossing.y := -1; IF outside.x < oldleft.x (* is it to the left? *) THEN BEGIN crossing.x := oldleft.x; crossing.y := vertcross(outside, inside, oldleft.x); END (* IF outside ... *) ELSE IF outside.x > oldright.x (* or to the right? *) THEN BEGIN crossing.x := oldright.x; crossing.y := vertcross(inside, outside, oldright.x); END; (* ELSE IF outside.x ... *) IF NOT isinwindow(crossing) (* did we not find it yet? *) THEN IF outside.y < oldleft.y (* is it below? *) THEN BEGIN crossing.y := oldleft.y; crossing.x := horcross(outside, inside, oldleft.y); END (* IF outside ... *) ELSE IF outside.y > oldright.y (* or above? *) THEN BEGIN crossing.y := oldright.y; crossing.x := horcross(inside, outside, oldright.y); END; (* ELSE IF outside.y ... *) END; (* interpolate *) BEGIN (* drawto *) oldpen := penlifted; IF isinwindow(lastpt) THEN IF isinwindow(dest) THEN plotpoint(dest) ELSE BEGIN interpolate(oldpt, dest, temp); plotpoint(temp); END (* ELSE *) ELSE { was not inside the window before } IF isinwindow(dest) THEN IF oldpen THEN plotpoint(dest) ELSE BEGIN interpolate(dest, lastpt, temp); penup; plotpoint(temp); pendown; plotpoint(dest); END; lastpt:=dest; END; (* drawto *) PROCEDURE draw(what: aendtype); (*----------------------------------------------------------------*) (* Draws the endpoint symbol 'what' with size 'oldesize' *) (* centered at the present position. *) (*----------------------------------------------------------------*) VAR origin, (* holds line endpoint *) temp: apointtype; oldpenup: BOOLEAN; (* holds old penlifted *) PROCEDURE closed(initangle: REAL; npoints: INTEGER); (*--------------------------------------------------------------*) (* Plots a polygon of size 'oldesize' with 'npoints' *) (* corners starting at 'initangle' degrees clockwise from *) (* vertical centered at 'origin'. *) (*--------------------------------------------------------------*) VAR i: INTEGER; (* corner counter *) angle: REAL; (* angle counter *) BEGIN (* closed *) FOR i := 0 to npoints DO BEGIN IF i = 0 THEN penup ELSE IF penlifted THEN pendown; angle := (initangle + i * (360.0 / npoints)) / radian; temp.x := origin.x + ( oldesize * sin(angle)) / 2.0; temp.y := origin.y + ( oldesize * cos(angle)) / 2.0; drawto(temp); END; (* FOR i ... *) END; (* closed *) PROCEDURE open(initangle: REAL); (*--------------------------------------------------------------*) (* Plots a cross of size 'oldesize' with one axis at *) (* 'initangle' clockwise from vertical centered at 'origin'. *) (*--------------------------------------------------------------*) VAR i, (* loop counters *) j: INTEGER; angle, (* angle of a line segment *) stangle: REAL; (* start angle of a line segment *) BEGIN (* open *) FOR j := 0 TO 1 DO BEGIN stangle := initangle + j * 90.0; FOR i := 0 TO 1 DO BEGIN IF i = 0 THEN penup ELSE pendown; angle := (stangle + i * 180.0) / radian; temp.x := origin.x + ( oldesize * sin(angle)) / 2.0; temp.y := origin.y + ( oldesize * cos(angle)) / 2.0; drawto(temp); END; (* FOR i ... *) END; (* FOR j ... *) END; (* open *) BEGIN (* draw *) IF what <> noend THEN BEGIN origin := oldpt; (* save endpoint *) oldpenup := penlifted; (* and pen status *) IF what IN [square, triangle, diamond, circle, cross, ecks] THEN CASE what OF square: closed(45.0, 4); triangle: closed(0.0, 3); diamond: closed(0.0, 4); circle: closed(0.0, 10); cross: open(0.0); ecks: open(45.0); END (* CASE what *) ELSE IF what = point THEN pendown; (* make a mark *) IF NOT penlifted (* return to last endpoint *) THEN penup; drawto(origin); (* also resets vector mode *) IF NOT oldpenup THEN pendown ELSE penup; END; (* IF what... *) END; (* draw *) PROCEDURE pltpat(source, dest: apointtype); (*----------------------------------------------------------------*) (* Plots the a line segment of the pattern 'how' from 'source' *) (* to 'dest'. *) (*----------------------------------------------------------------*) VAR p1, (* pattern fraction endpoints *) p2, p3: apointtype; dx, (* pattern fraction increment *) dy: REAL; BEGIN (* pltpat *) CASE how OF dotted: BEGIN IF NOT penlifted THEN penup; drawto(dest); draw(point); END; (* dotted: *) dashed: BEGIN p1.x := (source.x + dest.x) / 2.0; p1.y := (source.y + dest.y) / 2.0; IF NOT penlifted THEN penup; drawto(p1); pendown; drawto(dest); END; (* dashed: *) dotdashed: BEGIN dx := (dest.x - source.x) / 3.0; dy := (dest.y - source.y) / 3.0; p1.x := source.x + dx; p2.x := p1.x + dx; p1.y := source.y + dy; p2.y := p1.y + dy; IF NOT penlifted THEN penup; drawto(p1); draw(point); drawto(p2); pendown; drawto(dest); END; (* dotdashed: *) dotdotdashed: BEGIN dx := (dest.x - source.x) / 4.0; dy := (dest.y - source.y) / 4.0; p1.x := source.x + dx; p2.x := p1.x + dx; p3.x := p2.x + dx; p1.y := source.y + dy; p2.y := p1.y + dy; p3.y := p2.y + dy; IF NOT penlifted THEN penup; drawto(p1); draw(point); drawto(p2); draw(point); drawto(p3); pendown; drawto(dest); END; (* dotdotdashed: *) END; (* CASE how *) END; (* pltpat *) BEGIN (* plot *) IF dest.x > absmaxx THEN dest.x := absmaxx ELSE IF dest.x < (0 - absmaxx) THEN dest.x := (0 - absmaxx); IF dest.y > absmaxy THEN dest.y := absmaxy ELSE IF dest.y < (0 - absmaxy) THEN dest.y := (0 - absmaxy); IF how IN [noline, solid] (* segmenting not needed *) THEN BEGIN IF how = noline THEN penup ELSE pendown; drawto(dest); END (* IF how ... *) ELSE BEGIN len := sqr(oldpt.x - dest.x) + sqr(oldpt.y - dest.y); IF len > 0.25 (* make sure won't bomb on *) THEN (* underflow *) len := sqrt(len) ELSE len := 0; number := 1 + trunc(len / oldrptlength); dx := (dest.x - oldpt.x) / number; dy := (dest.y - oldpt.y) / number; previous := oldpt; FOR i := 1 TO number DO BEGIN temp.x := previous.x + dx; temp.y := previous.y + dy; pltpat(previous, temp); previous := temp; END; (* FOR i ... *) END; (* ELSE *) draw(endsym); END; (* plot *) (*$E+*) FUNCTION abadcall: BOOLEAN; (*------------------------------------------------------------------*) (* Returns TRUE if something is wrong with a procedure call. Not *) (* implemented. *) (*------------------------------------------------------------------*) BEGIN (* abadcall *) abadcall := FALSE; END; (* abadcall *) PROCEDURE adefault; (*------------------------------------------------------------------*) (* Sets all globals to their default values. *) (*------------------------------------------------------------------*) BEGIN (* adefault *) oldchrspace:=3.0; oldchrheight:=3.5; oldchrwidth:=3.0; oldchrangle:=0.0; oldstringangle:=0.0; oldend := noend; (* simple line *) oldesize := 3.0; oldrptlength := 5.0; oldline := noline; oldleft.x := minx; (* window size to full screen *) oldleft.y := miny; oldright.x := maxx; oldright.y := maxy; END; (* adefault *) PROCEDURE agraph; (*------------------------------------------------------------------*) (* Does nothing *) (*------------------------------------------------------------------*) BEGIN (* agraph *) END; (* agraph *) PROCEDURE ainit; (*------------------------------------------------------------------*) (* Initializes the I/O to the DMP-2 plotter, the character set, *) (* sets all paramters to their default values, and places the pen *) (* in the lower left-hand corner. *) (*------------------------------------------------------------------*) VAR ch: CHAR; result: INTEGER; x: FILE OF roff; y: FILE OF vec; BEGIN (* ainit *) assign(x,'A:CHROFF.DAT'); reset(x); IF ioresult = 255 THEN BEGIN assign(x,'B:CHROFF.DAT'); reset(x); IF ioresult = 255 THEN BEGIN writeln('Cannot find CHROFF.DAT'); @hlt; END; END; chroff:=x^; close(x,result); assign(y,'A:CHRVEC.DAT'); reset(y); IF ioresult = 255 THEN BEGIN assign(y,'B:CHRVEC.DAT'); reset(y); IF ioresult = 255 THEN BEGIN writeln('Cannot find CHRVEC.DAT'); @hlt; END; END; chrvec:=y^; close(y,result); initac; penup; adefault; agraph; oldpt.x:=0.0; oldpt.y :=0.0; lastpt:=oldpt; writeln('Set plotter to lower left corner, type anything when ready'); read(ch); END; (* ainit *) PROCEDURE amakecopy; (*------------------------------------------------------------------*) (* Does nothing *) (*------------------------------------------------------------------*) BEGIN (* amakecopy *) END; (* amakecopy *) PROCEDURE aplot(endpoint: apointtype); (*------------------------------------------------------------------*) (* Plots to 'endpoint' using line type 'oldline' and end type *) (* 'oldend'. *) (*------------------------------------------------------------------*) BEGIN (* aplot *) plot(endpoint, oldline, oldend); END; (* aplot *) PROCEDURE asetplot(line: alinetype; repeatlength, endsize: REAL; endsymbol: aendtype); (*------------------------------------------------------------------*) (* Sets the characteristics of the line(s) to be plotted next. *) (*------------------------------------------------------------------*) BEGIN (* asetplot *) oldline := line; oldrptlength := repeatlength; oldesize := endsize; oldend := endsymbol; END; (* asetplot *) PROCEDURE asetstr(charheight, charwidth, charangle, charspace, strangle: REAL); (*------------------------------------------------------------------*) (* Sets the characteristics of the next string(s) to be plotted. *) (*------------------------------------------------------------------*) BEGIN (* asetstr *) oldchrheight:=charheight; oldchrwidth:=charwidth; oldchrangle:=charangle; oldchrspace:=charspace; oldstringangle:=strangle; END; (* asetstr *) PROCEDURE asetwindow(lowerleft, upperright: apointtype); (*------------------------------------------------------------------*) (* Sets the window size. Nothing will appear outside this window. *) (*------------------------------------------------------------------*) BEGIN (* asetwindow *) oldleft := lowerleft; oldright := upperright; IF lowerleft.x < minx THEN oldleft.x := minx; IF lowerleft.y < miny THEN oldleft.y := miny; IF upperright.x > maxx THEN upperright.x := maxx; IF upperright.y > maxy THEN upperright.y := maxy; END; (* asetwindow *) PROCEDURE asize(VAR size: apointtype); (*------------------------------------------------------------------*) (* Returns the size of the display in mm. *) (*------------------------------------------------------------------*) BEGIN (* asize *) size.x := maxx - minx; size.y := maxy - miny; END; (* asize *) PROCEDURE astr(str: astringtype); (*------------------------------------------------------------------*) (* writes the string 'str' out to plotter *) (*------------------------------------------------------------------*) TYPE pen = (down,up); moves = RECORD number:integer; x,y: ARRAY [1..15] of REAL; how: ARRAY [1..15] of pen; END; (* record *) VAR i,j,nchr: integer; init,temp: apointtype; co_ord: moves; PROCEDURE rotandmake(ch:CHAR;height,width,angle:REAL;VAR co_ord:moves ); (* makes up a set of moves in order to plot the character *) VAR sine,cosine,tempx,tempy: REAL; i: INTEGER; PROCEDURE getch(ch:char;var vals:moves); VAR n,i,j,beg,last,val: INTEGER; BEGIN val := ord(ch)-32; while val>63 do val:=val-32; { remove lower case char. } if (val>0) and (val<64) THEN BEGIN beg:=chroff[val]; if beg < 0 then beg := 0-beg; last := chroff[val+1]; if last < 0 then last := 0 - last; last := last - 1; FOR i :=beg to last do BEGIN j:=i+1-beg; n := chrvec[i]; if n < 0 then n := (-1)*n; vals.x[j]:=n div 10; vals.y[j]:=n mod 10; if chroff[val] < 0 then vals.y[j]:=vals.y[j]-4.0; if (i=beg) or (chrvec[i]<0) THEN vals.how[j]:=up ELSE vals.how[j]:=down; END; vals.number := last+1-beg; END; END; (* getch *) BEGIN sine:=sin(angle/radian); cosine:=cos(angle/radian); getch(ch,co_ord); FOR i := 1 TO co_ord.number DO BEGIN tempx:=co_ord.x[i]*width/10.0; tempy:=co_ord.y[i]*height/10.0; co_ord.x[i]:=tempx*cosine-tempy*sine; co_ord.y[i]:=tempy*cosine+tempx*sine; END; END; BEGIN (* astr *) nchr:=length(str); FOR i := 1 to nchr DO BEGIN init:=oldpt; if str[i]<>' ' THEN BEGIN rotandmake(str[i],oldchrheight,oldchrwidth, oldchrangle,co_ord); FOR j:=1 TO co_ord.number DO BEGIN temp.x:=init.x+co_ord.x[j]; temp.y:=init.y+co_ord.y[j]; IF co_ord.how[j]=up THEN plot(temp,noline,noend) ELSE plot(temp,solid,noend); END; END; temp.x:=init.x+oldchrspace*cos(oldstringangle/radian); temp.y:=init.y+oldchrspace*sin(oldstringangle/radian); plot(temp,noline,noend); END; END; (* astr *) PROCEDURE atext; (*------------------------------------------------------------------*) (* Does nothing in this implementation *) (*------------------------------------------------------------------*) BEGIN (* atext *) END; (* atext *) PROCEDURE awhere(VAR where: apointtype; VAR inwindow: BOOLEAN); (*------------------------------------------------------------------*) (* Returns the current locatation and whether it's inside the *) (* window. *) (*------------------------------------------------------------------*) BEGIN (* awhere *) where := oldpt; inwindow := isinwindow(oldpt); END; (* awhere *) modend.