home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / turbopas / paslib.arc / PASLIB01.INC < prev    next >
Text File  |  1986-05-22  |  31KB  |  801 lines
  1.  
  2.    (*
  3.    **     PASLIB01.INC
  4.    **          Pascal function library
  5.    **          by Robert B. Wooster, May, 1986
  6.    **
  7.    *)
  8.  
  9.    CONST
  10.       IsColor : Boolean = False; {7/4/85}
  11.       MaxRow = 25;
  12.       MaxCol = 80;
  13.       { screen attributes }
  14.       LO_V : Byte = 7; HI_V : Byte = 15; RE_V : Byte = 112;
  15.       { cursor control keys }
  16.       SK_HM = 71; SK_UP = 72; SK_PU = 73; SK_LE = 75; SK_RI = 77;
  17.       SK_EN = 79; SK_DO = 80; SK_PD = 81; SK_IN = 82; SK_DE = 83;
  18.       E_S_C = 27;             {6/22/85}
  19.       { function keys }
  20.       SK_F1 = 59; SK_F2 = 60; SK_F3 = 61; SK_F4 = 62; SK_F5 = 63;
  21.       SK_F6 = 64; SK_F7 = 65; SK_F8 = 66; SK_F9 = 67; SK_F0 = 68;
  22.    TYPE
  23.       chrset = SET OF Char;
  24.       string80 = STRING[80];  {7/3/85}
  25.       bigstring = STRING[255];
  26.       regtype = RECORD CASE Integer OF
  27.          1 : (ax, bx, cx, dx, bp, si, ds, es, fl : Integer);
  28.          2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
  29.                 END;
  30.       datetype = RECORD
  31.                     month : 1..12; day : 1..31; year : 1960..2050;
  32.                  END;
  33.       timetype = RECORD
  34.                     hour, min, sec : Byte;
  35.                  END;
  36.       scrntype = ARRAY[0..1999] OF RECORD
  37.                                      Ch : Char; At : Byte;
  38.                                   END;
  39.       screenptr = ^scrntype;
  40.    VAR
  41.       EquipFlag : Integer ABSOLUTE $0000 : $0410; {7/4/85}
  42.       MonoScreen : scrntype ABSOLUTE $B000 : $0000;
  43.       ColorScreen : scrntype ABSOLUTE $B800 : $0000; {7/4/85}
  44.       KeyStat : Byte ABSOLUTE $0000 : $0417; {10/29/85}
  45.       savedscrn : screenptr;
  46.       SplKey : Byte;
  47.       sdt : datetype;
  48.       out : Text;             {6/22/85}
  49.       To_LST : Boolean;       {6/22/85}
  50.       EscFlag : Boolean;      {6/22/85}
  51.  
  52.       {---------------------------------------}
  53.       { monitor initialization                }
  54.       {---------------------------------------}
  55.    PROCEDURE InitMonitor;     {7/4/85}
  56.       BEGIN                   { initmonitor }
  57.          IsColor := (((Lo(EquipFlag) SHR 4) MOD 4) <> 3);
  58.       END;                    { initmonitor }
  59.  
  60.    PROCEDURE SwapMonitors;    {7/4/85}
  61.       VAR r : regtype;
  62.       BEGIN                   { swapmonitors }
  63.          IF (((Lo(EquipFlag) SHR 4) MOD 4) = 3) THEN BEGIN
  64.             EquipFlag := EquipFlag-16;
  65.             { note: color monitor set to 80x25 b&w }
  66.             r.AH := 0; r.AL := 2; Intr($10, r);
  67.          END                  {if}
  68.          ELSE BEGIN
  69.             EquipFlag := EquipFlag+16;
  70.             r.AH := 0; r.AL := 8; Intr($10, r);
  71.          END;                 {else}
  72.          InitMonitor;
  73.       END;                    { swapmonitors }
  74.       {==============================================}
  75.       {     i/o primitives                           }
  76.       {----------------------------------------------}
  77.    FUNCTION ugetc : Char;
  78.          { unbuffered getc, does not echo, ^c breaks }
  79.       VAR reg : regtype; c : Char;
  80.       BEGIN
  81.          SplKey := 0;
  82.          WITH reg DO BEGIN
  83.             ax := $0000; Intr($16, reg); c := Chr(AL);
  84.             SplKey := AH;
  85.          END;                 { with }
  86.          IF reg.AL = 3 THEN Halt; {^c}
  87.          IF reg.AL = 27 THEN BEGIN
  88.             SplKey := 27; {esc} c := Chr(0); {7/5/85}
  89.          END;
  90.          ugetc := c;
  91.       END;                    { ugetc }
  92.  
  93.    PROCEDURE putc(c : Char; b : Byte); {7/3/85}
  94.          { put character on screen with attribute b}
  95.       VAR row, col : Integer;
  96.       BEGIN
  97.          col := WhereX-1; row := WhereY-1;
  98.          IF IsColor THEN BEGIN
  99.             ColorScreen[80*row+col].Ch := c;
  100.             ColorScreen[80*row+col].At := b;
  101.          END                  {if}
  102.          ELSE BEGIN
  103.             MonoScreen[80*row+col].Ch := c;
  104.             MonoScreen[80*row+col].At := b;
  105.          END;                 {else}
  106.       END;                    { putc }
  107.  
  108.    PROCEDURE aputc(c : Char; a : Byte; col, row : Integer);
  109.          { put character c on screen at col,row with attribute a }
  110.       VAR i : Integer;
  111.       BEGIN
  112.          IF IsColor THEN BEGIN
  113.             ColorScreen[80*(row-1)+col-1].Ch := c;
  114.             ColorScreen[80*(row-1)+col-1].At := a;
  115.          END                  {if}
  116.          ELSE BEGIN
  117.             MonoScreen[80*(row-1)+col-1].Ch := c;
  118.             MonoScreen[80*(row-1)+col-1].At := a;
  119.          END;                 {else}
  120.       END; { putc }           {7/3/85}
  121.  
  122.       {==============================================}
  123.       {     i/o routines                             }
  124.       {----------------------------------------------}
  125.    FUNCTION GetUC(default : Char; okset : chrset) : Char;
  126.          { get a character from the keyboard, if lower case convert to upper }
  127.          { must be character in okset. if cr return default                  }
  128.       CONST CR = 13; ESC = 27;
  129.       VAR ok : Boolean; ch : Char;
  130.       BEGIN
  131.          REPEAT
  132.             Write(default, Char(8));
  133.             ch := UpCase(ugetc);
  134.             IF (ch = Chr(CR)) OR (ch = Chr(ESC)) OR (Ord(ch) = 0)
  135.             THEN ch := default;
  136.             ok := ch IN okset;
  137.             IF NOT ok THEN Write(Chr(7));
  138.          UNTIL ok;
  139.          Write(ch : 1);
  140.          GetUC := ch;
  141.       END;                    { getuc }
  142.  
  143.    PROCEDURE PutString(s : string80; col, row : Integer);
  144.          { put string on crt at indicated position }
  145.       BEGIN
  146.          GoToXY(col, row); Write(s);
  147.       END;                    { posstr }
  148.  
  149.    PROCEDURE GetString(VAR inpstr : string80;
  150.                        maxlen, col, row : Integer;
  151.                        default : string80);
  152.          { get an input string from the keyboard }
  153.       CONST BS = 8;           { ascii backspace }
  154.          CR = 13;             { ascii carriage return }
  155.          ESC = 27;            { ascii escape }
  156.  
  157.       VAR
  158.          ch : Char;
  159.          i : Integer;
  160.          isdefault : Boolean;
  161.          code : Byte;
  162.          done : Boolean;
  163.          FLDCHR : Char;       { input field marker }
  164.  
  165.  
  166.       FUNCTION AddChar(VAR s : string80; c : Char; max : Integer) : Boolean;
  167.             { add a character to the end of string }
  168.          BEGIN
  169.             IF Length(s) < max THEN BEGIN
  170.             s[0] := Succ(s[0]); s[Length(s)] := ch; END; { if }
  171.             IF Length(s) = max THEN AddChar := True
  172.             ELSE AddChar := False;
  173.          END;                 { addchar }
  174.  
  175.       PROCEDURE ChopChar(VAR s : string80);
  176.             { delete character from end of string }
  177.          BEGIN
  178.             IF Length(s) > 0 THEN s[0] := Pred(s[0]);
  179.             Write(^H); Write(FLDCHR); Write(^H);
  180.             IF (Length(s) = 0) AND isdefault THEN BEGIN
  181.                PutString(default, col, row);
  182.             GoToXY(col, row); END;
  183.          END;                 { chopchar }
  184.  
  185.       BEGIN
  186.          FLDCHR := Chr(254);
  187.          inpstr := '';
  188.          isdefault := Length(default) <> 0;
  189.          GoToXY(col, row);
  190.          FOR i := 1 TO maxlen DO Write(' ');
  191.          IF isdefault THEN PutString(default, col, row)
  192.          ELSE BEGIN GoToXY(col, row); {4/27/85}
  193.             FOR i := 1 TO maxlen DO Write(FLDCHR);
  194.          END;
  195.          GoToXY(col, row); done := False;
  196.          REPEAT
  197.             ch := ugetc;
  198.             CASE Ord(ch) OF
  199.                0 : done := True; { special key }
  200.                CR : done := True; { return }
  201.                BS : ChopChar(inpstr); { backspace }
  202.             ELSE BEGIN done := AddChar(inpstr, ch, maxlen);
  203.                IF isdefault AND (Length(inpstr) = 1) THEN BEGIN
  204.                   FOR i := 1 TO maxlen DO Write(FLDCHR); GoToXY(col, row);
  205.                END;
  206.             Write(ch); END;   { else }
  207.             END;              { case }
  208.          UNTIL done;
  209.          IF isdefault AND (Length(inpstr) = 0) THEN inpstr := default;
  210.          GoToXY(col, row); Write(' ' : maxlen);
  211.          GoToXY(col, row); Write(inpstr);
  212.       END;                    { getstring }
  213.  
  214.    PROCEDURE PutInteger(anum, col, row, maxlen : Integer); {11/8/85}
  215.          { put integer on crt}
  216.       VAR ts : String80;
  217.       BEGIN
  218.          Str(anum : maxlen, ts);
  219.          PutString(ts, col, row);
  220.       END;                    { putinteger }
  221.  
  222.    PROCEDURE GetInteger(VAR anum : Integer; {11/8/85}
  223.                         col, row, maxlen, min, max, default : Integer);
  224.       VAR newnum,
  225.          tstr : string80;
  226.          ii : Integer;
  227.       BEGIN
  228.          KeyStat := KeyStat+$20; {10/29/85}
  229.          Str(default : maxlen, tstr);
  230.          REPEAT
  231.             GetString(newnum, maxlen, col, row, tstr);
  232.             IF newnum = tstr THEN BEGIN
  233.             anum := default; ii := 0; END
  234.             ELSE BEGIN
  235.                WHILE newnum[1] = ' ' DO Delete(newnum, 1, 1);
  236.                Val(newnum, anum, ii);
  237.             END;
  238.          UNTIL (ii = 0) AND (anum >= min) AND (anum <= max);
  239.          PutInteger(anum, col, row, maxlen);
  240.          KeyStat := KeyStat-$20; {10/29/85}
  241.       END;                    { getinteger }
  242.  
  243.    FUNCTION Format(x : Real; i, j : Integer) : string80;
  244.          { format number with parens and commas }
  245.       VAR s : string80;
  246.          k : Integer;
  247.       BEGIN
  248.          Str(abs(x) : i : j, s);
  249.          WHILE s[1] = ' ' DO Delete(s, 1, 1);
  250.          IF j <> 0 THEN k := Pos('.', s)
  251.          ELSE k := Length(s)+1; {4/27/85}
  252.          IF abs(x) > 999.9999 THEN Insert(',', s, k-3);
  253.          IF abs(x) > 999999.9999 THEN Insert(',', s, k-6); {5/14/85}
  254.          IF x < 0 THEN s := '('+s+')'
  255.          ELSE s := ' '+s+' ';
  256.          WHILE Length(s) < i DO s := ' '+s;
  257.          Format := s;
  258.       END;                    { format }
  259.  
  260.    PROCEDURE PutNumber(anum : Real;
  261.                        col, row, maxlen, dcmls : Integer);
  262.          { put formatted number on crt}
  263.       BEGIN
  264.          GoToXY(col, row);
  265.          Write(anum : maxlen : dcmls);
  266.       END;                    { putnumber }
  267.  
  268.    PROCEDURE GetNumber(VAR anum : Real;
  269.                        col, row, maxlen, dcmls : Integer;
  270.                        min, max, default : Real);
  271.       VAR newnum,
  272.          tstr : string80;
  273.          ii : Integer;
  274.       BEGIN
  275.          KeyStat := KeyStat+$20; {10/29/85}
  276.          Str(default : maxlen : dcmls, tstr); {12/23/85}
  277.          REPEAT
  278.             GetString(newnum, maxlen, col, row, tstr);
  279.             IF newnum = tstr THEN BEGIN
  280.             anum := default; ii := 0; END
  281.             ELSE BEGIN
  282.                WHILE newnum[1] = ' ' DO Delete(newnum, 1, 1);
  283.                Val(newnum, anum, ii);
  284.             END;
  285.          UNTIL (ii = 0) AND (anum >= min) AND (anum <= max);
  286.          PutNumber(anum, col, row, maxlen, dcmls);
  287.          KeyStat := KeyStat-$20; {10/29/85}
  288.       END;                    { getnumber }
  289.  
  290.    FUNCTION Jul(dt : datetype) : Integer; FORWARD;
  291.    PROCEDURE SysDate(VAR dt : datetype); FORWARD;
  292.  
  293.    PROCEDURE PutDate(dt : datetype; col, row : Integer);
  294.       VAR dstr, temp : string80; i : Integer;
  295.       BEGIN
  296.          WITH dt DO BEGIN
  297.             Str(month, dstr); Str(day, temp);
  298.             dstr := dstr+'/'+temp+'/';
  299.             i := year MOD 100;
  300.             IF i < 10 THEN dstr := dstr+'0'+Chr(i+Ord('0'))
  301.             ELSE BEGIN Str((year MOD 100) : 2, temp);
  302.                dstr := dstr+temp;
  303.             END;              {else}
  304.          END;                 { with }
  305.          GoToXY(col, row); Write(dstr : 8);
  306.       END;                    { putdate }
  307.  
  308.    PROCEDURE GetDate(VAR dr : datetype; col, row : Integer; df : datetype);
  309.          { enter date at col x row }
  310.       VAR prompt, temp : string80; i, j, k : Integer; dateok, default : Boolean;
  311.          tdy : datetype;
  312.  
  313.       FUNCTION PickOff(VAR s : string80) : Integer;
  314.          VAR ii : Integer;
  315.          BEGIN
  316.             ii := 0;
  317.             WHILE (Length(s) > 0) AND (s[1] IN ['0'..'9']) DO BEGIN
  318.                ii := ii*10+Ord(s[1])-Ord('0');
  319.                Delete(s, 1, 1);
  320.             END;              { while  }
  321.             PickOff := ii;
  322.          END;                 { pickoff }
  323.  
  324.       PROCEDURE DtoStr(d : datetype; VAR s : string80);
  325.          VAR s1, s2 : STRING[2];
  326.          BEGIN
  327.             Str(d.month : 2, s); Str(d.day : 2, s1);
  328.             Str((d.year MOD 100) : 2, s2);
  329.             s := s+'/'+s1+'/'+s2;
  330.          END;                 { dtostr }
  331.  
  332.       BEGIN
  333.          KeyStat := KeyStat+$20; {10/29/85}
  334.          REPEAT
  335.             dateok := False; default := False;
  336.             IF (df.month = 1) AND (df.day = 1) AND (df.year = 1960)
  337.             THEN prompt := 'mm/dd/yy'
  338.             ELSE DtoStr(df, prompt);
  339.             GetString(temp, 8, col, row, prompt);
  340.             IF temp = prompt THEN BEGIN
  341.             dateok := True; dr := df; default := True; END
  342.             ELSE BEGIN
  343.                i := PickOff(temp); Delete(temp, 1, 1);
  344.                j := PickOff(temp);
  345.                IF Length(temp) > 0 THEN BEGIN
  346.                Delete(temp, 1, 1); k := PickOff(temp); END
  347.                ELSE k := sdt.year MOD 100;
  348.                IF (i > 0) AND (i < 13) THEN
  349.                   CASE i OF
  350.                      1, 3, 5, 7, 8, 10, 12 : IF (j < 32) AND (j > 0) THEN dateok
  351.                                                 := True;
  352.                      4, 6, 9, 11 : IF (j < 31) AND (j > 0) THEN dateok := True;
  353.                      2 : IF (j < 29) AND (j > 0) AND ((k MOD 4) <> 0)
  354.                         THEN dateok := True
  355.                         ELSE IF (j < 30) AND (j > 0) AND ((k MOD 4) = 0)
  356.                            THEN dateok := True;
  357.                   END;        { case }
  358.             END;              { if else }
  359.             IF NOT dateok THEN Write(^G);
  360.          UNTIL dateok;
  361.          IF NOT default THEN WITH dr DO BEGIN
  362.             month := i; day := j;
  363.             IF k < 60 THEN year := k+2000 ELSE year := k+1900;
  364.          END;                 { with }
  365.          PutDate(dr, col, row);
  366.          KeyStat := KeyStat-$20; {10/29/85}
  367.       END;                    { getdate }
  368.  
  369.    FUNCTION NextField(x, mx : Integer) : Integer;
  370.          { return next field based on splkey }
  371.       BEGIN
  372.          EscFlag := False;
  373.          CASE SplKey OF
  374.             SK_HM : NextField := 1;
  375.             SK_UP,
  376.             SK_LE : IF x = 1 THEN NextField := mx
  377.                     ELSE NextField := x-1;
  378.             SK_EN : NextField := mx;
  379.             E_S_C : BEGIN     {6/22/85}
  380.                     EscFlag := True; NextField := 1; END;
  381.          ELSE NextField := x+1;
  382.          END;                 { case }
  383.       END;                    { nextfield }
  384.  
  385.       {==============================================}
  386.       { date routines                                }
  387.       {----------------------------------------------}
  388.    FUNCTION StrDate(dr : datetype) : string80;
  389.       CONST nmon : ARRAY[1..12] OF STRING[3] =
  390.          ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  391.          'Nov', 'Dec');
  392.       VAR s1 : STRING[2]; s2 : STRING[2];
  393.       BEGIN
  394.          WITH dr DO BEGIN
  395.             Str(day : 2, s1); Str((year MOD 100) : 2, s2);
  396.             IF Length(s1) < 2 THEN s1 := Concat(' ', s1);
  397.             IF Length(s2) < 2 THEN s2 := Concat('0', s2);
  398.             StrDate := s1+' '+nmon[month]+' '+s2;
  399.          END;                 { with dr }
  400.       END;                    { strdate }
  401.  
  402.    FUNCTION Jul (*(var dt: datetype): integer*) ;
  403.       VAR i, j, k, j2, ju : Real;
  404.       BEGIN
  405.          WITH dt DO BEGIN
  406.             i := year; j := month; k := day;
  407.          END;                 { with }
  408.          j2 := Int((j-14)/12);
  409.          ju := k-32075+Int(1461*(i+4800+j2)/4);
  410.          ju := ju+Int(367*(j-2-j2*12)/12);
  411.          ju := ju-Int(3*Int((i+4900+j2)/100)/4);
  412.          Jul := Trunc(ju-2436935.0);
  413.       END;                    { jul }
  414.  
  415.  
  416.    PROCEDURE JtoD(pj : Integer; VAR dt : datetype);
  417.       VAR ju, i, j, k, l, n : Real;
  418.       BEGIN
  419.          ju := pj+2436935.0;
  420.          l := ju+68569.0;
  421.          n := Int(4*l/146097.0);
  422.          l := l-Int((146097.0*n+3)/4);
  423.          i := Int(4000.0*(l+1)/1461001.0);
  424.          l := l-Int(1461.0*i/4.0)+31.0;
  425.          j := Int(80*l/2447.0);
  426.          k := l-Int(2447.0*j/80.0);
  427.          l := Int(j/11);
  428.          j := j+2-12*l;
  429.          i := 100*(n-49)+i+l;
  430.          WITH dt DO BEGIN
  431.             year := Trunc(i);
  432.             month := Trunc(j);
  433.             day := Trunc(k);
  434.          END;                 { with }
  435.       END;                    { jtod }
  436.  
  437.    FUNCTION J30(dt : datetype) : Integer;
  438.          { calculate the 30/360 equivalent of the pseudo-julian  }
  439.       VAR i, j, k, ju : Real;
  440.       BEGIN
  441.          WITH dt DO BEGIN
  442.          i := year-1960; j := month; k := day; END; { with }
  443.          ju := 360*(i-1)+30*(j-1);
  444.          IF k > 30 THEN k := 30;
  445.          ju := ju+k;
  446.          J30 := Trunc(ju);
  447.       END;                    { j30 }
  448.  
  449.  
  450.    PROCEDURE LegalDate(VAR dt : datetype);
  451.          { checks to see if dt is a legal date.  if not fixes it. }
  452.       BEGIN
  453.          WITH dt DO CASE month OF
  454.             1, 3, 5, 7, 8, 10, 12 : IF day > 27 THEN day := 31;
  455.             4, 6, 9, 11 : IF day > 30 THEN day := 30;
  456.             2 : IF (year MOD 4) = 0 THEN BEGIN
  457.                 IF day > 29 THEN day := 29; END
  458.                 ELSE IF day > 28 THEN day := 28;
  459.          END;                 { case }
  460.       END;                    { legaldate }
  461.  
  462.    FUNCTION mmdd(d : datetype) : string80; {5/16/85}
  463.          { returns date of the form "mm/dd" }
  464.       BEGIN                   {  shortdate }
  465.          WITH d DO
  466.             mmdd := Chr(48+(month DIV 10))
  467.             +Chr(48+(month MOD 10))+'/'
  468.             +Chr(48+(day DIV 10))
  469.             +Chr(48+(day MOD 10))
  470.       END;                    {  shortdate }
  471.  
  472.    FUNCTION mmddyy(d : datetype) : string80; {5/16/85}
  473.          { returns date of the form "mm/dd/yy" }
  474.       BEGIN                   {  shortdate }
  475.          WITH d DO
  476.             mmddyy := Chr(48+(month DIV 10))
  477.             +Chr(48+(month MOD 10))+'/'
  478.             +Chr(48+(day DIV 10))
  479.             +Chr(48+(day MOD 10))+'/'
  480.             +Chr(48+((year MOD 100) DIV 10))
  481.             +Chr(48+(year MOD 10))
  482.       END;                    {  shortdate }
  483.  
  484.    FUNCTION DayOfWeek(adate : datetype) : Integer; {11/8/85}
  485.          { DOW: Monday = 0,..., Sunday = 6}
  486.       CONST Map : ARRAY[0..6] OF Integer = (4, 5, 6, 0, 1, 2, 3);
  487.       BEGIN                   { DayOfWeek }
  488.          DayOfWeek := Map[Jul(adate) MOD 7];
  489.       END;                    { DayOfWeek }
  490.  
  491.    PROCEDURE NextBday(olddate : datetype; {11/8/85}
  492.                       VAR newdate : datetype);
  493.       BEGIN                   { NextBday }
  494.          newdate.day := olddate.day; newdate.month := olddate.month;
  495.          newdate.year := olddate.year;
  496.          REPEAT
  497.             JtoD(jul(newdate)+1, newdate);
  498.          UNTIL DayOfWeek(newdate) < 5;
  499.       END;                    { NextBday }
  500.  
  501.    PROCEDURE AddMonths(olddate : datetype; months : Integer;
  502.                        VAR newdate : datetype); {5/20/86}
  503.       VAR n : Integer;
  504.       BEGIN                   { AddMonths }
  505.          newdate := olddate;
  506.          n := months+newdate.month;
  507.          IF n > 12 THEN BEGIN
  508.          n := n-12; newdate.year := newdate.year+1; END;
  509.          newdate.month := n;
  510.          IF ((olddate.month IN [1, 3, 5, 7, 8, 10, 12]) AND (olddate.day = 31))
  511.          OR ((olddate.month IN [4, 6, 9, 11]) AND (olddate.day = 30))
  512.          OR ((olddate.month = 2) AND (olddate.day = 28) AND ((olddate.year MOD 4) <> 0))
  513.          OR ((olddate.month = 2) AND (olddate.day = 29) AND ((olddate.year MOD 4) = 0))
  514.          THEN CASE newdate.month OF
  515.             1, 3, 5, 7, 8, 10, 12 : newdate.day := 31;
  516.             4, 6, 9, 11 : newdate.day := 30;
  517.             2 : IF (newdate.year MOD 4) = 0 THEN newdate.day := 29
  518.                 ELSE newdate.day := 28;
  519.          END;                 {case}
  520.       END;                    {AddMonths}
  521.  
  522.    FUNCTION DayCount(d1, d2 : datetype) : Integer;
  523.       BEGIN                   { DayCount }
  524.          DayCount := abs(jul(d2)-jul(d1));
  525.       END;                    { DayCount }
  526.  
  527.    FUNCTION DatesEqual(d1, d2 : datetype) : Boolean;
  528.       BEGIN                   { DatesEqual }
  529.          DatesEqual := False;
  530.          IF d1.month = d2.month THEN
  531.             IF d1.day = d2.day THEN
  532.                IF d1.year = d2.year THEN DatesEqual := True;
  533.       END;                    { DatesEqual }
  534.  
  535.    FUNCTION NullDate(d1 : datetype) : Boolean;
  536.       BEGIN                   { NullDate }
  537.          NullDate := False;
  538.          IF d1.month = 1 THEN
  539.             IF d1.day = 1 THEN
  540.                IF d1.year = 1960 THEN NullDate := True;
  541.       END;                    { NullDate }
  542.       {==============================================}
  543.       {       windowing routines                     }
  544.       {==============================================}
  545.    PROCEDURE MakeBox(x1, y1, x2, y2 : Integer); {7/4/85}
  546.       VAR x, y : Integer;
  547.          { draw a box from x1,y1 to x2,y2 }
  548.       BEGIN                   { procedure makebox }
  549.          Window(1, 1, 80, 25);
  550.          aputc('+', RE_V, x1, y1);
  551.          FOR x := x1+1 TO x2-1 DO aputc(' ', RE_V, x, y1);
  552.          aputc('+', RE_V, x2, y1);
  553.          FOR y := y1+1 TO y2-1 DO aputc(' ', RE_V, x2, y);
  554.          aputc('+', RE_V, x2, y2);
  555.          FOR x := x2-1 DOWNTO x1+1 DO aputc(' ', RE_V, x, y2);
  556.          aputc('+', RE_V, x1, y2);
  557.          FOR y := y2-1 DOWNTO y1+1 DO aputc(' ', RE_V, x1, y);
  558.       END;                    { procedure makebox }
  559.  
  560.    PROCEDURE MainWdo;         {7/3/85}
  561.       BEGIN Window(1, 2, 80, 24); END;
  562.  
  563.    PROCEDURE InitWindows;     {12/23/85}
  564.       VAR i : Integer;
  565.       BEGIN
  566.          ClrScr;
  567.          FOR i := 1 TO 80 DO aputc(' ', RE_V, i, 1);
  568.          FOR i := 1 TO 80 DO aputc(' ', RE_V, i, 25);
  569.          MainWdo; GoToXY(1, 1);
  570.       END;                    {initwindows}
  571.  
  572.    PROCEDURE HelpWdo;
  573.       VAR i : Integer;
  574.       BEGIN                   { HelpWdo; }
  575.          Window(1, 1, 80, 25); GoToXY(1, 25);
  576.          FOR i := 1 TO 80 DO aputc(' ', RE_V, i, 25);
  577.       END;                    { HelpWdo; }
  578.  
  579.    PROCEDURE Heading(s : string80); {7/3/85}
  580.       VAR x, y, col, lbegin, lend, i : Integer;
  581.       BEGIN                   { heading }
  582.          x := WhereX; y := WhereY; Window(1, 1, 80, 1);
  583.          FOR col := 1 TO 80 DO aputc(' ', 112, col, 1);
  584.          lbegin := 40-(Length(s) DIV 2); lend := lbegin+Length(s)-1;
  585.          i := 0;
  586.          FOR col := lbegin TO lend DO BEGIN
  587.             i := i+1; aputc(s[i], 112, col, 1);
  588.          END;                 {for}
  589.          MainWdo; GoToXY(x, y);
  590.       END;                    { heading }
  591.  
  592.    PROCEDURE SaveScrn;
  593.          { push active screen into memory }
  594.       BEGIN                   {  SaveScrn }
  595.          GetMem(savedscrn, 4000);
  596.          IF IsColor THEN Move(ColorScreen, savedscrn^, 4000)
  597.          ELSE Move(MonoScreen, savedscrn^, 4000);
  598.       END;                    {  SaveScrn }
  599.  
  600.    PROCEDURE RestoreScrn;
  601.          { pop old screen from memory }
  602.       BEGIN                   {  RestoreScrn }
  603.          IF IsColor THEN Move(savedscrn^, ColorScreen, 4000)
  604.          ELSE Move(savedscrn^, MonoScreen, 4000);
  605.          FreeMem(savedscrn, 4000);
  606.       END;                    {  RestoreScrn }
  607.  
  608.    PROCEDURE Wait;
  609.       VAR xx, yy : Integer;
  610.       BEGIN                   {  wait }
  611.          xx := WhereX; yy := WhereY; HelpWdo;
  612.          TextColor(0+BLINK); TextBackground(15);
  613.          Write('Press any key to continue' : 52);
  614.          REPEAT UNTIL KeyPressed;
  615.          HelpWdo;
  616.          TextColor(15); TextBackground(0);
  617.          MainWdo; GoToXY(xx, yy);
  618.          NormVideo;
  619.       END;                    {  wait }
  620.  
  621.    PROCEDURE WhereOut;
  622.       VAR xx, yy : Integer;
  623.       BEGIN                   {  whereout: }
  624.          xx := WhereX; yy := WhereY; HelpWdo;
  625.          TextColor(1); TextBackground(15);
  626.          Write('Do you want report sent to the printer? ' : 65);
  627.          IF GetUC('N', ['Y', 'N']) = 'Y' THEN
  628.             BEGIN Assign(out, 'LST:'); To_LST := True; END
  629.          ELSE BEGIN Assign(out, 'CON:'); To_LST := False; END;
  630.          Reset(out); ClrScr;
  631.          TextColor(15); TextBackground(0);
  632.          NormVideo; MainWdo; GoToXY(xx, yy);
  633.       END;                    {  whereout: }
  634.  
  635.    PROCEDURE Page;
  636.       BEGIN                   { page; }
  637.          IF To_LST THEN Write(out, ^L) ELSE wait;
  638.       END;                    { page; }
  639.  
  640.    PROCEDURE ShowHelp(s1 : string80); {7/7/85}
  641.       VAR x, y : Integer;
  642.       BEGIN                   { showhelp }
  643.          x := WhereX; y := WhereY;
  644.          HelpWdo;
  645.          TextBackground(7); TextColor(1);
  646.          Write(s1 : (38+Length(s1) DIV 2));
  647.          MainWdo; GoToXY(x, y);
  648.          TextBackground(0); TextColor(15);
  649.          NormVideo;
  650.       END;                    { showhelp }
  651.  
  652.    FUNCTION Prompt(s : string80; default : Char) : Char; {7/7/85}
  653.       VAR x, y, i, len, offset : Integer; okset : SET OF Char;
  654.       BEGIN                   { prompt }
  655.          x := WhereX; y := WhereY; okset := [];
  656.          HelpWdo;
  657.          TextBackground(15); TextColor(1);
  658.          len := Length(s); offset := 38-len DIV 2;
  659.          LowVideo; Write(s : len+offset); NormVideo;
  660.          FOR i := 1 TO len DO BEGIN
  661.             IF s[i] IN ['A'..'Z'] THEN BEGIN
  662.                okset := okset+[s[i]];
  663.             END;              {if}
  664.          END;                 {for}
  665.          GoToXY(offset+len+3, 1);
  666.          Prompt := GetUC(default, okset);
  667.          HelpWdo;
  668.          TextBackground(0); TextColor(15);
  669.          MainWdo; GoToXY(x, y);
  670.       END;                    { prompt }
  671.  
  672.    VAR
  673.       Xmain,
  674.       Ymain : Integer;
  675.  
  676.    PROCEDURE UseWdo(x, y, cols, rows : Integer; Head : string80);
  677.       VAR left, right, top, bottom : Integer;
  678.  
  679.       PROCEDURE OutlineWdo(x1, y1, x2, y2 : Integer;
  680.                            Lines : Boolean; Head : string80);
  681.          VAR i, len, hstart : Integer;
  682.          BEGIN                { OutlineWdo }
  683.             len := Length(head);
  684.             IF lines THEN BEGIN
  685.                IF y1 > 1 THEN BEGIN
  686.                   IF x1 > 1 THEN aputc(Chr(218), LO_V, x1-1, y1-1);
  687.                   FOR i := x1 TO x2 DO aputc(Chr(196), LO_V, i, y1-1);
  688.                   IF x2 < 80 THEN aputc(Chr(191), LO_V, x2+1, y1-1);
  689.                   IF (len > 0) AND (len < (x2-x1-1)) THEN BEGIN
  690.                      hstart := x1+(x2-x1) DIV 2-len DIV 2;
  691.                      FOR i := 1 TO len
  692.                      DO aputc(head[i], RE_V, i+hstart-1, y1-1);
  693.                   END;
  694.                END {if} ;
  695.                IF x2 < 80 THEN
  696.                   FOR i := y1 TO y2 DO aputc(Chr(179), LO_V, x2+1, i);
  697.                IF x1 > 1 THEN
  698.                   FOR i := y1 TO y2 DO aputc(Chr(179), LO_V, x1-1, i);
  699.                IF y2 < 25 THEN BEGIN
  700.                   IF x1 > 1 THEN aputc(Chr(192), LO_V, x1-1, y2+1);
  701.                   FOR i := x1 TO x2 DO aputc(Chr(196), LO_V, i, y2+1);
  702.                   IF x2 < 80 THEN aputc(Chr(217), LO_V, x2+1, y2+1);
  703.                END {if} ;
  704.             END ELSE BEGIN
  705.                IF y1 > 1 THEN BEGIN
  706.                   IF x1 > 1 THEN aputc(' ', RE_V, x1-1, y1-1);
  707.                   FOR i := x1 TO x2 DO aputc(' ', RE_V, i, y1-1);
  708.                   IF x2 < 80 THEN aputc(' ', RE_V, x2+1, y1-1);
  709.                   IF (len > 0) AND (len < (x2-x1-1)) THEN BEGIN
  710.                      hstart := x1+(x2-x1) DIV 2-len DIV 2;
  711.                      FOR i := 1 TO len
  712.                      DO aputc(head[i], RE_V, i+hstart-1, y1-1);
  713.                   END;
  714.                END {if} ;
  715.                IF x2 < 80 THEN
  716.                   FOR i := y1 TO y2 DO aputc(' ', RE_V, x2+1, i);
  717.                IF x1 > 1 THEN
  718.                   FOR i := y1 TO y2 DO aputc(' ', RE_V, x1-1, i);
  719.                IF y2 < 25 THEN BEGIN
  720.                   IF x1 > 1 THEN aputc(' ', RE_V, x1-1, y2+1);
  721.                   FOR i := x1 TO x2 DO aputc(' ', RE_V, i, y2+1);
  722.                   IF x2 < 80 THEN aputc(' ', RE_V, x2+1, y2+1);
  723.                END {if} ;
  724.             END;
  725.          END;                 { OutlineWdo }
  726.  
  727.       BEGIN                   { UseWdo }
  728.          Xmain := WhereX; Ymain := WhereY;
  729.          left := x; right := x+cols-1;
  730.          IF right > 80 THEN BEGIN
  731.             left := 80-cols;
  732.             right := 80;
  733.          END {if} ;
  734.          top := y; bottom := y+rows-1;
  735.          IF bottom > 25 THEN BEGIN
  736.             top := 25-rows;
  737.             bottom := 25;
  738.          END {if} ;
  739.          Window(1, 1, 80, 25);
  740.          OutlineWdo(left, top, right, bottom, True, head);
  741.          Window(left, top, right, bottom);
  742.          ClrScr;
  743.       END;                    { UseWdo }
  744.  
  745.    PROCEDURE CloseWdo;
  746.       BEGIN                   { CloseWdo; }
  747.          MainWdo;
  748.          GoToXY(Xmain, Ymain);
  749.       END;                    { CloseWdo; }
  750.  
  751.       {==============================================}
  752.       {      system services                         }
  753.       {----------------------------------------------}
  754.  
  755.    PROCEDURE SysDate (*var dt: datetype*) ;
  756.          { read system clock }
  757.       VAR r : regtype;
  758.       BEGIN
  759.          WITH r DO BEGIN
  760.             AH := $2A; MsDos(r);
  761.             dt.month := DH; dt.day := DL;
  762.             dt.year := CX;
  763.          END;                 { with }
  764.       END;                    { sysdate }
  765.  
  766.    PROCEDURE SysTime(VAR tm : timetype);
  767.          { read system clock }
  768.       VAR r : regtype;
  769.       BEGIN
  770.          WITH r DO BEGIN
  771.             AH := $2C; MsDos(r);
  772.             tm.hour := CH; tm.min := CL; tm.sec := DH;
  773.          END;                 { with }
  774.       END;                    { systime }
  775.  
  776.    FUNCTION TimeStamp : string80;
  777.          { return system date and time as a string }
  778.       VAR t : timetype; d : datetype; ts, t1 : string80; pm : Boolean;
  779.       BEGIN
  780.          SysTime(t); SysDate(d);
  781.          pm := False;
  782.          IF t.hour > 11 THEN pm := True;
  783.          IF t.hour > 12 THEN t.hour := t.hour-12;
  784.          IF t.hour = 0 THEN t.hour := 12;
  785.          Str(t.hour : 2, ts);
  786.          Str(t.min, t1);
  787.          IF t.min < 10 THEN ts := ts+':0'+t1
  788.          ELSE ts := ts+':'+t1;
  789.          IF pm THEN ts := ts+' pm '
  790.          ELSE ts := ts+' am ';
  791.          TimeStamp := ts+StrDate(d);
  792.       END;                    { timestamp }
  793.  
  794.    PROCEDURE InitSys;
  795.       BEGIN                   { initsys; }
  796.          InitMonitor; InitWindows; SysDate(sdt);
  797.       END;                    { initsys; }
  798.       {----------------------------------------------}
  799.       { end of file paslib.inc                       }
  800.       {----------------------------------------------}
  801.