Artifact 4bdda55b207edb4203ed9188ca77964a909da1dc7c73720b0ccf6bba80afaef6:
- File
psl-1983/3-1/util/pr-main.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 25857) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/pr-main.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 25857) [annotate] [blame] [check-ins using]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % PictureRLISP : A Lisp-Based Graphics Language System with % % Flexible Syntax and Hierarchical % % Data Structure % % % % Author: Fuh-Meei Chen, Paul Stay and Martin L. Griss % % Symbolic Computation Group % % Computer Science Dept. % % University of Utah % % % % <PSL.UTIL>PRLISP.RED.21, 9-Jan-82 22:47:43, Edit by GRISS % % <STAY.PICT>PRLISP.B 12-april-82 8:00:00 by Paul Stay % % changed bezier circle and bspline drivers and hp terminal % % on 10-april-82 by Paul Stay % % Added MPS support software for use on the graphics vax % % Added ST.INIT % % Copyright (c) 1981 University of Utah % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Part of the parser to accomplish the Pratt parser written % % in New-Rlisp runs at DEC-20. % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% RemFlag('(MKVECT),'TWOREG); %/ Seems in Error RemProp('!{,'NEWNAM!-OP); %. left and right brackets RemProp('!},'NEWNAM!-OP); %. handling. RemProp('!{,'NEWNAM); % left and right brackets are RemProp('!},'NEWNAM); % used to Define points. Put('!{, 'NEWNAM,'!*LBRAC!*); Put('!}, 'NEWNAM,'!*RBRAC!*); % Put on to the property list. DefineROP('!*LBRAC!*,NIL,LBC); % Define the precedence. DefineBOP('!*RBRAC!*,1,0); FLUID '(OP); Procedure LBC X; Begin scalar RES; If X EQ '!*RBRAC!* then <<OP := X; RES := '!*EMPTY!*>> else RES:= RDRIGHT(2,X); If OP EQ '!*RBRAC!* then OP := SCAN() else PARERR("Missing } after argument list",NIL); Return REPCOM('OnePoint,RES) end; Procedure REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); RemProp('!_,'NEWNAM); %. underscore handling. Put('!_,'NEWNAM,'POINTSET); % "_" is used for Pointset. DefineBOP('POINTSET,17,18,NARY('POINTSET,X,Y)); Put('!&,'NEWNAM,'GROUP); %. and sign handling. DefineBOP('GROUP,13,14,NARY('GROUP,X,Y)); % "&" is used for Group. Put('!|,'NEWNAM,'TRANSFORM); %. back slash handling. DefineROP('TRANSFORM,20, % "|" is used for transform. If EQCAR(X,'!*COMMA!*) then REPCOM('TRANSFORM,X)); DefineBOP('TRANSFORM,15,16); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of external Procedures to % % internal form. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ************************************** % conversion on structures of models. * % ************************************** NExpr Procedure POINTSET L$ 'POINTSET . L$ NExpr Procedure GROUP L$ 'GROUP . L$ NExpr Procedure TRANSFORM L$ 'TRANSFORM . L$ % *********************************** % conversion on interpreter level * % Procedures. * % *********************************** Procedure BSPLINE; LIST 'BSPLINE; Procedure BEZIER; LIST 'BEZIER; Procedure LINE; LIST 'LINE; Procedure CIRCLE(R); LIST('CIRCLE,R); Procedure COLOR N; List('Color,N); Procedure REPEATED(COUNT,TRANS); LIST('REPEATED,COUNT,TRANS); BothTimes <<Procedure MKLIST L$ 'LIST . L; >>; MACRO Procedure OnePoint L$ LIST('MKPOINT, MKLIST CDR L)$ MACRO Procedure MAT16 L; LIST('LIST2VECTOR, MKLIST (NIL. CDR L))$ Procedure PNT4(X1,X2,X3,X4); % create a vector of a point Begin scalar V; V:=MKVECT 4; V[1]:=X1; V[2]:=X2; V[3]:=X3; V[4]:=X4; Return V; end; % %%%%%%%%%%%%%%%%%%%%%%%%% % PAIR KLUDGES % % %%%%%%%%%%%%%%%%%%%%%%%%% Procedure PRLISPCDR L$ %. PRLISPCDR of a list. If PAIRP L then CDR L else 'NIL$ Procedure CAR1 L$ %. the Car1 element of If PAIRP L then CAR L else 'NIL$ %. a list. Procedure CAR2 L$ %. the CAR2 element of If LENGTH L > 1 then CADR L else 'NIL$ %. a list. Procedure CAR3 L$ %. the CAR3 element of If LENGTH L > 2 then CADDR L else 'NIL$ %. a list. Procedure CAR4 L$ %. the CAR4 element of If LENGTH L > 3 then CADDDR L else 'NIL$ %. a list. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % interpreter supporting Procedures % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure V!.COPY V1$ %. Copy a vector Begin scalar N, V2$ V2 := MKVECT(N := SIZE V1)$ FOR I := 0 : N DO V2[I] := V1[I]$ Return V2$ end$ % ********************* % point primitive * % ********************* Procedure MKPOINT (POINTLIST)$ %. make a vector form for Begin scalar P,I; P:=Pnt4(0,0,0,1); I:=1; While PairP PointList and I<=4 do <<P[I]:=Car PointList; I:=I+1; PointList:=Cdr PointList>>; Return P End; % ************************** % initialize globals and * % and fluids * % set up for compiled * % version * % ************************** FLUID '( DISPLAY!.LIST %. Used for object definition for MPS MAT!*0 %. 4 x 4 Zero Matrix MAT!*1 %. 4 x 4 Unit Matrix FirstPoint!* % FirstPoint of PointSet is MOVED to GLOBAL!.TRANSFORM %. Accumulation Transform CURRENT!.TRANSFORM CURRENT!.LINE %. Line Style CURRENT!.COLOR %. Default Color X1CLIP % Set by VWPORT for Clipping X2CLIP Y1CLIP Y2CLIP FourClip % Vector to return New Clipped point Xprevious Yprevious DEV!. % Device Name, set by xxx!.Init() )$ Procedure SetUpVariables; % Intialize Globals and Fluids Begin MAT!*0 := MAT16 ( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0)$ MAT!*1 := MAT16 (1,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,1)$ % unit matrix. GLOBAL!.TRANSFORM := MAT!*1$ CURRENT!.TRANSFORM := MAT!*1$ % current transformation matrix % initialized as mat!*1. CURRENT!.LINE := 'LINE$ CURRENT!.COLOR := 'BLACK$ Xprevious := 0; Yprevious:=0; FourClip := PNT4(0,0,0,0); FirstPoint!* := NIL$ End; % ---------------- BASIC Moving and Drawing ------------------- % Project from Normalized 4 Vector to X,Y plane Procedure MoveToXY(X,Y)$ %. Move current cursor to x,y of P <<MoveS(X,Y); Xprevious := X; Yprevious := Y>>$ Procedure DrawToXY(X,Y)$ %. Move cursor to "P" and draw from Previous <<DrawS(X,Y); Xprevious := X; Yprevious := Y>>$ % ************************************** % clipping-- on 2-D display screen * % ************************************** Smacro procedure MakeFourClip(X1,Y1,X2,Y2); <<FourClip[1]:=x1; FourClip[2]:=y1; FourClip[3]:=x2; FourClip[4]:=y2; FourClip>>; Procedure InView (L); NULL(Car L) and NULL(cadr L) and NULL(caddr L) and NULL (cadddr L); Procedure CLIP2D (x1,y1,x2,y2); % Iterative Clipper Begin scalar P1,P2,TMP; % Newmann and Sproull P1 := TESTPOINT(x1,y1); % Classify EndPoints, get 4 List P2 := TESTPOINT(x2,y2); If InView(P1) and InView(P2) then Return MakeFourClip(x1,y1,X2,Y2); WHILE NOT(InView(P1) AND InView(P2) OR LOGICAND(P1,P2)) DO << If InView(P1) then % SWAP to get Other END <<TMP := P1$ P1 := P2$ P2 := TMP$ TMP := X1$ X1 := X2$ X2 := TMP$ TMP := Y1$ Y1 := Y2$ Y2 := TMP>>$ If CADDDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X1CLIP-X1)) / (X2-X1)$ X1 := X1CLIP>> else If CADDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X2CLIP-X1)) / (X2-X1)$ X1 := X2CLIP>> else If CADR P1 then <<X1 := X1 + ((X2-X1)*(Y1CLIP-Y1)) / (Y2-Y1)$ Y1 := Y1CLIP>> else If CAR P1 then <<X1 := X1 + ((X2-X1)*(Y2CLIP-Y1)) / (Y2-Y1)$ Y1 := Y2CLIP>>$ P1 := TESTPOINT(X1,Y1)>>; % reTest P1 after clipping If Not LOGICAND(P1,P2) then Return MakeFourClip(X1,Y1,X2,Y2); Return NIL end$ Procedure LOGICAND (P1, P2)$ %. logical "and". (CAR P1 AND CAR P2) OR %. use in clipping (CADR P1 AND CADR P2) OR (CADDR P1 AND CADDR P2) OR (CADDDR P1 AND CADDDR P2) $ Procedure TESTPOINT(x,y)$ %. test If "P" LIST (If y > Y2CLIP then T else NIL, %. inside the viewport. If y < Y1CLIP then T else NIL, %.used in clipping If x > X2CLIP then T else NIL, If x < X1CLIP then T else NIL)$ % All NIL if Inside % ********************************** % tranformation matrices * % matrices internal are stored as * % OnePoint = [x y z w] * % matrix = [v1 v5 v9 v13 * % v2 v6 v10 v14 * % v3 v7 v11 v15 * % v4 v8 v12 v16 ] * % ********************************** %******************************************************* % Matrix Multiplication given two 4 by 4 matricies * %******************************************************* Procedure MAT!*MAT (V1,V2)$ %. multiplication of matrices. MAT16 ( % V1 and V2 are 4 by 4 matrices. V1[ 1] * V2[ 1] + V1[ 5] * V2[ 2] + V1[ 9] * V2[ 3] + V1[ 13] * V2[ 4], V1[ 2] * V2[ 1] + V1[ 6] * V2[ 2] + V1[ 10] * V2[ 3] + V1[ 14] * V2[ 4], V1[ 3] * V2[ 1] + V1[ 7] * V2[ 2] + V1[ 11] * V2[ 3] + V1[ 15] * V2[ 4], V1[ 4] * V2[ 1] + V1[ 8] * V2[ 2] + V1[ 12] * V2[ 3] + V1[ 16] * V2[ 4], V1[ 1] * V2[ 5] + V1[ 5] * V2[ 6] + V1[ 9] * V2[ 7] + V1[ 13] * V2[ 8], V1[ 2] * V2[ 5] + V1[ 6] * V2[ 6] + V1[ 10] * V2[ 7] + V1[ 14] * V2[ 8], V1[ 3] * V2[ 5] + V1[ 7] * V2[ 6] + V1[ 11] * V2[ 7] + V1[ 15] * V2[ 8], V1[ 4] * V2[ 5] + V1[ 8] * V2[ 6] + V1[ 12] * V2[ 7] + V1[ 16] * V2[ 8], V1[ 1] * V2[ 9] + V1[ 5] * V2[ 10] + V1[ 9] * V2[ 11] + V1[ 13] * V2[ 12], V1[ 2] * V2[ 9] + V1[ 6] * V2[ 10] + V1[ 10] * V2[ 11] + V1[ 14] * V2[ 12], V1[ 3] * V2[ 9] + V1[ 7] * V2[ 10] + V1[ 11] * V2[ 11] + V1[ 15] * V2[ 12], V1[ 4] * V2[ 9] + V1[ 8] * V2[ 10] + V1[ 12] * V2[ 11] + V1[ 16] * V2[ 12], V1[ 1] * V2[ 13] + V1[ 5] * V2[ 14] + V1[ 9] * V2[ 15] + V1[ 13] * V2[ 16], V1[ 2] * V2[ 13] + V1[ 6] * V2[ 14] + V1[ 10] * V2[ 15] + V1[ 14] * V2[ 16], V1[ 3] * V2[ 13] + V1[ 7] * V2[ 14] + V1[ 11] * V2[ 15] + V1[ 15] * V2[ 16], V1[ 4] * V2[ 13] + V1[ 8] * V2[ 14] + V1[ 12] * V2[ 15] + V1[ 16] * V2[ 16])$ Procedure PNT!*PNT(U,V)$ %. multiplication of matrices U[1] * V[1] + %. 1 by 4 and 4 by 1. U[2] * V[2] + % Returning a value. U[3] * V[3] + U[4] * V[4] $ Procedure PNT!*MAT(U,V)$ %. multiplication of matrices Begin scalar U1,U2,U3,U4$ %. 1 by 4 with 4 by 4. U1 := U[1]$ % Returning a 1 by 4 vector. U2 := U[2]$ U3 := U[3]$ U4 := U[4]$ U:=Mkvect 4; u[1]:= U1 * V[1] + U2 * V[2] + U3 * V[3] + U4 * V[4]; u[2]:= U1 * V[5] + U2 * V[6] + U3 * V[7] + U4 * V[8]; u[3]:= U1 * V[9] + U2 * V[10] + U3 * V[11] + U4 * V[12]; u[4]:= U1 * V[13] + U2 * V[14] + U3 * V[15] + U4 * V[16]; Return U; end$ % ************************************ % set up perspective transformtion * % given eye and screen distances * % ************************************ Procedure WINDOW(EYE,SCREEN)$ %. perspective transformation. Begin scalar SE$ SE := SCREEN - EYE$ % EYE and SCREEN are distances Return MAT16(SE,0.0,0.0,0.0, % from eye and screen to 0.0,SE,0.0,0.0, % origin respectively. 0.0,0.0,SE,0.0, 0.0,0.0,1.0, -EYE) end$ % ********************** % translation * % ********************** Procedure XMove (TX)$ %. x translation only Move (TX,0,0) $ Procedure YMove (TY)$ %. y translation only Move (0,TY,0) $ Procedure ZMove (TZ)$ %. z translation only Move (0,0,TZ) $ Procedure Move (TX,TY,TZ)$ %. Move origin / object$ MAT16 (1, 0, 0, TX, %. make a translation 0, 1, 0, TY, %. transformation matrix 0, 0, 1, TZ, %. [ 1 O O O 0, 0, 0, 1)$ %. 0 1 0 0 %. 0 0 1 0 %. Tx Ty Tz 1 ] % ******************* % rotation * % ******************* Procedure XROT (X)$ %. rotation about x FROTATE (X,2,3) $ Procedure YROT (X)$ %. rotation about y FROTATE (X,3,1) $ Procedure ZROT (X)$ %. rotation about z FROTATE (X,1,2) $ Procedure FROTATE (THETA,I,J)$ %. scale factor Begin scalar S,C,W,TEMP$ %. i and j are the index %. values to set up matrix S := SIND (THETA)$ %. sin in degrees uses mathlib C := COSD (THETA)$ %. cos in degrees uses mathlib TEMP := V!.COPY MAT!*1; PutV (TEMP, 5 * I-4, C)$ PutV(TEMP, 5 * J-4, C)$ PutV (TEMP, I+4 * J-4,-S)$ PutV (TEMP, J+4 * I-4, S)$ Return TEMP end $ %/ Need to add rotate about an AXIS % ****************** % scaling * % ****************** Procedure XSCALE (SX)$ %. scaling along X axis only. SCALE1 (SX,1,1) $ Procedure YSCALE (SY)$ %. scaling along Y axis only. SCALE1 (1,SY,1) $ Procedure ZSCALE (SZ)$ %. scaling along Z axis only. SCALE1 (1,1,SZ) $ Procedure SCALE1(XT,YT,ZT)$ %. scaling transformation MAT16 ( XT, 0, 0, 0, %. matrix. 0 ,YT, 0, 0, 0 , 0,ZT, 0, 0 , 0, 0, 1)$ Procedure SCALE SFACT; %. scaling along 3 axes. SCALE1(SFACT,SFACT,SFACT); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Procedure definitions % % in the interpreter % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Put('OnePoint,'PBINTRP,'DrawPOINT)$ Put('POINTSET,'PBINTRP,'DrawPOINTSET)$ Put('GROUP,'PBINTRP,'DrawGROUP)$ Put('TRANSFORM,'PBINTRP,'PERFORMTRANSFORM)$ Put('PICTURE,'PBINTRP,'DrawModel)$ Put('CIRCLE,'PBINTRP,'DrawCIRCLE)$ Put('BEZIER,'PBINTRP,'DOBEZIER)$ Put('LINE,'PBINTRP,'DOLINE)$ Put('BSPLINE,'PBINTRP,'DOBSPLINE)$ Put('REPEATED, 'PBINTRP,'DOREPEATED)$ Put('Color,'pbintrp,'Docolor); %****************************************** % SETUP Procedure FOR BEZIER AND BSPLINE * % LINE and COLOR %****************************************** procedure DoColor(Object,N); Begin scalar SaveColor; SaveColor:=Current!.color; N:=Car1 N; % See CIRCLE example, huh? If IDP N then N:=EVAL N; ChangeColor N; Draw1(Object,CURRENT!.TRANSFORM); ChangeColor SaveColor; Return NIL; End; Procedure DOBEZIER OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BEZIER$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOBSPLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BSPLINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'LINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ %************************************* % interpreted function calls * %************************************* Procedure DOREPEATED(MODEL,REPTFUN)$ %. repeat applying Begin scalar TEMP,I,TRANS,COUNT,TS,TA,GRP$ %. transformations. TRANS := PRLISPCDR REPTFUN$ If LENGTH TRANS = 1 then TRANS := EVAL CAR1 TRANS else % "TRANS": transformation << TS :=CAR1 TRANS$ % matrix. TA := PRLISPCDR TRANS $ % "MODEL": the model. TRANS := APPLY(TS,TA) >> $ % "COUNT": the times "MODEL" COUNT := CAR1 REPTFUN$ % is going to be GRP := LIST('GROUP)$ % repeated. TEMP := V!.COPY TRANS$ FOR I := 1 : COUNT DO << GRP := LIST('TRANSFORM,MODEL,TEMP) . GRP$ TEMP := MAT!*MAT(TEMP,TRANS) >>$ GRP := REVERSE GRP$ Return GRP end$ %*********************************** % Define SHOW ESHOW Draw AND EDraw * % ESHOW AND EDraw ERASE THE SCREEN * %*********************************** Procedure SHOW X; %. ALIAS FOR Draw << If DEV!. = 'MPS then %. MPS driver don't call << %. echo functions for diplay %. device DISPLAY!.LIST := LIST (X, DISPLAY!.LIST); FOR EACH Z IN DISPLAY!.LIST DO If Z neq NIL then Draw1(Z,GLOBAL!.TRANSFORM); % Draw object list % to frame PSnewframe(); % display frame >> else << GraphOn(); % call echo off If not emode % If neccessary turn low level Draw1(X,GLOBAL!.TRANSFORM); % Draw model tekronix style GraphOff(); % call echoon >>; >>; Procedure ESHOW ZZ$ %. erases the screen and << Erase(); GraphOn(); DELAY(); Draw1(ZZ,GLOBAL!.TRANSFORM); % Draw model tekronix style If DEV!. = 'MPS then << % Mps display frame PSnewframe(); DISPLAY!.LIST := ZZ; >>; GraphOff(); 0 >>; DefineROP('SHOW,10); %. set up precedence DefineROP('ESHOW,10); Procedure Draw X; %. ALIAS FOR SHOW SHOW X$ Procedure EDraw ZZ$ %. erases the screen and ESHOW ZZ$ DefineROP('Draw,10); DefineROP('EDraw,10); Procedure Col N; % User top-level color <<GraphOn(); ChangeColor N; GraphOff()>>; %************************************* % Define Draw FUNCTIONS FOR VARIOUS * % TYPES OF DISPLAYABLE OBJECTS * %************************************* Procedure DrawModel PICT$ %. given picture "PICT" will Draw1(PICT,CURRENT!.TRANSFORM)$ %. be applyied with global Procedure DERROR(MSG,OBJECT); <<PRIN2 " Draw Error `"; PRIN2T MSG; PRIN2 OBJECT; ERROR(700,MSG)>>; Procedure Draw1 (PICT,CURRENT!.TRANSFORM)$ % Draw PICT with TRANSFORMATION Begin scalar ITM,ITSARGS$ If NULL Pict then Return NIL; If IDP PICT then PICT:=EVAL PICT; If VECTORP PICT AND SIZE(PICT)=4 then Return DrawPOINT PICT$ If NOT PAIRP PICT then DERROR("Non Pair in Draw1: ",PICT); ITM := CAR1 PICT$ ITSARGS := PRLISPCDR PICT$ If NOT (ITM = 'TRANSFORM) then ITSARGS := LIST ITSARGS$ % gets LIST of args ITM := GET (ITM,'PBINTRP)$ If NULL ITM then DERROR("Unknown Operator in Draw1:",PICT); APPLY(ITM,ITSARGS)$ Return PICT$ end$ Procedure DrawGROUP(GRP)$ % Draw a group object Begin scalar ITM,ITSARGS,LMNT$ If PAIRP GRP then FOR EACH LMNT IN GRP DO If PAIRP LMNT then Draw1 (LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL GRP,CURRENT!.TRANSFORM)$ Return GRP$ end$ Procedure DrawPOINTSET (PNTSET)$ Begin scalar ITM,ITSARGS,PT$ FirstPoint!* := 'T$ If PAIRP PNTSET then << If CURRENT!.LINE = 'BEZIER then PNTSET := DrawBEZIER PNTSET else If CURRENT!.LINE = 'BSPLINE then PNTSET := DrawBSPLINE PNTSET$ FOR EACH PT IN PNTSET DO <<If PAIRP PT then Draw1 (PT,CURRENT!.TRANSFORM) else Draw1 (EVAL PT,CURRENT!.TRANSFORM)$ FirstPoint!* := 'NIL>> >> else Draw1 (EVAL PNTSET,CURRENT!.TRANSFORM)$ Return PNTSET$ end$ Procedure DrawPOINT (PNT)$ Begin scalar CLP,X1,Y1,W1,V,U1,U2,U3,U4; If IDP PNT then PNT := EVAL PNT$ If PAIRP PNT then PNT := MKPOINT PNT; V:=CURRENT!.TRANSFORM; % Transform Only x,y and W U1:=PNT[1]; U2:=PNT[2]; U3:= PNT[3]; U4:=PNT[4]; X1:=U1 * V[1] + U2 * V[2] + U3 * V[3] + U4 * V[4]; Y1:=U1 * V[5] + U2 * V[6] + U3 * V[7] + U4 * V[8]; W1:=U1 * V[13] + U2 * V[14] + U3 * V[15] + U4 * V[16]; IF NOT (W1 = 1.0) then <<x1:=x1/w1; y1:=y1/w1>>; If FirstPoint!* then Return MoveToXY(X1,Y1); % back to w=1 plane If needed. CLP := CLIP2D(Xprevious,Yprevious, X1,Y1)$ If CLP then <<MoveToXY(CLP[1],CLP[2])$ DrawToXY(CLP[3],CLP[4])>>$ end$ Procedure PERFORMTRANSFORM(PCTSTF,TRNSFRM)$ Begin scalar PROC,OLDTRNS,TRNSFMD,TRANSFOP, TRANSARG,ITM,ITSARGS$ If IDP TRNSFRM then TRNSFRM := EVAL TRNSFRM$ If VECTORP TRNSFRM AND SIZE(TRNSFRM) = 16 then Draw1 (PCTSTF,MAT!*MAT(TRNSFRM,CURRENT!.TRANSFORM)) else If PAIRP TRNSFRM then <<TRANSFOP := CAR1 TRNSFRM$ If (TRANSARG := PRLISPCDR TRNSFRM) then TRANSARG := LIST (PCTSTF,TRANSARG) else TRANSARG := LIST PCTSTF$ If (TRANSFOP = 'BEZIER OR TRANSFOP = 'BSPLINE) then APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG) else Draw1 (APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG), CURRENT!.TRANSFORM) >> end$ %*************************************** % circle bezier and bspline functions * %*************************************** Procedure DrawCIRCLE(CCNTR,RADIUS); %. Draw a circle with radius Begin scalar APNT,POLY,APNTX, APNTY$ %. "RADIUS". POLY := LIST('POINTSET)$ If IDP CCNTR then CCNTR := EVAL CCNTR$ RADIUS := CAR1 RADIUS$ If IDP RADIUS then RADIUS := EVAL RADIUS$ FOR ANGL := 180 STEP -15 UNTIL -180 DO % each line segment << APNTX := CCNTR[1] + RADIUS * COSD ANGL$ % represents an arc of 15 dgrs APNTY := CCNTR[2] + RADIUS * SIND ANGL$ POLY := LIST('Onepoint,APNTX,APNTY) . POLY>>$ Return REVERSE POLY end$ Procedure DrawBSPLINE CONPTS$ %. a closed bspline curve Begin scalar N,TWOLIST,PX,PY,CURPTS, %. will be Drawn when given BSMAT,II,TFAC,CPX,CPY$ %. a polygon "CONPTS". BSMAT := MAT16 % " CONPTS" is a pointset. ( -0.166666, 0.5, -0.5, 0.166666, 0.5 , -1.0, 0.0, 0.666666, -0.5 , 0.5, 0.5, 0.166666, 0.166666, 0.0, 0.0, 0.0 )$ CURPTS := NIL$ N := LENGTH CONPTS$ TWOLIST := APPend (CONPTS,CONPTS)$ WHILE N > 0 DO << PX :=PNT4 (GETV(CAR1 TWOLIST,1), GETV(CAR2 TWOLIST,1), GETV(CAR3 TWOLIST,1),GETV(CAR4 TWOLIST,1))$ PY := PNT4 (GETV(CAR1 TWOLIST,2), GETV(CAR2 TWOLIST,2), GETV(CAR3 TWOLIST,2), GETV(CAR4 TWOLIST,2))$ FOR I := 0.0 STEP 1.0 UNTIL 4.0 DO << II := I/4.$ TFAC := PNT4 (II*II*II, II*II, II, 1.)$ TFAC := PNT!*MAT(TFAC,BSMAT)$ CPX := PNT!*PNT(TFAC,PX)$ CPY := PNT!*PNT(TFAC,PY)$ CURPTS := LIST ('Onepoint, CPX, CPY) . CURPTS >>$ N := N - 1$ TWOLIST := PRLISPCDR TWOLIST >>$ Return REVERSE CURPTS end$ LISP Procedure DrawBEZIER CNTS; Begin scalar LEN, NALL, SAVEX, SAVEY, CPX, CPY, CURPTS, I, T0, TEMP, FACTL; CURPTS := NIL; SAVEX := NIL; SAVEY := NIL; LEN := LENGTH CNTS; FOR I := 1 STEP 1 UNTIL LEN DO << SAVEX := GETV(CAR1 CNTS, 1) . SAVEX; SAVEY := GETV(CAR1 CNTS, 2) . SAVEY; CNTS := PRLISPCDR CNTS >>; SAVEX := LIST2VECTOR SAVEX; SAVEY := LIST2VECTOR SAVEY; NALL := 8.0 * (LEN - 1); FACTL := FACT (LEN - 1); T0 := 0.0; FOR T0 := 0.0 STEP 1.0 / NALL UNTIL 1.0 DO << CPX := 0.0; CPY := 0.0; TEMP := 0.0; FOR I := 0 STEP 1 UNTIL LEN - 1 DO << TEMP := FACTL / ((FACT I) * (FACT (LEN -1 - I))) * (T0 ** I) * (1.0 - T0)**(LEN -1 - I); CPX := TEMP * SAVEX[I] + CPX; CPY := TEMP * SAVEY[I] + CPY >>; CURPTS := LIST ('ONEPOINT, CPX, CPY, 0.0) . CURPTS >>; Return REVERSE CURPTS; end; procedure FACT N; % Simple factorial Begin scalar M; M:=1; for i:=1:N do M:=M*I; Return M; end; LoadTime SetUpVariables();