home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / BEEHIVE / UTILITYS / PUDD.ARC / PUDD-02.PAS < prev    next >
Pascal/Delphi Source File  |  1991-08-11  |  12KB  |  471 lines
  1.  
  2.  
  3.  
  4. procedure HeadLine;
  5. begin
  6.  ClrScr;
  7.  GoToXY(2,1);
  8.  write('Line Style is ');
  9.  write(vLineStyle);
  10.  write(', color is ');
  11.  write(vLineColor);
  12.  GoToXY(2,2);
  13.  write('Fill Style is ');
  14.  write(vFillStyle);
  15.  write(', mode is ');
  16.  write(vWriteMode);
  17.  write(' with and index of ');
  18.  writeln(vFillIndex);
  19.  GoToXY(2,3);
  20.  write('Current curser position is X = ');
  21.  write(Xpoz);
  22.  write(', Y = ');
  23.  write(Ypoz);
  24.  write('  Speed is ');
  25.  write(speed);
  26.  GoToXY(2,4);
  27.  write('Current screen position is X = ');
  28.  write(x1);
  29.  write(', Y = ');
  30.  write(y1);
  31.  write(' Curser is ');
  32.  case Size of
  33.   5:  write('regular');
  34.   0:  write('off');
  35.   63: write('big');
  36.  end;   {....case }
  37.  GoToXY(2,5);
  38.  write('Please select......');
  39.  GoToXY(1,7);
  40.   writeln(' FROM HERE              IN GRAPHICS');
  41.   writeln('    (H)elp                 (R)eturn to main menu    c(U)rves ');
  42.   writeln('    (G)raphic screen       (D)raw w/ update point   ');
  43.   writeln('    (F)iles                (L)ine w/o update        ');
  44.   writeln('    (C)hange status        (P)oint set              ');
  45.   writeln('    (P)rint screen         e(X)tensive drawing      ');
  46.   writeln('    (Q)uit                 (F)ill an area           ');
  47.   writeln('    (W)rite                (E)rase an area          ');
  48.   writeln('                           (B)lock create/fill      ');
  49.   writeln('                           (R)eturn to main menu    ');
  50.   writeln('                           (S)peed set              ');
  51.   writeln('                              also 5 sets speed     ');
  52.   writeln('                           (W)ipe screen            ');
  53.   writeln('                           (A)rrow                  ');
  54.   writeln('                           (T)ext                   ');
  55.   writeln('                           (C)hange defaults        ');
  56. end;
  57.  
  58. procedure SetSpeed(var speed:integer);
  59. var response  :char;
  60.     junk      :integer;
  61. begin
  62.  alphamode;
  63.  clrscr;
  64.  gotoXY(10,10);
  65.  write('Please enter the new curser movement speed...');
  66.  read(kbd,response);
  67.  val(response,speed,junk);
  68.  gotoXY(10,24);
  69.  ClrEol;
  70.  initgraph
  71. end;
  72.  
  73.  
  74. procedure eXtensive(   size      :integer;
  75.                    var x1,y1     :integer;
  76.                    var Xpoz,Ypoz :integer);
  77. var direction :char;
  78. begin
  79.  PointSet(size,x1,y1,Xpoz,Ypoz);
  80.  repeat
  81.   read(kbd,direction);
  82.   direction := UpCase(direction);
  83.   if (direction = '5') or (direction = 'S') then
  84.    SetSpeed(speed)
  85.   else
  86.    begin
  87.     MoveCross(size,speed,direction,Xpoz,Ypoz);
  88.     DrawNext(size,x1,y1,Xpoz,Ypoz);
  89.    end;
  90.  until direction = 'X';
  91. end;
  92.  
  93.  
  94. procedure ClrSomeScr(Here,there:integer);
  95. var i:  integer;
  96. begin
  97.  for i := here to there do
  98.   begin
  99.    gotoXY(1,i);
  100.    ClrEol;
  101.   end;
  102. end;
  103.  
  104.  
  105. procedure Set1(var vLineStyle:DefTypes);
  106. var  response :char;
  107. begin
  108.  ClrSomeScr(12,24);
  109.  gotoXY(10,12);
  110.  write('Line styles available.......');
  111.  gotoXY(15,13);
  112.  write('1) Solid');
  113.  gotoXY(15,14);
  114.  write('2) Dashed');
  115.  gotoXY(15,15);
  116.  write('3) Dotted');
  117.  gotoXY(15,16);
  118.  write('4) Dash-Dot');
  119.  gotoXY(15,17);
  120.  write('5) Long-Dash');
  121.  gotoXY(15,18);
  122.  write('6) Short-Dash');
  123.  gotoXY(15,19);
  124.  write('7) Dot-Dot-Dash');
  125.  gotoXY(15,20);
  126.  write('8) Long-Dot');
  127.  gotoXY(41,18);
  128.  write('choice ?');
  129.  read(kbd,response);
  130.  case response of
  131.   '1':vLineStyle := 'Solid';
  132.   '2':vLineStyle := 'Dashed';
  133.   '3':vLineStyle := 'Dotted';
  134.   '4':vLineStyle := 'Dash-Dot';
  135.   '5':vLineStyle := 'Long-Dash';
  136.   '6':vLineStyle := 'Short-Dash';
  137.   '7':vLineStyle := 'Dot-Dot-Dash';
  138.   '8':vLineStyle := 'Long-Dot';
  139.  end;  {......case }
  140. end;
  141.  
  142.  
  143.  
  144. procedure Set2(var vLineColor:DefTypes);
  145. var  response :char;
  146. begin
  147.  ClrSomeScr(12,24);
  148.  gotoXY(10,12);
  149.  write('Line colors can be.......');
  150.  gotoXY(15,13);
  151.  write('1) White');
  152.  gotoXY(15,14);
  153.  write('2) Black');
  154.  gotoXY(41,18);
  155.  write('choice ?');
  156.  read(kbd,response);
  157.  case response of
  158.   '1':vLineColor := 'White';
  159.   '2':vLineColor := 'Black';
  160.  end;  {......case }
  161. end;
  162.  
  163.  
  164.  
  165. procedure Set3(var vFillStyle:DefTypes);
  166. var  response :char;
  167. begin
  168.  ClrSomeScr(12,24);
  169.  gotoXY(10,12);
  170.  write('Fill Styles are.......');
  171.  gotoXY(15,13);
  172.  write('1) Hollow');
  173.  gotoXY(15,14);
  174.  write('2) Solid');
  175.  gotoXY(15,15);
  176.  write('3) Pattern');
  177.  gotoXY(15,16);
  178.  write('4) Hatched');
  179.  gotoXY(41,18);
  180.  write('choice ?');
  181.  read(kbd,response);
  182.  case response of
  183.   '1':vFillStyle := 'Hollow';
  184.   '2':vFillStyle := 'Solid';
  185.   '3':vFillStyle := 'Pattern';
  186.   '4':vFillStyle := 'Hatched';
  187.  end;  {......case }
  188. end;
  189.  
  190.  
  191. procedure Set4(var vFillIndex:Integer);
  192. var  response :char;
  193. begin
  194.  ClrSomeScr(12,24);
  195.  gotoXY(10,12);
  196.  write('Fill Indices effect style as.......  index (pattern) or (hatched)');
  197.  gotoXY(15,13);
  198.  write('0) Intensity 0   or  Vertical ');
  199.  gotoXY(15,14);
  200.  write('1) Intensity 1   or  Horizontal');
  201.  gotoXY(15,15);
  202.  write('2) Intensity 2   or  Diagonal positive');
  203.  gotoXY(15,16);
  204.  write('3) Intensity 3   or  Diagonal negative');
  205.  gotoXY(15,17);
  206.  write('4) Intensity 4   or  Vert/Horz');
  207.  gotoXY(15,18);
  208.  write('5) Intensity 5   or  Vert/Diag +');
  209.  gotoXY(15,19);
  210.  write('6) Intensity 6   or  Vert/Diag -');
  211.  gotoXY(15,20);
  212.  write('7) Intensity 7   or  Diag +/Diag -');
  213.  gotoXY(61,18);
  214.  write('choice ?');
  215.  read(kbd,response);
  216.  case response of
  217.   '0':vFillIndex := 0;
  218.   '1':vFillIndex := 1;
  219.   '2':vFillIndex := 2;
  220.   '3':vFillIndex := 3;
  221.   '4':vFillIndex := 4;
  222.   '5':vFillIndex := 5;
  223.   '6':vFillIndex := 6;
  224.   '7':vFillIndex := 7;
  225.  end;  {......case }
  226. end;
  227.  
  228.  
  229.  
  230. procedure Set5(var vFillColor:DefTypes);
  231. var  response :char;
  232. begin
  233.  ClrSomeScr(12,24);
  234.  gotoXY(10,12);
  235.  write('Fill colors can be.......');
  236.  gotoXY(15,13);
  237.  write('1) White');
  238.  gotoXY(15,14);
  239.  write('2) Black');
  240.  gotoXY(41,18);
  241.  write('choice ?');
  242.  read(kbd,response);
  243.  case response of
  244.   '1':vFillColor := 'White';
  245.   '2':vFillColor := 'Black';
  246.  end;  {......case }
  247. end;
  248.  
  249.  
  250.  
  251. procedure Set6(var vWriteMode:DefTypes);
  252. var  response :char;
  253. begin
  254.  ClrSomeScr(12,24);
  255.  gotoXY(10,12);
  256.  write('Write Modes are.......');
  257.  gotoXY(15,13);
  258.  write('1) Replace');
  259.  gotoXY(15,14);
  260.  write('2) Fill');
  261.  gotoXY(15,15);
  262.  write('3) OverWrite');
  263.  gotoXY(15,16);
  264.  write('4) Reverse');
  265.  gotoXY(41,18);
  266.  write('choice ?');
  267.  read(kbd,response);
  268.  case response of
  269.   '1':vWriteMode := 'Replace';
  270.   '2':vWriteMode := 'Fill';
  271.   '3':vWriteMode := 'OverWrite';
  272.   '4':vWriteMode := 'Reverse';
  273.  end;  {......case }
  274. end;
  275.  
  276.  
  277.  
  278. procedure Set7(var size:integer);
  279. var NewSize :integer;
  280. begin
  281.  NewSize := size;
  282.  ClrSomeScr(12,24);
  283.  gotoXY(10,12);
  284.  write('You can have .......');
  285.  gotoXY(15,13);
  286.  write('1) Regular crosshair');
  287.  gotoXY(15,14);
  288.  write('2) Big crosshair');
  289.  gotoXY(15,15);
  290.  write('3) No Crosshair');
  291.  gotoXY(51,18);
  292.  write('choice ?');
  293.  read(kbd,response);
  294.  case response of
  295.   '1':begin
  296.        NewSize := 5;
  297.       end;
  298.   '2':begin
  299.        NewSize := 63;
  300.      end;
  301.   '3':begin
  302.          NewSize := 0;
  303.       end;
  304.  end;  {......case }
  305.  offXhair(size,xPoz,yPoz);
  306.  size := NewSize;
  307.  initXhair(size,xpoz,ypoz);
  308. end;
  309.  
  310. procedure Status; {..... a lot of global var's here }
  311. var    response   :char;
  312.  
  313. begin
  314.  alphamode;
  315.  response := '?';
  316.  repeat
  317.    ClrScr;
  318.    gotoXY(1,1);
  319.    write('              Variable                Current Value ');
  320.    writeln;
  321.    write('               1) LineStyle         ');writeln(vLineStyle);
  322.    write('               2) LineColor         ');writeln(vLineColor);
  323.    write('               3) FillStyle         ');writeln(vFillStyle);
  324.    write('               4) FillIndex         ');writeln(vFillIndex);
  325.    write('               5) FillColor         ');writeln(vFillColor);
  326.    write('               6) FillMode          ');writeln(vWriteMode);
  327.    write('               7) CrossHair         ');
  328.     case size of
  329.       5:writeln('regular');
  330.       0:writeln('is turned off');
  331.       63:writeln('big');
  332.     end;      {....case }
  333.    writeln;
  334.    write('Enter value to change.......');
  335.    read(kbd,response);
  336.    case response of
  337.     '1':Set1(vLineStyle);
  338.     '2':Set2(vLineColor);
  339.     '3':Set3(vFillStyle);
  340.     '4':Set4(vFillIndex);
  341.     '5':Set5(vFillColor);
  342.     '6':Set6(vWriteMode);
  343.     '7':Set7(size);
  344.  
  345.    end;   {.....case }
  346.  until not(response in ['1','2','3','4','5','6','7']);
  347.  SetTypes;
  348. end;
  349.  
  350.  
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  
  357. procedure CleanUp;
  358. var  response  :char;
  359. begin
  360.  alphamode;
  361.  clrscr;
  362.  gotoXY(10,10);
  363.  write('Are you sure you want to erase screen ? ');
  364.  read(kbd,response);
  365.  response := UpCase(response);
  366.  if response = 'Y' then
  367.    begin
  368.     ClearGraph;
  369.     InitXhair(size,xpoz,yPoz);
  370.    end;
  371.  gotoXY(10,24);
  372.  ClrEol;
  373.  initgraph
  374. end;
  375.  
  376.  
  377. {*****************************************************************************}
  378. {*  text will put text on the graphic screen.  It checks for space above and *}
  379. {*  to the right before writing.  It also checks to the left before a DEL    *}
  380. {*****************************************************************************}
  381. procedure text(var xPoz,yPoz:integer);
  382. var next    :char;
  383. begin
  384.  charcolor(1);
  385.  offXhair(size,xPoz,yPoz);
  386.  if (yPoz < 233) and (yPoz > 2) then  {.......if there's vertical room }
  387.   begin
  388.    repeat
  389.     read(kbd,next);
  390.     if (next = chr(127)) or (next = chr(8)) then  { ...if backspace or del }
  391.      if xPoz < 8 then         {.....too close to left side to backspace}
  392.       write(^G)
  393.      else                      {.....do a backspace }
  394.       begin
  395.        next := ' ';
  396.        xPoz := xPoz - 8;
  397.        MoveTo(xPoz,yPoz);
  398.        CharGraph(next);
  399.       end
  400.      else
  401.      if next <> chr(13) then   {......if no CR then..}
  402.       if xPoz > 629 then       {...if there's no room}
  403.        write(^G)                    {ring the bell   }
  404.       else                     {..else write the charactor }
  405.        begin
  406.         MoveTo(xPoz,yPoz);
  407.         charGraph(next);             {....write }
  408.         xPoz := xPoz + 8;
  409.        end;
  410.     if xPoz > 629 then               {....unless too far to the right}
  411.      begin
  412.       next := chr(13);
  413.       write(^G);
  414.      end;
  415.    until next = chr(13);
  416.   end
  417.  else      {.......no room for charactor above line or descenders below}
  418.   write(^G);
  419.  initXhair(size,xPoz,yPoz);
  420. end;
  421.  
  422.  
  423. procedure Arrow(size,x1,y1,xPoz,yPoz:integer);
  424.   {.....comments:  theta is the angle from 0 to 2 pie of the line that
  425.    is drawn. Gamma is the interior angle of the arrowhead. Beta is the
  426.    difference.  To make the arrow longer change the length which is really
  427.    the height or centerline of the arrowhead.  To make the head fatter change
  428.    the loop which sets gamma. Comments below assume Xhair is origin of an
  429.    alternate frame of reference.                                            }
  430.  
  431. const length = 10.0;                {.... yields length of arrow }
  432. var theta,gamma,beta   :real;    {......trig type stuff }
  433.     i                  :integer;
  434.     Lx,Ly              :integer;
  435. begin
  436.  if (xPoz-x1 = 0) then   {....vertical line }
  437.   if (yPoz > y1) then
  438.     theta := 1.5707963          {.......which points up }
  439.   else
  440.     theta := -1.5707936         {.......which points down }
  441.  else
  442.    theta := arctan((2*(yPoz-y1))/(xPoz-x1));
  443.  if (xPoz < x1) then    {....angle is greater than 90 }
  444.   begin
  445.     begin
  446.      theta := 3.1415927 + theta;   {...in 2nd or 3rd quardents }
  447.     end
  448.   end;
  449.  if (theta < 0) then
  450.   theta := theta + 6.2831853;
  451.  DrawNext(size,x1,y1,xPoz,yPoz);
  452.  offXhair(size,xPoz,yPoz);
  453.  SetLine(1);            { draw a white arrow }
  454.  for i := 1 to 46 do
  455.   begin
  456.    gamma := 0.3 - i * 0.015;
  457.    beta := theta - gamma;
  458.    Lx := round(2*(length * cos(beta)));
  459.    Ly := round(length * sin(beta));
  460.    if (x1-Lx > -1) and (x1-Lx < 640) and (y1-Ly > -1) and (y1-Ly < 240) then
  461.     begin
  462.      DrawTo((x1-Lx),(y1-Ly));
  463.      MoveTo(x1,y1);
  464.     end;
  465.   end;
  466.  SetTypes;                { return previous settings }
  467.  initXhair(size,xPoz,yPoz);
  468. end;
  469.  
  470.  
  471.