procedure arbitraryscale(var inputmatrix  : matrixtype ;
                             scalevector  : vectortype;
                                    point : pointtype );
(************************************************************
**  arbitrary scale:                                       **
**    scale about the given point by using translatinon    **
**    and scale procedure. concatenate the result to the   **
**    inputmatrix.                                         **
**                                                         **
**  local variables:                                       **
**    i : counter                                          **
**    negativepoint: negate of the input point             **
**                                                         **
*************************************************************)

{ add a scaling to the inputmatrix about the given point}
   var
   i            : integer;
   negativepoint : pointtype;
   begin { arbitrarscale }
   for i := 1 to userdimension do
      negativepoint[i] := -1*point[i] ;
   translate(inputmatrix,negativepoint);
   scale(inputmatrix,scalevector);
   translate(inputmatrix,point);
   end; { arbitraryscale }


procedure arbitraryrotate(var inputmatrix : matrixtype ;
                              point       : pointtype  ;
                              angle       : integer    );
(************************************************************
**  arbitraryrotate:                                       **
**     apply a rotation about the given point by the given **
**     angle( in degrees ). and concatenate the result     **
**     with the input matrix. procedure is optimized       **
**                                                         **
**  local variables:                                       **
**    rotation,tempmatrix : temporary matrices             **
**    radian              : value of angle in radians      **
**                                                         **
*************************************************************)

   var
      rotationmatrix,
      tempmatrix  : matrixtype;
      radian      : real;
   begin  { arbitraryrotate }
   radian := angle*pi/180;
   rotationmatrix[1,1] := cos(radian);
   rotationmatrix[1,2] := sin(radian);
   rotationmatrix[1,3] := 0 ;
   rotationmatrix[2,1] := -1*sin(radian) ;
   rotationmatrix[2,2] := cos(radian);
   rotationmatrix[2,3] := 0 ;
   rotationmatrix[3,1] := point[1]*(1-cos(radian))+point[2]*sin(radian) ;
   rotationmatrix[3,2] := point[2]*(1-cos(radian))-point[1]*sin(radian) ;
   rotationmatrix[3,3] := 1;
   concatenate(inputmatrix,rotationmatrix,tempmatrix);
   inputmatrix := tempmatrix;
   end;

(************************************************************
**           viewing transformtion routines                **
*************************************************************)


procedure init_clip_rectangle(var viewarea : viewareatype);
(************************************************************
**                                                         **
**  init_clip_rectangle:                                   **
**    reset the viewarea with the new values of the view   **
**    -port                                                **
**                                                         **
**  local variables:                                       **
**    i : counter                                          **
**                                                         **
*************************************************************)

   var
     i  : integer;

   begin  { init_clip_rectangle }
   with viewarea[1] do
      begin
      a := 1;
      b := 0;
      c := viewminx;
      orgdir := true;
      end;
   with viewarea[2] do
      begin
      a := 1;
      b := 0;
      c := viewmaxx;
      orgdir := false;
      end;
   with viewarea[3] do
      begin
      a := 0;
      b := 1;
      c := viewminy;
      orgdir := true;
      end;
   with viewarea[4] do
      begin
      a := 0;
      b := 1;
      c := viewmaxy;
      orgdir := false;
      end;
   end; { init_clip_rectangle }

procedure updatewindow(var windowmatrix : matrixtype );
(************************************************************
**                                                         **
** updates the viewing transformation matrix according to  **
** the values in global variables :                        **
**     xwindsize,ywindsize : window values,                **
** viewminx,viewminy,viewmaxx,                             **
**                    viewmaxy : viewport coordinates      **
**                                                         **
**     using the formula of                                **
**          xv = sx(xw - xwmin)+ xvmin                     **
**          yv = sy(yw - ywmin)+ yvmin                     **
**                                                         **
*************************************************************)

   begin
   windowmatrix[1,1] := (viewmaxx - viewminx) / (xwindsize );
   windowmatrix[1,2] := 0;
   windowmatrix[1,3] := 0;
   windowmatrix[2,1] := 0;
   windowmatrix[2,2] := (viewmaxy - viewminy) / (ywindsize );
   windowmatrix[2,3] := 0;
   windowmatrix[3,1] := viewminx - xwindpos * windowmatrix[1,1];
   windowmatrix[3,2] := viewminy - ywindpos * windowmatrix[2,2];
   windowmatrix[3,3] := 1;
   end; { updatewindow }

procedure resetview ;
(************************************************************
**   resetview:                                            **
**     reinitialize the window and viewport so the         **
**     object is visible.                                  **
**                                                         **
*************************************************************)

   begin
   viewminx := 0;
   viewminy := 0;
   viewmaxx := xscreensize;
   viewmaxy := yscreensize;
   xwindsize := 8;
   ywindsize := 8;
   xwindpos := -4;
   ywindpos := -4;
   init_clip_rectangle( myviewarea  );
   updatewindow(windowmatrix);
   end; { resetview }


