home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MKSCREN2.ZIP / MKSCREEN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-10-16  |  8.0 KB  |  251 lines
  1. {$U+}{$V-}
  2. type
  3.  str35          = string[35];
  4.  str80          = string[80];
  5.  
  6. const
  7.  label_end      = ':';
  8.  field_mark     = '_';
  9.  max_fields     = 100;
  10.  used           = '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$';
  11.  
  12. var
  13.  command_line   : string[80] absolute Cseg:$80;
  14.  infile         : text;
  15.  outfile        : text;
  16.  final          : text;
  17.  fname1         : string[255];
  18.  qtyfields      : integer;
  19.  qtylabels      : integer;
  20.  row,col        : integer;
  21.  indata         : string[255];
  22.  seqno          : integer;
  23.  varname        : array[1..max_fields] of string[35];
  24.  fieldW         : array[1..max_fields] of integer;
  25.  checktype      : array[1..max_fields] of char;
  26.  Lchoices       : array[1..max_fields] of string[50];
  27.  maxlen         : integer;
  28.  
  29. procedure capitalize(var str : str80);
  30. var
  31.  index : integer;
  32. begin
  33.  for index := 1 to length(str) do str[index] := upcase(str[index]);
  34. end;
  35.  
  36. function tab(sname : str35;loc : integer) : str80;
  37. var
  38.  wstr  : str80;
  39.  index : integer;
  40. begin
  41.  wstr := '';
  42.  for index := 1 to loc - length(sname) do wstr := ' ' + wstr;
  43.  tab := wstr;
  44. end;
  45.  
  46. procedure make_final;
  47. var puts : integer;
  48.     index : integer;
  49. begin
  50.  assign(final,'SCREENxx.OVL');
  51.  rewrite(final);
  52.  writeln(final,'overlay procedure screenXX; {<<<}');
  53.  writeln(final,'const');
  54.  writeln(final,' total_fields = ',(seqno-1):2,';');
  55.  writeln(final,'label');
  56.  writeln(final,' repaint;');
  57.  writeln(final,'var');
  58.  writeln(final,' lun',tab('xxx',maxlen+1),': _textfile;');
  59.  writeln(final,' field_no',tab('xxxxxxxx',maxlen+1),': integer;');
  60.  writeln(final,' xf,yf',tab('xxxxx',maxlen+1),': array [1..total_fields] of integer;');
  61.  writeln(final,' done',tab('xxxx',maxlen+1),': boolean;');
  62.  for index := 1 to seqno-1 do
  63.  writeln(final,' ',varname[index],tab(varname[index],maxlen+1),': string[',fieldW[index]:2,'];');
  64.  writeln(final,'begin');
  65.  writeln(final,'cursor_on;');
  66.  writeln(final,'gotoxy(1,5);Clreos;');
  67.  writeln(final,'with header do begin                       {vvv}');
  68.  writeln(final,'if exist(work_drive+''@''+a.operation_no+''TXT.xxx'') then begin');
  69.  writeln(final,'assign(lun,work_drive+''@''+a.operation_no+''TXT.xxx'');');
  70.  writeln(final,'reset(lun);');
  71.  puts := 0;
  72.  for index := 1 to seqno-1 do begin
  73.   write(final,'readln(lun,',varname[index],');');
  74.   puts := succ(puts);
  75.   if (puts = 3) then begin writeln(final);puts := 0;end;
  76.  end;
  77.  writeln(final,'close(lun);');
  78.  writeln(final,'end else begin');
  79.  for index := 1 to seqno-1 do writeln(final,' ',varname[index],tab(varname[index],maxlen+1),':= '''';');
  80.  writeln(final,'end;');
  81.  writeln(final,'field_no := 1;');
  82.  writeln(final,'repaint:');
  83.  reset(outfile);
  84.  repeat readln(outfile,indata);writeln(final,indata);until eof(outfile);
  85.  writeln(final,'repeat');
  86.  writeln(final,'Case field_no of');
  87.  for index := 1 to seqno-1 do begin
  88.  writeln(final,index:2,' : begin');
  89.  writeln(final,'     done := false;');
  90.  writeln(final,'     repeat');
  91.  writeln(final,'      get_field(',VarName[index],',',fieldW[index]:2,',xf[',index:2,
  92.          '],yf[',index:2,'],term,answer,0);');
  93.  write(final,'      done := ');
  94.  case checktype[index] of
  95.   'I' : write(final,'integer');
  96.   'L' : write(final,'list');
  97.   'R' : write(final,'real');
  98.   'S' : write(final,'string');
  99.  end;
  100.  write(final,'_check(',varname[index],',');
  101.  case checktype[index] of
  102.   'I','R'     : writeln(final,'''N'',''N'',''0'',',fieldW[index]:2,');');
  103.   'S'         : writeln(final,'''Y'',''N'','' '',',fieldW[index]:2,');');
  104.   'L'         : writeln(final,'''',Lchoices[index],''',''N'',''Y'',''N'','' '',',fieldW[index]:2,');');
  105.  end;
  106.  writeln(final,'     until done;');
  107.  writeln(final,'     end;');
  108.  end;
  109.  writeln(final,'end;');
  110.  writeln(final,'case answer of');
  111.  writeln(final,' ^I,^M,^X : if (field_no = total_fields) then field_no := 1 else field_no := field_no + 1;');
  112.  writeln(final,' ^E : if field_no = 1 then field_no := total_fields else field_no := field_no - 1;');
  113.  writeln(final,' ^T : field_no := 1;');
  114.  writeln(final,' ^B : field_no := total_fields;');
  115.  writeln(final,'end;');
  116.  writeln(final,'until (answer = ^M) and (field_no=1) or (answer = #27);');
  117.  writeln(final,'if (answer <> #27) then begin                {vvv}');
  118.  writeln(final,'assign(lun,work_drive+''@''+a.operation_no+''TXT.xxx'');');
  119.  writeln(final,'rewrite(lun);');
  120.  puts := 0;
  121.  for index := 1 to seqno-1 do begin
  122.   write(final,'writeln(lun,',varname[index],');');
  123.   puts := succ(puts);
  124.   if (puts = 3) then begin writeln(final);puts := 0;end;
  125.  end;
  126.  writeln(final,'close(lun);');
  127.  writeln(final,'end;');
  128.  writeln(final,'end;');
  129.  writeln(final,'cursor_off;');
  130.  writeln(final,'end;');
  131.  close(final);
  132. end;
  133.  
  134. procedure find_fields;
  135. var
  136. fstart,fend : integer;
  137. lstart,lend : integer;
  138. flabel      : string[255];
  139. nofield     : boolean;
  140.  
  141. procedure get_varname;
  142.  
  143. begin
  144.  if (not nofield) then begin
  145.  textcolor(green);
  146.  gotoxy(1,10);clreol;write('Enter VARNAME for field label ''',flabel,''': ');
  147.  textcolor(yellow);
  148.  read(Varname[seqno]);
  149.  textcolor(green);
  150.  gotoxy(1,12);write('Field Check [I,L,R,S]: ');
  151.  repeat
  152.  read(KBD,checktype[seqno]);
  153.  checktype[seqno] := upcase(checktype[seqno]);
  154.  until checktype[seqno] in ['I','L','R','S'];
  155.  if (checktype[seqno] = 'L') then begin
  156.  textcolor(green);
  157.  gotoxy(1,14);write('Enter choices (i.e. ''Y,N,?''): ');
  158.  textcolor(yellow);
  159.  read(Lchoices[seqno]);
  160.  capitalize(Lchoices[seqno]);
  161.  gotoxy(1,14);clreol;
  162.  end else Lchoices[seqno] := '';
  163.  if (length(varname[seqno]) > maxlen) then maxlen := length(varname[seqno]);
  164.  fieldW[seqno] := (Fend - Fstart + 1);
  165.  end;
  166. end;
  167.  
  168. procedure make_pascal;
  169. begin
  170.  if (nofield) then begin
  171.  qtylabels := succ(qtylabels);
  172.  writeln(outfile,'gotoxy(',lstart:2,',',row:2,');','write(''',flabel,''');');
  173.  textcolor(black);textbackground(red);
  174.  gotoxy(5,6);write(qtylabels:3);
  175.  textcolor(yellow);textbackground(black);write(' Labels processed.');
  176.  end else begin
  177.  qtyfields := succ(qtyfields);
  178.  writeln(outfile,'draw_field(',lstart:2,',',row:2,',xf[',seqno:2,'],yf[',seqno:2,'],''',
  179.          flabel,''',',VarName[seqno],',0,',(fend-fstart+1):2,');');
  180.  textcolor(black);textbackground(red);
  181.  gotoxy(45,6);write(qtyfields:3);
  182.  textcolor(yellow);textbackground(black);write(' Fields processed.');
  183.  end;
  184. end;
  185.  
  186. begin
  187.  col := 0;
  188.  while (col < length(indata)) do begin
  189.   col := succ(col);
  190.   if (indata[col] <> ' ') then begin
  191.    lstart := col;
  192.    lend := pos(label_end,indata);
  193.    if (lend = 0) then lend := length(indata);
  194.    flabel := copy(indata,lstart,lend-lstart+1);
  195.    fstart := pos(field_mark,indata);
  196.    if (fstart = 0) then nofield := true else nofield := false;
  197.    if (not nofield) then begin
  198.    fend := fstart;
  199.    repeat
  200.     fend := succ(fend)
  201.    until indata[fend] <> field_mark;
  202.    fend := pred(fend);
  203.    delete(indata,fstart,fend-fstart+1);
  204.    insert(copy(used,1,fend-fstart+1),indata,fstart);
  205.    end;
  206.    get_varname;
  207.    make_pascal;
  208.    if (not nofield) then seqno := succ(seqno);
  209.    indata[lend] := '$';
  210.    if (nofield) then col := length(indata) else col := fend;
  211.   end;
  212.  end;
  213. end;
  214.  
  215. begin
  216. textcolor(lightred);
  217. clrscr;
  218. writeln('Turbo Pascal Screen Code Manufacturing Program');
  219. writeln('v01.01 Released 16 Oct 87 by R.P.Helmle');
  220.  
  221. if (length(command_line)> 0) then begin
  222. delete(command_line,1,1);
  223. fname1 := command_line;
  224. assign(infile,fname1);
  225. reset(infile);
  226. assign(outfile,'SCREENXX.INC');
  227. rewrite(outfile);
  228. row := 0;
  229. seqno := 1;
  230. maxlen := 0;
  231. qtyfields := 0;
  232. qtylabels := 0;
  233. repeat
  234.  readln(infile,indata);
  235.  row := succ(row);
  236.  if (row > 3) and (length(indata) > 1) then find_fields;
  237. until eof(infile);
  238. make_final;
  239. close(outfile);
  240.  textcolor(lightgreen);
  241.  gotoxy(1,20);write('NOTE:');
  242.  gotoxy(1,21);write('Final screen source code saved in SCREENXX.OVL in current directory!');
  243.  gotoxy(1,22);write('Draw Field statements saved in SCREENXX.INC for fast location updates!');
  244. end else begin
  245.  textcolor(red+blink);
  246.  writeln;writeln;
  247.  writeln('Error - You must specify the text file name in command line!');
  248.  writeln('Format: MkScreen <filename>');
  249. end;
  250. end.
  251.