home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CNC11TP.ZIP / HYPRMB.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-01-20  |  3.3 KB  |  115 lines
  1. { Copyright (C) 1989 Adam Fritz, 133 Main St., Afton, N.Y. 13730 }
  2.  
  3. procedure StrokeHyperbola ( xc, yc : integer ; { center }
  4.                               a, b : word ; { radii }
  5.                                 ta : single ) ; { rotation angle (rad) }
  6.  
  7.      { HyprMB - Modified Bresenham hyperbola algorithm }
  8.  
  9. var
  10.    Color            : word ;    { default color }
  11.    px,py            : single ;  { aspect variables }
  12.    pxx,pyy          : single ;  {        "         }
  13.    ix,iy            : integer ; { display coordinates }
  14.    ixx,iyx          : integer ; { maximum display coordinates }
  15.    ie,iex,iey       : longint ; { error variables }
  16.    idex,idey        : longint ; { error offset counters }
  17.    idexx,ideyy      : longint ; { error offset increments }
  18.  
  19. begin
  20.  
  21.    if (a > 0) and (b > 0) then begin
  22.  
  23.       Color := GetColor ;
  24.                                 { initialize assuming 3/2 aspect }
  25.       px := 3 * GetMaxY ;
  26.       py := 2 * GetMaxX ;
  27.       if px > py then begin
  28.          py := py / px ;
  29.          px := 1.0
  30.       end
  31.       else begin
  32.          px := px / py ;
  33.          py := 1.0
  34.       end ;
  35.  
  36.       pxx := sqr(b*px) ;
  37.       pyy := -sqr(a*py) ;
  38.                                 { error increments }
  39.       idexx := Round(2*pxx) ;
  40.       ideyy := Round(2*pyy) ;
  41.                                 { starting point }
  42.       ix := a ;
  43.       iy := 0 ;
  44.       ie := 0 ;
  45.                                 { error offsets }
  46.       idex := Round((2*ix+1)*pxx) ;
  47.       idey := Round(pyy) ;
  48.                                 { diameter points }
  49.       PutPixel(xc+ix,yc,Color) ;
  50.       PutPixel(xc-ix,yc,Color) ;
  51.                                 { coordinate limits }
  52.       if xc > 0 then
  53.          if xc > GetMaxX + 1 then
  54.             ixx := xc
  55.          else
  56.             if xc > GetMaxX div 2 then
  57.                ixx := xc
  58.             else
  59.                ixx := GetMaxX - xc
  60.       else
  61.          ixx := abs(xc) + GetMaxX + 1 ;
  62.  
  63.       if yc > 0 then
  64.          if yc > GetMaxY + 1 then
  65.             iyx := yc
  66.          else
  67.             if yc > GetMaxY div 2 then
  68.                iyx := yc
  69.             else
  70.                iyx := GetMaxY - yc
  71.       else
  72.          iyx := abs(yc) + GetMaxY + 1 ;
  73.                                 { octant points - 1,4,5,8 }
  74.       while (-idey < idex) and (ix < ixx) and (iy < iyx) do begin
  75.  
  76.          Inc(ie,idey) ;
  77.          Inc(idey,ideyy) ;
  78.          Inc(iy) ;
  79.          iex := ie + idex ;
  80.          if abs(ie) >= abs(iex) then begin
  81.             ie := iex ;
  82.             Inc(idex,idexx) ;
  83.             Inc(ix)
  84.          end ;
  85.  
  86.          PutPixel(xc+ix,yc+iy,Color) ;
  87.          PutPixel(xc+ix,yc-iy,Color) ;
  88.          PutPixel(xc-ix,yc+iy,Color) ;
  89.          PutPixel(xc-ix,yc-iy,Color)
  90.  
  91.       end ;
  92.                                { octant points - 2,3,6,7 }
  93.       while (ix < ixx) and (iy < iyx) do begin
  94.  
  95.          Inc(ie,idex) ;
  96.          Inc(idex,idexx) ;
  97.          Inc(ix) ;
  98.          iey := ie + idey ;
  99.          if abs(ie) >= abs(iey) then begin
  100.             ie := iey ;
  101.             Inc(idey,ideyy) ;
  102.             Inc(iy)
  103.          end ;
  104.  
  105.          PutPixel(xc+ix,yc+iy,Color) ;
  106.          PutPixel(xc+ix,yc-iy,Color) ;
  107.          PutPixel(xc-ix,yc+iy,Color) ;
  108.          PutPixel(xc-ix,yc-iy,Color)
  109.  
  110.       end
  111.    end
  112. end ;
  113.  
  114. { Copyright (C) 1989 Adam Fritz, 133 Main St., Afton, N.Y. 13730 }
  115.