(************************************************************
**                user menu routines                       **
*************************************************************)



procedure gettranslate(var  transmatrix : matrixtype);
(************************************************************
**                                                         **
**  gettranslate:                                          **
**     get a translation vector from the user and do       **
**     the appropriate translation                         **
**                                                         **
**  local variables:                                       **
**     tempvector : user transformtion vector              **
**                                                         **
*************************************************************)

   var
      transvector : vectortype;
   begin
   writeln;
   writeln( '**  give me the translation values ** ');
   writeln;
   readvector(transvector);
   translate(transmatrix , transvector );
   print(transmatrix);
   end; { gettranslate }

procedure getscale( var transmatrix : matrixtype);
(************************************************************
**                                                         **
**  getscale:                                              **
**      get a scaling vector and a point about which to    **
**      scale . and do the scaling                         **
**                                                         **
**  local variables:                                       **
**      point : point about which to scale                 **
**      scalevect : user scaling vector                    **
**                                                         **
*************************************************************)

   var
      point : pointtype;
      scalevect : vectortype;
   begin
   writeln;
   writeln('****** scale about a point ******');
   writeln('** first give me the point about which to scale **  ');
   writeln;
   readvector(point);
   writeln;
   writeln('** now give me the scaling vector ** ');
   writeln;
   readvector(scalevect);
   arbitraryscale(transmatrix , scalevect , point) ;
   print(transmatrix);
   end; { getscale }

procedure getrotate( var transmatrix : matrixtype);
(************************************************************
**   getrotate:                                            **
**     get a point and angle of rotation from the user     **
**     and go do the actual rotation. add it to the        **
**     transformatiion matrix                              **
**                                                         **
**  local variables:                                       **
**     point : user rotation point                         **
**     angle : angle of rotation                           **
**                                                         **
*************************************************************)
   var
      point : pointtype;
      angle : integer;
   begin
   writeln;
   writeln('*****   rotate about a point    *******');
   writeln('**  first give me the rotation value **');
   write('** in degrees counterclockwise? ');
   readln( angle);
   writeln;
   writeln('** now give me the point to rotate about **');
   readvector(point);
   arbitraryrotate(transmatrix ,  point , angle);
   print(transmatrix);
   end; { getrotate }

procedure changeviewport;
(************************************************************
**  changeviewport:                                        **
**     get the new values of the viewport from the user    **
**     and reset the wiewing matrix and viewarea to        **
**     reflect the change.                                 **
**                                                         **
**  local variables:                                       **
**     temp : temporary normalize form of viewport location**
**                                                         **
*************************************************************)

   var
    temp : real;
   begin
   writeln;
   writeln('********      change viewport    **********');
   writeln;
   writeln('** enter the coordinates of the viewport **');
   writeln('**    in normalized form (real 0..1 )    **');
   repeat
      write('** minimum x-axis? ');
      readln(temp);
      viewminx := trunc( temp * xscreensize );
      write('** maximum x-axis? ');
      readln(temp);
      viewmaxx := trunc(temp * xscreensize );
      write('** minimum y-axis? ');
      readln(temp);
      viewminy := trunc( temp * yscreensize );
      write('** maximum y-axis? ');
      readln(temp);
      viewmaxy := trunc( temp * yscreensize );
   until ((viewminx < viewmaxx) and (viewminy < viewmaxy));
   updatewindow(windowmatrix);
   init_clip_rectangle(myviewarea );
   print(windowmatrix);
   end;

procedure changewindow;
(************************************************************
**  changewindow:                                          **
**      get the new window size from the user and update   **
**      the wiewing matrix                                 **
**                                                         **
*************************************************************)

   begin
   writeln;
   writeln('********  change window size  ********');
   writeln;
   writeln('** enter the size of the window     ** ');
   writeln('** in integer form ,can not be zero **');
   repeat
      write('** size in x direction? ');
      readln(xwindsize);
      until xwindsize <> 0;
   repeat
      write('** size in y direction? ');
      readln(ywindsize);
      until ywindsize <> 0;
   init_clip_rectangle(myviewarea );
   updatewindow( windowmatrix);
   print(windowmatrix);
   end; { changewindow }

procedure movewindow;
(************************************************************
**  movewindow:                                            **
**    get the new location of the window and update the    **
**    viewing matrix                                       **
**                                                         **
*************************************************************)

   begin
   writeln;
   writeln('*********    move the window    **********');
   writeln;
   writeln('** enter the new location of the window **');
   writeln('** this is the location of the lower    ** ');
   writeln('** lefthand corner  of the window       ** ');
   writeln;
   write('** x coordinate ? ');
   readln(xwindpos);
   write('** y coordinate ? ');
   readln(ywindpos);
   updatewindow(windowmatrix);
   print(windowmatrix);
   end; { movewindow }



procedure drawline( segment : segmenttype;
                    matrix  : matrixtype   );
