reduce-historical/psl-1983/util/pr2d-main.red

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                %
%  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.