home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CNC11TP.ZIP / PARAMBR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-01-20  |  19.1 KB  |  633 lines
  1. { Copyright (C) 1989 Adam Fritz, 133 Main St., Afton, N.Y. 13730 }
  2.  
  3. procedure StrokeParabola ( xf, yf : integer ; { focus }
  4.                                 p : word ; { parameter }
  5.                                ta : single ) ; { rotation angle (rad) }
  6.  
  7.      { ParaMBR - draw parabola using modified Bresenham with }
  8.      {           rotation and aspect correction              }
  9.  
  10. const
  11.    s = 16.0 ;
  12.  
  13. var
  14.    Color            : word ;    { default color }
  15.    costa,costa2     : single ;  { rotation angle functions }
  16.    sinta,sinta2     : single ;  {            "             }
  17.    px,py            : single ;  { aspect variables }
  18.    pxx,pxy,pyy      : single ;  {         "        }
  19.    x0,y0            : single ;  { extremum point, float }
  20.    ix0,iy0          : integer ; {        "      , fixed }
  21.    ix,iy            : integer ; { coordinate variables }
  22.    ixx,iyx          : integer ; { coordinate limits }
  23.    ie,iex,iey       : longint ; { error variables }
  24.    idex,idey        : longint ; { error offsets }
  25.    idex0,idey0      : longint ; {       "      , initial }
  26.    idexx,idexy      : longint ; { error increments }
  27.    ideyx,ideyy      : longint ; {        "         }
  28.  
  29. begin
  30.                                 { ignore rectilinear parabola }
  31.    if p > 0 then begin
  32.  
  33.       Color := GetColor ;
  34.                                 { scaling parameters }
  35.       px := 3 * GetMaxY ;
  36.       py := 2 * GetMaxX ;
  37.       if px > py then begin
  38.          py := s * py / px ;
  39.          px := s
  40.       end
  41.       else begin
  42.          px := s * px / py ;
  43.          py := s
  44.       end ;
  45.                                 { rotation angle functions }
  46.       costa := cos(ta) ;
  47.       costa2 := sqr(costa) ;
  48.       sinta := sin(ta) ;
  49.       sinta2 := sqr(sinta) ;
  50.  
  51.       pxx := sqr(px)*sinta2 ;
  52.       pxy := px*py*sinta*costa ;
  53.       pyy := sqr(py)*costa2 ;
  54.                                 { error increments }
  55.       idexx := Round(2.0*pxx) ;
  56.       idexy := Round(2.0*pxy) ;
  57.       ideyx := idexy ;
  58.       ideyy := Round(2.0*pyy) ;
  59.                                 { coordinate limits }
  60.       if xf > 0 then
  61.          if xf > GetMaxX + 1 then
  62.             ixx := xf
  63.          else
  64.             if xf > GetMaxX div 2 then
  65.                ixx := xf
  66.             else
  67.                ixx := GetMaxX - xf
  68.       else
  69.          ixx := abs(xf) + GetMaxX + 1 ;
  70.  
  71.       if yf > 0 then
  72.          if yf > GetMaxY + 1 then
  73.             iyx := yf
  74.          else
  75.             if yf > GetMaxY div 2 then
  76.                iyx := yf
  77.             else
  78.                iyx := GetMaxY - yf
  79.       else
  80.          iyx := abs(yf) + GetMaxY + 1 ;
  81.                                 { step in y }
  82.       if abs(costa) > abs(sinta) then begin
  83.                                 { extremum point }
  84.          x0 := p/2/costa ;
  85.          y0 := -p/2/py*px*sinta/costa2 ;
  86.          ix0 := Round(x0) ;
  87.          iy0 := Round(y0) ;
  88.          idex0 := Round((2*x0+1)*pxx - 2*y0*pxy + 2*p*sqr(px)*costa) ;
  89.          idey0 := Round((2*y0+1)*pyy - 2*x0*pxy + 2*p*py*px*sinta) ;
  90.                                 { starting point }
  91.          ix := ix0 ;
  92.          iy := iy0 ;
  93.          ie := 0 ;
  94.                                 { extremum point }
  95.          PutPixel(xf+ix,yf-iy,Color) ;
  96.                                 { open leftwards }
  97.          if costa >= 0.0 then begin
  98.  
  99.             idex := -idex0 + idexx ;
  100.             idey := idey0 ;
  101.                                 { extremum to dx = dy }
  102.             while (-idex > idey) and
  103.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  104.  
  105.                Inc(ie,idey) ;
  106.                Inc(idey,ideyy) ;
  107.                Inc(iy) ;
  108.                Inc(idex,idexy) ;
  109.                iex := ie + idex ;
  110.                if abs(ie) > abs(iex) then begin
  111.                   Inc(idex,idexx) ;
  112.                   Dec(ix) ;
  113.                   Inc(idey,ideyx) ;
  114.                   ie := iex
  115.                end ;
  116.  
  117.                PutPixel(xf+ix,yf-iy,Color)
  118.  
  119.             end ;
  120.                                 { dx = dy to dy = 0 }
  121.             while (-idex > 0) and
  122.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  123.  
  124.                Inc(ie,idex) ;
  125.                Inc(idex,idexx) ;
  126.                Dec(ix) ;
  127.                Inc(idey,ideyx) ;
  128.                iey := ie + idey ;
  129.                if abs(ie) > abs(iey) then begin
  130.                   Inc(idey,ideyy) ;
  131.                   Inc(iy) ;
  132.                   Inc(idex,idexy) ;
  133.                   ie := iey
  134.                end ;
  135.  
  136.                PutPixel(xf+ix,yf-iy,Color)
  137.  
  138.             end ;
  139.  
  140.             idey := -idey + ideyy ;
  141.                                 { dy = 0 to asymptote }
  142.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  143.  
  144.                Inc(ie,idex) ;
  145.                Inc(idex,idexx) ;
  146.                Dec(ix) ;
  147.                Dec(idey,ideyx) ;
  148.                iey := ie + idey ;
  149.                if abs(ie) > abs(iey) then begin
  150.                   Inc(idey,ideyy) ;
  151.                   Dec(iy) ;
  152.                   Dec(idex,idexy) ;
  153.                   ie := iey
  154.                end ;
  155.  
  156.                PutPixel(xf+ix,yf-iy,Color)
  157.  
  158.             end ;
  159.                                 { reinitialize }
  160.             ix := ix0 ;
  161.             iy := iy0 ;
  162.             ie := 0 ;
  163.  
  164.             idex := -idex0 + idexx ;
  165.             idey := -idey0 + ideyy ;
  166.                                 { extremum to dx = dy }
  167.             while (-idex > idey) and
  168.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  169.  
  170.                Inc(ie,idey) ;
  171.                Inc(idey,ideyy) ;
  172.                Dec(iy) ;
  173.                Dec(idex,idexy) ;
  174.                iex := ie + idex ;
  175.                if abs(ie) > abs(iex) then begin
  176.                   Inc(idex,idexx) ;
  177.                   Dec(ix) ;
  178.                   Dec(idey,ideyx) ;
  179.                   ie := iex
  180.                end ;
  181.  
  182.                PutPixel(xf+ix,yf-iy,Color)
  183.  
  184.             end ;
  185.                                 { dx = dy to dy = 0 }
  186.             while (-idex > 0) and
  187.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  188.  
  189.                Inc(ie,idex) ;
  190.                Inc(idex,idexx) ;
  191.                Dec(ix) ;
  192.                Dec(idey,ideyx) ;
  193.                iey := ie + idey ;
  194.                if abs(ie) > abs(iey) then begin
  195.                   Inc(idey,ideyy) ;
  196.                   Dec(iy) ;
  197.                   Dec(idex,idexy) ;
  198.                   ie := iey
  199.                end ;
  200.  
  201.                PutPixel(xf+ix,yf-iy,Color)
  202.  
  203.             end ;
  204.  
  205.             idey := -idey + ideyy ;
  206.                                 { dy = 0 to asymptote }
  207.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  208.  
  209.                Inc(ie,idex) ;
  210.                Inc(idex,idexx) ;
  211.                Dec(ix) ;
  212.                Inc(idey,ideyx) ;
  213.                iey := ie + idey ;
  214.                if abs(ie) > abs(iey) then begin
  215.                   Inc(idey,ideyy) ;
  216.                   Inc(iy) ;
  217.                   Inc(idex,idexy) ;
  218.                   ie := iey
  219.                end ;
  220.  
  221.                PutPixel(xf+ix,yf-iy,Color)
  222.  
  223.             end
  224.          end
  225.                                 { open rightwards }
  226.          else begin
  227.  
  228.             idex := idex0 ;
  229.             idey := idey0 ;
  230.                                 { extremum to dx = dy }
  231.             while (-idex > idey) and
  232.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  233.  
  234.                Inc(ie,idey) ;
  235.                Inc(idey,ideyy) ;
  236.                Inc(iy) ;
  237.                Dec(idex,idexy) ;
  238.                iex := ie + idex ;
  239.                if abs(ie) > abs(iex) then begin
  240.                   Inc(idex,idexx) ;
  241.                   Inc(ix) ;
  242.                   Dec(idey,ideyx) ;
  243.                   ie := iex
  244.                end ;
  245.  
  246.                PutPixel(xf+ix,yf-iy,Color)
  247.  
  248.             end ;
  249.                                 { dx = dy to dy = 0 }
  250.             while (-idex > 0) and
  251.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  252.  
  253.                Inc(ie,idex) ;
  254.                Inc(idex,idexx) ;
  255.                Inc(ix) ;
  256.                Dec(idey,ideyx) ;
  257.                iey := ie + idey ;
  258.                if abs(ie) > abs(iey) then begin
  259.                   Inc(idey,ideyy) ;
  260.                   Inc(iy) ;
  261.                   Dec(idex,idexy) ;
  262.                   ie := iey
  263.                end ;
  264.  
  265.                PutPixel(xf+ix,yf-iy,Color)
  266.  
  267.             end ;
  268.  
  269.             idey := -idey + ideyy ;
  270.                                 { dy = 0 to asymptote }
  271.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  272.  
  273.                Inc(ie,idex) ;
  274.                Inc(idex,idexx) ;
  275.                Inc(ix) ;
  276.                Inc(idey,ideyx) ;
  277.                iey := ie + idey ;
  278.                if abs(ie) > abs(iey) then begin
  279.                   Inc(idey,ideyy) ;
  280.                   Dec(iy) ;
  281.                   Inc(idex,idexy) ;
  282.                   ie := iey
  283.                end ;
  284.  
  285.                PutPixel(xf+ix,yf-iy,Color)
  286.  
  287.             end ;
  288.                                 { reinitialize }
  289.             ix := ix0 ;
  290.             iy := iy0 ;
  291.             ie := 0 ;
  292.  
  293.             idex := idex0 ;
  294.             idey := -idey0 + ideyy ;
  295.                                 { extremum to dx = dy }
  296.             while (-idex > idey) and
  297.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  298.  
  299.                Inc(ie,idey) ;
  300.                Inc(idey,ideyy) ;
  301.                Dec(iy) ;
  302.                Inc(idex,idexy) ;
  303.                iex := ie + idex ;
  304.                if abs(ie) > abs(iex) then begin
  305.                   Inc(idex,idexx) ;
  306.                   Inc(ix) ;
  307.                   Inc(idey,ideyx) ;
  308.                   ie := iex
  309.                end ;
  310.  
  311.                PutPixel(xf+ix,yf-iy,Color)
  312.  
  313.             end ;
  314.                                 { dx = dy to dy = 0 }
  315.             while (-idex > 0) and
  316.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  317.  
  318.                Inc(ie,idex) ;
  319.                Inc(idex,idexx) ;
  320.                Inc(ix) ;
  321.                Inc(idey,ideyx) ;
  322.                iey := ie + idey ;
  323.                if abs(ie) > abs(iey) then begin
  324.                   Inc(idey,ideyy) ;
  325.                   Dec(iy) ;
  326.                   Inc(idex,idexy) ;
  327.                   ie := iey
  328.                end ;
  329.  
  330.                PutPixel(xf+ix,yf-iy,Color)
  331.  
  332.             end ;
  333.  
  334.             idey := -idey + ideyy ;
  335.                                 { dx = 0 to asymptote }
  336.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  337.  
  338.                Inc(ie,idex) ;
  339.                Inc(idex,idexx) ;
  340.                Inc(ix) ;
  341.                Dec(idey,ideyx) ;
  342.                iey := ie + idey ;
  343.                if abs(ie) > abs(iey) then begin
  344.                   Inc(idey,ideyy) ;
  345.                   Inc(iy) ;
  346.                   Dec(idex,idexy) ;
  347.                   ie := iey
  348.                end ;
  349.  
  350.                PutPixel(xf+ix,yf-iy,Color)
  351.  
  352.             end
  353.          end
  354.       end
  355.                                 { step in x }
  356.       else begin
  357.  
  358.          x0 := -p/2.0*costa/sinta2 ;
  359.          y0 := p/2.0/py*px/sinta ;
  360.          ix0 := Round(x0) ;
  361.          iy0 := Round(y0) ;
  362.          idex0 := Round((2*x0+1)*pxx - 2*y0*pxy + 2*p*sqr(px)*costa) ;
  363.          idey0 := Round((2*y0+1)*pyy - 2*x0*pxy + 2*p*py*px*sinta) ;
  364.                                 { starting point }
  365.          ix := ix0 ;
  366.          iy := iy0 ;
  367.          ie := 0 ;
  368.                                 { extremum point }
  369.          PutPixel(xf+ix,yf-iy,Color) ;
  370.                                 { open upwards }
  371.          if sinta >= 0.0 then begin
  372.  
  373.             idex := idex0 ;
  374.             idey := -idey0 + ideyy ;
  375.                                 { extremum to dx = dy }
  376.             while (-idey > idex) and
  377.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  378.  
  379.                Inc(ie,idex) ;
  380.                Inc(idex,idexx) ;
  381.                Inc(ix) ;
  382.                Inc(idey,ideyx) ;
  383.                iey := ie + idey ;
  384.                if abs(ie) > abs(iey) then begin
  385.                   Inc(idey,ideyy) ;
  386.                   Dec(iy) ;
  387.                   Inc(idex,idexy) ;
  388.                   ie := iey
  389.                end ;
  390.  
  391.                PutPixel(xf+ix,yf-iy,Color)
  392.  
  393.             end ;
  394.                                 { dx = dy to dx = 0 }
  395.             while (-idey > 0) and
  396.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  397.  
  398.                Inc(ie,idey) ;
  399.                Inc(idey,ideyy) ;
  400.                Dec(iy) ;
  401.                Inc(idex,idexy) ;
  402.                iex := ie + idex ;
  403.                if abs(ie) > abs(iex) then begin
  404.                   Inc(idex,idexx) ;
  405.                   Inc(ix) ;
  406.                   Inc(idey,ideyx) ;
  407.                   ie := iex
  408.                end ;
  409.  
  410.                PutPixel(xf+ix,yf-iy,Color)
  411.  
  412.             end ;
  413.  
  414.             idex := -idex + idexx ;
  415.                                 { dx = 0 to asymptote }
  416.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  417.  
  418.                Inc(ie,idey) ;
  419.                Inc(idey,ideyy) ;
  420.                Dec(iy) ;
  421.                Dec(idex,idexy) ;
  422.                iex := ie + idex ;
  423.                if abs(ie) > abs(iex) then begin
  424.                   Inc(idey,ideyx) ;
  425.                   Dec(ix) ;
  426.                   Dec(idey,ideyx) ;
  427.                   ie := iex
  428.                end ;
  429.  
  430.                PutPixel(xf+ix,yf-iy,Color)
  431.  
  432.             end ;
  433.                                 { reinitialize }
  434.             ix := ix0 ;
  435.             iy := iy0 ;
  436.             ie := 0 ;
  437.  
  438.             idex := -idex0 + idexx ;
  439.             idey := -idey0 + ideyy ;
  440.                                 { extremum to dx = dy }
  441.             while (-idey > idex) and
  442.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  443.  
  444.                Inc(ie,idex) ;
  445.                Inc(idex,idexx) ;
  446.                Dec(ix) ;
  447.                Dec(idey,ideyx) ;
  448.                iey := ie + idey ;
  449.                if abs(ie) > abs(iey) then begin
  450.                   Inc(idey,ideyy) ;
  451.                   Dec(iy) ;
  452.                   Dec(idex,idexy) ;
  453.                   ie := iey
  454.                end ;
  455.  
  456.                PutPixel(xf+ix,yf-iy,Color)
  457.  
  458.             end ;
  459.                                 { dx = dy to dx = 0 }
  460.             while (-idey > 0) and
  461.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  462.  
  463.                Inc(ie,idey) ;
  464.                Inc(idey,ideyy) ;
  465.                Dec(iy) ;
  466.                Dec(idex,idexy) ;
  467.                iex := ie + idex ;
  468.                if abs(ie) > abs(iex) then begin
  469.                   Inc(idex,idexx) ;
  470.                   Dec(ix) ;
  471.                   Dec(idey,ideyx) ;
  472.                   ie := iex
  473.                end ;
  474.  
  475.                PutPixel(xf+ix,yf-iy,Color)
  476.  
  477.             end ;
  478.  
  479.             idex := -idex + idexx ;
  480.                                 { dx = 0 to asymptote }
  481.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  482.  
  483.                Inc(ie,idey) ;
  484.                Inc(idey,ideyy) ;
  485.                Dec(iy) ;
  486.                Inc(idex,ideyx) ;
  487.                iex := ie + idex ;
  488.                if abs(ie) > abs(iex) then begin
  489.                   Inc(idex,idexx) ;
  490.                   Inc(ix) ;
  491.                   Inc(idey,ideyx) ;
  492.                   ie := iex
  493.                end ;
  494.  
  495.                PutPixel(xf+ix,yf-iy,Color)
  496.  
  497.             end
  498.          end
  499.                                 { open downwards }
  500.          else begin
  501.  
  502.             idex := idex0 ;
  503.             idey := idey0 ;
  504.                                 { extremum to dx = dy }
  505.             while (-idey > idex) and
  506.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  507.  
  508.                Inc(ie,idex) ;
  509.                Inc(idex,idexx) ;
  510.                Inc(ix) ;
  511.                Dec(idey,ideyx) ;
  512.                iey := ie + idey ;
  513.                if abs(ie) > abs(iey) then begin
  514.                   Inc(idey,ideyy) ;
  515.                   Inc(iy) ;
  516.                   Dec(idex,idexy) ;
  517.                   ie := iey
  518.                end ;
  519.  
  520.                PutPixel(xf+ix,yf-iy,Color)
  521.  
  522.             end ;
  523.                                 { dx = dy to dx = 0 }
  524.             while (-idey > 0) and
  525.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  526.  
  527.                Inc(ie,idey) ;
  528.                Inc(idey,ideyy) ;
  529.                Inc(iy) ;
  530.                Dec(idex,idexy) ;
  531.                iex := ie + idex ;
  532.                if abs(ie) > abs(iex) then begin
  533.                   Inc(idex,idexx) ;
  534.                   Inc(ix) ;
  535.                   Dec(idey,ideyx) ;
  536.                   ie := iex
  537.                end ;
  538.  
  539.                PutPixel(xf+ix,yf-iy,Color)
  540.  
  541.             end ;
  542.  
  543.             idex := -idex + idexx ;
  544.                                 { dx = 0 to asymptote }
  545.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  546.  
  547.                Inc(ie,idey) ;
  548.                Inc(idey,ideyy) ;
  549.                Inc(iy) ;
  550.                Inc(idex,idexy) ;
  551.                iex := ie + idex ;
  552.                if abs(ie) > abs(iex) then begin
  553.                   Inc(idex,idexx) ;
  554.                   Dec(ix) ;
  555.                   Inc(idey,ideyx) ;
  556.                   ie := iex
  557.                end ;
  558.  
  559.                PutPixel(xf+ix,yf-iy,Color)
  560.  
  561.             end ;
  562.                                 { reinitialize }
  563.             ix := ix0 ;
  564.             iy := iy0 ;
  565.             ie := 0 ;
  566.  
  567.             idex := -idex0 + idexx ;
  568.             idey := idey0 ;
  569.                                 { extremum to dx = dy }
  570.             while (-idey > idex) and
  571.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  572.  
  573.                Inc(ie,idex) ;
  574.                Inc(idex,idexx) ;
  575.                Dec(ix) ;
  576.                Inc(idey,ideyx) ;
  577.                iey := ie + idey ;
  578.                if abs(ie) > abs(iey) then begin
  579.                   Inc(idey,ideyy) ;
  580.                   Inc(iy) ;
  581.                   Inc(idex,idexy) ;
  582.                   ie := iey
  583.                end ;
  584.  
  585.                PutPixel(xf+ix,yf-iy,Color)
  586.  
  587.             end ;
  588.                                 { dx = dy to dx = 0 }
  589.             while (-idey > 0) and
  590.                     (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  591.  
  592.                Inc(ie,idey) ;
  593.                Inc(idey,ideyy) ;
  594.                Inc(iy) ;
  595.                Inc(idex,idexy) ;
  596.                iex := ie + idex ;
  597.                if abs(ie) > abs(iex) then begin
  598.                   Inc(idex,idexx) ;
  599.                   Dec(ix) ;
  600.                   Inc(idey,ideyx) ;
  601.                   ie := iex
  602.                end ;
  603.  
  604.                PutPixel(xf+ix,yf-iy,Color)
  605.  
  606.             end ;
  607.  
  608.             idex := -idex + idexx ;
  609.                                 { dx = 0 to asymptote }
  610.             while (abs(ix) < ixx) and (abs(iy) < iyx) do begin
  611.  
  612.                Inc(ie,idey) ;
  613.                Inc(idey,ideyy) ;
  614.                Inc(iy) ;
  615.                Dec(idex,idexy) ;
  616.                iex := ie + idex ;
  617.                if abs(ie) > abs(iex) then begin
  618.                   Inc(idex,idexx) ;
  619.                   Inc(ix) ;
  620.                   Dec(idey,ideyx) ;
  621.                   ie := iex
  622.                end ;
  623.  
  624.                PutPixel(xf+ix,yf-iy,Color)
  625.  
  626.             end
  627.          end
  628.       end
  629.    end
  630. end ;
  631.  
  632. { Copyright (C) 1989 Adam Fritz, 133 Main St., Afton, N.Y. 13730 }
  633.