Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/3DGRAPH.ZIP/3DGRAPH.PAS

Pascal/Delphi Source File | 1985-08-21 | 26.0 KB | 706 lines

(*************************************************************
**                                                          **
**                 ICS 4390 Project                         **
**                      part 2                              **
**                   written by:                            **
**                 Fereydon Shenassa                        **
**                 Fall Quarter 1984                        **
**                                                          **
**  this program is a monitor which allows the use and test **
**  of a 2d graphics package on a predefine object.         **
**  the object is defined as a triangle with vertices at    **
**  (-1,-1),(1,-1),(0,5) in world coordinates with a line   **
**  in the middle (0,-1)-(0,5).                             **
**                                                          **
**  the operations defined are:                             **
**    1)rotation,translation,scaling                        **
**    2)window and viewport operations                      **
**                                                          **
**  the program makes use of 3 procedures in the lida       **
**  package:                                                **
**    1) openwk : initialize the workstation                **
**    2) clearscreen                                        **
**    3) line(x1,y1,x2,y2)                                  **
**                                                          **
**  the program is device independent.                      **
*************************************************************)










program monitor(input,output);
(*************************************************************
**  constants:                                              **
**      userdimension- the number of dimensions the user    **
**                     works with. 2 for this program.      **
**      dimension    - userdimension + 1.                   **
**      numhplanes   - number of hyperplanes in the viewport**
**                     used in clipping                     **
**                                                          **
*************************************************************)

const
   userdimension = 2;
   dimension     = 3;
   num_hplanes   = 4;


(*************************************************************
**  types:                                                  **
**   elementtype : type of each entry in vectors and matrix **
**   columntype  : one column of elements                   **
**   matrixtype  : a matrix with 1 dimension higher than    **
**                 the user dimension                       **
**   pointype,vectortype : same as columntype, renamed for  **
**                         clarity                          **
**   viewareatype: array of halfspaces for clipping         **
**   polygontyp  : polygon represented as circular          **
**                 linked list                              **
**   command     : a linked list representation of commands **
**                 which could be lines or polygons         **
**                                                          **
*************************************************************)


type
  (*  types needed by the user to access package utilities *)

  devicechoice = (hp9845,iklores,ikhires, ps300,tek4115,tek4107);
  inpnames     = (lightpen, digitizer, tablet);
  inpclass     = (locator, pick, choice, valuator, strings, stroke);
  outnames     = (plotter);
  polygontype  = (hollow, solid);
  pointcoords = record
                x, y : integer
                end;
  symbolid = array[1..6] of char;
  textstring  = array[1..80] of char;
  ptpairarray = array[1..50] of pointcoords;
  polytype    = array[0..49, 1..3] of integer;  (* for solid polygons *)
  orientationrange = -180..180;   (* angle of the text *)
  anglerange  = -89..89;          (* angle of each character in the text *)


  colorrec   =    record
                hpred, hpgreen, hpblue : real
                end;

  (* types needed for the clipping operation *)

  realptcoords = record
                  x, y : real;
                  end;

  bezierarray = array[1..4] of realptcoords;

  lines = record
          a, b, c : integer;  (* equation ax + by = c is used *)
          orgdir : boolean;   (* true implies that the origin is outside *)
          end;

  (* types needed by the package to process symbols  *)
  commandptr   = ^commandentry;
  commandentry = record
                next : commandptr;
                case tag: char of
                 'a' : (polnum : integer;
                        polptarr : ptpairarray);

                 'b' : (linnum : integer;
                        linptarr : ptpairarray);

                 'c' : ();

                 'd' : (xs, ys, xd, yd : integer);     (* line *)

                 'e' : (setindex : integer; sred, sgreen, sblue : real);

                 'g' : (xt, yt, lgth : integer;
                        strings : textstring);

                 'h' : (bezierpts : bezierarray);

                 'i' : (isymname : symbolid;
                        i11, i12, i21, i22, i31, i32 : real);

                 'j' : (orientation : orientationrange);

                 'k' : (csize: integer; htwdthratio: real; tilt: anglerange);

                 'l' : (lstyle, lindex : integer );

                 'p' : (pfill : polygontype; pindex : integer);

                end;

  symbolptr = ^symbolrec;
  symbolrec = record
                name : array[1..6] of char;
                start : commandptr;
                next : symbolptr
               end;

  segtransform = array [1..3,1..2] of real;

  visibility = (visible,invisible);

  highlighting = (normal,highlighted);

  detectability = (detectable,undetectable);

   elementtype   = real;
   columntype    = array[1..dimension] of elementtype;
   matrixtype    = array[1..dimension] of columntype;
   pointtype     = columntype;
   vectortype    = columntype;
   segmenttype   = array[1..2] of pointtype;

   viewareatype  = array[1..num_hplanes] of lines;
   polygontyp    = ^polygonelement;
   polygonelement= record
                   point: pointtype;
                   next : polygontyp;
                   end; { polygon element }


   kindtype     = ( lineseg,poly);
   command      = ^commandnode;
   commandnode  = record
                  next : command;
                  case kind  : kindtype of
                     lineseg : ( segment : segmenttype);
                     poly    : ( polygon : polygontyp );
                  end; { record }

