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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                %
%  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();