home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol082 / jgraf.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  7.1 KB  |  372 lines
  1. %ltrace %ptrace
  2. extern
  3.  
  4. type
  5. char1000 = array [1..1000] of char;
  6. char2000 = array [1..2000] of char;
  7. char3000 = array [1..3000] of char;
  8. char4000 = array [1..4000] of char;
  9. char5000 = array [1..5000] of char;
  10. char6000 = array [1..6000] of char;
  11. char7000 = array [1..7000] of char;
  12. char8000 = array [1..8000] of char;
  13. char9000 = array [1..9000] of char;
  14. jgraf_interface =
  15.     record
  16.     command, plot_char : char;
  17.     x_grid, y_grid : boolean;
  18.     rows, columns : integer;
  19.     x_lower, x_upper, y_lower, y_upper : real;
  20.     filename : array [1..14] of char;
  21.     title : string;
  22.     b : ^char9000;
  23.     bufr_size, line_size, row_count : integer;
  24.     x_spacing, y_spacing : real;
  25.     end;
  26.  
  27. procedure jgraf ( var jg : jgraf_interface;
  28.         x, y : real );
  29. var
  30. i : integer;
  31. f1 : file of char;
  32.  
  33. procedure setup;
  34. var
  35. ai : integer;
  36. axis_labels : array [1..50] of
  37.     record
  38.     axis : char;
  39.     ptr : integer;
  40.     end;
  41.  
  42. procedure allocate_buffer;
  43. label 99;
  44. var
  45. x : integer;
  46. b1 : ^char1000;    b2 : ^char2000;    b3 : ^char3000;
  47. b4 : ^char4000;    b5 : ^char5000; b6 : ^char6000;
  48. b7 : ^char7000; b8 : ^char8000; b9 : ^char9000;
  49. begin
  50. jg.line_size:=jg.columns+16;
  51. jg.row_count:=jg.rows+5;
  52. jg.bufr_size:=jg.line_size * jg.row_count + 8;
  53. x := (jg.bufr_size div 1000) + 1;
  54.  
  55. if (x < 1) or (x > 9) then
  56.     begin
  57.     writeln('JGRAF - graph size error:',
  58.         jg.bufr_size);
  59.     goto 99;
  60.     end;
  61. case x of
  62. 1 : begin new(b1); jg.b:=b1 end;
  63. 2 : begin new(b2); jg.b:=b2 end;
  64. 3 : begin new(b3); jg.b:=b3 end;
  65. 4 : begin new(b4); jg.b:=b4 end;
  66. 5 : begin new(b5); jg.b:=b5 end;
  67. 6 : begin new(b6); jg.b:=b6 end;
  68. 7 : begin new(b7); jg.b:=b7 end;
  69. 8 : begin new(b8); jg.b:=b8 end;
  70. 9 : begin new(b9); jg.b:=b9 end;
  71. end;
  72. 99: end; (* allocate_buffer *)
  73.  
  74. procedure crlfs; (* put crlfs in buffer *)
  75. var
  76. i, ptr : integer;
  77. cr, lf : char;
  78. begin
  79. cr:=chr(0dh);
  80. lf:=chr(0ah);
  81. ptr:=jg.line_size - 1;
  82. for i:=1 to jg.row_count-1 do
  83.     begin
  84.     jg.b^[ptr]:=cr;
  85.     jg.b^[ptr+1]:=lf;
  86.     ptr:=ptr + jg.line_size;
  87.     end;
  88. ptr := ptr + 8;
  89. jg.b^[ptr]:=cr;
  90. jg.b^[ptr+1]:=lf;
  91. end; (* crlfs *)
  92.  
  93. procedure xgrid;
  94. var x : integer;
  95.  
  96. procedure x_axes ( r : integer; main : boolean );
  97. var
  98. i,r1,ptr,count : integer;
  99. ll,ss,rr,xx : real;
  100. begin
  101. r1 := jg.row_count - r;
  102. ptr := (r1 * jg.line_size) + 13;
  103. (* update axis labels array and file *)
  104. axis_labels[ai].axis:='x';
  105. axis_labels[ai].ptr:=ptr;
  106. ai:=ai+1;
  107. rr:=r;
  108. ss:=jg.y_spacing;
  109. ll:=jg.y_lower;
  110. xx := ((rr - 3.0) * ss) + ll;
  111. write(f1; xx);
  112.  
  113. if jg.x_grid or main then
  114.     count := jg.columns
  115. else count := 1;
  116. for i:=0 to count do
  117.     jg.b^[ptr+i] := '-';
  118. end; (* x_axes *)
  119.  
  120. begin (* xgrid *)
  121. x_axes(3,true);
  122. x := 13;
  123. while x <= jg.row_count-1 do
  124.     begin
  125.     x_axes(x,false);
  126.     x := x + 10;
  127.     end;
  128. end; (* xgrid *)
  129.  
  130. procedure ygrid;
  131. var y : integer;
  132.  
  133. procedure y_axes ( c : integer; main : boolean );
  134. var
  135. i, ptr : integer;
  136. cc,ll,ss,yy : real;
  137. begin
  138. if jg.y_grid or main then
  139.     begin
  140.     ptr := (2 * jg.line_size) + c;
  141.     for i:=1 to jg.rows + 1 do
  142.         begin
  143.         jg.b^[ptr]:='I';
  144.         ptr:=ptr + jg.line_size;
  145.         end;
  146.     end
  147. else
  148.     begin    (* no ygrid *)
  149.     ptr := (jg.line_size * (jg.rows+2)) + c;
  150.     jg.b^[ptr]:='I';
  151.     end;
  152. (* update axis labels array and file *)
  153. axis_labels[ai].axis:='y';
  154. axis_labels[ai].ptr:=ptr;
  155. ai:=ai+1;
  156. cc:=c;
  157. ss:=jg.x_spacing;
  158. ll:=jg.x_lower;
  159. yy := ((cc - 14.0) * ss) + ll;
  160. write(f1; yy);
  161.  
  162. end; (* y_axes *)
  163.  
  164. begin (* ygrid *)
  165. y_axes(14,true);
  166. y := 24;
  167. while y <= jg.columns + 14 do
  168.     begin
  169.     y_axes(y,false);
  170.     y := y + 10;
  171.     end;
  172. end; (* ygrid *)
  173.  
  174. procedure clear_bufr;
  175. type
  176. buffer = array [1..20] of char1000;
  177. var
  178. a : char1000;
  179. i : integer;
  180. ptr : ^buffer;
  181. begin
  182. a:=' ';
  183. map(ptr,addr(jg.b^));
  184. for i:=1 to (jg.bufr_size div 1000) + 1 do
  185.     ptr^[i]:=a;
  186. end;
  187.  
  188. procedure move_title;
  189. var
  190. s : string[20];
  191. x,i : integer;
  192. begin
  193. s := 'JGRAF ver 1.0';
  194. for i:=1 to 13 do jg.b^[i]:=s[i];
  195. x := (jg.line_size div 2) - (length(jg.title) div 2)
  196.     + 2;
  197. for i:=1 to 4 do
  198.     begin
  199.     jg.b^[x] := '*';
  200.     x:=x+1;
  201.     end;
  202. x:=x+1;        (* skip 1 space *)
  203. for i:=1 to length(jg.title) do
  204.     begin
  205.     jg.b^[x] := jg.title[i];
  206.     x:=x+1;
  207.     end;
  208. x:=x+1;        (* skip 1 space *)
  209. for i:=1 to 4 do
  210.     begin
  211.     jg.b^[x] := '*';
  212.     x:=x+1;
  213.     end;
  214. end; (* move_title *)
  215.  
  216. procedure process_axis_labels;
  217. var
  218. hold : array [1..30] of char;
  219. i,j : integer;
  220. ch : char;
  221.  
  222. procedure xlabels;
  223. var
  224. count,ptr,number_length,k : integer;
  225. begin
  226. number_length:=j-1;
  227. ptr := axis_labels[i].ptr;
  228. if number_length <= 8 then
  229.     begin
  230.     ptr := ptr - number_length;
  231.     count:=number_length;
  232.     end
  233. else
  234.     begin
  235.     ptr:=ptr - 8;
  236.     count:=8;
  237.     end;
  238. for k:=1 to count do
  239.     begin
  240.     jg.b^[ptr] := hold[k];
  241.     ptr := ptr + 1;
  242.     end;
  243. end; (* xlabels *)
  244.  
  245. procedure ylabels;
  246. var
  247. count, ptr, number_length, k : integer;
  248. begin
  249. number_length:=j-1;
  250. ptr:=axis_labels[i].ptr;
  251. if number_length <= 8 then
  252.     begin
  253.     ptr := ptr + jg.line_size
  254.         - (number_length div 2) + 1;
  255.     count:=number_length;
  256.     end
  257. else
  258.     begin
  259.     ptr := ptr + jg.line_size - 4;
  260.     count:=8;
  261.     end;
  262. for k:=1 to count do
  263.     begin
  264.     jg.b^[ptr]:= hold[k];
  265.     ptr := ptr + 1;
  266.     end;
  267. end; (* ylabels *)
  268.  
  269.  
  270. begin
  271. reset(f1,'jgraf.$$$',binary,128);
  272. read(f1; ch);    (* skip over leading blank *)
  273. for i:=1 to ai-1 do
  274.     begin
  275.     hold:=' ';
  276.     j:=1;
  277.     repeat
  278.       read(f1; ch);
  279.       hold[j]:=ch;
  280.       j:=j+1;
  281.     until ch = ' ';
  282.     case axis_labels[i].axis of
  283.     'x' : xlabels;
  284.     'y' : ylabels;
  285.     end;
  286.     end;
  287. close(f1);
  288. end; (* process_axis_labels *)
  289.  
  290. begin (* setup *)
  291. jg.x_spacing := (jg.x_upper - jg.x_lower) / jg.columns;
  292. jg.y_spacing := (jg.y_upper - jg.y_lower) / jg.rows;
  293. allocate_buffer;
  294. clear_bufr;
  295. crlfs;
  296. ai := 1;    (* axis labels array index *)
  297. rewrite(f1,'jgraf.$$$',text,128);
  298. xgrid;
  299. ygrid;
  300. write(f1; ' ');
  301. close(f1);
  302. process_axis_labels;
  303. move_title;
  304. end; (* setup *)
  305.  
  306.  
  307. procedure data;
  308. label 99;
  309. var
  310. x1, y1 : integer;
  311.  
  312. procedure plot ( x,y : integer );
  313. (* place char in graph area - origin 0 at lower left *)
  314. var
  315. ptr : integer;
  316. begin
  317. ptr := (jg.line_size * (jg.row_count - y - 3))
  318.     + (x + 14);
  319. if ptr > jg.bufr_size then
  320.     writeln('plot computation error')
  321. else
  322.     jg.b^[ptr] := jg.plot_char;
  323. end; (* plot *)
  324.  
  325. begin
  326. if not ((x >= jg.x_lower) and (x <= jg.x_upper) and
  327.     (y >= jg.y_lower) and (y <= jg.y_upper)) then
  328.     goto 99;
  329. x1 := round((x - jg.x_lower) / jg.x_spacing);
  330. y1 := round((y - jg.y_lower) / jg.y_spacing);
  331. plot(x1,y1);
  332. 99: end;
  333.  
  334.  
  335. procedure display ( mode : char );
  336. var
  337. bytes_remaining, len, start : integer;
  338. begin
  339. if mode = 'p' then system(list);
  340. if mode = 's' then
  341.     rewrite(f1,jg.filename,binary,1024);
  342. bytes_remaining := jg.bufr_size;
  343. start:=1;
  344. repeat
  345.   if bytes_remaining >= 1024 then len:=1024
  346.   else len:=bytes_remaining;
  347.   if mode = 's' then
  348.     write(f1; copy(jg.b^,start,len))
  349.   else  write( copy(jg.b^,start,len));
  350.   start:=start+1024;
  351.   bytes_remaining:=bytes_remaining-1024;
  352. until bytes_remaining <= 0;
  353. if mode = 'p' then system(nolist);
  354. if mode = 's' then
  355.     close(f1);
  356. end; (* display *)
  357.  
  358.  
  359. begin (* jgraf *)
  360. case upcase(jg.command) of
  361. 'D' : data;
  362. 'I' : setup;
  363. 'S' : display('s');
  364. 'C' : display('c');
  365. 'P' : display('p');
  366. 'X' : dispose(jg.b);
  367. else : writeln('JGRAF - unknown command: ',
  368.         jg.command);
  369. end; (* case *)
  370.  
  371. end; (* jgraf *).
  372.