(************************************************************
**  drawline:                                              **
**     draw the line segment after applying the given      **
**     matrix to it. and clipping it to the viewport.      **
**     used by the draw window procedure                   **
**                                                         **
**  local variables:                                       **
**     outside : whether the line is totally outside or not**
**                                                         **
*************************************************************)

   var
     outside : boolean;
   begin
   applymatrix(segment,matrix);
   clip_line(segment,segment,myviewarea,outside);
   if not outside then
      begin
      line(trunc(segment[1,1]),trunc(segment[1,2]),
           trunc(segment[2,1]),trunc(segment[2,2]));
      end;
   end; { drawline }

procedure drawsymbol(symbol : command) ;
(************************************************************
**  drawsymbol:                                            **
**    draw the symbol which is a list of commands.         **
**    each command could be a line or polygon              **
**                                                         **
**  local variables:                                       **
**    tempmatrix : result of concatenation of trans and    **
**                 view matrices                           **
**    tempcommand : local pointer to the symbol commands   **
**     polyptr    : pointers to the polygon nodes          **
**     tempsegment: temporary line segment                 **
**                                                         **
*************************************************************)
   var
      tempmatrix : matrixtype;
      tempcommand: command;
      polyptr1,
      polyptr2   : polygontyp;
      tempsegment: segmenttype;
   begin

   hires;
   hirescolor(white);

   line(viewminx,viewminy,viewmaxx,viewminy);
   line(viewminx,viewmaxy,viewmaxx,viewmaxy);
   line(viewminx,viewminy,viewminx,viewmaxy);
   line(viewmaxx,viewminy,viewmaxx,viewmaxy);

   concatenate(transmatrix,windowmatrix,tempmatrix);
   tempcommand := symbol;
   while ( tempcommand <> nil ) do
      begin
      with tempcommand^ do
         begin
         case kind of
            lineseg : begin
                      drawline(segment , tempmatrix );
                      end;
            poly    : begin
                      polyptr1 := polygon;
                      polyptr2 := polygon^.next;
                      repeat
                         tempsegment[1] := polyptr1^.point;
                         tempsegment[2] := polyptr2^.point;
                         drawline(tempsegment , tempmatrix);
                         polyptr1 := polyptr2;
                         polyptr2 := polyptr2^.next;
                      until (polyptr1 = polygon );
                      end;
            end; { case }
         tempcommand := tempcommand^.next;
         end; { with }
      end; { while }

   gotoxy(24,1);
   writeln('press a key to continue');
   while not keypressed do;
   textmode(bw80);
   textcolor(white);
   end; { draw }




procedure menu;
(************************************************************
**   menu:                                                 **
**     give the user a menu to work with.                  **
**     has toggle print and expert mode options            **
**                                                         **
*************************************************************)

   var
     i : integer;
     expert : boolean;
     done   : boolean;
     c      : char;
   begin
   expert := false;
   done   := false;
   repeat
   if not expert then
      begin
      writeln('********  user menu options ********* ');
      writeln('** 0. quit this program ');
      writeln('** 1. translate the model');
      writeln('** 2. scale the model about a point ');
      writeln('** 3. rotate the model about a point ');
      writeln('** 4. reset the transformation matrix');
      writeln('** 5. reset the viewing and viewport ');
      writeln('** 6. change the viewport');
      writeln('** 7. change the window size');
      writeln('** 8. change window location');
      writeln('** 9. clear the screen ');
      writeln('**10. draw the model ');
      writeln('**11. set expert mode ');
      writeln('**12. toggle print mode ');
      end
   else
   begin
   writeln(' 0. quit      1. trans      2. scal      3. rotat   4. rst-trans');
   writeln(' 5. rst-view  6. chg-view   7. wnd-size  8. wnd-loc 9. clr');
   writeln('10. draw     11.novice     12. togl-prnt  ');
   end;
   repeat
     write('** your choice (0 to 12)? ');
     readln(i);
     until ((i>=0) and ( i<=12));
   case i of
      0 : begin
          write('are you sure (y/n) ? ');
          readln(c);
          if c in ['y','Y'] then
             done := true;
          end;
      1 : gettranslate(transmatrix) ;
      2 : getscale(transmatrix)     ;
      3 : getrotate(transmatrix)    ;
      4 : setidentity(transmatrix);
      5 : resetview;
      6 : changeviewport;
      7 : changewindow;
      8 : movewindow;
      9 : {clearscreen} ;
      10: drawsymbol(mysymbol) ;
      11: expert := not expert ;
      12: printmode := not printmode ;
      end; { case }
   until done ;
   end; { menu }



(************************************************************
**                  main program                           **
*************************************************************)

begin  { main }
xscreensize := 639;
yscreensize := 199;
printmode := false;
initialize;
resetview;
define_model(mysymbol);
setidentity(transmatrix);
menu;
end.   { main }
9;
printmode := false;
initializ