ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/GRAPHICS/PLOT/SURFUTI3.ZIP/REV.PAS

Pascal/Delphi Source File | 1991-11-19 | 18.4 KB | 571 lines

program revolution;
uses crt,surfgraf;
{ Written by Ian Murphy }

{ fri 6th-nov-87 : wrote most of code, addpoint/insert/delete/move, very buggy
  mon 9th-nov-87 : noticed the pointer bug, couldn't track it down.
                   added redraw/ select point.
  tue 10th-nov-87: Found&fixed the above bug. added axes, menu for params
  wed 11th-nov-87: improved parameters menu, added saving data
  thur12th-nov-87: tidied up the bits and pieces

  16 Jan. 1987:    Re-written in turbo 4 by Kevin Lowey
  }



{ Global variables and constants for SURFMODL }


const
      spc = ' ';
      shapecode = 2; { surface of revolution}
      maxpts= 100;
      up    = 242; down =250;  left = 245;
      right = 247; esc  =27;   space= 32;
      ret   = 13;
      blank = 0;
      MAXVAR = 20;          { maximum # of numeric inputs on a line }

type anystring = string[80];
     vartype = array[1..MAXVAR] of real;
     text80 = string[80];
var
    version,nmatl,maxvert,nsides  : integer;
    r1,r2,r3,ambient : real; color : integer;
    noutln,nslice,material,orient  : integer;
    xscale,yscale,zscale,xshift,yshift,zshift : real;
    xrotate,yrotate,zrotate : real;
    x,y,ptr : array [1..maxpts] of integer;
    firstpt,finalpt,lastpt,numpts,nextpt,curpt : integer;
    i,j,ch : integer;
    mono,arrow,debug,debug2 : boolean ;
    infile,outfile  : text;
    infilename,outfilename : text80;
    title : text80;
    flpurpose : text80;
    gxcenter,gycenter : integer;
    linecolor, linecolor2 : integer;
    hilite : integer;
    ngraphchar : integer;
    tbinit : boolean;
    sys : integer;
    sys_type_set : boolean;
    xfactor : real;
    period : integer;
    prefilename, batfilename : text80;
    { Following vbls not used, but defined only to allow compilation
      of drawplot.pas }
    dorandom : boolean;
    randshade : real;

{ Dummy STOPSTAT procedure for REVOLUTE }
procedure STOPSTAT;
begin
end;

{$i colormod.inc}
{$i oinreal.inc}


procedure msg(s:anystring);
begin
   if (Ngraphchar >= 40) then begin
     gotoxy (1,2);
     write ('                                              ');
     gotoxy (1,2);
     write (s);
   end;
end;

procedure tmsg(s:anystring);
{ same as msg, but used in textmode so it doesn't matter whether the system
  has ability to display characters on the graphics screen }
begin
     gotoxy (1,2);
     write ('                                              ');
     gotoxy (1,2);
     write (s);
end;

function next_free_pt:integer;
var i : integer;
begin
     if debug then msg('Next_free_pt');
     i := 0;
     repeat
           i := i +1;
     until (x[i] =0) and (y[i]=0);
     next_free_pt := i;
end;

function getch:integer;
var ch:char;
begin
     if debug then msg('readch');
     ch := readkey;
     arrow :=false;
     if ((ch=#0) and keypressed) then
     begin
          arrow:=true;
          ch := readkey;
     end;
     if arrow then getch:=ord(ch)+170
     else getch:=ord(ch)
end;

function ptrto(cp:integer):integer;
var x,lastx : integer;
begin
     if debug then msg('ptrto');
     x:= firstpt;
     repeat
           if debug2 then writeln ('cp ',cp,' ptr[',x,']=',ptr[x]);
           lastx :=x;
           x := ptr[x];
           if debug2 then write (x);
     until (x=cp)or(x=0);
     ptrto := lastx;
     if debug2 then writeln ('cp ',cp,' ptr[',x,']=',ptr[x]);
end;

procedure drawcross(cp,color:integer);
const crossize = 3;
begin
     if debug then msg('drawcross');
     gdraw (x[cp]-crossize,y[cp],x[cp]+crossize,y[cp],color);
     gdraw (x[cp],y[cp]-crossize,x[cp],y[cp]+crossize,color);
end;

procedure split (var cp:integer);
var np,lp :integer;
begin
     if debug then msg('split');
     if cp <>firstpt then cp := ptrto(cp);
     np := ptr[cp];
     lp := cp;
     cp := next_free_pt;
     if debug2 then writeln ('lp=',lp,' cp=',cp,' np=',np);
     x[cp] := round((x[lp]+x[np])/2);
     y[cp] := round((y[lp]+y[np])/2);
     ptr[lp] := cp;
     ptr[cp] := np;
     numpts := numpts +1;
end;

procedure redraw;
var cp,lp,np,k:integer;
begin
     if debug then msg ('redraw');
     cp := firstpt;
     setgmode;
     gotoxy(1,1);
     if (Ngraphchar >= 80) then
       writeln ('Addpoint Delete Insert Move Redraw Params Writedata')
     else if (Ngraphchar >= 40) then
       writeln ('Add Del Ins Move Redraw Params Write');
     { Hercules users get no text on graphics screen }

     gdraw (gxmin,gycenter,gxmax,gycenter,1);
     gdraw (gxcenter,gymin,gxcenter,gymax,1);

     repeat
           if debug2 then write (cp:2);
           np := ptr[cp];
           gdraw (x[cp],y[cp],x[np],y[np],linecolor);
           cp := np;
     until ptr[np]=0;
end;

procedure pickpoint(var cp:integer;var ch: integer);
var lp,np,tmpcp : integer;
begin
     msg('pick a point');
     tmpcp := cp;
     drawcross(cp,hilite);
     repeat
           ch := getch;
           case ch of
                right : if cp<>finalpt then
                        begin
                             drawcross(cp,blank);
                             cp := ptr[cp];
                             drawcross(cp,hilite);
                        end;
                left  : if cp<>firstpt then
                        begin
                             drawcross(cp,blank);
                             cp := ptrto(cp);
                             drawcross(cp,hilite);
                        end;
           end;{case ch of}
    until not(ch in [left,right]);
    drawcross(cp,blank);
    if ch=esc then cp := tmpcp;
    msg('            ');
end;

procedure move(cp:integer);
var lp,np,ch,tmpcpx,tmpcpy : integer;
begin
     msg('move the pt');
     if cp=firstpt then lp:=firstpt
        else lp := ptrto(cp);
     if cp=finalpt then np:=finalpt
        else np := ptr[cp];
     tmpcpx := x[cp]; tmpcpy := y[cp];
     gdraw (x[cp],y[cp],x[lp],y[lp],linecolor2);
     gdraw (x[cp],y[cp],x[np],y[np],linecolor2);
     repeat
           ch := getch;
           gdraw (x[cp],y[cp],x[lp],y[lp],blank);
           gdraw (x[cp],y[cp],x[np],y[np],blank);

           case ch of
                left : if x[cp] > gxmin then x[cp] := x[cp] -1;
                right: if x[cp] < gxmax then x[cp] := x[cp] +1;
                up   : if y[cp] > gymin then y[cp] := y[cp] -1;
                down : if y[cp] < gymax then y[cp] := y[cp] +1;
           end; {case}
           gdraw (x[cp],y[cp],x[lp],y[lp],linecolor);
           gdraw (x[cp],y[cp],x[np],y[np],linecolor);
     until not(ch in [up,down,left,right]);
     if ch = esc then
     begin
           gdraw (x[cp],y[cp],x[lp],y[lp],blank);
           gdraw (x[cp],y[cp],x[np],y[np],blank);
           x[cp] := tmpcpx; y[cp] := tmpcpy;
           gdraw (x[cp],y[cp],x[lp],y[lp],linecolor);
           gdraw (x[cp],y[cp],x[np],y[np],linecolor);
     end;
     msg('           ');
end;

procedure addpoint(var cp:integer);
var lp,np : integer;
begin
     if debug then msg('addpoint');
     if cp = firstpt then
     begin
          lp := next_free_pt;
          firstpt := lp;
          ptr[lp] := cp;
          x[lp] := x[cp];
          y[lp] := y[cp];
          cp := lp;
          move(cp);
          numpts := numpts +1;
     end
     else
     if cp = finalpt then
     begin
          cp  := finalpt;
          np := next_free_pt;
          finalpt:= np;
          ptr[cp]  := np;
          ptr[lp] := cp;
          x[np] := x[cp];
          y[np] := y[cp];
          cp := finalpt;
          move (cp);
          numpts := numpts +1;
     end
     else
     msg ('You must be at either one of the ends');
end;

procedure setparams;
var i,chh,num : integer;
    ch : char;
    Realvar: vartype;      { variables from input }
    Comment: text80;       { user's comment }

begin
     nmatl := 1; version := 1;
     maxvert := 4; nsides := 1;
     noutln := numpts;
     repeat
{          clrscr;
           lowvideo;
}
           gotoxy (1,5);
           writeln ('1) r1,r2,r3 ',r1:6:2,spc ,r2:6:2,spc ,r3:6:2);
           writeln ('2) ambient light intensity  ',ambient:6:3);
           writeln ('3) number of points         ',noutln);
           writeln ('4) number of angular slices ',nslice);
           writeln ('5) number of materials   ',nmatl);
           writeln ('6) orientation code      ',orient);
           writeln ('7) scaling factors x,y,z      :',
                     xscale:6:2,spc ,yscale:6:2,spc ,zscale:6:2);
           writeln ('8) displacement factors x,y,z :',
                     xshift:6:2,spc ,yshift:6:2,spc ,zshift:6:2);
           writeln ('9) rotation around x,y,z      :  ',
                     xrotate:6:2,'    ',yrotate:6:2,'     ',zrotate:6:2);
 {         highvideo; }

           tmsg (' choose which one to change');
           repeat chh := getch; until chh in [48..57,13];

           ch := chr(chh);
           case ch of
           '1' : begin
                    repeat
                       tmsg ('enter r1,r2,r3 : ');
                       num := inreal(input,realvar,comment,0,true);
                       if num=3 then
                       begin
                            r1 := realvar[1];
                            r2 := realvar[2];
                            r3 := realvar[3];
                       end
                       else if num >0 then
                       begin
                            tmsg('expecting 3 numeric values.');
                            delay (1500);
                       end;
                    until (num=0) or (num=3);
               end;
           '2' : begin
                    repeat
                       tmsg ('enter ambient light intensity : ');
                       num := inreal(input,realvar,comment,0,true);
                       if num=1 then ambient := realvar[1]
                       else if num >0 then
                       begin
                            tmsg('expecting 1 numeric value.');
                            delay (1500);
                       end;
                    until (num=0) or (num=1);

               end;
           '3' : begin tmsg ('Not settable'); delay(1000);end;
           '4' : begin
                      tmsg ('enter number of angular slices to take : ');
                      readln (nslice);
                 end;
           '5' : begin tmsg ('not settable..defaults to 1'); delay(1000);end;
           '6' : begin tmsg ('not settable..defaults to 3'); delay(1000);end;
           '7' : begin
                    repeat
                       tmsg ('enter scaling factors for x,y,z : ');
                       num := inreal(input,realvar,comment,0,true);
                       if num=3 then
                       begin
                            xscale := realvar[1];
                            yscale := realvar[2];
                            zscale := realvar[3];
                       end
                       else if num >0 then
                       begin
                            tmsg('expecting 3 numeric values.');
                            delay (1500);
                       end;
                    until (num=0) or (num=3);
               end;
           '8' : begin
                    repeat
                       tmsg ('enter disp. factors for x,y,z : ');
                       num := inreal(input,realvar,comment,0,true);
                       if num=3 then
                       begin
                            xshift := realvar[1];
                            yshift := realvar[2];
                            zshift := realvar[3];
                       end
                       else if num >0 then
                       begin
                            tmsg('expecting 3 numeric values.');
                            delay (1500);
                       end;
                    until (num=0) or (num=3);
               end;
           '9' : begin
                    repeat
                       tmsg ('enter rotation for x,y,z (deg) : ');
                       num := inreal(input,realvar,comment,0,true);
                       if num=3 then
                       begin
                            xrotate := realvar[1];
                            yrotate := realvar[2];
                            zrotate := realvar[3];
                       end
                       else if num >0 then
                       begin
                            tmsg('expecting 3 numeric values.');
                            delay (1500);
                       end;
                    until (num=0) or (num=3);
               end;
           end; {case}
    until (chh = 48) or (chh=ret);
end;

procedure writedata;
var cp,lp,np,k:integer;
    ch :char;

begin
     tmsg ('Do you really want to save the data (Y/N)');
     ch := readkey;
     if ch in ['Y','y'] then
     begin
          if outfilename = '' then
          begin
               tmsg ('File name : ');
               readln (outfilename);
               tmsg ('Plot title : ');
               readln (title);
               { Strip any filename extension off the name }
               period := pos ('.', outfilename);
               if (period > 0) then
                 outfilename := copy (outfilename, 1, period-1);
               { PREPROC file has a .IN extension }
               prefilename := outfilename + '.IN';
               { Batch file has a .BAT extension }
               batfilename := outfilename + '.BAT';
          end;
          assign (outfile,prefilename);
          rewrite (outfile);

          writeln (outfile,title);
          writeln (outfile,version);
          writeln (outfile,nmatl:3,maxvert:3,nsides:3);
          writeln (outfile, r1:3:1,spc ,r2:3:1,spc ,r3:3:1,spc
                          ,color:3,spc ,ambient:3:1);
          writeln (outfile,shapecode);
          writeln (outfile,numpts:4  ,nslice:4 ,material:3 ,orient:3);
          write   (outfile,xscale:3:1,spc ,yscale:3:1,spc ,zscale:3:1,spc );
          writeln (outfile,xshift:3:1,spc ,yshift:3:1,spc ,zshift:3:1);
          writeln (outfile,xrotate:3:1,spc ,yrotate:3:1,spc ,zrotate:3:1);
          cp := firstpt;
          repeat
                writeln (outfile, xfactor*(x[cp]-gxcenter),
                         spc ,gycenter-y[cp]);
                cp := ptr[cp];
          until ptr[cp]=0;
          { one more write for the last point }
          writeln (outfile, xfactor*(x[cp]-gxcenter),
                   spc ,gycenter-y[cp]);
          writeln (outfile,0);
          close (outfile);

          { Now write the batch file }
          assign (outfile,batfilename);
          rewrite (outfile);
          writeln (outfile, 'PREPROC ', prefilename, ' ', outfilename);
          writeln (outfile, 'SURFMODL ', outfilename);
          close (outfile);
          writeln ('To view this file in SURFMODL, just type "',
                   outfilename,'"');
          delay(1500);
     end;
end;

begin { main }
     tbinit := false;
     sys_type_set := false;
     flpurpose := '';
     setsys; { set gxmin,gxmax,gymin,gymax,ngraphchar & ncolors }
     { 9.375 is x dimension of screen in inches; 6.625 is y dimension. }
     xfactor := ((Gymax - Gymin) / (Gxmax - Gxmin)) * 9.375 / 6.625;
     debug := false;
     debug2 := false;
     for i := 1 to maxpts do
     begin
          x[i] := 0;  y[i] := 0; ptr[i] :=0;
     end;
     version:= 1; nmatl := 1; maxvert :=4 ;
     nsides := 1; r1 := 1; r2 := 1; r3 := 1;
     ambient:=0.2;color  := 1; noutln  := 1;
     nslice := 20; orient := 3; material:= 1;
     xscale := 1; yscale := 1; zscale :=1;
     xshift := 0; yshift := 0; zshift :=0;
     xrotate:= 0; yrotate:= 0; zrotate:=0;
     if (ncolors > 1) then
       linecolor := 2
     else
       linecolor := 1;
     if (ncolors > 2) then
       linecolor2 := 3
     else
       linecolor2 := 1;
     if (ncolors >= 12) then
       hilite := 12
     else if (ncolors >= 4) then
       hilite := 4
     else
       hilite := 1;

     numpts := 2; lastpt  := 1; nextpt  := 1;
     curpt  := 2; firstpt := 1; finalpt := 2;
     gxcenter := round(gxmax/2);
     gycenter := round(gymax/2);
     x[1]   := gxcenter-50; y[1]  := gycenter-10; ptr[1] := 2;
     x[2]   := gxcenter-10; y[2]  := gycenter-10; ptr[2] := 0;
     outfilename :='';
     setgmode;
     redraw;

     repeat
           drawcross(curpt,hilite);
           ch :=0;
           repeat pickpoint (curpt,ch);
           until (upcase(chr(ch)) in ['A','I','D','M','R','P','W'])
                 or (ch in [up,down,left,right,esc]);
           drawcross(curpt,blank);

           case upcase(CHR(ch)) of
           'A' : addpoint (curpt);
           'I' : begin
                      pickpoint(curpt,ch);
                      split(curpt);
                      move (curpt);
                  end;
           'D' : begin
                      pickpoint(curpt,ch);
                      if curpt=firstpt then
                      begin
                           firstpt := ptr[curpt];
                           x[curpt]:=0; y[curpt]:=0;
                           curpt:=firstpt;
                      end
                      else if curpt=finalpt then
                      begin
                           x[curpt]:=0; y[curpt]:=0;
                           curpt := ptrto(curpt);
                           ptr[curpt]:=0;
                           finalpt:=curpt;
                      end
                      else
                      begin
                           lastpt := ptrto(curpt);
                           nextpt := ptr[curpt];
                           x[curpt] := 0;
                           y[curpt] := 0;
                           ptr[lastpt] := nextpt;
                           curpt := lastpt;
                      end;
                      numpts := numpts -1;
                 end;
           'M' : move(curpt);
           'R' : redraw;
           'P' : begin
                      exgraphic;
                      setparams;
                      setgmode;
                      redraw;
                 end;
           'W' : begin
                      exgraphic;
                      writedata;
                      setgmode;
                      redraw;
                 end;
           end;{case ch of}
           if arrow = true then pickpoint(curpt,ch);
     until (ch=esc);
     exgraphic;
     writeln ('Finished....');
end.