home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / PLOT / SURFUTI3.ZIP / REVOLUTE.PRE < prev    next >
Encoding:
Text File  |  1987-12-06  |  25.4 KB  |  742 lines
  1. program revolution;
  2. { Written by Ian Murphy }
  3.  
  4. { fri 6th-nov-87 : wrote most of code, addpoint/insert/delete/move, very buggy
  5.   mon 9th-nov-87 : noticed the pointer bug, couldn't track it down.
  6.                    added redraw/ select point.
  7.   tue 10th-nov-87: Found&fixed the above bug. added axes, menu for params
  8.   wed 11th-nov-87: improved parameters menu, added saving data
  9.   thur12th-nov-87: tidied up the bits and pieces
  10.   }
  11.  
  12. {$i tbemulat.pas}
  13.  
  14. { Names of all the systems currently supported by SURFMODL: }
  15. const MAXSYS = 10;        { maximum # of systems currently supported }
  16. const Sys_name: array[1..MAXSYS] of string[30] = (
  17.         'IBM Color Graphics Adapter',
  18.         'IBM Enhanced Graphics Adapter',
  19.         'Hercules Graphics Adapter',
  20.         'Sanyo MBC-555',
  21.         'Heath/Zenith Z-100',
  22.         'CGA Compatible',
  23.         'AT&T 6300',
  24.         'IBM 3270',
  25.         'QuadEGA 640x480',
  26.         'QuadEGA 752x410');
  27.  
  28. { Constants for system numbers: }
  29. const STDCGA   = 1;
  30.       EGA      = 2;
  31.       HERCULES = 3;
  32.       SANYO    = 4;
  33.       Z100     = 5;
  34.       TBCGA    = 6;
  35.       ATT      = 7;
  36.       IBM3270  = 8;
  37.       QUAD480  = 9;
  38.       QUAD752  = 10;
  39.  
  40. #ifdef CEHS
  41. { (This version supports all of the: CGA, EGA, Hercules, and Sanyo.)
  42.   Note that TOOLBOX must be defined to compile this version.
  43. }
  44. {$I SGRAPH.P}
  45. {$I GRAPH.P}
  46. {$I B:TYPEDEF.SYS}  { VARIABLE DECLARATIONS FOR THE TURBO GRAPHIX TOOLBOX }
  47. {$I B:GRAPHIX.HGC}  { VBLS & ROUTINES FOR BASIC DRAWING }
  48. {$I B:KERNEL.SYS}   { PRIMITIVES FOR CNTL/INITIALIZATION OF GRAPHIX TOOLBOX }
  49. const NUMLGLSYS = 4;      { number of legal system numbers in this version }
  50.       LGLSYS: array[1..NUMLGLSYS] of integer = (STDCGA, EGA, HERCULES, SANYO);
  51. #endif
  52. #ifdef HZCGA
  53. { (This version supports BOTH of the Heath/Zenith and CGA (under MSDOS
  54.   Turbo Pascal, not PCDOS).
  55.   Note that TOOLBOX must be defined to compile this version.
  56. }
  57. {$I B:TYPEDEF.SYS}  { VARIABLE DECLARATIONS FOR THE TURBO GRAPHIX TOOLBOX }
  58. {$I B:GRAPHIX.IBM}  { VBLS & ROUTINES FOR BASIC DRAWING }
  59. {$I B:KERNEL.SYS}   { PRIMITIVES FOR CNTL/INITIALIZATION OF GRAPHIX TOOLBOX }
  60. const NUMLGLSYS = 2;      { number of legal system numbers in this version }
  61.       LGLSYS: array[1..NUMLGLSYS] of integer = (Z100, TBCGA);
  62. #endif
  63. #ifdef STDCGA
  64. { (This version supports the graphics of the IBM PC and true compatibles only.
  65.   It requires a standard IBM Color Graphics Adapter and uses the GRAPH.BIN
  66.   graphics library in the Turbo Pascal 3.01A PC-DOS version.)
  67. }
  68. {$I GRAPH.P}      { GRAPHICS LIBRARY FOR IBM PC }
  69. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  70.       LGLSYS: array[1..NUMLGLSYS] of integer = (STDCGA);
  71. #endif
  72. #ifdef EGA
  73. { (This version includes support for the IBM Enhanced Graphics Adapter.
  74.   It may be compiled with either the PC-DOS or
  75.   generic MS-DOS Turbo Pascal 3.01A.)
  76. }
  77. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  78.       LGLSYS: array[1..NUMLGLSYS] of integer = (EGA);
  79. #endif
  80. #ifdef HERCULES
  81. { (This version includes support for the Hercules Monochrome Graphics Card.
  82.   Note that TOOLBOX must be defined to compile this version.
  83. }
  84. {$I B:TYPEDEF.SYS}  { VARIABLE DECLARATIONS FOR THE TURBO GRAPHIX TOOLBOX }
  85. {$I B:GRAPHIX.HGC}  { VBLS & ROUTINES FOR BASIC DRAWING }
  86. {$I B:KERNEL.SYS}   { PRIMITIVES FOR CNTL/INITIALIZATION OF GRAPHIX TOOLBOX }
  87. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  88.       LGLSYS: array[1..NUMLGLSYS] of integer = (HERCULES);
  89. #endif
  90. #ifdef SANYO
  91. { (This version includes support for only the Sanyo MBC-55x.
  92.   It requires the SGRAPH graphics library.
  93.   SGRAPH may be purchased, for $25, from Jim Pelley, 2570 Adams,
  94.   Eugene, OR 97405.)
  95. }
  96. {$I SGRAPH.P}     { GRAPHICS LIBRARY FOR SANYO MBC-55x }
  97. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  98.       LGLSYS: array[1..NUMLGLSYS] of integer = (SANYO);
  99. #endif
  100. #ifdef Z100
  101. { (This version includes support for the Heath/Zenith Z100 computer,
  102.   It should be compiled using the generic MS-DOS Turbo Pascal 3.01A.)
  103. }
  104. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  105.       LGLSYS: array[1..NUMLGLSYS] of integer = (Z100);
  106. #endif
  107. #ifdef TBCGA
  108. { (This version includes support for only the IBM Color Graphics Adapter,
  109.   using the Turbo Graphix Toolbox. It is used for computers that are not
  110.   compatible enough with the IBM PC to be able to run programs compiled
  111.   under the PC-DOS version of Turbo Pascal 3.01A.)
  112.   Note that TOOLBOX must be defined to compile this version.
  113. }
  114. {$I B:TYPEDEF.SYS}  { VARIABLE DECLARATIONS FOR THE TURBO GRAPHIX TOOLBOX }
  115. {$I B:GRAPHIX.IBM}  { VBLS & ROUTINES FOR BASIC DRAWING }
  116. {$I B:KERNEL.SYS}   { PRIMITIVES FOR CNTL/INITIALIZATION OF GRAPHIX TOOLBOX }
  117. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  118.       LGLSYS: array[1..NUMLGLSYS] of integer = (TBCGA);
  119. #endif
  120. #ifdef ATT
  121. { (This version includes support for the AT&T PC 6300,
  122.   using the Turbo Graphix Toolbox. It may be compiled with either
  123.   the PC-DOS or generic MS-DOS Turbo Pascal 3.01A.)
  124.   Note that TOOLBOX must be defined to compile this version.
  125. }
  126. {$I B:TYPEDEF.SYS}  { VARIABLE DECLARATIONS FOR THE TURBO GRAPHIX TOOLBOX }
  127. {$I B:GRAPHIX.ATT}  { VBLS & ROUTINES FOR BASIC DRAWING }
  128. {$I B:KERNEL.SYS}   { PRIMITIVES FOR CNTL/INITIALIZATION OF GRAPHIX TOOLBOX }
  129. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  130.       LGLSYS: array[1..NUMLGLSYS] of integer = (ATT);
  131. #endif
  132. #ifdef IBM3270
  133. { (This version includes support for the IBM 3270 PC,
  134.   using the Turbo Graphix Toolbox. It may be compiled with either
  135.   the PC-DOS or generic MS-DOS Turbo Pascal 3.01A.)
  136.   Note that TOOLBOX must be defined to compile this version.
  137. }
  138. {$I B:TYPEDEF.SYS}  { VARIABLE DECLARATIONS FOR THE TURBO GRAPHIX TOOLBOX }
  139. {$I B:GRAPHIX.327}  { VBLS & ROUTINES FOR BASIC DRAWING }
  140. {$I B:KERNEL.SYS}   { PRIMITIVES FOR CNTL/INITIALIZATION OF GRAPHIX TOOLBOX }
  141. const NUMLGLSYS = 1;      { number of legal system numbers in this version }
  142.       LGLSYS: array[1..NUMLGLSYS] of integer = (IBM3270);
  143. #endif
  144. #ifdef QUADEGA
  145. { (This version includes support for the Quadram QuadEGA Prosync graphics
  146.   card in either 640x480 or 752x410 mode, as provided by Rainer Kleinrensing.
  147.   Note that the VEGA Deluxe card is compatible with the QuadEGA, so both
  148.   modes should work with that card as well.
  149.   It may be compiled with either the PC-DOS or
  150.   generic MS-DOS Turbo Pascal 3.01A.)
  151. }
  152. const NUMLGLSYS = 2;      { number of legal system numbers in this version }
  153.       LGLSYS: array[1..NUMLGLSYS] of integer = (QUAD480, QUAD752);
  154. #endif
  155.  
  156. { Global variables and constants for SURFMODL }
  157.  
  158. #ifdef MSDOS
  159. const MSDOS: boolean = TRUE;
  160. #endif
  161. #ifndef MSDOS
  162. const MSDOS: boolean = FALSE;
  163. #endif
  164. #ifdef TOOLBOX
  165. const TOOLBOX: boolean = TRUE;
  166. #endif
  167. #ifndef TOOLBOX
  168. const TOOLBOX: boolean = FALSE;
  169. #endif
  170.  
  171. const
  172.       spc = ' ';
  173.       shapecode = 2; { surface of revolution}
  174.       maxpts= 100;
  175.       up    = 242; down =250;  left = 245;
  176.       right = 247; esc  =27;   space= 32;
  177.       ret   = 13;
  178.       blank = 0;
  179.       MAXVAR = 20;          { maximum # of numeric inputs on a line }
  180.  
  181. type anystring = string[80];
  182.      vartype = array[1..MAXVAR] of real;
  183.      text80 = string[80];
  184. var
  185.     version,nmatl,maxvert,nsides  : integer;
  186.     r1,r2,r3,ambient : real; color : integer;
  187.     noutln,nslice,material,orient  : integer;
  188.     xscale,yscale,zscale,xshift,yshift,zshift : real;
  189.     xrotate,yrotate,zrotate : real;
  190.     x,y,ptr : array [1..maxpts] of integer;
  191.     firstpt,finalpt,lastpt,numpts,nextpt,curpt : integer;
  192.     i,j,ch : integer;
  193.     mono,arrow,debug,debug2 : boolean ;
  194.     infile,outfile  : text;
  195.     infilename,outfilename : text80;
  196.     title : text80;
  197.     flpurpose : text80;
  198.     gxcenter,gycenter : integer;
  199.     linecolor, linecolor2 : integer;
  200.     hilite : integer;
  201.     system : integer;
  202.     ncolors : integer;
  203.     gxmin, gxmax, gymin, gymax : integer;
  204.     ngraphchar : integer;
  205.     tbinit : boolean;
  206.     sys : integer;
  207.     sys_type_set : boolean;
  208.     xfactor : real;
  209.     period : integer;
  210.     prefilename, batfilename : text80;
  211.     { Following vbls not used, but defined only to allow compilation
  212.       of drawplot.pas }
  213.     dorandom : boolean;
  214.     randshade : real;
  215.  
  216. { Dummy STOPSTAT procedure for REVOLUTE }
  217. procedure STOPSTAT;
  218. begin
  219. end;
  220.  
  221. {$i colormod.pas}
  222. {$i drawplot.pas}
  223. {$i setgmode.pas}
  224. {$i exgraphi.pas}
  225. {$i setsys.pas}
  226. {$i inreal.pas}
  227.  
  228.  
  229. procedure msg(s:anystring);
  230. begin
  231.    if (Ngraphchar >= 40) then begin
  232.      gotoxy (1,2);
  233.      write ('                                              ');
  234.      gotoxy (1,2);
  235.      write (s);
  236.    end;
  237. end;
  238.  
  239. procedure tmsg(s:anystring);
  240. { same as msg, but used in textmode so it doesn't matter whether the system
  241.   has ability to display characters on the graphics screen }
  242. begin
  243.      gotoxy (1,2);
  244.      write ('                                              ');
  245.      gotoxy (1,2);
  246.      write (s);
  247. end;
  248.  
  249. function next_free_pt:integer;
  250. var i : integer;
  251. begin
  252.      if debug then msg('Next_free_pt');
  253.      i := 0;
  254.      repeat
  255.            i := i +1;
  256.      until (x[i] =0) and (y[i]=0);
  257.      next_free_pt := i;
  258. end;
  259.  
  260. function getch:integer;
  261. var ch:char;
  262. begin
  263.      if debug then msg('readch');
  264.      read(kbd,ch);
  265.      arrow :=false;
  266.      if ((ord(ch)=esc) and keypressed) then
  267.      begin
  268.           arrow:=true;
  269.           read(kbd,ch)
  270.      end;
  271.      if arrow then getch:=ord(ch)+170
  272.      else getch:=ord(ch)
  273. end;
  274.  
  275. function ptrto(cp:integer):integer;
  276. var x,lastx : integer;
  277. begin
  278.      if debug then msg('ptrto');
  279.      x:= firstpt;
  280.      repeat
  281.            if debug2 then writeln ('cp ',cp,' ptr[',x,']=',ptr[x]);
  282.            lastx :=x;
  283.            x := ptr[x];
  284.            if debug2 then write (x);
  285.      until (x=cp)or(x=0);
  286.      ptrto := lastx;
  287.      if debug2 then writeln ('cp ',cp,' ptr[',x,']=',ptr[x]);
  288. end;
  289.  
  290. procedure drawcross(cp,color:integer);
  291. const crossize = 3;
  292. begin
  293.      if debug then msg('drawcross');
  294.      gdraw (x[cp]-crossize,y[cp],x[cp]+crossize,y[cp],color);
  295.      gdraw (x[cp],y[cp]-crossize,x[cp],y[cp]+crossize,color);
  296. end;
  297.  
  298. procedure split (var cp:integer);
  299. var np,lp :integer;
  300. begin
  301.      if debug then msg('split');
  302.      if cp <>firstpt then cp := ptrto(cp);
  303.      np := ptr[cp];
  304.      lp := cp;
  305.      cp := next_free_pt;
  306.      if debug2 then writeln ('lp=',lp,' cp=',cp,' np=',np);
  307.      x[cp] := round((x[lp]+x[np])/2);
  308.      y[cp] := round((y[lp]+y[np])/2);
  309.      ptr[lp] := cp;
  310.      ptr[cp] := np;
  311.      numpts := numpts +1;
  312. end;
  313.  
  314. procedure redraw;
  315. var cp,lp,np,k:integer;
  316. begin
  317.      if debug then msg ('redraw');
  318.      cp := firstpt;
  319.      setgmode;
  320.      gotoxy(1,1);
  321.      if (Ngraphchar >= 80) then
  322.        writeln ('Addpoint Delete Insert Move Redraw Params Writedata')
  323.      else if (Ngraphchar >= 40) then
  324.        writeln ('Add Del Ins Move Redraw Params Write');
  325.      { Hercules users get no text on graphics screen }
  326.  
  327.      gdraw (gxmin,gycenter,gxmax,gycenter,1);
  328.      gdraw (gxcenter,gymin,gxcenter,gymax,1);
  329.  
  330.      repeat
  331.            if debug2 then write (cp:2);
  332.            np := ptr[cp];
  333.            gdraw (x[cp],y[cp],x[np],y[np],linecolor);
  334.            cp := np;
  335.      until ptr[np]=0;
  336. end;
  337.  
  338. procedure pickpoint(var cp:integer;var ch: integer);
  339. var lp,np,tmpcp : integer;
  340. begin
  341.      msg('pick a point');
  342.      tmpcp := cp;
  343.      drawcross(cp,hilite);
  344.      repeat
  345.            ch := getch;
  346.            case ch of
  347.                 right : if cp<>finalpt then
  348.                         begin
  349.                              drawcross(cp,blank);
  350.                              cp := ptr[cp];
  351.                              drawcross(cp,hilite);
  352.                         end;
  353.                 left  : if cp<>firstpt then
  354.                         begin
  355.                              drawcross(cp,blank);
  356.                              cp := ptrto(cp);
  357.                              drawcross(cp,hilite);
  358.                         end;
  359.            end;{case ch of}
  360.     until not(ch in [left,right]);
  361.     drawcross(cp,blank);
  362.     if ch=esc then cp := tmpcp;
  363.     msg('            ');
  364. end;
  365.  
  366. procedure move(cp:integer);
  367. var lp,np,ch,tmpcpx,tmpcpy : integer;
  368. begin
  369.      msg('move the pt');
  370.      if cp=firstpt then lp:=firstpt
  371.         else lp := ptrto(cp);
  372.      if cp=finalpt then np:=finalpt
  373.         else np := ptr[cp];
  374.      tmpcpx := x[cp]; tmpcpy := y[cp];
  375.      gdraw (x[cp],y[cp],x[lp],y[lp],linecolor2);
  376.      gdraw (x[cp],y[cp],x[np],y[np],linecolor2);
  377.      repeat
  378.            ch := getch;
  379.            gdraw (x[cp],y[cp],x[lp],y[lp],blank);
  380.            gdraw (x[cp],y[cp],x[np],y[np],blank);
  381.  
  382.            case ch of
  383.                 left : if x[cp] > gxmin then x[cp] := x[cp] -1;
  384.                 right: if x[cp] < gxmax then x[cp] := x[cp] +1;
  385.                 up   : if y[cp] > gymin then y[cp] := y[cp] -1;
  386.                 down : if y[cp] < gymax then y[cp] := y[cp] +1;
  387.            end; {case}
  388.            gdraw (x[cp],y[cp],x[lp],y[lp],linecolor);
  389.            gdraw (x[cp],y[cp],x[np],y[np],linecolor);
  390.      until not(ch in [up,down,left,right]);
  391.      if ch = esc then
  392.      begin
  393.            gdraw (x[cp],y[cp],x[lp],y[lp],blank);
  394.            gdraw (x[cp],y[cp],x[np],y[np],blank);
  395.            x[cp] := tmpcpx; y[cp] := tmpcpy;
  396.            gdraw (x[cp],y[cp],x[lp],y[lp],linecolor);
  397.            gdraw (x[cp],y[cp],x[np],y[np],linecolor);
  398.      end;
  399.      msg('           ');
  400. end;
  401.  
  402. procedure addpoint(var cp:integer);
  403. var lp,np : integer;
  404. begin
  405.      if debug then msg('addpoint');
  406.      if cp = firstpt then
  407.      begin
  408.           lp := next_free_pt;
  409.           firstpt := lp;
  410.           ptr[lp] := cp;
  411.           x[lp] := x[cp];
  412.           y[lp] := y[cp];
  413.           cp := lp;
  414.           move(cp);
  415.           numpts := numpts +1;
  416.      end
  417.      else
  418.      if cp = finalpt then
  419.      begin
  420.           cp  := finalpt;
  421.           np := next_free_pt;
  422.           finalpt:= np;
  423.           ptr[cp]  := np;
  424.           ptr[lp] := cp;
  425.           x[np] := x[cp];
  426.           y[np] := y[cp];
  427.           cp := finalpt;
  428.           move (cp);
  429.           numpts := numpts +1;
  430.      end
  431.      else
  432.      msg ('You must be at either one of the ends');
  433. end;
  434.  
  435. procedure setparams;
  436. var i,chh,num : integer;
  437.     ch : char;
  438.     Realvar: vartype;      { variables from input }
  439.     Comment: text80;       { user's comment }
  440.  
  441. begin
  442.      nmatl := 1; version := 1;
  443.      maxvert := 4; nsides := 1;
  444.      noutln := numpts;
  445.      repeat
  446. {          clrscr;
  447.            lowvideo;
  448. }
  449.            gotoxy (1,5);
  450.            writeln ('1) r1,r2,r3 ',r1:6:2,spc ,r2:6:2,spc ,r3:6:2);
  451.            writeln ('2) ambient light intensity  ',ambient:6:3);
  452.            writeln ('3) number of points         ',noutln);
  453.            writeln ('4) number of angular slices ',nslice);
  454.            writeln ('5) number of materials   ',nmatl);
  455.            writeln ('6) orientation code      ',orient);
  456.            writeln ('7) scaling factors x,y,z      :',
  457.                      xscale:6:2,spc ,yscale:6:2,spc ,zscale:6:2);
  458.            writeln ('8) displacement factors x,y,z :',
  459.                      xshift:6:2,spc ,yshift:6:2,spc ,zshift:6:2);
  460.            writeln ('9) rotation around x,y,z      :  ',
  461.                      xrotate:6:2,'    ',yrotate:6:2,'     ',zrotate:6:2);
  462.  {         highvideo; }
  463.  
  464.            tmsg (' choose which one to change');
  465.            repeat chh := getch; until chh in [48..57,13];
  466.  
  467.            ch := chr(chh);
  468.            case ch of
  469.            '1' : begin
  470.                     repeat
  471.                        tmsg ('enter r1,r2,r3 : ');
  472.                        num := inreal(input,realvar,comment,0,true);
  473.                        if num=3 then
  474.                        begin
  475.                             r1 := realvar[1];
  476.                             r2 := realvar[2];
  477.                             r3 := realvar[3];
  478.                        end
  479.                        else if num >0 then
  480.                        begin
  481.                             tmsg('expecting 3 numeric values.');
  482.                             delay (1500);
  483.                        end;
  484.                     until (num=0) or (num=3);
  485.                end;
  486.            '2' : begin
  487.                     repeat
  488.                        tmsg ('enter ambient light intensity : ');
  489.                        num := inreal(input,realvar,comment,0,true);
  490.                        if num=1 then ambient := realvar[1]
  491.                        else if num >0 then
  492.                        begin
  493.                             tmsg('expecting 1 numeric value.');
  494.                             delay (1500);
  495.                        end;
  496.                     until (num=0) or (num=1);
  497.  
  498.                end;
  499.            '3' : begin tmsg ('Not settable'); delay(1000);end;
  500.            '4' : begin
  501.                       tmsg ('enter number of angular slices to take : ');
  502.                       readln (nslice);
  503.                  end;
  504.            '5' : begin tmsg ('not settable..defaults to 1'); delay(1000);end;
  505.            '6' : begin tmsg ('not settable..defaults to 3'); delay(1000);end;
  506.            '7' : begin
  507.                     repeat
  508.                        tmsg ('enter scaling factors for x,y,z : ');
  509.                        num := inreal(input,realvar,comment,0,true);
  510.                        if num=3 then
  511.                        begin
  512.                             xscale := realvar[1];
  513.                             yscale := realvar[2];
  514.                             zscale := realvar[3];
  515.                        end
  516.                        else if num >0 then
  517.                        begin
  518.                             tmsg('expecting 3 numeric values.');
  519.                             delay (1500);
  520.                        end;
  521.                     until (num=0) or (num=3);
  522.                end;
  523.            '8' : begin
  524.                     repeat
  525.                        tmsg ('enter disp. factors for x,y,z : ');
  526.                        num := inreal(input,realvar,comment,0,true);
  527.                        if num=3 then
  528.                        begin
  529.                             xshift := realvar[1];
  530.                             yshift := realvar[2];
  531.                             zshift := realvar[3];
  532.                        end
  533.                        else if num >0 then
  534.                        begin
  535.                             tmsg('expecting 3 numeric values.');
  536.                             delay (1500);
  537.                        end;
  538.                     until (num=0) or (num=3);
  539.                end;
  540.            '9' : begin
  541.                     repeat
  542.                        tmsg ('enter rotation for x,y,z (deg) : ');
  543.                        num := inreal(input,realvar,comment,0,true);
  544.                        if num=3 then
  545.                        begin
  546.                             xrotate := realvar[1];
  547.                             yrotate := realvar[2];
  548.                             zrotate := realvar[3];
  549.                        end
  550.                        else if num >0 then
  551.                        begin
  552.                             tmsg('expecting 3 numeric values.');
  553.                             delay (1500);
  554.                        end;
  555.                     until (num=0) or (num=3);
  556.                end;
  557.            end; {case}
  558.     until (chh = 48) or (chh=ret);
  559. end;
  560.  
  561. procedure writedata;
  562. var cp,lp,np,k:integer;
  563.     ch :char;
  564.  
  565. begin
  566.      tmsg ('Do you really want to save the data (Y/N)');
  567.      read (kbd,ch);
  568.      if ch in ['Y','y'] then
  569.      begin
  570.           if outfilename = '' then
  571.           begin
  572.                tmsg ('File name : ');
  573.                readln (outfilename);
  574.                tmsg ('Plot title : ');
  575.                readln (title);
  576.                { Strip any filename extension off the name }
  577.                period := pos ('.', outfilename);
  578.                if (period > 0) then
  579.                  outfilename := copy (outfilename, 1, period-1);
  580.                { PREPROC file has a .IN extension }
  581.                prefilename := outfilename + '.IN';
  582.                { Batch file has a .BAT extension }
  583.                batfilename := outfilename + '.BAT';
  584.           end;
  585.           assign (outfile,prefilename);
  586.           rewrite (outfile);
  587.  
  588.           writeln (outfile,title);
  589.           writeln (outfile,version);
  590.           writeln (outfile,nmatl:3,maxvert:3,nsides:3);
  591.           writeln (outfile, r1:3:1,spc ,r2:3:1,spc ,r3:3:1,spc
  592.                           ,color:3,spc ,ambient:3:1);
  593.           writeln (outfile,shapecode);
  594.           writeln (outfile,numpts:4  ,nslice:4 ,material:3 ,orient:3);
  595.           write   (outfile,xscale:3:1,spc ,yscale:3:1,spc ,zscale:3:1,spc );
  596.           writeln (outfile,xshift:3:1,spc ,yshift:3:1,spc ,zshift:3:1);
  597.           writeln (outfile,xrotate:3:1,spc ,yrotate:3:1,spc ,zrotate:3:1);
  598.           cp := firstpt;
  599.           repeat
  600.                 writeln (outfile, xfactor*(x[cp]-gxcenter),
  601.                          spc ,gycenter-y[cp]);
  602.                 cp := ptr[cp];
  603.           until ptr[cp]=0;
  604.           { one more write for the last point }
  605.           writeln (outfile, xfactor*(x[cp]-gxcenter),
  606.                    spc ,gycenter-y[cp]);
  607.           writeln (outfile,0);
  608.           close (outfile);
  609.  
  610.           { Now write the batch file }
  611.           assign (outfile,batfilename);
  612.           rewrite (outfile);
  613.           writeln (outfile, 'PREPROC ', prefilename, ' ', outfilename);
  614.           writeln (outfile, 'SURFMODL ', outfilename);
  615.           close (outfile);
  616.           writeln ('To view this file in SURFMODL, just type "',
  617.                    outfilename,'"');
  618.           delay(1500);
  619.      end;
  620. end;
  621.  
  622. begin { main }
  623.      tbinit := false;
  624.      sys_type_set := false;
  625.      flpurpose := '';
  626.      if (numlglsys = 1) then
  627.        system := lglsys[1]
  628.      else while (not sys_type_set) do begin
  629.        writeln ('Choose from the following legal system types:');
  630.        for sys := 1 to numlglsys do
  631.          writeln (lglsys[sys],'  ',sys_name[lglsys[sys]]);
  632.        write ('Enter your system type number: ');
  633.        readln (system);
  634.        for sys := 1 to numlglsys do
  635.          if (system = lglsys[sys]) then
  636.            sys_type_set := true;
  637.        if (not sys_type_set) then
  638.          writeln ('   Illegal System number.');
  639.      end; { while }
  640.      setsys; { set gxmin,gxmax,gymin,gymax,ngraphchar & ncolors }
  641.      { 9.375 is x dimension of screen in inches; 6.625 is y dimension. }
  642.      xfactor := ((Gymax - Gymin) / (Gxmax - Gxmin)) * 9.375 / 6.625;
  643.      debug := false;
  644.      debug2 := false;
  645.      for i := 1 to maxpts do
  646.      begin
  647.           x[i] := 0;  y[i] := 0; ptr[i] :=0;
  648.      end;
  649.      version:= 1; nmatl := 1; maxvert :=4 ;
  650.      nsides := 1; r1 := 1; r2 := 1; r3 := 1;
  651.      ambient:=0.2;color  := 1; noutln  := 1;
  652.      nslice := 20; orient := 3; material:= 1;
  653.      xscale := 1; yscale := 1; zscale :=1;
  654.      xshift := 0; yshift := 0; zshift :=0;
  655.      xrotate:= 0; yrotate:= 0; zrotate:=0;
  656.      if (ncolors > 1) then
  657.        linecolor := 2
  658.      else
  659.        linecolor := 1;
  660.      if (ncolors > 2) then
  661.        linecolor2 := 3
  662.      else
  663.        linecolor2 := 1;
  664.      if (ncolors >= 12) then
  665.        hilite := 12
  666.      else if (ncolors >= 4) then
  667.        hilite := 4
  668.      else
  669.        hilite := 1;
  670.  
  671.      numpts := 2; lastpt  := 1; nextpt  := 1;
  672.      curpt  := 2; firstpt := 1; finalpt := 2;
  673.      gxcenter := round(gxmax/2);
  674.      gycenter := round(gymax/2);
  675.      x[1]   := gxcenter-50; y[1]  := gycenter-10; ptr[1] := 2;
  676.      x[2]   := gxcenter-10; y[2]  := gycenter-10; ptr[2] := 0;
  677.      outfilename :='';
  678.      setgmode;
  679.      redraw;
  680.  
  681.      repeat
  682.            drawcross(curpt,hilite);
  683.            ch :=0;
  684.            repeat pickpoint (curpt,ch);
  685.            until (upcase(chr(ch)) in ['A','I','D','M','R','P','W'])
  686.                  or (ch in [up,down,left,right,esc]);
  687.            drawcross(curpt,blank);
  688.  
  689.            case upcase(CHR(ch)) of
  690.            'A' : addpoint (curpt);
  691.            'I' : begin
  692.                       pickpoint(curpt,ch);
  693.                       split(curpt);
  694.                       move (curpt);
  695.                   end;
  696.            'D' : begin
  697.                       pickpoint(curpt,ch);
  698.                       if curpt=firstpt then
  699.                       begin
  700.                            firstpt := ptr[curpt];
  701.                            x[curpt]:=0; y[curpt]:=0;
  702.                            curpt:=firstpt;
  703.                       end
  704.                       else if curpt=finalpt then
  705.                       begin
  706.                            x[curpt]:=0; y[curpt]:=0;
  707.                            curpt := ptrto(curpt);
  708.                            ptr[curpt]:=0;
  709.                            finalpt:=curpt;
  710.                       end
  711.                       else
  712.                       begin
  713.                            lastpt := ptrto(curpt);
  714.                            nextpt := ptr[curpt];
  715.                            x[curpt] := 0;
  716.                            y[curpt] := 0;
  717.                            ptr[lastpt] := nextpt;
  718.                            curpt := lastpt;
  719.                       end;
  720.                       numpts := numpts -1;
  721.                  end;
  722.            'M' : move(curpt);
  723.            'R' : redraw;
  724.            'P' : begin
  725.                       exgraphic;
  726.                       setparams;
  727.                       setgmode;
  728.                       redraw;
  729.                  end;
  730.            'W' : begin
  731.                       exgraphic;
  732.                       writedata;
  733.                       setgmode;
  734.                       redraw;
  735.                  end;
  736.            end;{case ch of}
  737.            if arrow = true then pickpoint(curpt,ch);
  738.      until (ch=esc);
  739.      exgraphic;
  740.      writeln ('Finished....');
  741. end.
  742.