(*************************************************************
**  variables:                                              **
**    mysymbol - predefined symbol used for testing the     **
**               routines. a triangle with a line in middle **
**    myviewarea-array of halfspaces defining the viewport  **
**    transmatrix-global transformation matrix              **
**    vindowmatrix-global viewing transformtion matrix      **
**    x,ywindpos-location of left hand corner of window     **
**    printmode - toggle for print routines on /off         **
**                                                          **
**    x,yscreensize-resolution of device in x and y direct  **
**    viewminx,maxx-location of viewport in physical coord  **
**    x,yscreensize-size of window in x and y directions    **
**                                                          **
*************************************************************)


var
  (* global variables needed by the package  *)
  rs : char;    (* control character to indicate graphics command for HP Emul *)
  station : devicechoice;
  fill : boolean;
  hpout : file of char;
  psratio : real;
  hpratio : real;      (* actually a constant of 4.55 *)
  setfill : boolean;
  esc,us : char; (*special chars for command initiation and termination
                   on tek4115 and tek4107 *)
  polyfillcolor : integer;   (* index location of fill color *)
  lowres : boolean;
  warnswitch : boolean;

  hptable : array[0..7] of colorrec;
  hplinestyletab : array[0..9] of integer;
(* variables needed to handle the window to viewport mapping *)
  mapmode : boolean;
  maphold : boolean;
  maxscreensize : integer;
  xscreensize, yscreensize : integer;
  xwindsize, ywindsize : integer;
  viewminx, viewmaxx : integer;
  viewminy, viewmaxy : integer;
  m11, m12, m21, m22, m31, m32 : real;   (* for the mapping transform *)
  charsize : integer;
  aspect : real;

  viewarea : array[1..4] of lines;       (* for the clipping operation *)
  intersectcoords : pointcoords;

  z11, z12, z21, z22, z31, z32 : real;
  recursecount : integer;

(* variables needed to handle the symbol mechanism *)
  namecount : integer;   (* global count of number of names used for PS 300 *)
  psname    : symbolid;
  defmode : boolean;  (* boolean for definition mode command *)
  symstart : symbolptr;
  thiscommand : commandptr;
  nextcommand : commandptr;
  lastcommand : commandptr;

   mysymbol      : command;
   myviewarea    : viewareatype;
   transmatrix ,
   windowmatrix  : matrixtype;
   xwindpos,
   ywindpos      : integer;
   printmode     : boolean;




(************************************************************
**             initialization procedures                   **
*************************************************************)

