Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PASLIB2.ZIP/PASLIB01.INC

Text File | 1986-05-22 | 30.2 KB | 801 lines

   (*
   **     PASLIB01.INC
   **          Pascal function library
   **          by Robert B. Wooster, May, 1986
   **
   *)

   CONST
      IsColor : Boolean = False; {7/4/85}
      MaxRow = 25;
      MaxCol = 80;
      { screen attributes }
      LO_V : Byte = 7; HI_V : Byte = 15; RE_V : Byte = 112;
      { cursor control keys }
      SK_HM = 71; SK_UP = 72; SK_PU = 73; SK_LE = 75; SK_RI = 77;
      SK_EN = 79; SK_DO = 80; SK_PD = 81; SK_IN = 82; SK_DE = 83;
      E_S_C = 27;             {6/22/85}
      { function keys }
      SK_F1 = 59; SK_F2 = 60; SK_F3 = 61; SK_F4 = 62; SK_F5 = 63;
      SK_F6 = 64; SK_F7 = 65; SK_F8 = 66; SK_F9 = 67; SK_F0 = 68;
   TYPE
      chrset = SET OF Char;
      string80 = STRING[80];  {7/3/85}
      bigstring = STRING[255];
      regtype = RECORD CASE Integer OF
         1 : (ax, bx, cx, dx, bp, si, ds, es, fl : Integer);
         2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
                END;
      datetype = RECORD
                    month : 1..12; day : 1..31; year : 1960..2050;
                 END;
      timetype = RECORD
                    hour, min, sec : Byte;
                 END;
      scrntype = ARRAY[0..1999] OF RECORD
                                     Ch : Char; At : Byte;
                                  END;
      screenptr = ^scrntype;
   VAR
      EquipFlag : Integer ABSOLUTE $0000 : $0410; {7/4/85}
      MonoScreen : scrntype ABSOLUTE $B000 : $0000;
      ColorScreen : scrntype ABSOLUTE $B800 : $0000; {7/4/85}
      KeyStat : Byte ABSOLUTE $0000 : $0417; {10/29/85}
      savedscrn : screenptr;
      SplKey : Byte;
      sdt : datetype;
      out : Text;             {6/22/85}
      To_LST : Boolean;       {6/22/85}
      EscFlag : Boolean;      {6/22/85}

      {---------------------------------------}
      { monitor initialization                }
      {---------------------------------------}
   PROCEDURE InitMonitor;     {7/4/85}
      BEGIN                   { initmonitor }
         IsColor := (((Lo(EquipFlag) SHR 4) MOD 4) <> 3);
      END;                    { initmonitor }

   PROCEDURE SwapMonitors;    {7/4/85}
      VAR r : regtype;
      BEGIN                   { swapmonitors }
         IF (((Lo(EquipFlag) SHR 4) MOD 4) = 3) THEN BEGIN
            EquipFlag := EquipFlag-16;
            { note: color monitor set to 80x25 b&w }
            r.AH := 0; r.AL := 2; Intr($10, r);
         END                  {if}
         ELSE BEGIN
            EquipFlag := EquipFlag+16;
            r.AH := 0; r.AL := 8; Intr($10, r);
         END;                 {else}
         InitMonitor;
      END;                    { swapmonitors }
      {==============================================}
      {     i/o primitives                           }
      {----------------------------------------------}
   FUNCTION ugetc : Char;
         { unbuffered getc, does not echo, ^c breaks }
      VAR reg : regtype; c : Char;
      BEGIN
         SplKey := 0;
         WITH reg DO BEGIN
            ax := $0000; Intr($16, reg); c := Chr(AL);
            SplKey := AH;
         END;                 { with }
         IF reg.AL = 3 THEN Halt; {^c}
         IF reg.AL = 27 THEN BEGIN
            SplKey := 27; {esc} c := Chr(0); {7/5/85}
         END;
         ugetc := c;
      END;                    { ugetc }

   PROCEDURE putc(c : Char; b : Byte); {7/3/85}
         { put character on screen with attribute b}
      VAR row, col : Integer;
      BEGIN
         col := WhereX-1; row := WhereY-1;
         IF IsColor THEN BEGIN
            ColorScreen[80*row+col].Ch := c;
            ColorScreen[80*row+col].At := b;
         END                  {if}
         ELSE BEGIN
            MonoScreen[80*row+col].Ch := c;
            MonoScreen[80*row+col].At := b;
         END;                 {else}
      END;                    { putc }

   PROCEDURE aputc(c : Char; a : Byte; col, row : Integer);
         { put character c on screen at col,row with attribute a }
      VAR i : Integer;
      BEGIN
         IF IsColor THEN BEGIN
            ColorScreen[80*(row-1)+col-1].Ch := c;
            ColorScreen[80*(row-1)+col-1].At := a;
         END                  {if}
         ELSE BEGIN
            MonoScreen[80*(row-1)+col-1].Ch := c;
            MonoScreen[80*(row-1)+col-1].At := a;
         END;                 {else}
      END; { putc }           {7/3/85}

      {==============================================}
      {     i/o routines                             }
      {----------------------------------------------}
   FUNCTION GetUC(default : Char; okset : chrset) : Char;
         { get a character from the keyboard, if lower case convert to upper }
         { must be character in okset. if cr return default                  }
      CONST CR = 13; ESC = 27;
      VAR ok : Boolean; ch : Char;
      BEGIN
         REPEAT
            Write(default, Char(8));
            ch := UpCase(ugetc);
            IF (ch = Chr(CR)) OR (ch = Chr(ESC)) OR (Ord(ch) = 0)
            THEN ch := default;
            ok := ch IN okset;
            IF NOT ok THEN Write(Chr(7));
         UNTIL ok;
         Write(ch : 1);
         GetUC := ch;
      END;                    { getuc }

   PROCEDURE PutString(s : string80; col, row : Integer);
         { put string on crt at indicated position }
      BEGIN
         GoToXY(col, row); Write(s);
      END;                    { posstr }

   PROCEDURE GetString(VAR inpstr : string80;
                       maxlen, col, row : Integer;
                       default : string80);
         { get an input string from the keyboard }
      CONST BS = 8;           { ascii backspace }
         CR = 13;             { ascii carriage return }
         ESC = 27;            { ascii escape }

      VAR
         ch : Char;
         i : Integer;
         isdefault : Boolean;
         code : Byte;
         done : Boolean;
         FLDCHR : Char;       { input field marker }


      FUNCTION AddChar(VAR s : string80; c : Char; max : Integer) : Boolean;
            { add a character to the end of string }
         BEGIN
            IF Length(s) < max THEN BEGIN
            s[0] := Succ(s[0]); s[Length(s)] := ch; END; { if }
            IF Length(s) = max THEN AddChar := True
            ELSE AddChar := False;
         END;                 { addchar }

      PROCEDURE ChopChar(VAR s : string80);
            { delete character from end of string }
         BEGIN
            IF Length(s) > 0 THEN s[0] := Pred(s[0]);
            Write(^H); Write(FLDCHR); Write(^H);
            IF (Length(s) = 0) AND isdefault THEN BEGIN
               PutString(default, col, row);
            GoToXY(col, row); END;
         END;                 { chopchar }

      BEGIN
         FLDCHR := Chr(254);
         inpstr := '';
         isdefault := Length(default) <> 0;
         GoToXY(col, row);
         FOR i := 1 TO maxlen DO Write(' ');
         IF isdefault THEN PutString(default, col, row)
         ELSE BEGIN GoToXY(col, row); {4/27/85}
            FOR i := 1 TO maxlen DO Write(FLDCHR);
         END;
         GoToXY(col, row); done := False;
         REPEAT
            ch := ugetc;
            CASE Ord(ch) OF
               0 : done := True; { special key }
               CR : done := True; { return }
               BS : ChopChar(inpstr); { backspace }
            ELSE BEGIN done := AddChar(inpstr, ch, maxlen);
               IF isdefault AND (Length(inpstr) = 1) THEN BEGIN
                  FOR i := 1 TO maxlen DO Write(FLDCHR); GoToXY(col, row);
               END;
            Write(ch); END;   { else }
            END;              { case }
         UNTIL done;
         IF isdefault AND (Length(inpstr) = 0) THEN inpstr := default;
         GoToXY(col, row); Write(' ' : maxlen);
         GoToXY(col, row); Write(inpstr);
      END;                    { getstring }

   PROCEDURE PutInteger(anum, col, row, maxlen : Integer); {11/8/85}
         { put integer on crt}
      VAR ts : String80;
      BEGIN
         Str(anum : maxlen, ts);
         PutString(ts, col, row);
      END;                    { putinteger }

   PROCEDURE GetInteger(VAR anum : Integer; {11/8/85}
                        col, row, maxlen, min, max, default : Integer);
      VAR newnum,
         tstr : string80;
         ii : Integer;
      BEGIN
         KeyStat := KeyStat+$20; {10/29/85}
         Str(default : maxlen, tstr);
         REPEAT
            GetString(newnum, maxlen, col, row, tstr);
            IF newnum = tstr THEN BEGIN
            anum := default; ii := 0; END
            ELSE BEGIN
               WHILE newnum[1] = ' ' DO Delete(newnum, 1, 1);
               Val(newnum, anum, ii);
            END;
         UNTIL (ii = 0) AND (anum >= min) AND (anum <= max);
         PutInteger(anum, col, row, maxlen);
         KeyStat := KeyStat-$20; {10/29/85}
      END;                    { getinteger }

   FUNCTION Format(x : Real; i, j : Integer) : string80;
         { format number with parens and commas }
      VAR s : string80;
         k : Integer;
      BEGIN
         Str(abs(x) : i : j, s);
         WHILE s[1] = ' ' DO Delete(s, 1, 1);
         IF j <> 0 THEN k := Pos('.', s)
         ELSE k := Length(s)+1; {4/27/85}
         IF abs(x) > 999.9999 THEN Insert(',', s, k-3);
         IF abs(x) > 999999.9999 THEN Insert(',', s, k-6); {5/14/85}
         IF x < 0 THEN s := '('+s+')'
         ELSE s := ' '+s+' ';
         WHILE Length(s) < i DO s := ' '+s;
         Format := s;
      END;                    { format }

   PROCEDURE PutNumber(anum : Real;
                       col, row, maxlen, dcmls : Integer);
         { put formatted number on crt}
      BEGIN
         GoToXY(col, row);
         Write(anum : maxlen : dcmls);
      END;                    { putnumber }

   PROCEDURE GetNumber(VAR anum : Real;
                       col, row, maxlen, dcmls : Integer;
                       min, max, default : Real);
      VAR newnum,
         tstr : string80;
         ii : Integer;
      BEGIN
         KeyStat := KeyStat+$20; {10/29/85}
         Str(default : maxlen : dcmls, tstr); {12/23/85}
         REPEAT
            GetString(newnum, maxlen, col, row, tstr);
            IF newnum = tstr THEN BEGIN
            anum := default; ii := 0; END
            ELSE BEGIN
               WHILE newnum[1] = ' ' DO Delete(newnum, 1, 1);
               Val(newnum, anum, ii);
            END;
         UNTIL (ii = 0) AND (anum >= min) AND (anum <= max);
         PutNumber(anum, col, row, maxlen, dcmls);
         KeyStat := KeyStat-$20; {10/29/85}
      END;                    { getnumber }

   FUNCTION Jul(dt : datetype) : Integer; FORWARD;
   PROCEDURE SysDate(VAR dt : datetype); FORWARD;

   PROCEDURE PutDate(dt : datetype; col, row : Integer);
      VAR dstr, temp : string80; i : Integer;
      BEGIN
         WITH dt DO BEGIN
            Str(month, dstr); Str(day, temp);
            dstr := dstr+'/'+temp+'/';
            i := year MOD 100;
            IF i < 10 THEN dstr := dstr+'0'+Chr(i+Ord('0'))
            ELSE BEGIN Str((year MOD 100) : 2, temp);
               dstr := dstr+temp;
            END;              {else}
         END;                 { with }
         GoToXY(col, row); Write(dstr : 8);
      END;                    { putdate }

   PROCEDURE GetDate(VAR dr : datetype; col, row : Integer; df : datetype);
         { enter date at col x row }
      VAR prompt, temp : string80; i, j, k : Integer; dateok, default : Boolean;
         tdy : datetype;

      FUNCTION PickOff(VAR s : string80) : Integer;
         VAR ii : Integer;
         BEGIN
            ii := 0;
            WHILE (Length(s) > 0) AND (s[1] IN ['0'..'9']) DO BEGIN
               ii := ii*10+Ord(s[1])-Ord('0');
               Delete(s, 1, 1);
            END;              { while  }
            PickOff := ii;
         END;                 { pickoff }

      PROCEDURE DtoStr(d : datetype; VAR s : string80);
         VAR s1, s2 : STRING[2];
         BEGIN
            Str(d.month : 2, s); Str(d.day : 2, s1);
            Str((d.year MOD 100) : 2, s2);
            s := s+'/'+s1+'/'+s2;
         END;                 { dtostr }

      BEGIN
         KeyStat := KeyStat+$20; {10/29/85}
         REPEAT
            dateok := False; default := False;
            IF (df.month = 1) AND (df.day = 1) AND (df.year = 1960)
            THEN prompt := 'mm/dd/yy'
            ELSE DtoStr(df, prompt);
            GetString(temp, 8, col, row, prompt);
            IF temp = prompt THEN BEGIN
            dateok := True; dr := df; default := True; END
            ELSE BEGIN
               i := PickOff(temp); Delete(temp, 1, 1);
               j := PickOff(temp);
               IF Length(temp) > 0 THEN BEGIN
               Delete(temp, 1, 1); k := PickOff(temp); END
               ELSE k := sdt.year MOD 100;
               IF (i > 0) AND (i < 13) THEN
                  CASE i OF
                     1, 3, 5, 7, 8, 10, 12 : IF (j < 32) AND (j > 0) THEN dateok
                                                := True;
                     4, 6, 9, 11 : IF (j < 31) AND (j > 0) THEN dateok := True;
                     2 : IF (j < 29) AND (j > 0) AND ((k MOD 4) <> 0)
                        THEN dateok := True
                        ELSE IF (j < 30) AND (j > 0) AND ((k MOD 4) = 0)
                           THEN dateok := True;
                  END;        { case }
            END;              { if else }
            IF NOT dateok THEN Write(^G);
         UNTIL dateok;
         IF NOT default THEN WITH dr DO BEGIN
            month := i; day := j;
            IF k < 60 THEN year := k+2000 ELSE year := k+1900;
         END;                 { with }
         PutDate(dr, col, row);
         KeyStat := KeyStat-$20; {10/29/85}
      END;                    { getdate }

   FUNCTION NextField(x, mx : Integer) : Integer;
         { return next field based on splkey }
      BEGIN
         EscFlag := False;
         CASE SplKey OF
            SK_HM : NextField := 1;
            SK_UP,
            SK_LE : IF x = 1 THEN NextField := mx
                    ELSE NextField := x-1;
            SK_EN : NextField := mx;
            E_S_C : BEGIN     {6/22/85}
                    EscFlag := True; NextField := 1; END;
         ELSE NextField := x+1;
         END;                 { case }
      END;                    { nextfield }

      {==============================================}
      { date routines                                }
      {----------------------------------------------}
   FUNCTION StrDate(dr : datetype) : string80;
      CONST nmon : ARRAY[1..12] OF STRING[3] =
         ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
         'Nov', 'Dec');
      VAR s1 : STRING[2]; s2 : STRING[2];
      BEGIN
         WITH dr DO BEGIN
            Str(day : 2, s1); Str((year MOD 100) : 2, s2);
            IF Length(s1) < 2 THEN s1 := Concat(' ', s1);
            IF Length(s2) < 2 THEN s2 := Concat('0', s2);
            StrDate := s1+' '+nmon[month]+' '+s2;
         END;                 { with dr }
      END;                    { strdate }

   FUNCTION Jul (*(var dt: datetype): integer*) ;
      VAR i, j, k, j2, ju : Real;
      BEGIN
         WITH dt DO BEGIN
            i := year; j := month; k := day;
         END;                 { with }
         j2 := Int((j-14)/12);
         ju := k-32075+Int(1461*(i+4800+j2)/4);
         ju := ju+Int(367*(j-2-j2*12)/12);
         ju := ju-Int(3*Int((i+4900+j2)/100)/4);
         Jul := Trunc(ju-2436935.0);
      END;                    { jul }


   PROCEDURE JtoD(pj : Integer; VAR dt : datetype);
      VAR ju, i, j, k, l, n : Real;
      BEGIN
         ju := pj+2436935.0;
         l := ju+68569.0;
         n := Int(4*l/146097.0);
         l := l-Int((146097.0*n+3)/4);
         i := Int(4000.0*(l+1)/1461001.0);
         l := l-Int(1461.0*i/4.0)+31.0;
         j := Int(80*l/2447.0);
         k := l-Int(2447.0*j/80.0);
         l := Int(j/11);
         j := j+2-12*l;
         i := 100*(n-49)+i+l;
         WITH dt DO BEGIN
            year := Trunc(i);
            month := Trunc(j);
            day := Trunc(k);
         END;                 { with }
      END;                    { jtod }

   FUNCTION J30(dt : datetype) : Integer;
         { calculate the 30/360 equivalent of the pseudo-julian  }
      VAR i, j, k, ju : Real;
      BEGIN
         WITH dt DO BEGIN
         i := year-1960; j := month; k := day; END; { with }
         ju := 360*(i-1)+30*(j-1);
         IF k > 30 THEN k := 30;
         ju := ju+k;
         J30 := Trunc(ju);
      END;                    { j30 }


   PROCEDURE LegalDate(VAR dt : datetype);
         { checks to see if dt is a legal date.  if not fixes it. }
      BEGIN
         WITH dt DO CASE month OF
            1, 3, 5, 7, 8, 10, 12 : IF day > 27 THEN day := 31;
            4, 6, 9, 11 : IF day > 30 THEN day := 30;
            2 : IF (year MOD 4) = 0 THEN BEGIN
                IF day > 29 THEN day := 29; END
                ELSE IF day > 28 THEN day := 28;
         END;                 { case }
      END;                    { legaldate }

   FUNCTION mmdd(d : datetype) : string80; {5/16/85}
         { returns date of the form "mm/dd" }
      BEGIN                   {  shortdate }
         WITH d DO
            mmdd := Chr(48+(month DIV 10))
            +Chr(48+(month MOD 10))+'/'
            +Chr(48+(day DIV 10))
            +Chr(48+(day MOD 10))
      END;                    {  shortdate }

   FUNCTION mmddyy(d : datetype) : string80; {5/16/85}
         { returns date of the form "mm/dd/yy" }
      BEGIN                   {  shortdate }
         WITH d DO
            mmddyy := Chr(48+(month DIV 10))
            +Chr(48+(month MOD 10))+'/'
            +Chr(48+(day DIV 10))
            +Chr(48+(day MOD 10))+'/'
            +Chr(48+((year MOD 100) DIV 10))
            +Chr(48+(year MOD 10))
      END;                    {  shortdate }

   FUNCTION DayOfWeek(adate : datetype) : Integer; {11/8/85}
         { DOW: Monday = 0,..., Sunday = 6}
      CONST Map : ARRAY[0..6] OF Integer = (4, 5, 6, 0, 1, 2, 3);
      BEGIN                   { DayOfWeek }
         DayOfWeek := Map[Jul(adate) MOD 7];
      END;                    { DayOfWeek }

   PROCEDURE NextBday(olddate : datetype; {11/8/85}
                      VAR newdate : datetype);
      BEGIN                   { NextBday }
         newdate.day := olddate.day; newdate.month := olddate.month;
         newdate.year := olddate.year;
         REPEAT
            JtoD(jul(newdate)+1, newdate);
         UNTIL DayOfWeek(newdate) < 5;
      END;                    { NextBday }

   PROCEDURE AddMonths(olddate : datetype; months : Integer;
                       VAR newdate : datetype); {5/20/86}
      VAR n : Integer;
      BEGIN                   { AddMonths }
         newdate := olddate;
         n := months+newdate.month;
         IF n > 12 THEN BEGIN
         n := n-12; newdate.year := newdate.year+1; END;
         newdate.month := n;
         IF ((olddate.month IN [1, 3, 5, 7, 8, 10, 12]) AND (olddate.day = 31))
         OR ((olddate.month IN [4, 6, 9, 11]) AND (olddate.day = 30))
         OR ((olddate.month = 2) AND (olddate.day = 28) AND ((olddate.year MOD 4) <> 0))
         OR ((olddate.month = 2) AND (olddate.day = 29) AND ((olddate.year MOD 4) = 0))
         THEN CASE newdate.month OF
            1, 3, 5, 7, 8, 10, 12 : newdate.day := 31;
            4, 6, 9, 11 : newdate.day := 30;
            2 : IF (newdate.year MOD 4) = 0 THEN newdate.day := 29
                ELSE newdate.day := 28;
         END;                 {case}
      END;                    {AddMonths}

   FUNCTION DayCount(d1, d2 : datetype) : Integer;
      BEGIN                   { DayCount }
         DayCount := abs(jul(d2)-jul(d1));
      END;                    { DayCount }

   FUNCTION DatesEqual(d1, d2 : datetype) : Boolean;
      BEGIN                   { DatesEqual }
         DatesEqual := False;
         IF d1.month = d2.month THEN
            IF d1.day = d2.day THEN
               IF d1.year = d2.year THEN DatesEqual := True;
      END;                    { DatesEqual }

   FUNCTION NullDate(d1 : datetype) : Boolean;
      BEGIN                   { NullDate }
         NullDate := False;
         IF d1.month = 1 THEN
            IF d1.day = 1 THEN
               IF d1.year = 1960 THEN NullDate := True;
      END;                    { NullDate }
      {==============================================}
      {       windowing routines                     }
      {==============================================}
   PROCEDURE MakeBox(x1, y1, x2, y2 : Integer); {7/4/85}
      VAR x, y : Integer;
         { draw a box from x1,y1 to x2,y2 }
      BEGIN                   { procedure makebox }
         Window(1, 1, 80, 25);
         aputc('+', RE_V, x1, y1);
         FOR x := x1+1 TO x2-1 DO aputc(' ', RE_V, x, y1);
         aputc('+', RE_V, x2, y1);
         FOR y := y1+1 TO y2-1 DO aputc(' ', RE_V, x2, y);
         aputc('+', RE_V, x2, y2);
         FOR x := x2-1 DOWNTO x1+1 DO aputc(' ', RE_V, x, y2);
         aputc('+', RE_V, x1, y2);
         FOR y := y2-1 DOWNTO y1+1 DO aputc(' ', RE_V, x1, y);
      END;                    { procedure makebox }

   PROCEDURE MainWdo;         {7/3/85}
      BEGIN Window(1, 2, 80, 24); END;

   PROCEDURE InitWindows;     {12/23/85}
      VAR i : Integer;
      BEGIN
         ClrScr;
         FOR i := 1 TO 80 DO aputc(' ', RE_V, i, 1);
         FOR i := 1 TO 80 DO aputc(' ', RE_V, i, 25);
         MainWdo; GoToXY(1, 1);
      END;                    {initwindows}

   PROCEDURE HelpWdo;
      VAR i : Integer;
      BEGIN                   { HelpWdo; }
         Window(1, 1, 80, 25); GoToXY(1, 25);
         FOR i := 1 TO 80 DO aputc(' ', RE_V, i, 25);
      END;                    { HelpWdo; }

   PROCEDURE Heading(s : string80); {7/3/85}
      VAR x, y, col, lbegin, lend, i : Integer;
      BEGIN                   { heading }
         x := WhereX; y := WhereY; Window(1, 1, 80, 1);
         FOR col := 1 TO 80 DO aputc(' ', 112, col, 1);
         lbegin := 40-(Length(s) DIV 2); lend := lbegin+Length(s)-1;
         i := 0;
         FOR col := lbegin TO lend DO BEGIN
            i := i+1; aputc(s[i], 112, col, 1);
         END;                 {for}
         MainWdo; GoToXY(x, y);
      END;                    { heading }

   PROCEDURE SaveScrn;
         { push active screen into memory }
      BEGIN                   {  SaveScrn }
         GetMem(savedscrn, 4000);
         IF IsColor THEN Move(ColorScreen, savedscrn^, 4000)
         ELSE Move(MonoScreen, savedscrn^, 4000);
      END;                    {  SaveScrn }

   PROCEDURE RestoreScrn;
         { pop old screen from memory }
      BEGIN                   {  RestoreScrn }
         IF IsColor THEN Move(savedscrn^, ColorScreen, 4000)
         ELSE Move(savedscrn^, MonoScreen, 4000);
         FreeMem(savedscrn, 4000);
      END;                    {  RestoreScrn }

   PROCEDURE Wait;
      VAR xx, yy : Integer;
      BEGIN                   {  wait }
         xx := WhereX; yy := WhereY; HelpWdo;
         TextColor(0+BLINK); TextBackground(15);
         Write('Press any key to continue' : 52);
         REPEAT UNTIL KeyPressed;
         HelpWdo;
         TextColor(15); TextBackground(0);
         MainWdo; GoToXY(xx, yy);
         NormVideo;
      END;                    {  wait }

   PROCEDURE WhereOut;
      VAR xx, yy : Integer;
      BEGIN                   {  whereout: }
         xx := WhereX; yy := WhereY; HelpWdo;
         TextColor(1); TextBackground(15);
         Write('Do you want report sent to the printer? ' : 65);
         IF GetUC('N', ['Y', 'N']) = 'Y' THEN
            BEGIN Assign(out, 'LST:'); To_LST := True; END
         ELSE BEGIN Assign(out, 'CON:'); To_LST := False; END;
         Reset(out); ClrScr;
         TextColor(15); TextBackground(0);
         NormVideo; MainWdo; GoToXY(xx, yy);
      END;                    {  whereout: }

   PROCEDURE Page;
      BEGIN                   { page; }
         IF To_LST THEN Write(out, ^L) ELSE wait;
      END;                    { page; }

   PROCEDURE ShowHelp(s1 : string80); {7/7/85}
      VAR x, y : Integer;
      BEGIN                   { showhelp }
         x := WhereX; y := WhereY;
         HelpWdo;
         TextBackground(7); TextColor(1);
         Write(s1 : (38+Length(s1) DIV 2));
         MainWdo; GoToXY(x, y);
         TextBackground(0); TextColor(15);
         NormVideo;
      END;                    { showhelp }

   FUNCTION Prompt(s : string80; default : Char) : Char; {7/7/85}
      VAR x, y, i, len, offset : Integer; okset : SET OF Char;
      BEGIN                   { prompt }
         x := WhereX; y := WhereY; okset := [];
         HelpWdo;
         TextBackground(15); TextColor(1);
         len := Length(s); offset := 38-len DIV 2;
         LowVideo; Write(s : len+offset); NormVideo;
         FOR i := 1 TO len DO BEGIN
            IF s[i] IN ['A'..'Z'] THEN BEGIN
               okset := okset+[s[i]];
            END;              {if}
         END;                 {for}
         GoToXY(offset+len+3, 1);
         Prompt := GetUC(default, okset);
         HelpWdo;
         TextBackground(0); TextColor(15);
         MainWdo; GoToXY(x, y);
      END;                    { prompt }

   VAR
      Xmain,
      Ymain : Integer;

   PROCEDURE UseWdo(x, y, cols, rows : Integer; Head : string80);
      VAR left, right, top, bottom : Integer;

      PROCEDURE OutlineWdo(x1, y1, x2, y2 : Integer;
                           Lines : Boolean; Head : string80);
         VAR i, len, hstart : Integer;
         BEGIN                { OutlineWdo }
            len := Length(head);
            IF lines THEN BEGIN
               IF y1 > 1 THEN BEGIN
                  IF x1 > 1 THEN aputc(Chr(218), LO_V, x1-1, y1-1);
                  FOR i := x1 TO x2 DO aputc(Chr(196), LO_V, i, y1-1);
                  IF x2 < 80 THEN aputc(Chr(191), LO_V, x2+1, y1-1);
                  IF (len > 0) AND (len < (x2-x1-1)) THEN BEGIN
                     hstart := x1+(x2-x1) DIV 2-len DIV 2;
                     FOR i := 1 TO len
                     DO aputc(head[i], RE_V, i+hstart-1, y1-1);
                  END;
               END {if} ;
               IF x2 < 80 THEN
                  FOR i := y1 TO y2 DO aputc(Chr(179), LO_V, x2+1, i);
               IF x1 > 1 THEN
                  FOR i := y1 TO y2 DO aputc(Chr(179), LO_V, x1-1, i);
               IF y2 < 25 THEN BEGIN
                  IF x1 > 1 THEN aputc(Chr(192), LO_V, x1-1, y2+1);
                  FOR i := x1 TO x2 DO aputc(Chr(196), LO_V, i, y2+1);
                  IF x2 < 80 THEN aputc(Chr(217), LO_V, x2+1, y2+1);
               END {if} ;
            END ELSE BEGIN
               IF y1 > 1 THEN BEGIN
                  IF x1 > 1 THEN aputc(' ', RE_V, x1-1, y1-1);
                  FOR i := x1 TO x2 DO aputc(' ', RE_V, i, y1-1);
                  IF x2 < 80 THEN aputc(' ', RE_V, x2+1, y1-1);
                  IF (len > 0) AND (len < (x2-x1-1)) THEN BEGIN
                     hstart := x1+(x2-x1) DIV 2-len DIV 2;
                     FOR i := 1 TO len
                     DO aputc(head[i], RE_V, i+hstart-1, y1-1);
                  END;
               END {if} ;
               IF x2 < 80 THEN
                  FOR i := y1 TO y2 DO aputc(' ', RE_V, x2+1, i);
               IF x1 > 1 THEN
                  FOR i := y1 TO y2 DO aputc(' ', RE_V, x1-1, i);
               IF y2 < 25 THEN BEGIN
                  IF x1 > 1 THEN aputc(' ', RE_V, x1-1, y2+1);
                  FOR i := x1 TO x2 DO aputc(' ', RE_V, i, y2+1);
                  IF x2 < 80 THEN aputc(' ', RE_V, x2+1, y2+1);
               END {if} ;
            END;
         END;                 { OutlineWdo }

      BEGIN                   { UseWdo }
         Xmain := WhereX; Ymain := WhereY;
         left := x; right := x+cols-1;
         IF right > 80 THEN BEGIN
            left := 80-cols;
            right := 80;
         END {if} ;
         top := y; bottom := y+rows-1;
         IF bottom > 25 THEN BEGIN
            top := 25-rows;
            bottom := 25;
         END {if} ;
         Window(1, 1, 80, 25);
         OutlineWdo(left, top, right, bottom, True, head);
         Window(left, top, right, bottom);
         ClrScr;
      END;                    { UseWdo }

   PROCEDURE CloseWdo;
      BEGIN                   { CloseWdo; }
         MainWdo;
         GoToXY(Xmain, Ymain);
      END;                    { CloseWdo; }

      {==============================================}
      {      system services                         }
      {----------------------------------------------}

   PROCEDURE SysDate (*var dt: datetype*) ;
         { read system clock }
      VAR r : regtype;
      BEGIN
         WITH r DO BEGIN
            AH := $2A; MsDos(r);
            dt.month := DH; dt.day := DL;
            dt.year := CX;
         END;                 { with }
      END;                    { sysdate }

   PROCEDURE SysTime(VAR tm : timetype);
         { read system clock }
      VAR r : regtype;
      BEGIN
         WITH r DO BEGIN
            AH := $2C; MsDos(r);
            tm.hour := CH; tm.min := CL; tm.sec := DH;
         END;                 { with }
      END;                    { systime }

   FUNCTION TimeStamp : string80;
         { return system date and time as a string }
      VAR t : timetype; d : datetype; ts, t1 : string80; pm : Boolean;
      BEGIN
         SysTime(t); SysDate(d);
         pm := False;
         IF t.hour > 11 THEN pm := True;
         IF t.hour > 12 THEN t.hour := t.hour-12;
         IF t.hour = 0 THEN t.hour := 12;
         Str(t.hour : 2, ts);
         Str(t.min, t1);
         IF t.min < 10 THEN ts := ts+':0'+t1
         ELSE ts := ts+':'+t1;
         IF pm THEN ts := ts+' pm '
         ELSE ts := ts+' am ';
         TimeStamp := ts+StrDate(d);
      END;                    { timestamp }

   PROCEDURE InitSys;
      BEGIN                   { initsys; }
         InitMonitor; InitWindows; SysDate(sdt);
      END;                    { initsys; }
      {----------------------------------------------}
      { end of file paslib.inc                       }
      {----------------------------------------------}