development/compilers/freepascal/rtl/inc/graph/clip.inc

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by the Free Pascal development team
   5
   6     This include implements the different clipping algorithms
   7
   8     See the file COPYING.FPC, included in this distribution,
   9     for details about the copyright.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15  **********************************************************************}
  16 const
  17   LEFT   = 1;    { Left window   }
  18   RIGHT  = 2;    { Right window  }
  19   BOTTOM = 4;    { Bottom window }
  20   TOP    = 8;    { Top window    }
  21                  { 0 = in window }
  22
  23
  24
  25
  26
  27
  28
  29   function LineClipped(var x1, y1,x2,y2: smallint; xmin, ymin,
  30       xmax, ymax:smallint): boolean;
  31   {********************************************************}
  32   { Function LineClipped()                                 }
  33   {--------------------------------------------------------}
  34   { This routine clips the line coordinates to the         }
  35   { min. and max. values of the window. Returns TRUE if    }
  36   { the ENTIRE line was clipped.  Updated                  }
  37   { clipped line endpoints are also returned.              }
  38   { This algorithm is the classic Cohen-Sutherland line    }
  39   { clipping algorithm.                                    }
  40   {--------------------------------------------------------}
  41   var
  42    code1, code2: longint;
  43    done:boolean;
  44    code: longint;
  45    newx,newy: word;
  46
  47
  48     function outcode(x,y:smallint): longint;
  49     {********************************************************}
  50     { Function OutCode()                                     }
  51     {--------------------------------------------------------}
  52     { This routine determines if the specified end point     }
  53     { of a line lies within the visible window, if not it    }
  54     { determines in which window the point is.               }
  55     {--------------------------------------------------------}
  56
  57     var
  58      code: longint;
  59     begin
  60       code := 0;
  61       if (x<xmin) then
  62         code:=code or LEFT
  63       else if (x>xmax) then
  64         code:=code or RIGHT;
  65       if (y>ymax) then
  66         code:=code or BOTTOM
  67       else if (y<ymin) then
  68         code:=code or TOP;
  69
  70       outcode:=code;
  71     end;
  72
  73   begin
  74     done:=false;
  75     code1:= OutCode(x1,y1);
  76     code2:= OutCode(x2,y2);
  77
  78     while not done do
  79      begin
  80        { Accept trivially }
  81        { both points are in window }
  82        if ((code1=0) and (code2=0)) then
  83          begin
  84            done:=TRUE;
  85            LineClipped:=FALSE;
  86                exit;
  87              end
  88        else
  89        { Reject trivially }
  90        { Neither points are in window }
  91        if (code1 and code2) <> 0 then
  92          begin
  93            done:=true;
  94            LineClipped:=TRUE;
  95            exit;
  96          end
  97        else
  98           begin
  99             { Some points are partially out of the window }
 100             { find the new end point of the lines...      }
 101             if code1 = 0 then
 102              code:=code2
 103             else
 104              code:=code1;
 105             if (code and LEFT) <> 0 then
 106               begin
 107                 newy:=y1+((y2-y1)*(xmin-x1)) div (x2-x1);
 108                 newx:=xmin;
 109               end
 110             else
 111             if (code and RIGHT) <> 0 then
 112               begin
 113                 newy:=y1+((y2-y1)*(xmax-x1)) div (x2-x1);
 114                 newx:=xmax;
 115               end
 116             else
 117             if (code and BOTTOM) <> 0 then
 118               begin
 119                 newx:=x1+((x2-x1)*(ymax-y1)) div (y2-y1);
 120                 newy:=ymax;
 121               end
 122             else
 123             if (code and TOP) <> 0 then
 124               begin
 125                 newx:=x1+((x2-x1)*(ymin-y1)) div (y2-y1);
 126                 newy:=ymin;
 127               end;
 128            if (code1 = code) then
 129             begin
 130               x1 := newx;  y1:= newy;
 131               code1:=outcode(x1,y1)
 132             end
 133                else
 134             begin
 135               x2:= newx; y2:= newy;
 136               code2:=outcode(x2,y2);
 137             end
 138          end;
 139       end;
 140   LineClipped:=FALSE;
 141 end;
 142
 143 {
 144 $Log$
 145 Revision 1.1  2002/02/19 08:25:31  sasu
 146 Initial revision
 147
 148 Revision 1.1  2000/07/13 06:30:50  michael
 149 + Initial import
 150
 151 Revision 1.9  2000/01/07 16:41:37  daniel
 152   * copyright 2000
 153
 154 Revision 1.8  2000/01/07 16:32:25  daniel
 155   * copyright 2000 added
 156
 157 Revision 1.7  1999/12/20 11:22:35  peter
 158   * integer -> smallint to overcome -S2 switch needed for ggi version
 159
 160 Revision 1.6  1999/09/27 12:35:27  jonas
 161   * execute multiplications before divisions in lineclipped to avoid rounding errors
 162
 163 Revision 1.5  1999/09/18 22:21:09  jonas
 164   + hlinevesa256 and vlinevesa256
 165   + support for not/xor/or/andput in vesamodes with 32k/64k colors
 166   * lots of changes to avoid warnings under FPC
 167
 168 Revision 1.4  1999/09/12 17:28:59  jonas
 169   * several changes to internalellipse to make it faster
 170     and to make sure it updates the ArcCall correctly
 171     (not yet done for width = 3)
 172   * Arc mostly works now, only sometimes an endless loop, don't know
 173     why
 174
 175 Revision 1.3  1999/07/12 13:27:09  jonas
 176   + added Log and Id tags
 177   * added first FPC support, only VGA works to some extend for now
 178   * use -dasmgraph to use assembler routines, otherwise Pascal
 179     equivalents are used
 180   * use -dsupportVESA to support VESA (crashes under FPC for now)
 181   * only dispose vesainfo at closegrph if a vesa card was detected
 182   * changed int32 to longint (int32 is not declared under FPC)
 183   * changed the declaration of almost every procedure in graph.inc to
 184     "far;" becquse otherwise you can't assign them to procvars under TP
 185     real mode (but unexplainable "data segnment too large" errors prevent
 186     it from working under real mode anyway)
 187
 188 }