Artifact c69ceaf08040a3ecb93c888ce8b451df56f845bc0e53db4efe51451655f63a1c:
- File
psl-1983/3-1/util/pr2d-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: 24923) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/pr2d-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: 24923) [annotate] [blame] [check-ins using]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % PictureRLISP : A Lisp-Based Graphics Language System with % % Flexible Syntax and Hierarchical % % Data Structure % % 2D version................ % % 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 Mat8 L; LIST('LIST2VECTOR, MKLIST (CDR L))$ Procedure Pnt2(X1,X2,X3); % create a vector of a point Begin scalar V; V:=MKVECT 2; V[0]:=X1; V[1]:=X2; V[2]:=X3; 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:=Pnt2(0,0,1); I:=0; While PairP PointList and I<=2 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 %. 3 x 3 Zero Matrix MAT!*1 %. 3 x 3 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 ThreeClip % Vector to return New Clipped point HEREPOINTX %/ Same as Xprevious? HEREPOINTY Xprevious % To do DDA on TEL and AAA Yprevious % Set by Move, used by DRAW DEV!. % Device Name, set by xxx!.Init() )$ Procedure SetUpVariables; % Intialize Globals and Fluids Begin MAT!*0 := Mat8 ( 0,0,0, 0,0,0, 0,0,0)$ MAT!*1 := Mat8 (1,0,0, 0,1,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$ HEREPOINTX := 0; HEREPOINTY:=0; ThreeClip := Vector(0,0,0,0); FirstPoint!* := NIL$ End; % ---------------- BASIC Moving and Drawing ------------------- % Project from Normalized 3 Vector to X,Y plane Procedure MoveToXY(X,Y)$ %. Move current cursor to x,y of P <<MoveS(X,Y); HEREPOINTX := X; HEREPOINTY := Y>>$ Procedure DrawToXY(X,Y)$ %. Move cursor to "P" and draw from Previous <<DrawS(X,Y); HEREPOINTX := X; HEREPOINTY := Y>>$ % ************************************** % clipping-- on 2-D display screen * % ************************************** Smacro procedure MakeThreeClip(X1,Y1,X2,Y2); <<ThreeClip[0]:=x1; ThreeClip[1]:=y1; ThreeClip[2]:=x2; ThreeClip[3]:=y2; ThreeClip>>; 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 MakeThreeClip(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 MakeThreeClip(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 w] * % matrix = [v0 v3 v6 * % v1 v4 v7 * % v2 v5 v8 ] * % ********************************** %******************************************************* % Matrix Multiplication given two 3 by 3 matricies * %******************************************************* Procedure MAT!*MAT (V1,V2)$ %. multiplication of matrices. Mat8 ( % V1 and V2 are 3 by 3 matrices. V1[0] * V2[0] + V1[3] * V2[1] + V1[6] * V2[2], V1[1] * V2[0] + V1[4] * V2[1] + V1[7] * V2[2], V1[2] * V2[0] + V1[5] * V2[1] + V1[8] * V2[2], V1[0] * V2[3] + V1[3] * V2[4] + V1[6] * V2[5], V1[1] * V2[3] + V1[4] * V2[4] + V1[7] * V2[5], V1[2] * V2[3] + V1[5] * V2[4] + V1[8] * V2[5], V1[0] * v2[6] + V1[3] * V2[7] + V1[6] * V2[8], V1[1] * v2[6] + V1[4] * V2[7] + V1[7] * V2[8], V1[2] * v2[6] + V1[5] * V2[7] + V1[8] * V2[8]); Procedure PNT!*PNT(U,V)$ %. multiplication of matrices U[0] * V[0] + U[1] * V[1] + %. 1 by 3 and 3 by 1. U[2] * V[2] $ % Returning a value. Procedure PNT!*MAT(U,V)$ %. multiplication of matrices Begin scalar U0,U1,U2$ %. 1 by 3 with 3 by 3. U0 := U[0]$ U1 := U[1]$ % Returning a 1 by 3 vector. U2 := U[2]$ U:=Mkvect 2; u[0]:= U0 * V[0] + U1 * V[3] + U2 * V[6]; u[1]:= U0 * V[1] + U1 * V[4] + U2 * V[7]; u[2]:= U0 * V[2] + U1 * V[5] + U2 * V[8]; Return U; end$ % ********************** % translation * % ********************** Procedure XMove(TX)$ %. x translation only Move (TX,0) $ Procedure YMove(TY)$ %. y translation only Move (0,TY) $ Procedure Move(TX,TY)$ %. Move origin / object$ Mat8(1, 0, TX, %. make a translation 0, 1, TY, %. transformation matrix 0, 0, 1)$ % ******************* % Z rotation * % ******************* Procedure ZROT(Theta)$ %. rotation about z Begin scalar S,C; S := SIND (THETA)$ %. sin in degrees uses mathlib C := COSD (THETA)$ %. cos in degrees uses mathlib Return Mat8( C,-S,0, S,C,0, 0,0,1); end $ % ****************** % scaling * % ****************** Procedure XSCALE (SX)$ %. scaling along X axis only. SCALE1 (SX,1) $ Procedure YSCALE (SY)$ %. scaling along Y axis only. SCALE1 (1,SY) $ Procedure SCALE1(XT,YT)$ %. scaling transformation Mat8 ( XT, 0, 0, %. matrix. 0 ,YT, 0, 0, 0, 1)$ Procedure SCALE SFACT; %. scaling along 2 axes. SCALE1(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(); %. display the picture "ZZ" 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)=2 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,U0,U1,U2; If IDP PNT then PNT := EVAL PNT$ If PAIRP PNT then PNT := MKPOINT PNT; V:=CURRENT!.TRANSFORM; % Transform Only x,y and W U0:=PNT[0]; U1:=PNT[1]; U2:=PNT[2]; X1:=U0 * V[0] + U1 * V[1] + U2 * V[2]; Y1:=U0 * V[3] + U1 * V[4] + U2 * V[5]; W1:=U0 * V[6] + U1 * V[7] + U2 * V[8]; IF NOT( (W1=1) or (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(HEREPOINTX,HerePointY, X1,Y1)$ If CLP then <<MoveToXY(CLP[0],CLP[1])$ DrawToXY(CLP[2],CLP[3])>>$ 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) = 8 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 Begin scalar APNT,POLY,APNTX, APNTY$ 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[0] + RADIUS * COSD ANGL$ % represents an arc of 15 dgrs APNTY := CCNTR[1] + RADIUS * SIND ANGL$ POLY := LIST('Onepoint,APNTX,APNTY) . POLY>>$ Return REVERSE POLY end$ Procedure DrawBspline CONPTS$ %. a "closed" Periodic bspline curve Begin scalar N,CURPTS, % See CATMUL thesis Appendix CPX,CPY, % Note correction in Matrix! X0,X1,X2,X3, Y0,Y1,Y2,Y3, T1,T2,T3, J0,J1,J2, NPTS; NPTS := 4; N := LENGTH CONPTS$ %/ Check at least 4 ? CONPTS := Append (CONPTS,CONPTS)$ % To make a Closed Loop % Set the Initial 4 points X0:=0; % Dummy Y0:=0; X1:=GETV(CAR CONPTS,0); % Will Be X0,Y0 in loop Y1:=GETV(CAR CONPTS,1); CONPTS := CDR CONPTS; X2:=GETV(CAR CONPTS,0); Y2:=GETV(CAR CONPTS,1); CONPTS := CDR CONPTS; X3:=GETV(CAR CONPTS,0); Y3:=GETV(CAR CONPTS,1); WHILE N > 0 DO << X0 := X1; Y0 := Y1; % Cycle Points X1 := X2; Y1 := Y2; X2 := X3; Y2 := Y3; CONPTS := CDR CONPTS; X3:=GETV(CAR CONPTS,0); Y3:=GETV(CAR CONPTS,1); % Compute X(t) and Y(t) for NPTS points on [0.0,1.0] FOR I := 0:NPTS-1 DO << T1 := FLOAT(I)/NPTS$ % Powers of t T2 := T1 * T1; T3 := T2 * T1; %/ ( -1 3 -3 1 %/ 3 -6 3 0 %/ -3 0 3 0 %/ 1 4 1 0 ) J0:= (1.0-T3) + 3.0*(T2-T1); J1 := 3.0*T3 - 6*T2 +4.0; J2 := 1.0+ 3.0*(T1 +T2- T3); CPX := (X0*J0 +X1*J1 + X2 *J2 +X3*T3)/6.0; CPY := (Y0*J0 +Y1*J1 + Y2 *J2 +Y3*T3)/6.0; CURPTS := Pnt2(CPX, CPY,1.0) . CURPTS >>$ N := N - 1>>; Return CURPTS end$ % Faster 2-d Bezier procedure DrawBEZIER CNTS; % Give list of Points Begin scalar LEN, NALL, SAVEX, SAVEY, CPX, CPY, CURPTS, T0, T1, TEMP, FACTL, TI, FI,COEFF; LEN := Isub1 LENGTH(CNTS); SaveX := MKVect Len; SaveY := MKVect Len; FACTL := IFACT LEN; FOR I := 0:LEN DO <<Coeff := FactL/(IFACT(i)*IFACT(Len-i)); SAVEX[I] := GETV(CAR CNTS, 0) * Coeff; SAVEY[I] := GETV(CAR CNTS, 1) * Coeff;; CNTS := CDR CNTS>>; NALL := 1.0/(8.0 * LEN); % Step Size FOR T0 := 0.0 STEP NALL UNTIL 1.0 DO << T1 := 1.0-T0; TI := T0; TEMP := T1**LEN; CPX := TEMP * SAVEX[0]; CPY := TEMP * SAVEY[0]; FOR I := 1:LEN DO << TEMP := (TI * (T1**(LEN - I))); TI := TI * T0; CPX := TEMP * SAVEX[I] + CPX; CPY := TEMP * SAVEY[I] + CPY >>; CURPTS := LIST ('ONEPOINT, CPX, CPY) . CURPTS >>; Return REVERSE CURPTS; end; procedure IFACT N; % fast factorial Begin scalar M; M:=1; While Igreaterp(N,1) do <<M:=Itimes2(N,M); N :=Isub1 N>>; Return M; end; LoadTime SetUpVariables(); % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture.