home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 189.img / TCS120S.ZIP / TCSGRAPH.PAS < prev    next >
Pascal/Delphi Source File  |  1989-03-02  |  4KB  |  183 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit tcsgraph;
  5.  
  6. interface
  7.  
  8. uses crt,dos,graph,
  9.      gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2,textret,
  10.      mailret,userret,flags,mainr1,ansiedit,lineedit,chatstuf,
  11.      mainr2,overret1;
  12.  
  13. procedure initialize;
  14. function randcolor:word;
  15. procedure drawborder;
  16. procedure fullport;
  17. procedure mainwindow (header:string);
  18. procedure exitproggraphics;
  19. procedure tcsgraphic1;
  20. procedure tcsgraphic2;
  21.  
  22. implementation
  23.  
  24. const
  25.   { The five fonts available }
  26.   fonts:array[0..4] of string[13] =
  27.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  28.  
  29.   { The five predefined line styles supported }
  30.   linestyles:array[0..4] of string[9] =
  31.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  32.  
  33.   { The twelve predefined fill styles supported }
  34.   fillstyles:array[0..11] of string[14] =
  35.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  36.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  37.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  38.  
  39.   { The two text directions available }
  40.   textdirect:array[0..1] of string[8] = ('HorizDir', 'VertDir');
  41.  
  42.   { The Horizontal text justifications available }
  43.   horizjust:array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  44.  
  45.   { The vertical text justifications available }
  46.   vertjust:array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  47.  
  48. var
  49.   graphdriver,graphmode,errorcode:integer;
  50.   maxx,maxy,maxcolor:word;
  51.   oldexitproc,pregraphexitproc:pointer;
  52.  
  53. procedure myexitproc;
  54. begin
  55.   exitproc:=oldexitproc;
  56.   closegraph;
  57. end;
  58.  
  59. {
  60. procedure mygetmem (var p:pointer; size:word);
  61. begin
  62.  getmem (p,size);
  63. end;
  64.  
  65. procedure myfreemem (var p:pointer; size:word);
  66. begin
  67.  if p <> nil then begin
  68.   freemem (p,size);
  69.   p:=nil;
  70.  end;
  71. end;
  72.  
  73. procedure domemstuff;
  74. begin
  75.  pregraphexitproc:=exitproc;
  76.  exitproc:=@myexitproc;
  77.  graphgetmemptr:=@mygetmem;
  78.  graphfreememptr:=@myfreemem;
  79. end;
  80. }
  81.  
  82. procedure initialize;
  83. var
  84.   ingraphicsmode:boolean;
  85.   pathtodriver:string;
  86. begin
  87.   directvideo:=false;
  88.   oldexitproc:=exitproc;
  89.   exitproc:=@myexitproc;
  90.   pathtodriver:=forumdir;
  91. { domemstuff; }
  92.   repeat
  93.     graphdriver:=detect;
  94.     initgraph (graphdriver,graphmode,pathtodriver);
  95.     errorcode:=graphresult;
  96.     if errorcode <> grok then
  97.     begin
  98.       writeln ('Graphics Error: ',grapherrormsg (errorcode));
  99.       if errorcode=grfilenotfound then
  100.       begin
  101.         writeln ('Enter full path to BGI driver or type <Ctrl-Break> to Quit.');
  102.         write ('─> ');
  103.         readln (pathtodriver);
  104.         writeln;
  105.       end
  106.       else
  107.         Halt(1);
  108.     end;
  109.   until ErrorCode = grok;
  110.   randomize;
  111.   maxcolor:=getmaxcolor;
  112.   maxx := getmaxx;
  113.   maxy := getmaxy;
  114. end;
  115.  
  116. function randcolor:word;
  117. { Returns a Random non-zero color value that is within the legal
  118.   color range for the selected device driver and graphics mode.
  119.   MaxColor is set to GetMaxColor by Initialize }
  120. begin
  121.   randcolor:=random(maxcolor)+1;
  122. end;
  123.  
  124. procedure drawborder;
  125. { Draw a border around the current view port }
  126. var
  127.   ViewPort : ViewPortType;
  128. begin
  129.   setcolor (maxcolor);
  130.   setlinestyle (solidln,0,normwidth);
  131.   getviewsettings (viewport);
  132.   with viewport do
  133.    rectangle (0,0,x2-x1,y2-y1);
  134. end;
  135.  
  136. procedure fullport;
  137. begin
  138.   setviewport (0,0,maxx,maxy,clipon);
  139. end;
  140.  
  141. procedure mainwindow (header:string);
  142. begin
  143.   setcolor (maxcolor);
  144.   graph.cleardevice;
  145.   settextstyle (defaultfont,horizdir,1);
  146.   settextjustify (centertext,toptext);
  147.   fullport;
  148.   OutTextXY(MaxX div 2,2,header);
  149.   { Draw main window }
  150.   SetViewPort (0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  151.   DrawBorder;
  152.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  153.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn)
  154.   end;
  155.  
  156. procedure exitproggraphics;
  157. var i,x,y:integer;
  158.     pausetime:word;
  159.     klux:char;
  160. begin
  161.   clrscr;
  162.   initialize;
  163.   for i:=1 to 1000 do begin
  164.  { klux:=readkey; }
  165.    if keypressed then exit;
  166.    putpixel (random(maxx),random(maxy),randcolor);
  167.   end;
  168.   x:=maxx div 2;
  169.   y:=maxy div 2;
  170.   pausetime:=70;
  171. end;
  172.  
  173. procedure tcsgraphic1;
  174. begin
  175. end;
  176.  
  177. procedure tcsgraphic2;
  178. begin
  179. end;
  180.  
  181. begin
  182. end.
  183.