home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FN3D1.ZIP / FN3D1.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-06-10  |  14.5 KB  |  505 lines
  1. program plot_surface ;
  2.  const numlines = 80 ;  { 7-dot strips }
  3.        pw = 199 ;  { 0..pw }
  4.        pl = 319 ;  { 0..pl }
  5.        xscmin = 0 ; xscmax = pl ;
  6.        yscmin = 0 ; yscmax = pw ;
  7.        c256 = 256 ;
  8.        c255 = 255 ;
  9.        pi   = 3.1415926 ;
  10.  type halflin = array[0..c255] of char ;
  11.       pair   = record  x,y : real  end ;
  12.       triple = record  x,y,z : real  end ;
  13.       intpair = record  x,y : integer  end;
  14.  var
  15.   ch      : char ;
  16.   k : integer ;
  17.   colorX,colorY,colorB,colorBack,colorAx,xlast,ylast,ngrid,ncur : integer;
  18.   scaleratio,shrink, a , b, c, d ,xl,xh,yl,yh : real ;
  19.   DotBack : Boolean;
  20.   xsc,ysc,xb,yb, zsc : real ;  {world-to-screen scale ratios, offsets,Zscaler}
  21.   P0,P1,IV,JV,KV,UP_V,DP : triple ;
  22.   DPdotI,DPdotJ,DPdotK, vtheta,alpha,beta,Xctr,Yctr  : real ;
  23.   top,bot,lasttop,lastbot : array[0..pl] of integer ;  {used by hidden line remover}
  24. function f( x,y : real ) : real ;
  25.  var   r : real;
  26.  begin
  27.    f := zsc * (X*X-1+2*X*COS(PI*Y))
  28. end; {R}
  29.  
  30.  function g1( x:real ) : real ;
  31.   begin
  32.    g1 := Yctr - beta*sqrt( 1.0 - sqr((x-Xctr)/alpha) )
  33.   end ;
  34.  
  35.  function g2( x:real ) : real ;
  36.   begin
  37.    g2 := Yctr + beta*sqrt( 1.0 - sqr((x-Xctr)/alpha) )
  38.   end;
  39.  
  40.  function h1( y:real ) : real ;
  41.   begin
  42.    h1 := Xctr - alpha*sqrt( 1.0 - sqr((y-Yctr)/beta) )
  43.   end;
  44.  
  45.  function h2( y:real ) : real ;
  46.   begin
  47.    h2 := Xctr + alpha*sqrt( 1.0 - sqr((y-Yctr)/beta) )
  48.   end;
  49.  
  50.  procedure pset( scrpt : intpair; color : integer ) ;  { 0<=x<=pl , 0<=y<=pw }
  51.   begin
  52.    with scrpt do PLOT(x,y,color)
  53.   end; {PSET}
  54.  
  55. procedure visipset( x,y : integer; color : integer ) ;
  56.  begin
  57.   if  y > lasttop[x]  then begin
  58.     PLOT(x,y,color) ; top[x] := y
  59.   end; {IF}
  60.   if  y < lastbot[x]  then begin
  61.     PLOT(x,y,color) ; bot[x] := y
  62.   end;
  63.  end; {VISIPSET}
  64.  
  65. procedure initvis ;  { sets visibility arrays last..  before a pass }
  66.  var  x,k,l : integer ;
  67.  begin
  68.   k := pw+1 ;  l := -1 ;
  69.   for x:=0 to pl  do begin
  70.    lastbot[x] := k ;  bot[x] := k ;
  71.    lasttop[x] := l ;  top[x] := l ;
  72.   end; {FOR}
  73.  end; {INITVIS}
  74.  
  75. procedure movevis ;
  76.  begin
  77.   lastbot := bot ;
  78.   lasttop := top
  79.  end; {MOVEVIS}
  80.  
  81.   procedure line(x,y,dx,dy : integer; color : integer) ;
  82.     { Bresenham's line-drawing algorithm }
  83.    var
  84.     i,dxsign,dysign,dxabs,dyabs : integer ;
  85.     e,f,g                     : integer ;
  86.     xp,yp                     : integer ;
  87.    begin
  88.    xp := x+dx ; yp := y+dy ; {check that all line on page}
  89.    if ( 0<=x ) and ( x<=pl ) and ( 0<=y ) and ( y <= pw ) and (0<=xp) and (xp<=pl) and (0<=yp) and (yp<=pw)
  90.     then begin {THEN}
  91.     dxabs := abs(dx) ; dyabs := abs(dy) ;
  92.     dxsign := 1 ; if dx<0 then dxsign := -dxsign ;
  93.     dysign := 1 ; if dy<0 then dysign := -dysign ;
  94.     f := 2*dxabs ; g := 2*dyabs ;
  95.     xp := x ; yp := y ;
  96.  
  97.     if  dxabs >= dyabs  then begin
  98.      e := 2*dyabs - dxabs ;
  99.      for i := 0 to dxabs do begin
  100.        visipset(xp,yp,color) ;
  101.        if  e > 0  then begin  yp := yp + dysign ;
  102.                               e  := e - f ;  end;
  103.        xp := xp + dxsign ;
  104.        e  := e + g ;
  105.      end; {for}
  106.     end {then}
  107.     else begin
  108.      e := 2*dxabs - dyabs ;
  109.      for i := 0 to dyabs  do begin
  110.       visipset(xp,yp,color) ;
  111.       if  e > 0  then begin  xp := xp + dxsign ;
  112.                              e  := e - g ;  end;
  113.       yp := yp + dysign ;
  114.       e  := e + f ;
  115.      end; {for}
  116.     end; {else}
  117.    end; {if}
  118.    end; {line}
  119.  
  120.  
  121. procedure plot_at( scrpt:intpair; color : integer ) ;
  122.  begin
  123.   with scrpt do begin
  124.    if (0<=x) and (x<=pl) and (0<=y) and (y<=pw)  then visipset(x,y,color) ;
  125.    xlast := x  ;  ylast := y  ;
  126.   end; {WITH}
  127.  end; { PLOT_AT }
  128.  
  129. procedure plot_to( scrpt:intpair; color : integer ) ;
  130.  begin
  131.   with scrpt do begin
  132.    line(xlast,ylast,x-xlast,y-ylast,color) ;
  133.    xlast := x  ;  ylast := y  ;
  134.   end; {WITH}
  135.  end; { PLOT_TO }
  136.   
  137. procedure setscale( eqscales : Boolean ; xl,xh,yl,yh : real ;
  138.                    var xsc,ysc,xb,yb : real ) ;
  139.      { calc scale factors and offsets }
  140.  var  xscmid,yscmid,xmid,ymid : real ;
  141.  begin
  142.   xsc := (xscmax-xscmin)/(xh-xl) ;
  143.   ysc := (yscmax-yscmin)/(yh-yl) ;
  144.   
  145.   if  eqscales  then begin
  146.     if  xsc > ysc   then xsc := ysc
  147.                     else ysc := xsc ;
  148.   end; {IF}
  149.   xsc :=  shrink * xsc ;
  150.   ysc := -shrink * ysc/scaleratio ;
  151.   xmid := (xl+xh)/2 ;  ymid := (yl+yh)/2 ;
  152.   xscmid := (xscmin+xscmax)/2 ;
  153.   yscmid := (yscmin+yscmax)/2 ;
  154.   xb := xscmid - xmid * xsc ;
  155.   yb := yscmid - ymid * ysc ;
  156.  end;  {SETSCALE}
  157.  
  158. procedure setviewpt ;  { inits P0,P1,IV,JV,KV }
  159.  var
  160.   vrho,vth,vph    : real ;
  161.   cth,sth,cph,sph : real ;
  162.   viewplfactor    : real ;
  163.  begin
  164.   viewplfactor := 0.5 ;  {temp}
  165.   write('Enter position of viewer :  rho theta phi  :') ;  ;
  166.   readln(vrho,vth,vph) ; writeln ;
  167.   vtheta := vth ;  { save eye theta in degrees }
  168.   
  169.   vth := pi*vth/180.0 ;  vph := pi*vph/180.0 ;
  170.   cth := cos(vth) ;  sth := sin(vth) ;
  171.   cph := cos(vph) ;  sph := sin(vph) ;
  172.   P0.x := vrho*cth*sph ;
  173.   P0.y := vrho*sth*sph ;
  174.   P0.z := vrho*cph ;
  175.    writeln(' VIEWER IS AT (x,y,z) = ',P0.x:6:1,P0.y:6:1,P0.z:6:1 ) ;
  176.   
  177.   P1.x := viewplfactor*P0.x ;
  178.   P1.y := viewplfactor*P0.y ;
  179.   P1.z := viewplfactor*P0.z ;
  180.   
  181.   KV.x := -cth*sph ;
  182.   KV.y := -sth*sph ;
  183.   KV.z := -cph ;
  184.   
  185.   IV.x := -sth ;
  186.   IV.y :=  cth ;
  187.   IV.z :=  0.0 ;
  188.   
  189.   JV.x := -cth*cph ;
  190.   JV.y := -sth*cph ;
  191.   JV.z :=  sph ;
  192.   
  193.   DP.x := P1.x-P0.x ;  DP.y := P1.y-P0.y ;  DP.z := P1.z-P0.z ;
  194.   DPdotI := DP.x*IV.x + DP.y*IV.y + DP.z*IV.z ;
  195.   DPdotJ := DP.x*JV.x + DP.y*JV.y + DP.z*JV.z ;
  196.   DPdotK := DP.x*KV.x + DP.y*KV.y + DP.z*KV.z ;
  197.   
  198.  end; {SETVIEWPT}
  199.  
  200. procedure persp( Q:triple; var PT:pair ) ;
  201.  var
  202.   DPQ : triple ;
  203.   tmp, DPQdotI,DPQdotJ,DPQdotK : real ;
  204.  begin
  205.   DPQ.x := Q.x-P0.x ;  DPQ.y := Q.y-P0.y ;  DPQ.z := Q.z-P0.z ;
  206.   DPQdotI := DPQ.x*IV.x + DPQ.y*IV.y + DPQ.z*IV.z ;
  207.   DPQdotJ := DPQ.x*JV.x + DPQ.y*JV.y + DPQ.z*JV.z ;
  208.   DPQdotK := DPQ.x*KV.x + DPQ.y*KV.y + DPQ.z*KV.z ;
  209.   tmp := DPdotK/DPQdotK ;
  210.   PT.x := tmp*DPQdotI - DPdotI ;
  211.   PT.y := tmp*DPQdotJ - DPdotJ ;
  212.  end; {PERSP}
  213.   
  214. procedure ToScreen( pt:pair; var scrpt:intpair );  { plane-to-screen transformation }
  215.  begin
  216.   with scrpt do begin
  217.     x := round( xsc*pt.x + xb );  y := round( ysc*pt.y + yb ) ;
  218.   end; {WITH}
  219.  end; {TOSCREEN}
  220.    
  221. procedure worldline( A,B : triple ; xsc,ysc,xb,yb : real ) ;
  222.     { draws line A to B }
  223.  var  AV,BV : pair ;
  224.       xap,yap,xbp,ybp : integer ;
  225.  begin
  226.   persp(A,AV) ;  persp(B,BV) ;
  227.   xap := round(AV.x*xsc + xb) ;
  228.   yap := round(AV.y*ysc + yb) ;
  229.   xbp := round(BV.x*xsc + xb) ;
  230.   ybp := round(BV.y*ysc + yb) ;
  231.  
  232.   DRAW(xap,yap,xbp,ybp,colorAx) ;
  233.  end;  {WORLDLINE}
  234.  
  235. procedure scale( a,b,c,d : real ;
  236.                  var xl,xh,yl,yh : real );
  237.  var
  238.   i,j : integer ;
  239.   w : triple ;  pt : pair;
  240.   y1,y2,curdx,dy : real ;
  241.  begin
  242.   curdx := (b-a)/ncur ;
  243.   xl := 0.0 ;  xh := xl ;
  244.   yl := 0.0 ;  yh := yl ;
  245.   
  246.   with w do begin
  247.    x := a ;
  248.    for i:=0 to ncur do begin
  249.     y1 := g1(x) ;  y2 := g2(x) ;  dy := (y2-y1)/ncur ;
  250.     y := y1 ;
  251.     for j:=0 to ncur do begin
  252.      z := f(x,y) ;  persp(w,pt);
  253.      if pt.x < xl then xl := pt.x  else if pt.x > xh then xh := pt.x ;
  254.      if pt.y < yl then yl := pt.y  else if pt.y > yh then yh := pt.y ;
  255.      y := y + dy ;
  256.     end; {FOR}
  257.     x := x + curdx ;
  258.    end; {FOR}
  259.   end; {WITH}
  260. end; {SCALE}
  261.  
  262. procedure PlotXY;
  263. var
  264.      w:triple; pt:pair; scrpt:intpair;
  265.      x1,x2,y1,y2,dx,dy,curdx,curdy,xlo,xhi : real;
  266.      nbetween,m,i,j,k : integer ;
  267. begin
  268.  nbetween := ngrid div ncur ;  m := 2*nbetween ;
  269.  curdx := (b-a)/ncur ;  curdy := (d-c)/ncur ;
  270.  with w do begin
  271.  x2 := b ;
  272.  for i:=ncur downto 0 do begin
  273.   { plot  coordinate curve  x=x2 }
  274.   y1 := g1(x2) ;  y2 := g2(x2) ;
  275.   dy := (y2-y1)/ngrid ;
  276.   if dy > 0 then begin
  277.    y := y1 ;  x := x2 ;  z := f(x,y) ;
  278.    persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorX);
  279.     if DotBack then pset(scrpt,colorBack) ;
  280.    for j:=1 to ngrid do begin  { draw coord curve  x=x2  from y1 to y2 }
  281.     y := y+dy ;  z := f(x,y) ;
  282.     persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorX);
  283.     if DotBack then pset(scrpt,colorBack);
  284.    end; {FOR}
  285.    movevis ;  { transfer h/l info to last.. arrays }
  286.  
  287.    if i>0 then begin
  288.     x1 := x2 - curdx ;
  289.     { plot y=g2(x)  from  x=x2  to  x=x1 }
  290.     dx := (x2-x1)/m ;
  291.     x := x2 ; y := g2(x) ; z := f(x,y) ;
  292.     persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorB);
  293.      if DotBack then pset(scrpt,colorBack);
  294.     for j:=m downto 1  do begin
  295.      x := x-dx ;  y := g2(x) ; z := f(x,y) ;
  296.      persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorB);
  297.       if DotBack then pset(scrpt,colorBack);
  298.     end; {FOR}
  299.     movevis;
  300.     { plot segments of 2nd coord curves from x2 to x1, WITHIN region }
  301.     y := d ;
  302.  
  303.     for j:=ncur downto 0 do begin { draw coord curve at w.y }
  304.      xlo := h1(y) ; if x1 > xlo  then  xlo := x1 ;
  305.      xhi := h2(y) ; if x2 < xhi  then  xhi := x2 ;
  306.      dx := (xhi-xlo)/nbetween ;  x := xhi ;
  307.      if dx > 0 then begin { draw coord curve at w.y, from xhi to xlo }
  308.       z := f(x,y) ;
  309.       persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorY);
  310.        if DotBack then pset(scrpt,colorBack) ;
  311.       for k:= nbetween downto 1 do begin
  312.        x := x-dx ;  z := f(x,y) ;
  313.        persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorY);
  314.         if DotBack then pset(scrpt,colorBack);
  315.       end; {FOR}
  316.       movevis ;
  317.      end; {IF}
  318.      y := y - curdy ;
  319.     end; {FOR}
  320.  
  321.     { plot y=g1(x)  from  x=x2  to x=x1 }
  322.     dx := (x2-x1)/m ;
  323.     x := x2 ;  y := g1(x) ;  z := f(x,y) ;
  324.     persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorB);
  325.      if DotBack then pset(scrpt,colorBack);
  326.     for j:=m downto 1 do begin
  327.      x := x-dx ;  y := g1(x) ; z := f(x,y) ;
  328.      persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorB);
  329.       if DotBack then pset(scrpt,colorBack);
  330.     end; {FOR}
  331.     movevis;
  332.    end; {IF}
  333.  
  334.    end; {IF}
  335.    x2 := x2 - curdx ;
  336.   end; {FOR}
  337.  end; {WITH}
  338. end; {PLOTXY}
  339.  
  340. procedure PlotYX;
  341.  var
  342.      w:triple; pt:pair; scrpt:intpair;
  343.      x1,x2,y1,y2,dx,dy,curdx,curdy,ylo,yhi : real;
  344.      nbetween,m,i,j,k : integer ;
  345. begin
  346.  nbetween := ngrid div ncur ;  m := 2*nbetween ;
  347.  curdx := (b-a)/ncur ;  curdy := (d-c)/ncur ;
  348.  with w do begin
  349.   y2 := d ;
  350.   for i:=ncur downto 0 do begin
  351.     { plot 1 coordinate curve }
  352.    x1 := h1(y2) ;  x2 := h2(y2) ;
  353.    dx := (x2-x1)/ngrid ;
  354.    if dx > 0 then begin
  355.     x := x1 ;  y := y2 ;  z := f(x,y) ;
  356.     persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorY);
  357.      if DotBack then pset(scrpt,colorBack) ;
  358.     for j:=1 to ngrid do begin  { draw coord curve  y=y2  from x1 to x2 }
  359.      x := x+dx ;  z := f(x,y) ;
  360.      persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorY);
  361.       if DotBack then pset(scrpt,colorBack);
  362.     end; {FOR}
  363.     movevis ;  { transfer h/l info to last.. arrays }
  364.  
  365.     if i>0 then begin
  366.      y1 := y2 - curdy ;
  367.  
  368.      { plot x=h2(y)  from  y=y2  to  y=y1 }
  369.      dy := (y2-y1)/m ;
  370.      y := y2 ; x := h2(y) ; z := f(x,y) ;
  371.     persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorB);
  372.      if DotBack then pset(scrpt,colorBack);
  373.     for j:=m downto 1  do begin
  374.      y := y-dy ;  x := h2(y) ; z := f(x,y) ;
  375.      persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorB);
  376.       if DotBack then pset(scrpt,colorBack);
  377.     end; {FOR}
  378.     movevis;
  379.  
  380.     { plot segments of 2nd coord curves from y2 to y1, WITHIN region }
  381.     x := b ;
  382.     for j:=ncur downto 0 do begin { draw coord curve at w.x }
  383.      ylo := g1(x) ; if y1 > ylo  then  ylo := y1 ;
  384.      yhi := g2(x) ; if y2 < yhi  then  yhi := y2 ;
  385.      dy := (yhi-ylo)/nbetween ;  y := yhi ;
  386.      if dy > 0 then begin { draw coord curve at w.x, from yhi to ylo }
  387.      z := f(x,y) ;
  388.      persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorX);
  389.       if DotBack then pset(scrpt,colorBack);
  390.      for k:= nbetween downto 1 do begin
  391.        y := y-dy ;  z := f(x,y) ;
  392.        persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorX);
  393.         if DotBack then pset(scrpt,colorBack);
  394.      end; {FOR}
  395.      movevis ;
  396.     end; {IF}
  397.     x := x - curdx ;
  398.    end; {FOR}
  399.  
  400.    { plot x=h1(y)  from  y=y2  to y=y1 }
  401.    dy := (y2-y1)/m ;
  402.    y := y2 ;  x := h1(y) ;  z := f(x,y) ;
  403.    persp(w,pt); ToScreen(pt,scrpt); plot_at(scrpt,colorB);
  404.     if DotBack then pset(scrpt,colorBack);
  405.    for j:=m downto 1 do begin
  406.     y := y-dy ;  x := h1(y) ; z := f(x,y) ;
  407.     persp(w,pt); ToScreen(pt,scrpt); plot_to(scrpt,colorB);
  408.      if DotBack then pset(scrpt,colorBack);
  409.    end; {FOR}
  410.    movevis;
  411.  
  412.   end; {IF}
  413.  
  414.   end; {IF}
  415.   y2 := y2 - curdy ;
  416.  end; {FOR}
  417.  end; {WITH}
  418. end; {PLOTYX}
  419.  
  420. procedure drawaxes( xsc,ysc,xb,yb : real ) ;
  421. const ticklen = 4 ;  {length of a tick mark}
  422. var  xlen,ylen,zlen : real ;
  423.      origin,xaxis,yaxis,zaxis : triple ;
  424.  
  425.  procedure drawxtick( xpos:real ; halflen:integer ) ;
  426.   begin
  427.   end; {DRAWXTICK}
  428.  
  429.  procedure drawytick( ypos:real ; halflen:integer ) ;
  430.   begin
  431.   end; {DRAWYTICK}
  432.  
  433.  begin {DRAWAXES}
  434.   writeln('Enter axis lengths from (0,0,0)') ;
  435.   write('  xlen ylen zlen  : ') ;
  436.   readln(xlen,ylen,zlen) ; writeln ;
  437.  
  438.   origin.x := 0.0 ;
  439.   origin.y := 0.0 ;
  440.   origin.z := 0.0 ;
  441.  
  442.   xaxis.x  := xlen ;
  443.   xaxis.y  := 0.0 ;
  444.   xaxis.z  := 0.0 ;
  445.  
  446.   yaxis.x  := 0.0 ;
  447.   yaxis.y  := ylen ;
  448.   yaxis.z  := 0.0 ;
  449.  
  450.   zaxis.x  := 0.0 ;
  451.   zaxis.y  := 0.0 ;
  452.   zaxis.z  := zlen ;
  453.  
  454.   initvis ;
  455.   worldline(origin,xaxis,xsc,ysc,xb,yb) ;
  456.   initvis ;
  457.   worldline(origin,yaxis,xsc,ysc,xb,yb) ;
  458.   initvis ;
  459.   worldline(origin,zaxis,xsc,ysc,xb,yb) ;
  460. end; {DRAWAXES}
  461.  
  462. procedure beep ;
  463.  var c : char ;
  464.  begin
  465.   c := chr(7) ;  {BELL}
  466.   write(c) ;
  467.  end; {BEEP}
  468.  
  469. begin { MAIN }
  470.  colorAx := 0 ;  {TEMP} ; colorBack := 2 {RED};
  471.  colorX := 3 {GREEN}; colorY := 3 {GREEN}; colorB := 1 {YELLOW};
  472.  scaleratio := 1.1 ;  { 66 v / 60 h }
  473.  
  474.  ngrid := 75;
  475.  ncur := 15;
  476.  shrink := 0.99 ; writeln;
  477.  setviewpt ;
  478.  
  479.  ch := 'n' ; writeln;
  480.   DotBack := ( ch = 'y' ) ;
  481.  write('Enter semiaxes and center for domain elliptdisk: a  b  Xc Yc :');
  482.  readln(alpha,beta,Xctr,Yctr); writeln;
  483.  a :=  -alpha + Xctr ; b := alpha + Xctr ;
  484.  c := -beta + Yctr ; d := beta + Yctr ;
  485.  alpha := alpha + 0.001 ; beta := beta + 0.001 ;
  486.  write('Enter Z-scale factor :');  readln(zsc); writeln;
  487.  scale(a,b,c,d,xl,xh,yl,yh) ;
  488.  setscale(true,xl,xh,yl,yh,xsc,ysc,xb,yb) ;
  489.  
  490.  
  491.  GraphBackground(black); GraphColorMode; Palette(1);
  492.  
  493.  { drawaxes(xsc,ysc,xb,yb) ; }
  494.  initvis ;
  495.  if (-45.0 <= vtheta) and (vtheta < 45.0)  then PlotXY
  496.    else if (45.0 <= vtheta) and (vtheta <= 135.0) then PlotYX
  497.    else begin writeln('This viewpoint not presently allowed.'); beep  end;
  498.  
  499.  
  500.  repeat until KeyPressed;
  501.  TextMode;
  502. end. { MAIN }
  503.  
  504.  
  505.