IMPLEMENTATION MODULE DIG; (* This module defines the graphics primitives. These can be used in a rather machine independent fashion. The routine "GInitDevice" must be called prior to any graphics command so that the Gfile can set upto receive graphics commands. GWrapUp must be called at the end to do the necessary clean up. The graphics output is written to the Gfile in binary form using WORD oriented output. A four byte character code identifies what the command is. Here are the DIG commands and the additional info written out to Gfile: 1. INIT baudrate 2. ERAS 3. WIND lowerx,lowery,upperx,uppery 4. MAPW xmin,ymin,xmax,ymax 5. MOVE x,y 6. DRAW x,y 7. PLIN pcount,x[1],y[1],...,x[pcount],y[pcount] 8. LPAT SOLI|DASH|DOTT 9. FONT HARD|ROMA|STIC|SCRI|GOTH 10. CSIZ cht,cwid,slant,hindex,vindex 11. COLO BLAC|BLUE|GREE|REDD 12. LORG 3|6|9 13. TEXT x,y,rotation,charcount 20 words for 80 byte string 14. *EOG (* marks end of graphics cmds *) *) FROM GfileManager IMPORT CreateGfile, PutW, PutWords, CloseGfile; FROM CubicSplines IMPORT Spline,MakeSpline,EvalSpline,DerivSpline; FROM InOut IMPORT WriteString,WriteCard,WriteLn; FROM FileSystem IMPORT File; FROM MathLib0 IMPORT arctan, cos, sin, sqrt; CONST pi = 3.141592653; Gcht = 0.10; Gh2wRatio = 0.65; MAXRGLCSIZES = 17; (* total csizes available with RGL *) MAXTEKCSIZES = 4; (* total csizes available with RGL *) TYPE CharSizeType = RECORD Cht, Cwid : REAL END; VAR RGLChSizes : ARRAY[ 1..MAXRGLCSIZES ] OF CharSizeType; TEKChSizes : ARRAY[ 1..MAXTEKCSIZES ] OF CharSizeType; RGLPhyX, RGLPhyY : REAL; Gfile : File; junk : BOOLEAN; PROCEDURE GSlope( x1,y1 : REAL (* in *); x2,y2 : REAL (* out*) ): REAL; (* Returns the slope of line (x1,y1) ---- (x2,y2) in radians. The range can be 0 to 2*pi. *) VAR num, den : REAL; ang : REAL; BEGIN num := y2 - y1; den := x2 - x1; IF den = 0.0 THEN IF num > 0.0 THEN ang := pi/2.0 (* 90.0 *) ELSIF num < 0.0 THEN ang := pi + pi/2.0 (* 270.0 *) ELSE ang := 0.0 END ELSE ang := arctan( num/den ); IF den < 0.0 THEN ang := pi + ang (* 2nd quadrant *) END END; IF ang < 0.0 THEN ang := 2.0*pi + ang END; RETURN ang END GSlope; PROCEDURE GInitDevice( HardXleft : REAL; (* in *) HardYbot : REAL; (* in *) HardXright : REAL; (* in *) HardYtop : REAL; (* in *) Baudrate : INTEGER; (* in *) (* tektronics needs this *) Gfilename : ARRAY OF CHAR (* in *) ); (* This routine must be invoked before any plotting can be done. It initializes the graphics device. HardBottom and HardTop define the physical limit for the cursor movement. Gin defines the standard input for graphics inquiries. The graphics commands are written out to "Gfilename". *) BEGIN junk := CreateGfile( Gfile, Gfilename ); junk := PutW( Gfile, "INIT" ); junk := PutW( Gfile, Baudrate ); junk := PutW( Gfile, "ERAS" ); junk := PutW( Gfile, "WIND" ); junk := PutW( Gfile, HardXleft ); junk := PutW( Gfile, HardYbot ); junk := PutW( Gfile, HardXright); junk := PutW( Gfile, HardYtop ); END GInitDevice; PROCEDURE GErase( ); (* Erase the plotting surface. *) BEGIN junk := PutW( Gfile, "ERAS" ) END GErase; PROCEDURE GWindow( LowerX : REAL; (* in *) LowerY : REAL; (* in *) UpperX : REAL; (* in *) UpperY : REAL (* in *) ); (* Defines the physical region of interest where plotting will be done. The soft clip region. *) BEGIN junk := PutW( Gfile, "WIND" ); junk := PutW( Gfile, LowerX ); junk := PutW( Gfile, LowerY ); junk := PutW( Gfile, UpperX ); junk := PutW( Gfile, UpperY ); END GWindow; PROCEDURE GMapWindow( Xmin : REAL; (* in *) Ymin : REAL; (* in *) Xmax : REAL; (* in *) Ymax : REAL (* in *) ); (* Maps the SoftClip window with these limits so that world coordinates can be used instead ot physical device coordinates. *) BEGIN junk := PutW( Gfile, "MAPW" ); junk := PutW( Gfile, Xmin ); junk := PutW( Gfile, Ymin ); junk := PutW( Gfile, Xmax ); junk := PutW( Gfile, Ymax ); END GMapWindow; PROCEDURE GMove( X : REAL; (* in *) Y : REAL (* in *) ); (* Moves the cursor to this location. *) BEGIN junk := PutW( Gfile, "MOVE" ); junk := PutW( Gfile, X ); junk := PutW( Gfile, Y ); END GMove; PROCEDURE GDraw( X : REAL; (* in *) Y : REAL (* in *) ); (* Draws a line from current cursor position to this X,Y. Current line pattern will be used. *) BEGIN junk := PutW( Gfile, "DRAW" ); junk := PutW( Gfile, X ); junk := PutW( Gfile, Y ); END GDraw; PROCEDURE GBox( Xleft : REAL; (* in *) Ybot : REAL; (* in *) Xright : REAL; (* in *) Ytop : REAL (* in *) ); (* Draws a box with (Xleft,Ybot) at lower left and (Xright,Ytop) at right top. *) VAR x, y : ARRAY [1..5] OF REAL; BEGIN x[1] := Xleft; x[2] := Xleft; x[3] := Xright; x[4] := Xright; x[5] := Xleft; y[1] := Ybot; y[2] := Ytop ; y[3] := Ytop; y[4] := Ybot; y[5] := Ybot; GPolyLine( x, y, 5 ); END GBox; PROCEDURE GCircle( CX : REAL; (* in *) CY : REAL; (* in *) Radius : REAL (* in *) ); (* Draws a circle centerd at CX,CY and radius "Radius". *) BEGIN GEllipse( CX, CY, Radius, Radius ) END GCircle; PROCEDURE GEllipse( CX : REAL; (* in *) CY : REAL; (* in *) SemiMajAxis : REAL; (* in *) SemiMinAxis : REAL (* in *) ); (* Draws an ellipse centered at CX,CY. *) CONST maxpt = 37; VAR x, y : ARRAY[ 1..maxpt ] OF REAL; t1 : REAL; I : CARDINAL; da : REAL; c2, s2, c3, s3: REAL; BEGIN da := 2.0*pi/FLOAT( maxpt-1); c2 := cos( da ); s2 := sin( da ); c3 := 1.0; s3 := 0.0; FOR I := 1 TO maxpt DO x[I] := CX + SemiMajAxis*c3; y[I] := CY + SemiMinAxis*s3; t1 := c3*c2 - s3*s2; s3 := s3*c2 + c3*s2; c3 := t1 END; GPolyLine( x, y, maxpt ) END GEllipse; PROCEDURE DrawHead( x, y, slope : REAL; head : GArrowHead ); (* This internal proc makes the head. The size is determined by const h defined below. *) CONST h = 0.05; (* inches *) VAR x1, y1, x2, y2 : REAL; a : REAL; BEGIN a := pi/8.0; (* 27.5 degrees *) CASE head OF RightHead : x1 := x - h*cos( slope+a ); (* lower leg of --> *) y1 := y - h*sin( slope+a ); x2 := x - h*cos( a-slope ); (* upper leg of --> *) y2 := y + h*sin( a-slope ); GLine( x1,y1, x2,y2 ); GLine( x1, y1, x, y ); GLine( x, y, x2, y2 ) | LeftHead : x1 := x + h*cos( a-slope ); (* lower leg of <-- *) y1 := y - h*sin( a-slope ); x2 := x + h*cos( a+slope ); (* upper leg of <-- *) y2 := y + h*sin( a+slope ); GLine( x1,y1, x2,y2 ); GLine( x1, y1, x, y ); GLine( x, y, x2, y2 ) ELSE END (* CASE *) END DrawHead; PROCEDURE GArc( X1,Y1 : REAL; (* in *) X2,Y2 : REAL; (* in *) X3,Y3 : REAL; (* in *) Heading : GArrowHead (* in *) ); (* Draws an arc through the three coordinates. *) PROCEDURE ThreePtCircle( x1, y1, x2, y2, x3, y3 : REAL; (* in *) VAR d , e , f : REAL; (* out *) VAR cx, cy : REAL; (* out *) VAR radius : REAL (* out *) ); (* This procedure determines a circle through three points. The coefficients of the circle equation: x**2 + y**2 + dx + ey + f = 0 are returned. Also returned are the coordinates of center of the circle and the radius. *) VAR a1, b1, c1, a2, b2, c2 : REAL; BEGIN a1 := x1*x1 + y1*y1 - ( x2*x2 + y2*y2 ); b1 := x1 - x2; c1 := y1 - y2; a2 := x2*x2 + y2*y2 - ( x3*x3 + y3*y3 ); b2 := x2 - x3; c2 := y2 - y3; IF ( c1 = 0.0 ) AND ( b1 = 0.0 ) THEN cx := x1; cy := y1; radius := 0.0; RETURN END; IF c1 # 0.0 THEN d := ( a1*c2/c1 - a2 )/( b2 - c2*b1/c1 ); e := -( a1 + b1*d )/c1 ELSE e := ( b2*a1- a2 )/( c2 - b2/b1*c1 ); d := -( a1 + c1*e )/b1 END; f := -( x1*x1 + y1*y1 + d*x1 + e*y1 ); cx := -d/2.0; cy := -e/2.0; radius := 0.5*sqrt( d*d + e*e - 4.0*f ); END ThreePtCircle; PROCEDURE PointSlope( x,y, d,e : REAL (* in *) ): REAL; VAR x1,x2,y1,y2 : REAL; BEGIN (* The slope along at a pt along the circle is: arctan( -( d + 2.0*x )/( 2.0*y + e ) ) create coordinates for GSlope *) y1 := 2.0*x; y2 := -d; x1 := -e; x2 := 2.0*y; RETURN GSlope( x1,y1, x2,y2 ) END PointSlope; CONST maxarcpts = 37; VAR d , e , f : REAL; cx, cy, rad : REAL; t1, t2, t3, p, cp, sp : REAL; slope1 , slope3 : REAL; x, y : ARRAY [1..maxarcpts] OF REAL; I : CARDINAL; BEGIN (* Run a circle throught the 3 points and then use the center and radius to turn an arc starting at p1 to p3. *) ThreePtCircle( X1,Y1, X2,Y2, X3,Y3, d,e,f, cx,cy, rad ); (* angle p1 makes with horizontal *) t1 := GSlope( cx,cy, X1,Y1 ); (* angle p2 makes with horizontal *) t2 := GSlope( cx,cy, X2,Y2 ); (* angle p3 makes with horizontal clockwise *) t3 := GSlope( cx,cy, X3,Y3 ); IF t1 >= t2 THEN IF t2 <= t3 THEN t3 := t3 - 2.0*pi; IF ABS( t3-t1 ) >= 2.0*pi THEN t3 := t3 + 2.0*pi; t1 := t1 - 2.0*pi END END ELSIF t2 >= t3 THEN t1 := t1 - 2.0*pi; IF ABS( t3-t1 ) >= 2.0*pi THEN t1 := t1 + 2.0*pi; t3 := t3 - 2.0*pi END END; (* divide angle the arc moves thru into increments *) p := ( t3 - t1 )/FLOAT( maxarcpts-1 ); cp := cos( p ); sp := sin( p ); (* initialize accumulation variables *) x[1] := cx + rad*cos( t1 ); y[1] := cy + rad*sin( t1 ); FOR I := 2 TO maxarcpts DO x[I] := cx + ( x[I-1]-cx )*cp - ( y[I-1]-cy )*sp; y[I] := cy + ( x[I-1]-cx )*sp + ( y[I-1]-cy )*cp; END; GPolyLine( x, y, maxarcpts ); (* Now draw the head based on the slopes of the arc the end points. *) slope1 := GSlope( x[2],y[2], X1,Y1 ); slope3 := GSlope( x[maxarcpts-1],y[maxarcpts-1], X3,Y3 ); IF Heading = LeftHead THEN DrawHead( X1,Y1, slope1, LeftHead ) ELSIF Heading = RightHead THEN DrawHead( X3,Y3, slope3, RightHead ) ELSIF Heading = BothHead THEN DrawHead( X1,Y1, slope1, LeftHead ); DrawHead( X3,Y3, slope3, RightHead ) END END GArc; PROCEDURE GLine( BegX : REAL; (* in *) BegY : REAL; (* in *) EX : REAL; (* in *) EY : REAL (* in *) ); (* Draws a line from BX,BY to EX,EY. *) BEGIN junk := PutW( Gfile, "MOVE" ); junk := PutW( Gfile, BegX ); junk := PutW( Gfile, BegY ); junk := PutW( Gfile, "DRAW" ); junk := PutW( Gfile, EX ); junk := PutW( Gfile, EY ); END GLine; PROCEDURE GPolyLine( X : ARRAY OF REAL; (* in *) Y : ARRAY OF REAL; (* in *) Npts : CARDINAL (* in *) ); (* Draws a line through all x,y. *) VAR i : CARDINAL; BEGIN junk := PutW( Gfile, "PLIN" ); junk := PutW( Gfile, INTEGER( Npts ) ); FOR i := 0 TO Npts-1 DO junk := PutW( Gfile, X[i] ); junk := PutW( Gfile, Y[i] ); END; END GPolyLine; PROCEDURE GArrow( BegX : REAL; (* in *) BegY : REAL; (* in *) EX : REAL; (* in *) EY : REAL; (* in *) Heading : GArrowHead (* in *) ); (* Draw an arrow with arrowhead at either or both ends. *) VAR slope : REAL; BEGIN slope := GSlope( BegX,BegY, EX,EY ); GLine( BegX, BegY, EX, EY ); CASE Heading OF LeftHead : DrawHead( EX, EY, slope, LeftHead ) | RightHead : DrawHead( EX, EY, slope, RightHead ) | BothHead : DrawHead( BegX, BegY, slope, LeftHead ); DrawHead( EX, EY, slope, RightHead ) ELSE WriteString("DIG -- strange arrow head" );WriteLn END END GArrow; PROCEDURE GSpline( BegX : REAL; (* in *) BegY : REAL; (* in *) EX : REAL; (* in *) EY : REAL; (* in *) GuideCount : CARDINAL; (* in *) GuideX : ARRAY OF REAL; (* in *) GuideY : ARRAY OF REAL; (* in *) Heading : GArrowHead (* in *) ); (* Draw a spline from BX,BY to EX,EY using GuideX,GuideY as tracking points. Heading indicates the tyoe of arrow head to draw at the ends. *) CONST MAXPT = 51; VAR X,Y : ARRAY [0..MAXPT] OF REAL; I,N : CARDINAL; ok : BOOLEAN; Flip: BOOLEAN; S : Spline; xs,ys, xe,ye : REAL; slope1, slope2 : REAL; dx : REAL; xv,yv : REAL; BEGIN X[0] := BegX; Y[0] := BegY; IF GuideCount <= 0 THEN X[1] := EX; Y[1] := EY; GPolyLine( X,Y, 2 ); (* 2 pts no good for spline *) RETURN; END; N := GuideCount-1; IF N >= MAXPT-2 THEN N := MAXPT-2; WriteString("DIG -- too many spline guidepoints, only " ); WriteCard( N,4 ); WriteString(" will be included"); WriteLn; END; FOR I := 0 TO N DO X[I+1] := GuideX[I]; Y[I+1] := GuideY[I]; END; IF( GuideX[N] # EX ) AND ( GuideY[N] # EY ) THEN X[N+1] := EX; Y[N+1] := EY; INC( N ); END; INC( N ); (* total number of x,y *) (* Try making a spline with x,y data set. If this fails, try y,x, i.e, switch x and y. If this to fails, x,y data items are not in increading order -- no spline. *) Flip := FALSE; ok := MakeSpline( X,Y,N+1, S ); IF NOT ok THEN ok := MakeSpline( Y,X,N+1, S ); IF NOT ok THEN WriteString("DIG - Can't make a spline. Neither X nor Y" ); WriteString(" along path are increasing." ); WriteLn; RETURN; END; Flip := TRUE; END; dx := ( X[N] - X[0] )/ FLOAT( 2*MAXPT - 1 ); xs := X[0]; ys := Y[0]; xe := X[N]; ye := Y[N]; IF Flip THEN dx := ( Y[N] - Y[0] )/ FLOAT( 2*MAXPT - 1 ); xs := Y[0]; ys := X[0]; xe := Y[N]; ye := X[N]; END; ok := PutW( Gfile, "PLIN" ); ok := PutW( Gfile, INTEGER( 2*MAXPT ) ); FOR I := 1 TO 2*MAXPT DO xv := xs + FLOAT( I-1 )*dx; ok := EvalSpline( xv, S, yv ); IF Flip THEN ok := PutW( Gfile, yv ); ok := PutW( Gfile, xv ); ELSE ok := PutW( Gfile, xv ); ok := PutW( Gfile, yv ); END; END; (* Draw arrowheads. Use the boundary and neighbor to determine slopes at the ends. *) xv := xs + dx; ok := EvalSpline( xv, S, yv ); slope1 := GSlope( xs,yv, xv,yv ); IF Flip THEN slope1 := GSlope( ys,xs, yv,xv ); END; IF( Heading = LeftHead ) OR ( Heading = BothHead ) THEN DrawHead( X[0],Y[0], slope1, LeftHead ) END; (* Slope at the end. *) xv := xe - dx; ok := EvalSpline( xv, S, yv ); slope2 := GSlope( xv,yv, xe,ye ); IF Flip THEN slope2 := GSlope( yv,xv, ye,xe ); END; IF( Heading = RightHead ) OR ( Heading = BothHead ) THEN DrawHead( X[N],Y[N], slope2, RightHead ) END; END GSpline; PROCEDURE GSetLinePattern( Pat : GLineType (* in *) ); (* Set line type *) BEGIN junk := PutW( Gfile, "LPAT" ); CASE Pat OF GSolid : junk := PutW( Gfile, "SOLI" ) | GDashed: junk := PutW( Gfile, "DASH" ) | GDotted: junk := PutW( Gfile, "DOTT" ) ELSE junk := PutW( Gfile, "SOLI" ) END; END GSetLinePattern; PROCEDURE GSetFont( Font : GFontType (* in *) ); BEGIN junk := PutW( Gfile, "FONT" ); CASE Font OF HardWare : junk := PutW( Gfile, "HARD" ) | Roman : junk := PutW( Gfile, "ROMA" ) | Stick : junk := PutW( Gfile, "STIC" ) | Script : junk := PutW( Gfile, "SCRI" ) | Gothic : junk := PutW( Gfile, "GOTH" ) ELSE END; END GSetFont; PROCEDURE LookUpRGLSizes( VAR Cht, Cwid : REAL (* in/out *) ): INTEGER; (* Because RGL does not provide just any size of character sizes, the fixed set of sizes have to be looked up and the Cht,Cwid set to the sizes that come closest. *) VAR d1, d2 : REAL; I : INTEGER; BEGIN IF Cwid < RGLChSizes[ 1 ].Cwid THEN Cwid := RGLChSizes[ 1 ].Cwid; Cht := RGLChSizes[ 1 ].Cht; RETURN 1 END; (* Find which two cwid's enclose Cwid *) FOR I := 1 TO MAXRGLCSIZES-1 DO IF( RGLChSizes[ I ].Cwid <= Cwid ) AND ( Cwid <= RGLChSizes[ I+1 ].Cwid ) THEN d1 := Cwid - RGLChSizes[ I ].Cwid; d2 := RGLChSizes[ I+1 ].Cwid - Cwid; Cwid := RGLChSizes[ I ].Cwid; Cht := RGLChSizes[ I ].Cht; (* pick the closer cwid *) IF d2 < d1 THEN Cwid := RGLChSizes[ I+1 ].Cwid; Cht := RGLChSizes[ I+1 ].Cht; RETURN I+1 END; RETURN I END END; (* FOR *) (* Cwid beyond maximum, set to maximum *) Cwid := RGLChSizes[ MAXRGLCSIZES ].Cwid; Cht := RGLChSizes[ MAXRGLCSIZES ].Cht; RETURN MAXRGLCSIZES; END LookUpRGLSizes; PROCEDURE LookUpTEKSizes( VAR Cht, Cwid : REAL (* in/out *) ): INTEGER; (* Because TEK does not provide just any size of character sizes, the fixed set of sizes have to be looked up and the Cht,Cwid set to the sizes that come closest. Note that the ICHAR numbering works 1 for largest charsize to 4 for smallest character size, thus things are reversed compared to RGL. *) VAR d1, d2 : REAL; I : INTEGER; BEGIN IF Cwid < TEKChSizes[ MAXTEKCSIZES ].Cwid THEN Cwid := TEKChSizes[ MAXTEKCSIZES ].Cwid; Cht := TEKChSizes[ MAXTEKCSIZES ].Cht; RETURN MAXTEKCSIZES END; (* Find which two cwid's enclose Cwid *) FOR I := 1 TO MAXTEKCSIZES-1 DO IF( TEKChSizes[ I ].Cwid >= Cwid ) AND ( Cwid >= TEKChSizes[ I+1 ].Cwid ) THEN d2 := Cwid - TEKChSizes[ I+1 ].Cwid; d1 := TEKChSizes[ I ].Cwid - Cwid; Cwid := TEKChSizes[ I ].Cwid; Cht := TEKChSizes[ I ].Cht; (* pick the closer cwid *) IF d2 < d1 THEN Cwid := TEKChSizes[ I+1 ].Cwid; Cht := TEKChSizes[ I+1 ].Cht; RETURN I+1 END; RETURN I END END; (* FOR *) (* Cwid beyond maximum, set to maximum *) Cwid := TEKChSizes[ 1 ].Cwid; Cht := TEKChSizes[ 1 ].Cht; RETURN 1 END LookUpTEKSizes; PROCEDURE GSetCharSize( VAR Cht : REAL; (* in/out *) VAR Cwid : REAL; (* in/out *) VAR Slant: REAL (* in/out *) ); (* Set the character hite and width. If however, the hite and/or size are not available, the hite and/or width are set to the nearest available. The slant is the italics angle w.r.t the vertical. *) VAR WIndex, Hindex : INTEGER; BEGIN junk := PutW( Gfile, "CSIZ" ); (* char size determination is device dependent until we have out own character generator. *) CASE GDevice OF vt125 : WIndex := LookUpRGLSizes( Cht, Cwid ); Hindex := WIndex; IF WIndex = 1 THEN Hindex := 2 END | hp7221, hp7550, hp7580, hp7470, hp7475, hp7220 : | tek : WIndex := LookUpTEKSizes( Cht, Cwid ); Hindex := WIndex ELSE END; junk := PutW( Gfile, Cht ); junk := PutW( Gfile, Cwid ); junk := PutW( Gfile, Slant ); junk := PutW( Gfile, WIndex ); junk := PutW( Gfile, Hindex ); END GSetCharSize; PROCEDURE GCharCellSize( Cht : REAL; (* in *) Cwid: REAL; (* in *) VAR Cellht : REAL; (* out *) VAR Cellwid: REAL (* out *) ); (* Returns the size of the character cell that can hold a character of hite and width = Cht,Cwid. *) VAR Index : INTEGER; BEGIN CASE GDevice OF vt125 : Index := LookUpRGLSizes( Cht, Cwid ); Cellht := Cht; Cellwid := Cwid | hp7221, hp7550, hp7580, hp7470, hp7475, hp7220 : Cellht := 2.0*Cht; Cellwid := 1.5*Cwid | tek : Index := LookUpTEKSizes( Cht, Cwid ); Cellht := 1.5*Cht; Cellwid := Cwid ELSE END END GCharCellSize; PROCEDURE GText( X : REAL; (* in *) Y : REAL; (* in *) Text : ARRAY OF CHAR; (* in *) Cht : REAL; (* in *) Cwid : REAL; (* in *) Rot : REAL; (* in *) Just : GJustType (* in *) ); (* displays a line of text at X,Y. The character size is controlled by Cht,Cwid. Rot controls how much to rotate the line of text w.r.t the horizontal. Just controls whether the line will be left, right or center justified. ** The base line falls on TOP of the characters. ** *) PROCEDURE ChangeColorAndFont( VAR I : CARDINAL (* in/out *) ); VAR J : CARDINAL; BEGIN J := I-1; IF( Cstr[J+1] = '\' )AND( Cstr[J+2] = 'f' )AND ( Cstr[J+3] = '(' ) THEN IF( Cstr[J+4] = 'h' ) AND ( Cstr[J+5] = 'd' ) THEN I := I+5; GSetFont( HardWare ) ELSIF( Cstr[J+4] = 's' ) AND ( Cstr[J+5] = 't' ) THEN I := I+5; GSetFont( Stick ) ELSIF( Cstr[J+4] = 'o' ) AND ( Cstr[J+5] = 'e' ) THEN I := I+5; GSetFont( Gothic ) ELSIF( Cstr[J+4] = 'r' ) AND ( Cstr[J+5] = 'm' ) THEN I := I+5; GSetFont( Roman ) ELSIF( Cstr[J+4] = 's' ) AND ( Cstr[J+5] = 'c' ) THEN I := I+5; GSetFont( Script ) END ELSIF( Cstr[J+1] = '\' )AND( Cstr[J+2] = 'c' )AND ( Cstr[J+3] = '(' ) THEN IF( Cstr[J+4] = 'b' ) AND ( Cstr[J+5] = 'k' ) THEN I := I+5; GSetColor( Gblack ) ELSIF( Cstr[J+4] = 'b' ) AND ( Cstr[J+5] = 'l' ) THEN I := I+5; GSetColor( Gblue ) ELSIF( Cstr[J+4] = 'g' ) AND ( Cstr[J+5] = 'r' ) THEN I := I+5; GSetColor( Ggreen ) ELSIF( Cstr[J+4] = 'r' ) AND ( Cstr[J+5] = 'd' ) THEN I := I+5; GSetColor( Gred ) END END END ChangeColorAndFont; CONST MAXTEXT = 80; VAR I, J : CARDINAL; Cstr : ARRAY [1..MAXTEXT] OF CHAR; slen, cellht, cellwid : REAL; just : INTEGER; CharCount : INTEGER; BEGIN J := 1; FOR I := 0 TO HIGH( Text ) DO IF( J < MAXTEXT ) THEN Cstr[ J ] := Text[ I ]; INC( J ) END END; Cstr[ J ] := 0C; I := 1; ChangeColorAndFont( I ); ChangeColorAndFont( I ); (* bump over any \f( constructs and '' together *) J := 1; WHILE( Cstr[ I ] # 0C ) AND ( J < MAXTEXT ) DO Cstr[ J ] := Cstr[ I ]; IF Cstr[ I ] = "'" THEN IF Cstr[ I+1 ] = "'" THEN INC( I ) END END; INC( I ); INC( J ) END; Cstr[ J ] := 0C; DEC( J ); CharCount := INTEGER( J ); CASE GDevice OF tek, vt125 : GCharCellSize( Cht, Cwid, cellht, cellwid ); slen := FLOAT( J )*cellwid; IF Just = CenterJustify THEN X := X - 0.5*slen*cos( Rot*pi/180.0 ); Y := Y - 0.5*slen*sin( Rot*pi/180.0 ) ELSIF Just = RightJustify THEN X := X - slen*cos( Rot*pi/180.0 ); Y := Y - slen*sin( Rot*pi/180.0 ) END | hp7221, hp7550, hp7580, hp7470, hp7475, hp7220 : junk := PutW( Gfile, "LORG" ); (* for hp only *) CASE Just OF LeftJustify : just := 3 | CenterJustify : just := 6 | RightJustify : just := 9 ELSE just := 6 END; junk := PutW( Gfile, just ) ELSE END; junk := PutW( Gfile, "TEXT" ); junk := PutW( Gfile, X ); junk := PutW( Gfile, Y ); junk := PutW( Gfile, Rot ); junk := PutW( Gfile, CharCount ); (* number of characters *) junk := PutWords( Gfile, Cstr, 20);(* always write out 80 characters. *) END GText; PROCEDURE GSetColor( col : GColorType (* in *)); BEGIN junk := PutW( Gfile, "COLO" ); CASE col OF Gblack : junk := PutW( Gfile, "BLAC" ) | Gblue : junk := PutW( Gfile, "BLUE" ) | Ggreen : junk := PutW( Gfile, "GREE" ) | Gred : junk := PutW( Gfile, "REDD" ) ELSE junk := PutW( Gfile, "GREE" ) END; END GSetColor; PROCEDURE GWrapUp( ); BEGIN junk := PutW( Gfile, "*EOG" ); junk := CloseGfile( Gfile ); END GWrapUp; (* BEGIN Initialization *) VAR I : CARDINAL; w, h : REAL; BEGIN RGLPhyX := 5.8; (* inches measured by dumping full screen image on *) RGLPhyY := 3.622; (* LA100 *) (* standard default cell is 9 by 15 pixels for RGL *) w := 9.0/767.0*RGLPhyX; h := 15.0/479.0*RGLPhyY; RGLChSizes[ 1 ].Cht := 20.0/479.0*RGLPhyY; RGLChSizes[ 1 ].Cwid := w; (* Set the cell hite to half the normal for sizes 2..MAXRGLCSIZES. Hite of cell I and cell I+1 will be the same. *) h := h * 0.5; FOR I := 2 TO MAXRGLCSIZES-1 BY 2 DO RGLChSizes[ I ].Cht := FLOAT( I+1 )*h; RGLChSizes[ I ].Cwid := FLOAT( I )*w; RGLChSizes[ I+1 ].Cht := FLOAT( I+1 )*h; RGLChSizes[ I+1 ].Cwid := FLOAT( I+1 )*w; END; (* Set up the four character sizes available for tektronics. These values are in inches. 4014/4015 have a screen width of 14.5 inches which can be addressed by 1024 raster units. Char size 1 is 14x22 of these raster units or tekpoints. *) h := 14.5/1024.0; (* in per raster *) TEKChSizes[ 4 ].Cht := 12.0*h; (* Ichar = 4, 8x12*) TEKChSizes[ 4 ].Cwid := 6.0*h; TEKChSizes[ 3 ].Cht := 13.0*h; (* Ichar = 3, 9x13 *) TEKChSizes[ 3 ].Cwid := 9.0*h; TEKChSizes[ 2 ].Cht := 21.0*h; (* Ichar = 2, 13x21*) TEKChSizes[ 2 ].Cwid := 13.0*h; TEKChSizes[ 1 ].Cht := 22.0*h; (* Ichar = 1, 14x22 *) TEKChSizes[ 1 ].Cwid := 14.0*h; END DIG.