procedure initialize ;
(*************************************************************
**   initialize :                                           **
**      open the work station as a tektronix 4107           **
**      and clear the screen.                               **
**      it sets up the xscreensize and yscreensize          **
**                                                          **
*************************************************************)

   begin { initialize}
{   open_wk(tek4107);
   clear_screen;}
   end; {initialize}

procedure line(x1,y1,x2,y2 : integer );
   begin
   draw(x1,yscreensize-y1,x2,yscreensize-y2,white);
   end; (* line *)


procedure setidentity(  var matrix : matrixtype);
(*************************************************************
**  setidentity:                                            **
**    reset the given matrix to the identity matrix         **
**    with 1's in the diagonal and 0's elsewhere            **
**                                                          **
**  local variables:                                        **
**    i,j : counters                                        **
**                                                          **
*************************************************************)
   var
     i,j : integer;

   begin { setidentity }
   for i:= 1 to dimension do
      begin
      for j := 1 to dimension do
         matrix[i,j] := 0;
      matrix[i,i] := 1;
      end;
   end; { setidentity }



procedure define_model(var mysymbol     : command );
(*************************************************************
**  define_model:                                           **
**    define the triangle used in the drawing routines      **
**    using a polygon and a line.                           **
**                                                          **
**  local variables:                                        **
**    element,element2 : pointers to polygon nodes          **
**    command2         : pointer to the line node           **
**                                                          **
*************************************************************)

   var
     element : polygontyp;
     element2: polygontyp;
     command2: command;
   begin
   new(mysymbol);
   mysymbol^.next := nil;
   mysymbol^.kind := poly;
   with mysymbol^  do
      begin
      new(polygon);
      new(element);
      with polygon^ do
         begin { with polygon }
         point[1] := -3;
         point[2] := -3;
         point[3] := 1;
         next := element;
         end; { with polygon }
      element^.point[1]:= 3;
      element^.point[2]:= -3 ;
      element^.point[3] := 1;
      new(element2);
      element^.next := element2;
      element2^.next := polygon;
      element2^.point[1] := 0;
      element2^.point[2] := 3;
      element2^.point[3] := 1;
      end; { with }
   new(command2);
   command2^.next := nil;
   command2^.kind := lineseg;
   command2^.segment[1,1] := 0;
   command2^.segment[1,2] := -3;
   command2^.segment[2,1] := 0;
   command2^.segment[2,2] := 3;
   mysymbol^.next := command2;
   end;   {define_symbol }

(************************************************************
**                 read and print routines                 **
*************************************************************)

procedure print(matrix : matrixtype);
(*************************************************************
**   print:                                                 **
**     utility to print a square matrix of size dimension   **
**     checks the printmode toggle first. if its false      **
**     it doesn't print anything                            **
**                                                          **
**   local variables:                                       **
**     i,j : counters                                       **
**                                                          **
*************************************************************)

   var
      i , j : integer;
   begin
   if printmode then
   begin
   writeln;
   write(' ':2);
   for i:= 1 to dimension do
      write('*******');
   writeln('*');
   for i := 1 to dimension do
      begin
      write('*':3);
      for j := 1 to dimension do
         write(matrix[i,j]:6:2);
      writeln('*':3);
      end; { i }
   write(' ':2);
   for i:= 1 to dimension do
      write('*******');
   writeln('*');
   writeln;
   end;
   end; { print }

