home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / 30TURUTL / PASCAL.LIB < prev    next >
Text File  |  1985-02-16  |  13KB  |  451 lines
  1. {Include File: PASCAL.LIB}
  2.  
  3. type string80 = string[80];
  4.      charset  = set of char;
  5.      dateset  = (century,year,month,day);
  6.      datetype = array[century..day] of char;
  7.      screencommand = (stop,goback,goforward);
  8.      fieldtype = (alpha,dollar,numeric,yesno);
  9.      screenprompt = record
  10.                       x,y,
  11.                       flen:integer;
  12.                       ftype:fieldtype;
  13.                       prompt:string[15]
  14.                     end;
  15.  
  16. const cr               = ^M;          { Keyboard constants }
  17.       lf               = ^J;
  18.       crlf             = ^M^J;
  19.       bell             = ^G;
  20.       bs               = ^H;
  21.       esc              = ^[;
  22.       null             = '';          { Concatenation constants }
  23.       space            = ' ';
  24.       digits:charset   = ['.', '-', '0'..'9', 'e', 'E'];
  25.       alphaset:charset = [' '..'}'];   { Printable characters }
  26.       sysdate:datetype = #19#84#01#15; (* { January 15, 1984 } *)
  27.  
  28. var   xsavx: integer;  {one-deep save area for stack pointer}
  29.  
  30. (*
  31. This is the code for simulating an Exit with TURBO Pascal 1.0,
  32. provided the A+ compiler option is on -- no recursion!
  33.  
  34.  A) Declare a GLOBAL Variable, " VAR XSAVX: INTEGER; ", included
  35.     here in the Pascal lib.  Procedure need not be FORWARD now.
  36.  
  37.  B) Include this as the FIRST instruction in the Procedure you wish
  38.     to eventually exit from, to set up the stack save:
  39.  
  40.          inline($21/0/0/         { LD HL,0000h   ; MARK PROC }
  41.                 $39/             { ADD HL,SP     ; FOR EXIT  }
  42.                 $22/xsavx);      { LD (xsavx),HL             }
  43.  
  44.  C) Include this instead of Exit(Procname) in the procedure which
  45.     actually invokes the exit, & make it the LAST code in block:
  46.  
  47.          inline($2A/xsavx/       { LD HL,(xsavx) ; EXIT PROC }
  48.                 $F9);            { LD SP,HL      ; !!!       }
  49.  
  50.     Turbo will manage stack details when triggered by block end.
  51.  
  52. David C. Oshel, 15 January 1984, 1219 Harding Ave., Ames, Iowa 50010
  53. *)
  54.  
  55.  
  56.  
  57. {:: Max and Min Functions
  58.  ::
  59.  }
  60.  
  61. function max(a,b:integer):integer;
  62. begin
  63.   if a<=b then max:=b else max:=a
  64. end;  {max}
  65.  
  66. function min(a,b:integer):integer;
  67. begin
  68.   if b<=a then min:=b else min:=a
  69. end;  {min}
  70.  
  71.  
  72.  
  73. {:: DrawBox Procedure
  74.  ::
  75.  :: Just what it sez; you supply the top left (x1,y1) and
  76.  :: bottom right (x2,y2) coordinates, and it draws a box on the
  77.  :: screen using the characters you want to draw the top, bottom
  78.  :: and sides.
  79.  ::
  80.  }
  81.  
  82. procedure drawbox(x1,y1,x2,y2:integer; top,side,bottom:char);
  83. var i:integer;
  84. begin
  85.   gotoxy(x1,y1);
  86.   for i:=x1 to x2 do write(top);
  87.   gotoxy(x1,y1+1);
  88.   for i:=y2 downto y1+1 do
  89.     begin
  90.       gotoxy(x2,i); write(side);
  91.       gotoxy(x1,i); write(side)
  92.     end;
  93.   gotoxy(x1,y2);
  94.   for i:=x1 to x2 do write(bottom)
  95. end;  {drawbox}
  96.  
  97.  
  98.  
  99. {:: GetLine Procedure
  100.  ::
  101.  :: Set the VAR string parameter to user input, restricted to
  102.  :: a set of allowed characters, less than or equal to allowed length.
  103.  ::
  104.  }
  105.  
  106. procedure getln(VAR s:string80; okset:charset; maxlen:integer);
  107. var ch:    char;
  108.     stemp: string80;
  109.     len:   integer;
  110.     first,
  111.     last:  boolean;
  112.     getset:charset;
  113.  
  114.   function getchar(okset:charset):char;
  115.   var ok:boolean; ch:char;
  116.   begin
  117.     repeat
  118.       read(KBD,ch);
  119.       if eoln(KBD) then ch:=cr;
  120.       ok:=ch in okset;
  121.       if not ok
  122.         then write(CON,bell)
  123.         else if ch in alphaset then write(CON,ch)
  124.     until ok;
  125.     getchar:=ch
  126.   end;  {getchar}
  127.  
  128. begin
  129.   stemp:=null;
  130.   ch:=space;
  131.   repeat
  132.     len:=length(stemp);
  133.     first:=len=0;
  134.     last:=len=maxlen;
  135.     if first then getset:=okset+[cr]
  136.       else if last then getset:=[cr,bs]
  137.       else getset:=okset+[cr,bs];
  138.     ch:=getchar(getset);
  139.     if ch=bs then
  140.       begin
  141.         write(bs,space,bs);
  142.         delete(stemp,len,1)
  143.       end
  144.     else if ch in okset-[cr] then stemp:=stemp+ch
  145.   until ch=cr;
  146.   s:=stemp
  147. end;  {getln}
  148.  
  149.  
  150. {:: DATE Utilities
  151.  ::
  152.  }
  153.  
  154. procedure bombline(VAR s:string80; select:charset);
  155. var go: boolean;
  156. begin
  157.   go:=true;
  158.   while (s<>null) and go do
  159.     begin
  160.       if s[1] in select then go:=false
  161.       else delete(s,1,1)
  162.     end
  163. end;  {bombline}
  164.  
  165. function ival(VAR s:string80):integer;
  166. VAR go: boolean; n:integer;
  167. begin
  168.   n:=0; go:=true;
  169.   while (s<>null) and go do
  170.     begin
  171.       if s[1] in ['0'..'9'] then
  172.         n:=( n*10 + ord(s[1])-ord('0') ) mod 3000
  173.       else go:=false;
  174.       delete(s,1,1)
  175.     end;
  176.   ival:=n
  177. end;  {ival}
  178.  
  179. function monthval(VAR s:string80):integer;
  180. var z:string[3]; n:integer;
  181. begin
  182.   if length(s)>=3 then
  183.     begin
  184.       z:=copy(s,1,3);
  185.       for n:=1 to 3 do z[n]:=upcase(z[n]);
  186.            if z='JAN' then n:=1
  187.       else if z='FEB' then n:=2
  188.       else if z='MAR' then n:=3
  189.       else if z='APR' then n:=4
  190.       else if z='MAY' then n:=5
  191.       else if z='JUN' then n:=6
  192.       else if z='JUL' then n:=7
  193.       else if z='AUG' then n:=8
  194.       else if z='SEP' then n:=9
  195.       else if z='OCT' then n:=10
  196.       else if z='NOV' then n:=11
  197.       else if z='DEC' then n:=12
  198.       else n:=0
  199.     end;
  200.   bombline(s,['0'..'9']);
  201.   if n=0 then monthval:=ival(s)
  202.   else monthval:=n
  203. end;  {monthval}
  204.  
  205. procedure dateval(VAR update:datetype; VAR s:string80);
  206. var i: century..day;
  207.     x,y,z: array[century..day] of integer;
  208.     n: integer;
  209. begin
  210.   for n:=1 to length(s) do s[n]:=upcase(s[n]);
  211.   y[century]:=ord(update[century]);   z[century]:= 30;
  212.   y[year]   :=ord(update[year]);      z[year]   :=100;
  213.   y[month]  :=ord(update[month]);     z[month]  := 13;
  214.   y[day]    :=ord(update[day]);       z[day]    := 32;
  215.   for i:=day downto year do
  216.     begin
  217.       n:=monthval(s);
  218.       x[i]:=n mod z[i]
  219.     end;
  220.   x[century]:=n div 100;
  221.   for i:=century to day do
  222.     begin
  223.       if x[i]=0 then x[i]:=y[i];
  224.       update[i]:=chr(x[i])
  225.     end
  226. end;  {dateval}
  227.  
  228. procedure monthstr(VAR s:string80; m:integer);
  229. begin
  230.   case m of
  231.      1: s:='January';
  232.      2: s:='February';
  233.      3: s:='March';
  234.      4: s:='April';
  235.      5: s:='May';
  236.      6: s:='June';
  237.      7: s:='July';
  238.      8: s:='August';
  239.      9: s:='September';
  240.     10: s:='October';
  241.     11: s:='November';
  242.     12: s:='December'
  243.   else s:='???'
  244.   end
  245. end;  {monthstr}
  246.  
  247. procedure datestr(VAR s:string80; d:datetype; long:boolean);
  248. var gimmick: char; scratch: string80;
  249. begin
  250.   if long
  251.     then gimmick:=' '
  252.     else gimmick:='/';
  253.   str(ord(d[day]),scratch);
  254.   s:=scratch+gimmick;
  255.  
  256.   if long
  257.     then monthstr(scratch,ord(d[month]))
  258.     else str(ord(d[month]),scratch);
  259.   s:=s+scratch+gimmick;
  260.  
  261.   if long then begin
  262.     str(ord(d[century]),scratch);
  263.     s:=s+scratch
  264.     end;
  265.  
  266.   str(ord(d[year]),scratch);
  267.   if length(scratch)=1 then insert('0',scratch,1);
  268.   s:=s+scratch
  269. end;  {datestr}
  270.  
  271. procedure putdate(d:datetype; long:boolean);
  272. var temp:string80;
  273. begin
  274.   datestr(temp,d,long); write(temp)
  275. end;  {putdate}
  276.  
  277. procedure setdate;
  278. var prompt:string80;
  279. begin
  280.   writeln;
  281.   write('Today is '); putdate(sysdate,true); writeln;
  282.   write('New date? ');
  283.   getln(prompt,alphaset,20); writeln;
  284.   dateval(sysdate,prompt);
  285.   write('The date is '); putdate(sysdate,true);
  286.   writeln
  287. end;  {setdate}
  288.  
  289.  
  290.  
  291.  
  292. {:: GetField Function
  293.  :: Parameters:  Screen prompt record, string80 to be updated.
  294.  :: Returns:  Screen commands STOP, GOBACK or GOFORWARD.
  295.  ::
  296.  :: This function moves the cursor into a protected screen field
  297.  :: and waits for user input.  If user types <RETURN> the previous
  298.  :: value of the field is accepted as the new value.  Otherwise,
  299.  :: the field is cleared and a new value must be typed in.  Fields
  300.  :: are validated for the types Alpha, Dollar, Numeric and YesNo.  The
  301.  :: YesNo type assumes NO if OLDS is null on entry, otherwise no
  302.  :: assumptions are made.  The values are set by side effects.
  303.  ::
  304.  :: If the user types <BACKSPACE> or <ESCAPE>, the previous value is
  305.  :: unchanged and the function returns screen commands GOBACK or STOP.
  306.  :: Otherwise, the function returns GOFORWARD.  ^Q is defined as BS,
  307.  :: and ^Z is defined as CR, for additional screen control.
  308.  }
  309.  
  310. function getfld(VAR field:screenprompt; VAR olds:string80):screencommand;
  311. var i, code: integer; signchar,ch: char; r:real; rstr: string[12];
  312.  
  313. procedure getln(VAR s:string80; okset:charset; maxlen:integer);
  314. var ch:    char;
  315.     stemp: string80;
  316.     len:   integer;
  317.     first,
  318.     last:  boolean;
  319.     getset:charset;
  320.  
  321.   function getchar(okset:charset):char;
  322.   var ok:boolean; ch:char;
  323.   begin
  324.     repeat
  325.       read(KBD,ch);
  326.       if eoln(KBD) then ch:=cr;
  327.       ok:=ch in okset;
  328.       if not ok
  329.         then write(CON,bell)
  330.         else if ch in alphaset then write(CON,ch)
  331.     until ok;
  332.     getchar:=ch
  333.   end;  {getchar}
  334.  
  335. begin
  336.   stemp:=s;  {this line is why getln is duplicated}
  337.   repeat
  338.     len:=length(stemp);
  339.     first:=len=0;
  340.     last:=len=maxlen;
  341.     if first then getset:=okset+[cr]
  342.       else if last then getset:=[cr,bs]
  343.       else getset:=okset+[cr,bs];
  344.     ch:=getchar(getset);
  345.     if ch=bs then
  346.       begin
  347.         write(bs,'.',bs);   {and this one!}
  348.         delete(stemp,len,1)
  349.       end
  350.     else if ch in okset-[cr] then stemp:=stemp+ch
  351.   until ch=cr;
  352.   s:=stemp
  353. end;  {getln}
  354.  
  355.  
  356. begin
  357.   with field do
  358.     begin
  359.       if (ftype=yesno) then flen:=1
  360.       else if (ftype=dollar)  then flen:=min(flen,12)
  361.       else if (ftype=numeric) then flen:=min(flen,5)
  362.       else flen:=min(flen,80);
  363.  
  364.       {display old values}
  365.       gotoxy(x,y);
  366.       if ftype=dollar
  367.         then write(prompt,space,olds:flen)
  368.       else begin
  369.         write(prompt,space,olds);
  370.         for i:=length(olds)+1 to flen do write(space)
  371.         end;
  372.       gotoxy(x+length(prompt)+1,y);
  373.  
  374.       {get user input; either screen command or first char of new input}
  375.       repeat until keypressed;
  376.       read(kbd,ch);
  377.  
  378.       {screen command character?}
  379.       if eoln(kbd) then
  380.         begin
  381.           if olds=null then
  382.             begin
  383.               case ftype of
  384.                 alpha:   ;
  385.                 dollar:  begin olds:='$0.00'; write(olds:flen) end;
  386.                 numeric: begin olds:='0'; write(olds:flen) end;
  387.                 yesno:   begin olds:='N'; write(olds) end;
  388.                 end  {case}
  389.             end;
  390.           getfld:=goforward
  391.         end
  392.       else if (ch=bs) or (ch=^Q) then getfld:=goback
  393.       else if ch=esc then getfld:=stop
  394.       else  {not a screen command, this is new input}
  395.         begin
  396.           olds:=null;
  397.           case ftype of
  398.             alpha:   if ch in alphaset          then olds:=null+ch;
  399.             dollar:  if ch in digits            then olds:=null+ch;
  400.             numeric: if ch in ['0'..'9']        then olds:=null+ch;
  401.             yesno:   if ch in ['y','Y']         then olds:='Y'
  402.                                                 else olds:='N'
  403.             end; {case}
  404.           gotoxy(x+length(prompt)+1,y);
  405.           write(olds);
  406.           for i:=length(olds)+1 to flen do write('.');
  407.           gotoxy(x+length(prompt)+length(olds)+1,y);
  408.           case ftype of
  409.             alpha:   getln(olds,alphaset,flen);
  410.             dollar:  getln(olds,digits,flen);
  411.             numeric: getln(olds,['0'..'9'],flen);
  412.             yesno:   begin
  413.                        getln(olds,['y','n','Y','N'],flen);
  414.                        olds:=upcase(olds)
  415.                      end
  416.             end; {case}
  417.  
  418.           {validate entry}
  419.           gotoxy(x+length(prompt)+1,y);
  420.           if ftype=dollar then
  421.             begin
  422.               val(olds,r,code);
  423.               if code=0 then
  424.                 begin
  425.                   if r<0 then signchar:='-' else signchar:=' ';
  426.                   r:=abs(r);
  427.                   str(r:12:2,olds);
  428.                   olds:=signchar+'$'+olds;
  429.                   while pos(space,olds)>0 do delete(olds,pos(space,olds),1);
  430.                   if length(olds) > flen then olds:='$LEN'
  431.                 end
  432.               else {did not evaluate to a number}
  433.                 begin
  434.                   olds:='$EVA'
  435.                 end;
  436.               write(olds:flen)
  437.             end  {field type was dollar}
  438.           else begin  {field type was alpha, simple numeric or yesno}
  439.             write(olds);
  440.             for i:=length(olds)+1 to flen do write(space)
  441.             end;
  442.           getfld:=goforward
  443.         end  {new input, first character was not a screen command}
  444.     end  {with field variable}
  445. end;  {getfld}
  446.  
  447.  
  448.  
  449.  
  450. {End of Include File: PASCAL.LIB}
  451.