procedure  readvector(var  vector : vectortype );
(*************************************************************
**  readvector:                                             **
**    read from the input elements of a vector of size      **
**    userdimension.                                        **
**                                                          **
*************************************************************)

   var
     i : integer;

   begin  { readvector }
   for i := 1 to userdimension do
      begin
      write(i:1,'''th  element ? ');
      readln(vector[i]);
      vector[dimension] := 1;
      end;
   end; { readvector }


(************************************************************
**                 clipping algorithm                      **
*************************************************************)


procedure clip_line(    line     : segmenttype ;
                    var result   : segmenttype;
                        viewarea : viewareatype;
                    var outside  : boolean );
(*************************************************************
**  clip_line :                                             **
**     clip the given line segment to the viewarea given.   **
**     and return the result. set outside to true if the    **
**     line is completely outside the viewarea.             **
**                                                          **
**  local variables:                                        **
**     i    : counter                                       **
**     done : flag to tell end of clipping                  **
**     outcode: array of boolean used to keep the           **
**              location of each point with respect to      **
**              the viewarea array.                         **
**                                                          **
**   local procedures:                                      **
**     computelocation:return true if point is outside      **
**                      the given halfspace                 **
**     computeintersection: compute the intersection of a   **
**                     point and a halfspace                **
**                                                          **
*************************************************************)

   var
      i        : integer;
      done     : boolean;
      outcode  : array[1..num_hplanes,1..3] of boolean;

   function compute_location(point : pointtype ; line : lines): boolean;
   (************************************************************
   ** compute_location:                                       **
   **    compute the location of the given point with         **
   **    respect to the given line. return true if the        **
   **    point is outside. false otherwise.                   **
   **                                                         **
   ** local variables:                                        **
   **    result : temporary storage of the result of puting   **
   **             the given point in the equation of the line **
   **                                                         **
   *************************************************************)

      var
        result : real;

      begin  { compute_location }
      with line do
        begin
        result := a * point[1] + b * point[2] ;
         compute_location := not(  ( ( result < c ) and (not orgdir ) )
                                 or( ( result > c ) and (    orgdir ) )
                                 or(   result = c )
                                   );
        end;
      end; { compute_location }

   procedure compute_intersection(var segment      : segmenttype ;
                                      line         : lines ;
                                      outsidepoint : integer );
   (************************************************************
   **  compute_intersection:                                  **
   **     compute the intersection of the segment with the    **
   **     given line. replace the result in the outside       **
   **     endpoint. use the equation                          **
   **        y = y1 + slope *(x-x1)                           **
   **        x = x1 + 1/slope * (y-y1)                        **
   **                                                         **
   **  local variables:                                       **
   **    tempx,tempy : temporary intersection points          **
   **                                                         **
   *************************************************************)

      var
         tempx , tempy   : real;

      begin  { compute_intersection }
      with line do
      if (line.a = 0 ) then
         begin
         if (segment[2,2] - segment[1,2]) <> 0 then
         begin
         tempx := segment[1,1] + (segment[2,1] - segment[1,1])
                               * (line.c - segment[1,2]      )
                              / ( segment[2,2] - segment[1,2]);
         tempy := line.c;
         end
         else
           begin
         tempx := segment[1,1];
         tempy := line.c;
           end;
         end
      else
         begin
         if (segment[2,1] - segment[1,1]) <> 0 then
         begin
         tempy := segment[1,2] + (segment[2,2] - segment[1,2])
                               * (line.c - segment[1,1]      )
                             / ( segment[2,1] - segment[1,1]);
         tempx := line.c;
         end
         else
            begin
         tempy := segment[1,2] ;
         tempx := line.c;
            end
         end;
      segment[outsidepoint,1] := trunc(tempx);
      segment[outsidepoint,2] := trunc(tempy);

     end; { compute_intersection }

   (************************************************************
   **            body of clip line starts here                **
   *************************************************************)

   begin { body of clip_line }
   done    := false;
   i       := 1;
   outside := false;
   result  := line;
   while (not done ) and ( i <= num_hplanes) do
      begin
      outcode[i,1] := compute_location(line[1],viewarea[i]);
      outcode[i,2] := compute_location(line[2],viewarea[i]);

      if outcode[i,1] and outcode[i,2] then
          begin
          outside := true;
          done    := true;
          end
      else
          outcode[i,3] := (not outcode[i,1]) and (not outcode[i,2]);
          { if both points are inside, skip that hplane, later }
      i := i + 1;
      end; { while }

   if ( not done ) then
      begin
      i := 1;
      while (i <=num_hplanes ) and (not done)  do
         begin
         if (not outcode[i,3]) then
            begin
            outcode[i,1] := compute_location(result[1],viewarea[i]);
            outcode[i,2] := compute_location(result[2],viewarea[i]);

            if (outcode[i,1] and outcode[i,2] ) then
               begin
               done    := true;
               outside := true;
               end
            else
               begin
               if outcode[i,1] or outcode[i,2] then
                  if ( outcode[i,1] ) then
                     compute_intersection(result,viewarea[i],1)
                  else
                     compute_intersection(result,viewarea[i],2);
               end;
            end;
         i := i + 1;
         end; { while not done }
      end; { if not done }
   end; { clip_line }

(************************************************************
**             matrix operation routines                   **
*************************************************************)



procedure  concatenate(leftmatrix,rightmatrix : matrixtype;
                             var   resultmatrix: matrixtype);
(************************************************************
**   concatenate:                                          **
**     multiply the left and right matrices and put the    **
**     result in resultmatrix.                             **
**                                                         **
**   local variables:                                      **
**     i,j,k : counters                                    **
**     temp  : temporary storage area for sum of a column  **
**                                                         **
*************************************************************)


  var
     i,j,k : integer;
     temp  : elementtype;

  begin { concatenate }
  for i := 1 to dimension do
     begin
     for j := 1 to dimension do
        begin
        temp := 0;
        for k  := 1 to dimension do
           temp := temp + leftmatrix[i,k] * rightmatrix[k,j] ;
        resultmatrix[i,j] := temp ;
        end;
     end;
  end; { concatenate }

procedure applymatrix(var segment : segmenttype;
                          matrix  : matrixtype );
(************************************************************
**  applymatrix:                                           **
**    multiply the segment vector by the matrix and return **
**    the result in the segment.                           **
**                                                         **
**  local variables:                                       **
**    i : counter                                          **
**    tempseg: temporary result of multiplication.         **
**                                                         **
*************************************************************)

   var
      i         : integer;
      tempseg   : segmenttype;

   begin { applymatrix }
   for i := 1 to 2 do
      begin
      tempseg[i,1] := segment[i,1] * matrix[1,1]+
                      segment[i,2] * matrix[2,1]+
                                   + matrix[3,1];
      tempseg[i,2] := segment[i,1] * matrix[1,2]+
                      segment[i,2] * matrix[2,2]+
                                   + matrix[3,2];
      tempseg[i,3] := 1;
      end; { for }
   segment := tempseg;
   end; {applymatrix }



(************************************************************
**             transformation routines                     **
*************************************************************)


procedure translate(var inputmatrix :matrixtype;
                         transvector : vectortype );
(************************************************************
**  translate:                                             **
**     add a translation by a translation vector to the    **
**     inputmatrix.                                        **
**                                                         **
**  local variables:                                       **
**     i : counters                                        **
**                                                         **
*************************************************************)

   var
     i  : integer;
   begin  { translate}
   for i := 1 to userdimension do
      inputmatrix[dimension,i] := inputmatrix[dimension,i]
                                 +transvector[i];
   end; { translate }


procedure scale(var inputmatrix  : matrixtype ;
                    scalevector  : vectortype );
(************************************************************
**  scale:                                                 **
**    concatenate a scaling matrix of value scalevector    **
**    to the input matrix.  the procedure is optimized     **
**                                                         **
**  local variables:                                       **
**    i,j : counters                                       **
**                                                         **
*************************************************************)

   var
   i , j : integer;
   begin  { scale }
   for i := 1 to userdimension do
      for j := 1 to dimension do
         inputmatrix[j,i]  := inputmatrix[j,i] * scalevector[i] ;
   end; { scale }
{$i graph2.pas }
 := 1 to dimension do
         inputmatrix[j,i]  := inputmatrix[j,i] * scalevector