home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sampler / 04 / tp4wio / tp4wio.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-27  |  73.6 KB  |  2,253 lines
  1. {$R-}    {Range checking off}
  2. {$B-}    {Boolean short circuiting off}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5. {$N-}    {No numeric coprocessor}
  6. {$M 65500,16384,65500}
  7.  
  8. unit tp4wio;
  9. {  -- Global I/O procedures to include in programs generally
  10.   Much credit is due Bill Meacham who wrote the original file IO22.INC
  11.   and released it to the public domain.  Using that work this unit was
  12.   created and added to by Gerald Rohr of Homogenized Software.  As
  13.   with Bill's work, this program is released to the Public Domain for
  14.   all to use and modify.
  15.                        REVISION  HISTORY
  16.   ---------------------------------------------------------------------
  17.   Ver 2.22 - Converted to a Turbo pascal V4 units.        30 Dec 87 gbr
  18.   Ver 2.30 - Converted dates to longint types             19 Jan 88 gbr
  19.   Ver 2.42 - Added global inv_flag for all write routines 08 Apr 88 gbr
  20.   Ver 2.43 - Added long integer read and write routines   01 May 88 gbr
  21.   Ver 2.43 - Added month and month/day routines           10 May 88 gbr
  22.   Ver 3.00 - Replaced Window procedures/Reformated file   15 Jul 88 gbr
  23.   Ver 3.10 - Moved Window error routines here             26 Aug 88 gbr
  24.   Ver 3.20 - Added code and globals for color hi lights   27 Aug 88 gbr
  25.   --------------------------------------------------------------------- }
  26.  
  27. interface
  28.  
  29. uses
  30.    crt,dos;
  31.  
  32. const
  33.    fdslen     = 29 ;  { length of fulldatestring }
  34.  
  35. type
  36.    datestring = string[10] ;  { 'MM/DD/YYYY' }
  37.  
  38.    fulldatestring = string[fdslen] ;
  39.  
  40.    juldate = record
  41.       yr  : integer ; { 0 .. 9999 }
  42.       day : integer ; { 1 .. 366 }
  43.    end ;
  44.  
  45.    juldatestring = string[8] ; { 'YYYY/DDD' }
  46.  
  47.    montharray = array [1 .. 13] of integer ;
  48.  
  49.    intst     = string[2];                   { string of an integer }
  50.  
  51. var
  52.    sys_date      :longint;
  53.    null_date     :longint;
  54.    null_date_str : datestring;
  55.  
  56.    fld, scrn     : integer ; { For field & screen cursor control }
  57.    macro         :array[1..10] of string; { Function key macro storage }
  58.    inv_flag      :boolean;  { if true all write routines inverse the screen,
  59.                               set to false by initialization. User uses
  60.                               this flag to control the screen attributes.}
  61.    col_inv_flag  :boolean;  { true if color monitor, false if monochrome,
  62.                               set by initialization routine,  User may change. }
  63.    inv_color     :byte;     { color to use for inverse data if col_inv_flag
  64.                               is true. Defaults to green, but user may change. }
  65.    in_window     :boolean;  { if true then we are in a window, used by the
  66.                               screen writing routines to high light screen
  67.                               data.  NOTE high lighting can only be done when
  68.                               in_window flag is true. }
  69.    reserv_wind   :integer;  { number of windows to reserve (not close) with
  70.                               endwindows procedure.  Initialized to 0, use
  71.                               with multiple program files. }
  72.  
  73. PROCEDURE CLRLINE (col,row : integer);
  74. PROCEDURE BEEP ;
  75. PROCEDURE DO_FLD_CTL (key : integer);
  76.          { Adjusts global FLD based on value of key, the ordinal value
  77.            of last key pressed }
  78. PROCEDURE DO_SCRN_CTL ;
  79.          { Checks value of FLD and adjusts value of SCRN accordingly }
  80. PROCEDURE WRITE_STR (st:string ; col,row:integer);
  81. PROCEDURE WRITE_TEMP(var ln:string;tmp:string;x,y:integer);
  82.          { writes a string using a template.  the string (ln) is printed
  83.            left justified in the template using the filler locations.
  84.            quits when the template is complete on the screen.  Fills unused
  85.            template filler locations with space. }
  86. PROCEDURE WRITE_INT (i:integer ; width,col,row:integer);
  87. PROCEDURE WRITE_LINT(lint:longint;width,col,row:integer);
  88. PROCEDURE SET_BOOL (var bool : boolean);
  89.          { Sets boolean to be undefined, neither true nor false.
  90.            Boolean is stored as one byte:
  91.                $80 = undefined
  92.                $01 = true
  93.                $00 = false.
  94.            Note : Turbo interprets $80 as true because it is greater than zero! }
  95. FUNCTION DEFINED (bool : boolean) : boolean ;
  96.          { Determines whether the boolean is defined or not }
  97. PROCEDURE WRITE_BOOL (bool:boolean ; col, row:integer);
  98. PROCEDURE WRITE_REAL (r:real ; width,frac,col,row:integer);
  99. FUNCTION BUILD_STR (ch : char ; n : integer) : string ;
  100.          { returns a string of length n of the character ch }
  101. FUNCTION PAD (st : string ; ch : char ; i : integer) : string ;
  102.          { Pad string with ch to length of i. }
  103. FUNCTION UPPER (st :string):string;
  104.          { returns upper case of st }
  105. FUNCTION STRIPCH (instr:string ; inchar:char) : string ;
  106.          {Strips leading instances of the character from the string}
  107. FUNCTION TRIM (st:string;len:integer):string;
  108.          { Chops spaces from string or truncates at l length }
  109. FUNCTION CHOPCH (instr:string ; inchar:char) : string ;
  110.          {Chops trailing instances of the character from the string}
  111. FUNCTION INTTOSTR(n:integer):intst;
  112.          { converts integer to packed two char string }
  113. FUNCTION STRTOINT(s:intst):integer;
  114.          { converts packed two char string to integer }
  115. PROCEDURE READ_STR (var st:string ; maxlen, col, row:integer);
  116.          { Read String.  This procedure gets input from the keyboard one
  117.            character at a time and edits on the fly, rejecting invalid
  118.            characters.  COL and ROW tell where to begin the data input
  119.            field, and MAXLEN is the maximum length of the string to be
  120.            returned.
  121.            Only use the Function keys for string input data, for other
  122.            types of input will beep. }
  123. PROCEDURE READ_TEMP(var st:string;tmp:string;col, row:integer);
  124.            { Read string with a template.  This procedure gets input from
  125.            the keyboard one character at a time and edits on the fly,
  126.            rejecting invalid characters.  tmp is a template which is filled
  127.            in where filler characters exist, any other characters are displayed
  128.            on the screen.  Returned string does NOT have the template imbeded in
  129.            it.  COL and ROW tell where to begin the data input
  130.            field, Max length of the string is the max length of the template.
  131.            }
  132. PROCEDURE READ_INT (var int:integer ; maxlen, col, row:integer);
  133.          { Read Integer.  This procedure gets input from the keyboard
  134.            one character at a time and edits on the fly, rejecting
  135.            invalid characters.  COL and ROW tell where to begin the data
  136.            input field, and MAXLEN is the maximum length of the integer
  137.            to be returned. }
  138. PROCEDURE READ_LINT (var lint:longint ; maxlen, col, row:integer);
  139.          { Read LongInt.  This procedure gets input from the keyboard
  140.            one character at a time and edits on the fly, rejecting
  141.            invalid characters.  COL and ROW tell where to begin the data
  142.            input field, and MAXLEN is the maximum length of the integer
  143.            to be returned. }
  144. FUNCTION EQUAL (r1,r2 : real) : boolean ;
  145.          { tests functional equality of two real numbers -- 4/30/85 }
  146. FUNCTION GREATER (r1,r2 : real) : boolean ;
  147.          { tests functional inequality of two real numbers -- 5/1/85 }
  148. PROCEDURE READ_REAL (var r:real ; maxlen,frac,col,row:integer);
  149.          { Read Real.  This procedure gets input from the keyboard
  150.            one character at a time and edits on the fly, rejecting
  151.            invalid characters.  COL and ROW tell where to begin the data
  152.            input field; MAXLEN is the maximum length of the string
  153.            representation of the real number, including sign and decimal
  154.            point; FRAC is the fractional part, the number of digits to
  155.            right of the decimal point.
  156.  
  157.            Note -- In Turbo the maximum number of significant digits in
  158.            decimal (not scientific) representation is 11.  In TurboBCD,
  159.            the maximum number of significant digits is 18.  It is the
  160.            programmer's responsibility to limit input and computed output
  161.            to the maximum significant digits. }
  162. PROCEDURE READ_YN (var bool:boolean; col,row:integer);
  163.          { Inputs "Y" OR "N" to boolean at column and row specified,
  164.            prints "YES" or "NO."
  165.            Note -- use this when the screen control will not return
  166.            to the question and the boolean IS NOT defined before the
  167.            user answers the question.  Does not affect global FLD. }
  168. PROCEDURE READ_BOOL (var bool:boolean; col,row:integer);
  169.          { Displays boolean at column and row specified, inputs "Y"
  170.            or "N" to set new value of boolean, prints "YES" or "NO."
  171.            Boolean is "forced;" user cannot cursor forward past undefined
  172.            boolean.  Pressing "Y" or "N" terminates entry.
  173.            Boolean is stored as one byte:
  174.                $80 = undefined
  175.                $01 = true
  176.                $00 = false.
  177.            Note : Turbo interprets $80 as true because it is greater
  178.            than zero! }
  179. PROCEDURE PAUSE ;
  180.          {Prints message on bottom line, waits for user response.
  181.           Changed from line 24 to line 23 for windows  gbr}
  182. PROCEDURE HARD_PAUSE ;
  183.          { Like Pause, but only accepts space bar or Escape and only
  184.            goes forward. Changed from line 24 to line 23 for windows.  gbr }
  185. PROCEDURE SHOW_MSG (msg : string);
  186.          { Beeps, displays message centered on line 22, pauses }
  187.          { changed from line 23 to line 22 for windows. gbr }
  188. FUNCTION MK_DT_ST (dt :longint) : datestring ;
  189.          { Makes a string out of a date -- used for printing dates }
  190. PROCEDURE WRITE_DATE (dt: longint ; col, row: integer);
  191.          { Writes date at column and row specified }
  192. FUNCTION MK_JUL_DT_ST (jdt : juldate) : juldatestring ;
  193.          { makes a string out of a julian date }
  194. PROCEDURE READ_DATE (var dt: longint ; col, row: integer);
  195.          { Read date at column and row specified.  If the user enters
  196.            only two digits for the year, the procedure plugs the
  197.            century as 1900 or 2000, but the user can enter all four
  198.            digits to override the plug. }
  199. FUNCTION GREATER_DATE (dt1, dt2 : longint) : integer ;
  200.          { Compares two dates, returns 0 if both equal, 1 if first is
  201.            greater, 2 if second is greater. }
  202. PROCEDURE GREG_TO_JUL (dt : longint ; var jdt : juldate);
  203.          { converts a gregorian date to a julian date }
  204. PROCEDURE JUL_TO_GREG (jdt : juldate ; var dt : longint);
  205.          { converts a julian date to a gregorian date }
  206. PROCEDURE NEXT_DAY (var dt : longint);
  207.          { Adds one day to the date }
  208. PROCEDURE PREV_DAY (var dt : longint);
  209.          { Subtracts one day from the date }
  210. FUNCTION DATE_DIFF (dt1, dt2 : longint) : longint ;
  211.          { computes the number of days between two dates }
  212. FUNCTION MONTH_DIFF (dt1, dt2 : longint ) : integer ;
  213.          { Computes number of months between two dates, rounded.
  214.            30.4167 = 356/12, average number of days in a month. }
  215. FUNCTION EQUAL_DATE (dt1, dt2 : longint) : boolean ;
  216.          { Tests whether two dates are equal }
  217. FUNCTION BUILD_FULL_DATE_STR (dt : longint) : fulldatestring ;
  218.          { Build printable string of current date -- from ROS 3.4
  219.            source code. }
  220. FUNCTION MONTH(dt:longint):integer;
  221.          { returns the month portion of a date.}
  222. FUNCTION DAY(dt:longint):integer;
  223.          { returns the day from the date }
  224. FUNCTION YEAR(dt:longint;centry:boolean):integer;
  225.          { returns the year of a date.  if the centry flag is true
  226.            returns 4 digit year otherwise returns two digit year. }
  227.  
  228. { ---- window procedures Derived from article in Computer Language
  229.   Magazine June 1988 by James Kerr ---- }
  230.  
  231. PROCEDURE OPENWINDOW(wtitle:string;x1,y1,x2,y2:byte;
  232.                      fgnd,bkgnd: byte);
  233.          { wtitle is centered on the top border line of the window, x
  234.          and y are the window coordinates, fgnd and bkgnd are the
  235.          colors of the inside of the window (note the border is always
  236.          white, if a window can not be opened, a message as to why will
  237.          be displayed and the program exits
  238.          }
  239. PROCEDURE CLOSEWINDOW;
  240.          { closes the current open window, does nothing if no
  241.            window to close. }
  242. PROCEDURE ENDWINDOWS;
  243.          { close any open windows when exiting the windows system.  Use
  244.            as the last statment in program to insure return to
  245.            enviroment you came from.  The global reserv_wind is normally
  246.            set to 0 allowing all windows to be closed, if using a
  247.            multi file window program, reserv_wind can be set to the
  248.            number of windows to be left open when a particular program
  249.            terminates.  Always set reserv_wind to 0 before the final
  250.            program call to endwindows.
  251.          }
  252.  
  253. { ---------------------------------------------------------------- }
  254.  
  255. implementation
  256.  
  257. const
  258.                       { ASCII values of cursor control keys, like WordStar. }
  259.                       { Note -- Backspace and Delete are different in CP/M  }
  260.                       {         and PC-DOS.  Proc KEYIN translates them.    }
  261.    prev_char = $13 ;  { ^S }
  262.    next_char = $04 ;  { ^D }
  263.    prev_fld  = $05 ;  { ^E }
  264.    next_fld  = $18 ;  { ^X }
  265.    prev_page = $12 ;  { ^R }
  266.    next_page = $03 ;  { ^C }
  267.    del_char  = $07 ;  { ^G }
  268.    del_left  = $08 ;  { ^H (Backspace) }
  269.    del_fld   = $19 ;  { ^Y }
  270.    del       = $7F ;  { Delete }
  271.    escape    = $1B ;
  272.    carr_rtn  = $0D ;
  273.    space     = $20 ;
  274.    filler    = $2E ;  { $2E = . $5F = _ }
  275.  
  276.    { The function keys return a value which is the index 201..210
  277.      used by subtracting 200 from the value and into the user array
  278.      of strings to insert into a field. }
  279.    f1 = 201;
  280.    f2 = 202;
  281.    f3 = 203;
  282.    f4 = 204;
  283.    f5 = 205;
  284.    f6 = 206;
  285.    f7 = 207;
  286.    f8 = 208;
  287.    f9 = 209;
  288.    f10= 210;
  289.  
  290.    monthtotal : montharray = (0,31,59,90,120,151,181,212,243,273,304,334,365);
  291.                 { used to convert julian date to gregorian and back }
  292.  
  293. type
  294.    intset = set of $00 .. $FF ;
  295.  
  296.    const  { Turbo typed constants -- initialized variables }
  297.    terminating : intset = [carr_rtn, next_fld, prev_fld, escape,
  298.                             next_page, prev_page] ;
  299.    adjusting   : intset = [prev_char, next_char, del_char, del_fld, del_left] ;
  300.  
  301. { --------------- local definitions for the window procedures -------------- }
  302. const
  303.    maxwindows = 10;     { maximum # on screen windows }
  304.    framefgnd = lightgray;  { frame colors }
  305.    framebkgnd = black;
  306.  
  307. type pointer = ^integer;
  308.    windowtype = record
  309.       xl,yl,xr,yr :integer;   { cordinates or corners }
  310.       bufrptr     :pointer;   { pointer to buffer location }
  311.       cursorx,cursory :integer; { cursor position brfore opening }
  312.       screenattr  :byte;      { text attributes before opening }
  313.    end;
  314.  
  315. var
  316.    windowstack   :array[0..maxwindows] of windowtype;
  317.    maxcols,maxrows :byte;  { # rows and columns for initial video mode }
  318.    numwindows :0..maxwindows; { # windows currently open }
  319.    vidstart   :word;          { location of video memory }
  320.    regs       :registers;
  321.    aw_fore,
  322.    aw_back    :byte;    { active window fore and background colors }
  323.  
  324. { ---------------------------------------------------------------- }
  325.  
  326. procedure beep;
  327. { this procedure is called if any routine causes an error }
  328. begin
  329.    sound(200); delay(100);
  330.    sound(350); delay(100);
  331.    sound(100); delay(100);
  332.    nosound;
  333. end; { procedure beep }
  334.  
  335. { ---------------------------------------------------------------- }
  336.  
  337. procedure SetColor(Fore, Back : byte);
  338. begin
  339.   TextColor(Fore);
  340.   TextBackground(Back);
  341. end; { SetColor }
  342.  
  343. { ---------------------------------------------------------------- }
  344.  
  345. function Center(Len, Left, Right : integer) : integer;
  346. { find the location to position (x) for title }
  347. begin
  348.    center := (left + ((right-left) div 2) - (len div 2));
  349. end;
  350.  
  351. { ---------------------------------------------------------------- }
  352.  
  353. procedure drawframe(wtitle:string;x1,y1,x2,y2:byte);
  354. { draws a rectangular frame on the screen with upper left hand corner
  355.   at x1,y1 and lower right hand corner at x2,y2 }
  356. var
  357.    k  :integer;
  358.    currentattr :byte;
  359. begin
  360.    currentattr := textattr;  { save the current text attributes }
  361.    textattr := framefgnd + 16 * framebkgnd; { change attributes for frame }
  362.    gotoxy(x1,y1);
  363.    write(chr(201));
  364.    for k := (x1 + 1) to (x2 -1) do  { top border line }
  365.       write(chr(205));
  366.    write(chr(187));
  367.    for k := (y1 + 1) to (y2 - 1) do
  368.       begin
  369.       gotoxy(x1,k); write(chr(186));
  370.       gotoxy(x2,k); write(chr(186));
  371.    end;
  372.    gotoxy(x1,y2);
  373.    write(chr(200));
  374.    for k := (x1 + 1) to (x2 - 1) do
  375.       write(chr(205));
  376.    write(chr(188));
  377.    { ---- put the title in the center of the window border if there is
  378.      a title, if length(wtitle) > 0 ----- }
  379.    if(length(wtitle) > 0) then
  380.       begin
  381.       if(length(wtitle) > (x2-x1-4)) then  { if title too long, clip it }
  382.          wtitle := copy(wtitle,1,(x2-x1-4));
  383.       GotoXY(Center(Length(WTitle) + 2, X1, X2), y1);
  384.       TextColor(White);
  385.       Write(' ', WTitle, ' ');
  386.    end;
  387.    textattr := currentattr;  { restore previous text attributes }
  388. end;  { procedure drawframe }
  389.  
  390. { ---------------------------------------------------------------- }
  391.  
  392. procedure saveregion(x1,y1,x2,y2:byte;
  393.                      var startaddr :pointer);
  394. { saves the contents of the screen rectangle with coordinates x1,y1,x2,y2
  395.   on the heap starting at address startaddr. }
  396. var
  397.    tempptr, lineptr :pointer;
  398.    k,linelength     :integer;
  399. begin
  400.    linelength := (x2 - x1 + 1) * 2; { # bytes per line in rectangel }
  401.    { allocate space on heap }
  402.    getmem(startaddr,linelength * (y2 - y1 + 1));
  403.    tempptr := startaddr; {tempptr points to copy destination on heap }
  404.    for k := y1 to y2 do
  405.       begin { make lineptr point to screen position x=s1, y=k }
  406.       lineptr := ptr(vidstart, (k -1) * maxcols * 2 + (x1 - 1) * 2);
  407.       { move the line from screen to heap }
  408.       move(lineptr^,tempptr^,linelength);
  409.       { increment the screen pointer }
  410.       tempptr := ptr(seg(tempptr^),ofs(tempptr^)+linelength);
  411.    end;
  412. end;  {procedure saveregion }
  413.  
  414. { ---------------------------------------------------------------- }
  415.  
  416. procedure recallregion(x1,y1,x2,y2 :integer;
  417.                        hpptr :pointer);
  418. { moves the contents of a previously saved region from the heap back
  419.   to the screen. }
  420. var
  421.    tempptr,lineptr  :pointer;
  422.    k,linelength     :integer;
  423. begin
  424.    linelength := (x2 - x1 + 1) * 2; { # bytes per line in rectangle }
  425.    tempptr := hpptr;    { tempptr gives the source location for copy }
  426.    for k := y1 to y2 do
  427.       begin { make lineptr point to screen position x=x1, y=k }
  428.       lineptr := ptr(vidstart,(k - 1) * maxcols * 2 + (x1 -1) * 2);
  429.       move(tempptr^,lineptr^,linelength);
  430.       tempptr := ptr(seg(tempptr^),ofs(tempptr^)+linelength);
  431.    end;
  432. end; { procedure recallregion }
  433.  
  434. { ---------------------------------------------------------------- }
  435.  
  436. procedure closewindow;
  437. var  x,y :integer;
  438. begin
  439.    if numwindows > 0 then
  440.       begin
  441.       with windowstack[numwindows] do
  442.          begin
  443.          recallregion(xl,yl,xr,yr,bufrptr);  { restore underlying text }
  444.          freemem(bufrptr,(xr -xl + 1) * (yr -yl + 1) * 2); { free heap }
  445.          x := cursorx;
  446.          y := cursory;   { prepare to restore cursor position }
  447.          textattr := screenattr;  { restore screen attributes }
  448.       end;
  449.       { activate the underlying window }
  450.       numwindows := numwindows -1;
  451.       with windowstack[numwindows] do
  452.          window(xl+1,yl+1,xr -1,yr -1);
  453.       gotoxy(x,y);     { restore cursor position }
  454.    end;
  455.    if numwindows = 0 then in_window := false;
  456. end; { procedure closewindow }
  457.  
  458. { ---------------------------------------------------------------- }
  459.  
  460. procedure endwindows;
  461. { close any open windows when exiting the windows system.  Use as the
  462.   last statment in program to insure return to enviroment you came from.
  463.   The global variable is normally set to 0 but may be set to a reserved
  464.   number of windows if using a multi file window system.}
  465. begin
  466.    while (numwindows > reserv_wind) do
  467.       closewindow;
  468. end;  { procedure endwindows }
  469.  
  470. { ---------------------------------------------------------------- }
  471.  
  472. procedure wind_err(msg : string);
  473. { Beeps, displays open window error message.  Can not do it right
  474.   as the window system is broke when this is called so will just
  475.   try to put something on the screen.
  476. }
  477. var
  478.    i  : integer ;
  479.    ch :char;
  480.  
  481. begin
  482.    beep ;
  483.    window(1,1,79,24);   { make sure we have some screen space }
  484.    write_str('+==========================================================+',10,10);
  485.    for i := 1 to 9 do
  486.    write_str('|                                                          |',10,10+i);
  487.    write_str('+=========== Any key to exit to DOS =======================+',10,20);
  488.    if length(msg) > 76 then msg := copy(msg,1,76);
  489.    write_str(msg,((76-length(msg)) div 2),13);
  490.    ch := readkey;
  491.    reserv_wind := 0;    { be sure we get them all }
  492.    endwindows;          { close them all before exit }
  493. end ; { wind_err }
  494.  
  495. { ---------------------------------------------------------------- }
  496.  
  497. procedure openwindow(wtitle       :string;
  498.                      x1,y1,x2,y2  :byte;
  499.                      fgnd,bkgnd   :byte
  500.                     );
  501. { creates a blank window with the given coordinates, and saves the contents
  502.   of the underlying region on the heap.  If an error occurs in attemping to
  503.   open the window, a message is displayed on the screen before exiting the
  504.   program a message is put on the screen. then the exit procedure returns
  505.   the following error codes: 1 = too many windows, 2 = out of heap memory,
  506.   3 = wrong window dimensions.
  507.   }
  508. var pntr :pointer;
  509. begin
  510.    if(numwindows = 0) then
  511.       begin  { determine current screen parameters }
  512.       maxcols := lo(windmax) + 1;  { add 1 since numbering begins with 0 }
  513.       maxrows := hi(windmax) + 1;
  514.       with windowstack[0] do  { windowstack[0] is the entire screen }
  515.          begin
  516.          xl := 0;
  517.          yl := 0;
  518.          xr := maxcols + 1;
  519.          yr := maxrows + 1;
  520.       end;
  521.    end;
  522.    { check for possible error conditions }
  523.    if(numwindows = maxwindows) then
  524.       begin
  525.       wind_err('Sorry, too may windows requested.');
  526.       halt(1);
  527.    end
  528.    else if(maxavail < (x2 - x1 + 1) * (y2 - y1 + 1) * 2) then
  529.       begin
  530.       wind_err('Sorry, No more Heap storage available.');
  531.       halt(2);
  532.    end
  533.    else if(not ((x1 in [1..maxcols-2]) and (x2 in [3..maxcols]) and
  534.                 (x2-x1> 1) and (y1 in [1..maxrows-2]) and
  535.                 (y2 in [3..maxrows]) and (y2 - y1 > 1))) then
  536.       begin
  537.       wind_err('Sorry, Invalid window dimensions.');
  538.       halt(3);
  539.    end
  540.    else
  541.       begin  { successful request }
  542.       saveregion(x1,y1,x2,y2,pntr);
  543.       numwindows := numwindows + 1;
  544.       with windowstack[numwindows] do
  545.          begin
  546.          xl := x1;
  547.          yl := y1;
  548.          xr := x2;
  549.          yr := y2;
  550.          bufrptr := pntr;
  551.          cursorx := wherex;
  552.          cursory := wherey;
  553.          screenattr := textattr;
  554.       end;
  555.       window(1,1,maxcols,maxrows);   { make the whole screen a window }
  556.       drawframe(wtitle,x1,y1,x2,y2);
  557.       window(x1+1,y1+1,x2-1,y2-1);  { create the requested window }
  558.       textcolor(fgnd);
  559.       textbackground(bkgnd);
  560.       aw_back := bkgnd;     { save the active window colors }
  561.       aw_fore := fgnd;
  562.       clrscr;
  563.    end;
  564.    in_window := true;
  565. end; { procedure openwindow }
  566.  
  567. { ------- End window unit ----- }
  568.  
  569. { procedure gotoxy (col,row); -- Built-in proc in Turbo to place
  570.   cursor on screen.  Upper left is (1,1) not (0,0)! }
  571.  
  572. { procedure clrscr ; -- Built-in proc in Turbo to clear screen. }
  573.  
  574. { procedure clreol ; -- built-in proc in Turbo to clear to end of line }
  575.  
  576. { -------------------------------------------------------------------------- }
  577.  
  578. procedure clrline(col,row : integer);
  579. begin
  580.    gotoxy (col,row);
  581.    clreol
  582. end ;
  583.  
  584. { -------------------------------------------------------------------------- }
  585.  
  586. procedure do_fld_ctl(key : integer);
  587. { Adjusts global FLD based on value of key, the ordinal value
  588.   of last key pressed }
  589. { global fld : integer -- for field cursor control }
  590. begin
  591.    case key of
  592.       carr_rtn, next_fld : fld := succ(fld);
  593.       prev_fld           : fld := pred(fld);
  594.       next_page          : fld := 999 ;
  595.       prev_page          : fld := -999 ;
  596.       escape             : fld := maxint ;
  597.    end  { case }
  598. end ;  { proc do_fld_ctl }
  599.  
  600. { ------------------------------------------------------------ }
  601.  
  602. procedure do_scrn_ctl ;
  603. { Checks value of FLD and adjusts value of SCRN accordingly }
  604. { Global fld, scrn : integer -- For field and screen cursor control }
  605. begin
  606.    if fld < 1 then
  607.       scrn := pred(scrn)
  608.    else if fld = maxint then
  609.       scrn := maxint
  610.    else
  611.       scrn := succ(scrn)
  612. end ;
  613.  
  614. { ------------------------------------------------------------ }
  615.  
  616. procedure write_str(st:string ; col,row:integer);
  617. begin
  618.    gotoxy (col,row);
  619.    if((in_window) and (inv_flag)) then
  620.       begin
  621.       if(col_inv_flag) then
  622.          setcolor(inv_color,aw_back)
  623.       else
  624.          setcolor(aw_back,aw_fore);
  625.       write (st);
  626.       setcolor(aw_fore,aw_back);
  627.    end
  628.    else
  629.       write(st);
  630. end ;
  631.  
  632. { -------------------------------------------------------------------------- }
  633. procedure write_temp(var ln:string;tmp:string;x,y:integer);
  634. { writes a string using a template.  the string (ln) is printed
  635.   left justified in the template using the filler locations.
  636.   quits when the template is complete on the screen.  Fills unused
  637.   template filler locations with space. }
  638. var
  639.    p,t  :integer;
  640. begin
  641.    p := 1;
  642.    t := 1;
  643.    gotoxy(x,y);
  644.    if((in_window) and (inv_flag)) then
  645.       if(col_inv_flag) then
  646.          setcolor(inv_color,aw_back)
  647.       else
  648.          setcolor(aw_back,aw_fore);
  649.    for t := 1 to length(tmp) do
  650.       begin
  651.       if(tmp[t] <> chr(filler)) then
  652.          write(tmp[t])
  653.       else
  654.          begin
  655.          if(p > length(ln)) then
  656.             write(' ')
  657.          else
  658.             begin
  659.             write(ln[p]);
  660.             p := p + 1;
  661.          end;
  662.       end;
  663.    end;
  664.    if((in_window) and (inv_flag)) then
  665.       setcolor(aw_fore,aw_back);
  666. end;  { procedure write_temp }
  667.  
  668. { -------------------------------------------------------------------------- }
  669.  
  670. procedure write_int(i:integer ; width,col,row:integer);
  671. begin
  672.    gotoxy (col,row);
  673.    if((in_window) and (inv_flag)) then
  674.       begin
  675.       if(col_inv_flag) then
  676.          setcolor(inv_color,aw_back)
  677.       else
  678.          setcolor(aw_back,aw_fore);
  679.       write(i:width);
  680.       setcolor(aw_fore,aw_back);
  681.    end
  682.    else
  683.       write (i:width)
  684. end ;
  685.  
  686. { -------------------------------------------------------------------------- }
  687.  
  688. procedure write_lint(lint:longint ; width,col,row:integer);
  689. begin
  690.    gotoxy (col,row);
  691.    if((in_window) and (inv_flag)) then
  692.       begin
  693.       if(col_inv_flag) then
  694.          setcolor(inv_color,aw_back)
  695.       else
  696.          setcolor(aw_back,aw_fore);
  697.       write (lint,width);
  698.       setcolor(aw_fore,aw_back);
  699.    end
  700.    else
  701.       write (lint:width)
  702. end ;
  703.  
  704. { -------------------------------------------------------------------------- }
  705.  
  706. procedure set_bool(var bool : boolean);
  707.   { Sets boolean to be undefined, neither true nor false.
  708.     Boolean is stored as one byte:
  709.         $80 = undefined
  710.         $01 = true
  711.         $00 = false.
  712.     Note : Turbo interprets $80 as true because it is greater than zero! }
  713.  
  714. var
  715.    b : byte absolute bool ;
  716. begin
  717.    b := $80
  718. end ;  { proc set_bool }
  719.  
  720. { -------------------------------------------------------------------------- }
  721.  
  722. function defined(bool : boolean) : boolean;
  723. { Determines whether the boolean is defined or not }
  724. var
  725.    b : byte absolute bool ;
  726. begin
  727.    defined := not (b = $80)
  728. end ;  { function defined }
  729.  
  730. { -------------------------------------------------------------------------- }
  731.  
  732. procedure write_bool(bool:boolean ; col, row:integer);
  733. begin
  734.    gotoxy (col,row);
  735.    if((in_window) and (inv_flag)) then
  736.       if(col_inv_flag) then
  737.          setcolor(inv_color,aw_back)
  738.       else
  739.          setcolor(aw_back,aw_fore);
  740.    if not defined(bool) then
  741.       write ('___')
  742.    else if bool then
  743.       write ('YES')
  744.    else
  745.       write ('NO ');
  746.    if((in_window) and (inv_flag)) then
  747.       setcolor(aw_fore,aw_back);
  748. end ;
  749.  
  750. { -------------------------------------------------------------------------- }
  751.  
  752. procedure write_real(r:real ; width,frac,col,row:integer);
  753. begin
  754.    gotoxy (col,row);
  755.    if((in_window) and (inv_flag)) then
  756.       begin
  757.       if(col_inv_flag) then
  758.          setcolor(inv_color,aw_back)
  759.       else
  760.          setcolor(aw_back,aw_fore);
  761.       write (r:width:frac);
  762.       setcolor(aw_fore,aw_back);
  763.    end
  764.    else
  765.       write (r:width:frac)
  766. end ;
  767.  
  768. { -------------------------------------------------------------------------- }
  769.  
  770. { This is for IBM PC-DOS only  !! not in the implimentation !!}
  771.  
  772. procedure keyin (var ch:char);
  773. { Reads a single character from keyboard without echoing it back.
  774.   Maps function key scan codes to single keyboard keys.
  775.   From Turbo 3.0 manual, page 360 -- 5/29/85
  776.   Modified for IO20 -- 2/26/86
  777.   Modified for IO22 -- 5/24/87
  778.   Modified to return different codes for the function keys than
  779.   the keypad keys.  Used to allow special entry for the function
  780.   keys.  10 Dec 87 gbr.
  781. }
  782. var
  783.    func : boolean ;     { Whether function key or not }
  784.       c : char ;        { Character read }
  785.     key : integer ;     { ORD of character returned }
  786.  
  787. begin
  788.    func := false ;
  789.    c := readkey;                    { Get first char }
  790.    if(c = #0) and keypressed then { If there is a second ... }
  791.       begin
  792.       c := readkey;                { Get 2nd char }
  793.       func := true
  794.    end ;
  795.    key := ord(c);
  796.    if func then                      { Translate function keys }
  797.       case key of
  798.          75 : key := prev_char ;  { left-arrow }
  799.          77 : key := next_char ;  { right-arrow }
  800.          72 : key := prev_fld ;   { up-arrow }
  801.          80 : key := next_fld ;   { down-arrow }
  802.          73 : key := prev_page ;  { PgUp }
  803.          81 : key := next_page ;  { PgDn }
  804.          83 : key := del_char ;   { DEL }
  805.          59 : key := f1       ;   { F1 }
  806.          60 : key := f2      ;    { F2 }
  807.          61 : key := f3;          { F3 }
  808.          62 : key := f4;          { F4 }
  809.          63 : key := f5;          { F5 }
  810.          64 : key := f6;          { F6 }
  811.          65 : key := f7;          { F7 }
  812.          66 : key := f8;          { F8 }
  813.          67 : key := f9;          { F9 }
  814.          68 : key := f10;         { F10}
  815.       else
  816.          key := 00 ;
  817.       end  { case }
  818.    else  { not a function key }
  819.       case key of                   { CP/M-like control keys }
  820.          $0B   : key := prev_fld ;   { ^K }
  821.          $0A   : key := next_fld ;   { ^J }
  822.          $0C   : key := next_char ;  { ^L }
  823.       end ;  { case }
  824.    ch := chr(key)                    { finally, return the character }
  825. end ;
  826.  
  827. { ------------------------------------------------------------ }
  828.  
  829. function build_str(ch : char ; n : integer) : string;
  830. { returns a string of length n of the character ch }
  831. var
  832.    st : string ;
  833. begin
  834.    if n < 0 then
  835.       n := 0 ;
  836.    st[0] := chr(n);
  837.    fillchar (st[1],n,ch);
  838.    build_str := st
  839. end ;  { function build_str);
  840.  
  841. { ---------------------------------------------------------------- }
  842.  
  843. FUNCTION UPPER(st :string):string;
  844. { make string upper case }
  845. var i:integer;
  846. begin
  847.    if (length(st) > 0) then
  848.       for i := 1 to length(st) do st[i] := upcase(st[i]);
  849.    upper := st;
  850. end;  {function upper}
  851.  
  852. { -------------------------------------------------------------------------- }
  853.  
  854. function pad(st : string ; ch : char ; i : integer) : string;
  855. { Pad string with ch to length of i }
  856. var
  857.   l : integer ;
  858. begin
  859.   l := length(st);
  860.   if l > i then st := copy(st,1,i); { if too long then shorten it }
  861.   if l < i then
  862.     begin
  863.       fillchar (st[l+1],i-l,ch);
  864.       st[0] := chr(i)
  865.     end ;
  866.   pad := st
  867. end;
  868.  
  869. { ------------------------------------------------------------ }
  870.  
  871. procedure adjust_str (var st : string ;
  872.                       var  p : integer ;  { position of char to left of cursor }
  873.                          key,             { ord of adjusting character }
  874.             maxlen, col, row : integer );
  875. { Adjusts position of cursor within string, deletes characters, etc. }
  876. begin
  877.    case key of
  878.       prev_char :if p > 0 then
  879.                     p := pred(p);
  880.       next_char :if p < length(st) then
  881.                     p := succ(p);
  882.       del_left  :if p > 0 then
  883.                     begin
  884.                     delete (st,p,1);
  885.                     write (^H,copy(st,p,maxlen),chr(filler));
  886.                     p := pred(p)
  887.                  end ;
  888.       del_char  :if p < length(st) then
  889.                     begin
  890.                     delete (st,p+1,1);
  891.                     write (copy(st,p+1,maxlen),chr(filler))
  892.                  end ;
  893.       del_fld   :begin
  894.                     st := '' ;
  895.                     p := 0  ;
  896.                     gotoxy(col,row);
  897.                     write(build_str(chr(filler),maxlen))
  898.                  end
  899.    end  { case }
  900. end ; { proc adjust_str }
  901.  
  902. { -------------------------------------------------------------------------- }
  903.  
  904. function purgech (instr : string ; inchar : char) : string ;
  905. {Purges all instances of the character from the string}
  906. var
  907.    n      : integer ;  {Loop counter}
  908.    outstr : string ; {Result string}
  909. begin
  910.    outstr := '' ;
  911.    for n := 1 to length (instr) do
  912.       if not (instr[n] = inchar) then
  913.          outstr := concat (outstr, instr[n]);
  914.    purgech := outstr
  915. end ;
  916.  
  917. { -------------------------------------------------------------------------- }
  918.  
  919. function stripch(instr:string ; inchar:char) : string;
  920. {Strips leading instances of the character from the string}
  921. begin
  922.    while not (length(instr) = 0) and (instr[1] = inchar) do
  923.       delete (instr, 1, 1);
  924.    stripch := instr
  925. end ;
  926.  
  927. { -------------------------------------------------------------------------- }
  928.  
  929. function chopch(instr:string ; inchar:char) : string;
  930. {Chops trailing instances of the character from the string}
  931. begin
  932.    while not (length(instr) = 0) and (instr[length(instr)] = inchar) do
  933.       delete (instr, length(instr), 1);
  934.    chopch := instr
  935. end ;
  936.  
  937. { -------------------------------------------------------------------------- }
  938.  
  939. function inttostr(n:integer):intst;
  940. { converts integer to packed two char string }
  941. begin
  942.    n := n + (-32768);
  943.    inttostr := chr(hi(n)) + chr(lo(n));
  944. end;    { function inttostr }
  945.  
  946. { -------------------------------------------------------------------------- }
  947.  
  948. function strtoint(s:intst):integer;
  949. { converts packed two char string to integer }
  950. begin
  951.    strtoint := swap(ord(s[1])) + ord(s[2]) + (-32768);
  952. end;    { function strtoint }
  953.  
  954. { -------------------------------------------------------------------------- }
  955.  
  956. function trim(st:string;len:integer):string;
  957. { trims right blanks from string and returns a string of len or less }
  958. var
  959.    i   :integer;
  960.  
  961. begin
  962.    if length(st) > len then trim := copy(st,1,len)
  963.    else
  964.       begin
  965.       i := length(st);
  966.       while (i >= 1) and (st[i] = ' ') do i := i - 1;
  967.       if i = 0 then trim := ''
  968.          else trim := copy(st,1,i);
  969.    end;
  970. end;  { function trim }
  971.  
  972. { -------------------------------------------------------------------------- }
  973.  
  974. procedure read_str(var st:string ; maxlen, col, row:integer);
  975.  
  976. { Read String.  This procedure gets input from the keyboard one
  977.   character at a time and edits on the fly, rejecting invalid
  978.   characters.  COL and ROW tell where to begin the data input
  979.   field, and MAXLEN is the maximum length of the string to be
  980.   returned.
  981.   Revised 6/04/85 -- WPM
  982.   Only use the Function keys for string input data, for other
  983.   types of input will beep.
  984.   10 Dec 87 gbr}
  985.  
  986. var
  987.    ch   : char ;     { character from keyboard }
  988.    key,              { ord(ch) }
  989.    p    : integer ;  { position of char to left of cursor }
  990.  
  991.    procedure add_to_str ;
  992.    begin
  993.       if not (length(st) = maxlen) then
  994.          begin
  995.          p := p + 1 ;
  996.          insert(ch,st,p);
  997.          write (copy(st,p,maxlen))
  998.       end
  999.    end ; {--- of add_to_str ---}
  1000.  
  1001. begin {--- read_str ---}
  1002.    write_str (st, col, row);
  1003.    write (build_str(chr(filler),maxlen - length(st)));
  1004.    p := length(st);
  1005.    repeat
  1006.       gotoxy (col + p, row);
  1007.       keyin (ch);          {^^^^ read keyboard here ^^^^}
  1008.       key := ord(ch);
  1009.       if key in [$20 .. $7E] then  { printable character }
  1010.          add_to_str
  1011.       else if key in adjusting then
  1012.          adjust_str (st,p,key,maxlen,col,row)
  1013.       else if key in terminating then
  1014.          do_fld_ctl (key)
  1015.       else if key in [201..210] then { Function key pressed }
  1016.          begin
  1017.             st := copy(macro[key-200],1,maxlen);  { put macro string in st }
  1018.             key := carr_rtn;            { cr to terminate entry }
  1019.          end
  1020.       else
  1021.          beep
  1022.    until key in terminating ;
  1023.    gotoxy (col + length(st), row);
  1024.    write_str(st,col,row);              { rewrite for display characteristics }
  1025.    write ('':maxlen - length(st))      { delete the filler characters on screen}
  1026. end ; {--- of read_str ---}
  1027.  
  1028. { ------------------------------------------------------------ }
  1029.  
  1030. function bld_tmp_str(st:string;  { input string so far }
  1031.                     tmp:string;  { template to put it in }
  1032.                     ch : char    { filler character }
  1033.                     ) : string ;
  1034. { returns a string of template filled in with the input string }
  1035. var
  1036.    i,t : integer;
  1037.    stt :string;
  1038. begin
  1039.    stt := tmp;
  1040.    t := 1;
  1041.    for i := 1 to length(st) do
  1042.       begin
  1043.       while(stt[t] <> ch) do t := t + 1;
  1044.    stt[t] := st[i];
  1045.    end;
  1046.    bld_tmp_str := stt
  1047. end ;  { function bld_tmp_str);
  1048.  
  1049. { -------------------------------------------------------------------------- }
  1050. procedure read_temp(var st:string;tmp:string;col, row:integer);
  1051. { Read string with a template.  This procedure gets input from
  1052.   the keyboard one character at a time and edits on the fly,
  1053.   rejecting invalid characters.  tmp is a template which is filled
  1054.   in where filler characters exist, any other characters are displayed
  1055.   on the screen.  Returned string does NOT have the template imbeded in
  1056.   it.  COL and ROW tell where to begin the data input
  1057.   field, Max length of the string is the max length of the template.
  1058. }
  1059. var
  1060.    ch   : char ;     { character from keyboard }
  1061.    key,              { ord(ch) }
  1062.    t,                { position in template }
  1063.    maxlen,           { max length of the template }
  1064.    maxline,          { max length of returned string }
  1065.    p,i     : integer ; { position in input string }
  1066.  
  1067.    procedure add_to_str ;
  1068.    begin
  1069.       if(length(st) < maxline) then
  1070.          begin
  1071.          p := p + 1 ;
  1072.          t := t + 1;
  1073.          insert(ch,st,p);
  1074.          gotoxy(col,row);
  1075.          write(bld_tmp_str(st,tmp,chr(filler)));
  1076.          while(tmp[t] <> chr(filler)) and (t < length(tmp)) do t := succ(t);
  1077.       end
  1078.    end ; {--- of add_to_str ---}
  1079.  
  1080.    procedure adj_tmp_str;
  1081.    { Adjusts position of cursor within string using a template,
  1082.      deletes characters, etc. }
  1083.    var
  1084.       rwt_flag :boolean;  { need to rewrite line }
  1085.    begin
  1086.       rwt_flag := false;
  1087.       case key of
  1088.          prev_char :if p > 0 then
  1089.                        begin
  1090.                        p := pred(p);
  1091.                        t := pred(t);
  1092.                        while(tmp[t] <> chr(filler)) and (t > 1) do t := pred(t);
  1093.                     end;
  1094.          next_char :if p < length(st) then
  1095.                        begin
  1096.                        p := succ(p);
  1097.                        t := succ(t);
  1098.                        while(tmp[t] <> chr(filler)) and (t < length(tmp)) do
  1099.                           t := succ(t);
  1100.                     end;
  1101.          del_left  :if p > 0 then
  1102.                        begin
  1103.                        delete (st,p,1);
  1104.                        rwt_flag := true;
  1105.                        p := pred(p);
  1106.                        t := pred(t);
  1107.                        while(tmp[t] <> chr(filler)) and (t > 1) do t := pred(t);
  1108.                     end ;
  1109.          del_char  :if p < length(st) then
  1110.                        begin
  1111.                        delete (st,p+1,1);
  1112.                        rwt_flag := true;
  1113.                     end ;
  1114.          del_fld   :begin
  1115.                        st := '' ;
  1116.                        p := 0  ;
  1117.                        t := 1;
  1118.                        while(tmp[t] <> chr(filler)) and (t <= maxlen) do
  1119.                           t := t + 1;
  1120.                        rwt_flag := true;
  1121.                     end
  1122.       end;  { case }
  1123.       if rwt_flag then
  1124.          begin
  1125.          gotoxy(col,row);
  1126.          write(bld_tmp_str(st,tmp,chr(filler)));
  1127.       end;
  1128.    end ; { proc adj_tmp_str }
  1129.  
  1130. begin {--- read_temp ---}
  1131.    maxlen := length(tmp);
  1132.    maxline := 0;
  1133.    for i := 1 to length(tmp) do
  1134.       if(tmp[i] = chr(filler)) then maxline := maxline + 1;
  1135.    p := length(st);
  1136.    t := 1;
  1137.    for i := 1 to p do  { find the present st length + template }
  1138.       begin
  1139.       while(tmp[t] <> chr(filler)) and (t <= maxlen) do t := t + 1;
  1140.       t := t + 1;
  1141.    end;       { check if the template character we are at is a template }
  1142.    while(tmp[t] <> chr(filler)) and (t <= maxlen) do t := t + 1;
  1143.    gotoxy(col,row);write(bld_tmp_str(st,tmp,chr(filler)));
  1144.    p := length(st);
  1145.    repeat
  1146.       gotoxy (col + t-1, row);
  1147.       keyin (ch);          {^^^^ read keyboard here ^^^^}
  1148.       key := ord(ch);
  1149.       if key in [$20 .. $7E] then  { printable character }
  1150.          add_to_str
  1151.       else if key in adjusting then
  1152.          adj_tmp_str
  1153.       else if key in terminating then
  1154.          do_fld_ctl (key)
  1155.       else if key in [201..210] then { Function key pressed }
  1156.          begin
  1157.          st := copy(macro[key-200],1,maxlen);  { put macro string in st }
  1158.          key := carr_rtn;            { cr to terminate entry }
  1159.       end
  1160.       else
  1161.          beep
  1162.    until key in terminating ;
  1163.    write_temp(st,tmp,col,row);
  1164. end ; {--- of read_temp ---}
  1165.  
  1166. { -------------------------------------------------------------------------- }
  1167.  
  1168. procedure read_int(var int:integer ; maxlen, col, row:integer);
  1169.  
  1170. { Read Integer.  This procedure gets input from the keyboard
  1171.   one character at a time and edits on the fly, rejecting
  1172.   invalid characters.  COL and ROW tell where to begin the data
  1173.   input field, and MAXLEN is the maximum length of the integer
  1174.   to be returned.
  1175.   Revised 6/04/85 -- WPM }
  1176.  
  1177. const
  1178.    maxst : string[5] = '32767' ;  { string representation of maxint }
  1179.  
  1180. var
  1181.    ch    : char ;       { character from keyboard }
  1182.    key,                 { ord(ch) }
  1183.    p     : integer ;    { position of char to left of cursor }
  1184.    st    : string;    { string representation of integer }
  1185.    code  : integer ;    { result of string to integer conversion }
  1186.  
  1187.    procedure add_to_str ;
  1188.    begin
  1189.       if not (length(st) = maxlen) then
  1190.          begin
  1191.          p := p + 1 ;
  1192.          insert (ch,st,p);
  1193.          write (copy(st,p,maxlen))
  1194.       end
  1195.    end ; {--- of add_to_str---}
  1196.  
  1197. begin {--- read_int ---}
  1198.    str (int:maxlen, st);          { convert integer into string }
  1199.    st := purgech (st, ' ');
  1200.    st := stripch (st, '0');
  1201.    write_str (st, col, row);
  1202.    write (build_str(chr(filler),maxlen - length(st)));
  1203.    p := length(st);
  1204.    repeat
  1205.       gotoxy (col + p, row);
  1206.       keyin (ch);
  1207.       key := ord(ch);
  1208.       if key = $2D then                 { minus sign }
  1209.          begin
  1210.          if(pos('-',st) = 0) and (length(st) < maxlen)
  1211.             and (p = 0) then
  1212.             add_to_str
  1213.       end
  1214.       else if key in [$30 .. $39] then  {digits 0 - 9}
  1215.          begin
  1216.          add_to_str ;
  1217.          if (length(st) = 5) and (st > maxst) then
  1218.             begin
  1219.             delete (st,p,1);
  1220.             write (^H,copy(st,p,maxlen),chr(filler));
  1221.             p := p - 1
  1222.          end
  1223.       end
  1224.       else if key in adjusting then
  1225.          adjust_str (st,p,key,maxlen,col,row)
  1226.       else if key in terminating then
  1227.          do_fld_ctl (key)
  1228.    until key in terminating ;
  1229.    if st = '' then
  1230.       begin
  1231.       int := 0 ;
  1232.       code := 0
  1233.    end
  1234.    else
  1235.       val (st, int, code);              {Make string into integer}
  1236.    gotoxy (col, row);
  1237.    if code = 0 then  {Conversion worked OK}
  1238.       write_int(int,maxlen,col,row)
  1239.    else
  1240.       begin
  1241.       write ('** conversion error ', code);
  1242.       halt
  1243.    end
  1244. end ; {--- of read_int ---}
  1245.  
  1246. { -------------------------------------------------------------------------- }
  1247.  
  1248. procedure read_lint(var lint:longint ; maxlen, col, row:integer);
  1249. { Read LongInt.  This procedure gets input from the keyboard
  1250.   one character at a time and edits on the fly, rejecting
  1251.   invalid characters.  COL and ROW tell where to begin the data
  1252.   input field, and MAXLEN is the maximum length of the long integer
  1253.   to be returned.
  1254. }
  1255. const
  1256.    maxst : string[10] = '2147483647' ;  { string representation of maxint }
  1257.  
  1258. var
  1259.    ch    : char ;       { character from keyboard }
  1260.    key,                 { ord(ch) }
  1261.    p     : integer ;    { position of char to left of cursor }
  1262.    st    : string;    { string representation of integer }
  1263.    code  : integer ;    { result of string to integer conversion }
  1264.  
  1265.    procedure add_to_str ;
  1266.    begin
  1267.       if not (length(st) = maxlen) then
  1268.          begin
  1269.          p := p + 1 ;
  1270.          insert (ch,st,p);
  1271.          write (copy(st,p,maxlen))
  1272.       end
  1273.    end ; {--- of add_to_str---}
  1274.  
  1275. begin {--- read_int ---}
  1276.    str (lint:maxlen, st);      { convert long integer into string }
  1277.    st := purgech (st, ' ');
  1278.    st := stripch (st, '0');
  1279.    write_str (st, col, row);
  1280.    write (build_str(chr(filler),maxlen - length(st)));
  1281.    p := length(st);
  1282.    repeat
  1283.       gotoxy (col + p, row);
  1284.       keyin (ch);
  1285.       key := ord(ch);
  1286.       if key = $2D then                 { minus sign }
  1287.          begin
  1288.          if(pos('-',st) = 0) and (length(st) < maxlen) and
  1289.             (p = 0) then
  1290.             add_to_str
  1291.       end
  1292.       else if key in [$30 .. $39] then  {digits 0 - 9}
  1293.          begin
  1294.          add_to_str ;
  1295.          if (length(st) = 10) and (st > maxst) then
  1296.             begin
  1297.             delete (st,p,1);
  1298.             write (^H,copy(st,p,maxlen),chr(filler));
  1299.             p := p - 1
  1300.          end
  1301.       end
  1302.       else if key in adjusting then
  1303.          adjust_str (st,p,key,maxlen,col,row)
  1304.       else if key in terminating then
  1305.          do_fld_ctl (key)
  1306.    until key in terminating ;
  1307.    if st = '' then
  1308.       begin
  1309.       lint := 0 ;
  1310.       code := 0
  1311.    end
  1312.    else
  1313.       val (st, lint, code);              {Make string into integer}
  1314.    gotoxy (col, row);
  1315.    if code = 0 then  {Conversion worked OK}
  1316.       write_lint(lint,maxlen,col,row)
  1317.    else
  1318.       begin
  1319.       write ('** conversion error ', code);
  1320.       halt
  1321.    end
  1322. end ; {--- of read_lint ---}
  1323.  
  1324. { -------------------------------------------------------------------------- }
  1325.  
  1326. function equal(r1,r2 : real) : boolean;
  1327. { tests functional equality of two real numbers -- 4/30/85 }
  1328. begin
  1329.    equal := abs(r1 - r2) < 1.0e-5
  1330. end ;  { function equal }
  1331.  
  1332. { -------------------------------------------------------------------------- }
  1333.  
  1334. function greater(r1,r2 : real) : boolean;
  1335. { tests functional inequality of two real numbers -- 5/1/85 }
  1336. begin
  1337.    greater := (r1 - r2) > 1.0e-5
  1338. end ;  { function greater }
  1339.  
  1340. { -------------------------------------------------------------------------- }
  1341.  
  1342. procedure read_real(var r:real ; maxlen,frac,col,row:integer);
  1343.  
  1344. { Read Real.  This procedure gets input from the keyboard
  1345.   one character at a time and edits on the fly, rejecting
  1346.   invalid characters.  COL and ROW tell where to begin the data
  1347.   input field; MAXLEN is the maximum length of the string
  1348.   representation of the real number, including sign and decimal
  1349.   point; FRAC is the fractional part, the number of digits to
  1350.   right of the decimal point.
  1351.  
  1352.   Note -- In Turbo the maximum number of significant digits in
  1353.   decimal (not scientific) representation is 11.  In TurboBCD,
  1354.   the maximum number of significant digits is 18.  It is the
  1355.   programmer's responsibility to limit input and computed output
  1356.   to the maximum significant digits.
  1357.  
  1358.   Revised 6/04/85 -- WPM }
  1359.  
  1360. var
  1361.    ch   : char ;       { Input character }
  1362.    key,                { ord(ch) }
  1363.    p    : integer ;    { position of char to left of cursor }
  1364.    st   : string;    { String representation of real number -- }
  1365.                        { max digits plus minus sign plus decimal point }
  1366.    code : integer ;    { Result of VAL conversion }
  1367.    rlen : integer ;    { Current length of st to right of dec. pt. }
  1368.    llen : integer ;    { Current length to left, including dec. pt. }
  1369.    maxl : integer ;    { Max allowable to left, including dec. pt. }
  1370.    posdec : integer ;  { position of decimal point in string }
  1371.  
  1372.    { +++++++++++++++++++++++++++++++++++++ }
  1373.  
  1374.    procedure compute_length ;
  1375.    { Compute length of left and right portions of string }
  1376.    begin
  1377.       posdec := pos('.',st);
  1378.       if posdec = 0 then                { If no dec. pt. ... }
  1379.          begin
  1380.          llen := length(st);      { the whole string is Left }
  1381.          rlen := 0                 { and none is Right }
  1382.       end
  1383.       else    {There is a decimal point ...}
  1384.          begin
  1385.          llen := posdec ;          { Left is all up to and incl. dec. pt. }
  1386.          rlen := length(st) - llen { Right is the rest }
  1387.       end
  1388.    end ; { proc compute_length }
  1389.  
  1390.    { +++++++++++++++++++++++++++++++++++++ }
  1391.  
  1392.    procedure add_to_str ;
  1393.  
  1394.       procedure add_it ;
  1395.       begin
  1396.          p := p + 1 ;
  1397.          insert (ch,st,p);
  1398.          write (copy(st,p,maxlen))
  1399.       end ;
  1400.  
  1401.    begin {add_to_str}
  1402.       posdec := pos ('.',st);
  1403.       if ch = '.' then        { Decimal point; if room, add it }
  1404.          begin
  1405.             if(posdec = 0) and (length(st) - p <= frac) then
  1406.                add_it
  1407.          end
  1408.                                { else it's not a decimal point }
  1409.                                { see if digit fits in whole part }
  1410.          else if((posdec = 0) and (llen < maxl - 1)) or
  1411.                 ((posdec > 0) and (llen < maxl) and (p < posdec)) then
  1412.                  add_it      { only dec. pt. allowed in pos. maxl }
  1413.                              { digit is candidate for fractional part }
  1414.          else if(not(posdec = 0)) and (p >= posdec) and (rlen < frac) then
  1415.                  add_it
  1416.    end ; {--- of add_to_str---}
  1417.  
  1418.    { +++++++++++++++++++++++++++++++++++++ }
  1419.  
  1420. begin {--- read_real ---}
  1421.               {Initialize}
  1422.    maxl  := maxlen - frac ;
  1423.                             {Set up string representation of real and }
  1424.                             {determine length of left & right portions}
  1425.    str(r:maxlen:frac,st);           {Make real into string}
  1426.    st := purgech (st, ' ');         {Purge all blanks}
  1427.    st := stripch (st, '0');         {Strip leading zeroes}
  1428.    if not (pos('.', st) = 0) then    {If there is a dec. pt ... }
  1429.       begin
  1430.       st := chopch (st, '0');  {Chop trailing zeroes}
  1431.       st := chopch (st, '.')    {and trailing dec. pt.}
  1432.    end ;
  1433.    compute_length ;
  1434.                             {Write string on console}
  1435.    write_str (st, col, row);
  1436.    write (build_str(chr(filler),maxlen - length(st)));
  1437.    p := length(st);
  1438.                 {Get input a character at a time & edit it}
  1439.    repeat
  1440.       gotoxy (col + p, row);
  1441.       compute_length ;
  1442.       if((posdec = 0) and (llen > maxl - 1)) or
  1443.          ((not (posdec = 0)) and (llen > maxl)) or
  1444.          (rlen > frac) then                   { if number is larger than }
  1445.          begin                                 { spec then delete it all }
  1446.          key := del_fld ;
  1447.          adjust_str (st,p,key,maxlen,col,row);
  1448.          gotoxy (col,row)
  1449.       end ;
  1450.       keyin (ch);
  1451.       key := ord(ch);
  1452.       if key = $2D  then                      { minus sign }
  1453.          begin
  1454.          if(pos('-',st) = 0) and (p = 0) and (((posdec = 0) and
  1455.             (llen < maxl - 1)) or
  1456.             ((not (posdec = 0)) and (llen < maxl))) then
  1457.             add_to_str
  1458.          end
  1459.          else if key in [$2E, $30 .. $39] then   { decimal point, numeric digits }
  1460.             add_to_str
  1461.          else if key in adjusting then
  1462.             adjust_str (st,p,key,maxlen,col,row)
  1463.          else if key in terminating then
  1464.             do_fld_ctl (key);
  1465.    until key in terminating ;
  1466.                         {Done getting input, now convert back to real}
  1467.    if(st = '') or (st = '.') or (st = '-') or (st = '-.') then 
  1468.       begin {If null string ... }
  1469.       r := 0.0 ;                       {Make real zero}
  1470.       code := 0
  1471.    end
  1472.    else    {Not a null string}
  1473.       val (st, r, code);              {Make string into real}
  1474.    gotoxy (col, row);
  1475.    if code = 0 then  {Conversion worked OK}
  1476.       write_real(r,maxlen,frac,col,row)     {Write the real on screen}
  1477.    else
  1478.       begin
  1479.       write ('** conversion error ', code);
  1480.       halt
  1481.    end
  1482. end ; {--- of read_real ---}
  1483.  
  1484. { -------------------------------------------------------------------------- }
  1485.  
  1486. procedure read_yn(var bool:boolean; col,row:integer);
  1487. { Inputs "Y" OR "N" to boolean at column and row specified,
  1488.   prints "YES" or "NO."
  1489.  
  1490.   Note -- use this when the screen control will not return
  1491.   to the question and the boolean IS NOT defined before the
  1492.   user answers the question.  Does not affect global FLD. }
  1493.  
  1494. var ch:char ;
  1495. begin
  1496.    gotoxy (col,row);
  1497.    write ('   ');
  1498.    gotoxy (col,row);
  1499.    repeat
  1500.       keyin (ch)
  1501.    until (ch in ['Y', 'y', 'N', 'n']);
  1502.    if (ch = 'Y') or (ch = 'y') then
  1503.       begin
  1504.       write_str('YES',col,row);
  1505.       bool := true
  1506.    end
  1507.    else
  1508.       begin
  1509.       write_str('NO ',col,row);
  1510.       bool := false
  1511.    end
  1512. end ; { proc read_yn }
  1513.  
  1514. { ------------------------------------------------------------ }
  1515.  
  1516. procedure read_bool(var bool:boolean; col,row:integer);
  1517. { Displays boolean at column and row specified, inputs "Y"
  1518.   or "N" to set new value of boolean, prints "YES" or "NO."
  1519.   Boolean is "forced;" user cannot cursor forward past undefined
  1520.   boolean.  Pressing "Y" or "N" terminates entry.
  1521.  
  1522.   Boolean is stored as one byte:
  1523.       $80 = undefined
  1524.       $01 = true
  1525.       $00 = false.
  1526.   Note : Turbo interprets $80 as true because it is greater than zero! }
  1527.  
  1528. var
  1529.    ch  : char ;
  1530.    key : integer ;
  1531.  
  1532. begin
  1533.    write_bool (bool, col, row);
  1534.    gotoxy (col, row);
  1535.    repeat
  1536.       keyin (ch);
  1537.       key := ord(ch);
  1538.       if key in [$59,$79] then          { 'Y','y' }
  1539.          begin
  1540.          bool := true ;
  1541.          key  := next_fld ;
  1542.          do_fld_ctl(key)
  1543.       end
  1544.       else if key in [$4E, $6E] then    { 'N','n' }
  1545.          begin
  1546.          bool := false ;
  1547.          key  := next_fld ;
  1548.          do_fld_ctl(key)
  1549.       end
  1550.       else if key in terminating then
  1551.          begin
  1552.          if(not defined(bool)) and
  1553.            (key in [carr_rtn, next_fld, next_page]) then
  1554.             key := $00
  1555.          else
  1556.             do_fld_ctl (key)
  1557.       end
  1558.    until key in terminating ;
  1559.    write_bool (bool, col, row)
  1560. end ; {--- of read_bool ---}
  1561.  
  1562. { -------------------------------------------------------------------------- }
  1563.  
  1564. procedure pause ;
  1565. {Prints message on bottom line, waits for user response.
  1566.  Moved message into window in lower left corner gbr}
  1567. var
  1568.    ch   : char ;
  1569.    key : integer ;
  1570. begin
  1571.    openwindow('',2,23,55,25,lightgray,black);
  1572.    write_str ('PRESS SPACE BAR TO CONTINUE OR UP-ARROW TO GO BACK',2,1);
  1573.    repeat
  1574.       keyin (ch);
  1575.       key := ord(ch);
  1576.       case key of
  1577.          $20      : fld := succ(fld);
  1578.          prev_fld : fld := pred(fld);
  1579.          prev_page : fld := -999 ;
  1580.          escape   : fld := maxint ;
  1581.       end ;
  1582.    until key in [$20, prev_fld, prev_page, escape] ;
  1583.    closewindow;
  1584. end ; { proc pause }
  1585.  
  1586. { ------------------------------------------------------------ }
  1587.  
  1588. procedure hard_pause ;
  1589. { Like Pause, but only accepts space bar or Escape and only goes forward }
  1590. { puts the message in a window at bottom of screen }
  1591. var
  1592.    ch   : char ;
  1593.    key : integer ;
  1594. begin
  1595.    openwindow('',5,23,35,25,lightgray,black);
  1596.    write_str('PRESS SPACE BAR TO CONTINUE',2,1);
  1597.    repeat
  1598.       keyin (ch);
  1599.       key := ord(ch);
  1600.       case key of
  1601.          $20      : fld := succ(fld);
  1602.          escape   : fld := maxint ;
  1603.       end ;
  1604.    until key in [$20, escape] ;
  1605.    closewindow;
  1606. end ; { proc hard_pause }
  1607.  
  1608. { ------------------------------------------------------------ }
  1609.  
  1610. procedure show_msg(msg : string);
  1611. { Beeps, displays message centered on line 22, pauses }
  1612. { changed to put message in window in lower left corner. gbr }
  1613.  
  1614. var
  1615.    savefld : integer ;
  1616.  
  1617. begin
  1618.    savefld := fld ;
  1619.    beep ;
  1620.    openwindow('ERROR MESSAGE',2,21,79,23,lightgray,black);
  1621.    if length(msg) > 76 then msg := copy(msg,1,76);
  1622.    write_str(msg,((76-length(msg)) div 2),1);
  1623.    hard_pause ;
  1624.    closewindow;
  1625.    fld := savefld ;
  1626. end ; { proc show_msg }
  1627.  
  1628. { ---------------------------------------------------------------- }
  1629.  
  1630. { -- End of Standard screen routines - Beginning of Date routines -- }
  1631.  
  1632. function mk_dt_st(dt:longint):datestring;
  1633. { returns a string of the dates to print }
  1634.  
  1635. var
  1636.    yr,mo,dy,i   :integer;
  1637.    result       :longint;
  1638.    stmo,stdy    :string[2];
  1639.    styr         :string[4];
  1640.  
  1641. begin
  1642.    if dt = 0 then mk_dt_st := null_date_str
  1643.    else
  1644.       begin
  1645.       dy := (dt mod 100);
  1646.       result := (dt - dy); { subtract the number of days }
  1647.       result := result div 100;  { move to right }
  1648.       mo := (result mod 100);  { get the month }
  1649.       yr := (result div 100); { get year }
  1650.       str(yr:1,styr);
  1651.       str(mo:1,stmo);
  1652.       if length(stmo) = 1 then stmo := concat('0',stmo);
  1653.       str(dy:1,stdy);
  1654.       if length(stdy) = 1 then stdy := concat('0',stdy);
  1655.       mk_dt_st := concat(stmo,'/',stdy,'/',styr);
  1656.    end;
  1657. end; {function mk_dt_st}
  1658.  
  1659. { ------------------------------------------------------------ }
  1660.  
  1661. procedure write_date(dt: longint ; col, row: integer);
  1662. { Writes date at column and row specified }
  1663. var
  1664.     ds : datestring ;
  1665. begin
  1666.     ds := mk_dt_st (dt);
  1667.     write_str(ds,col,row)
  1668. end ; { --- proc write_date --- }
  1669.  
  1670. { ------------------------------------------------------------ }
  1671.  
  1672. function mk_jul_dt_st(jdt : juldate) : juldatestring;
  1673. { makes a string out of a julian date }
  1674. var
  1675.    yr_st  : string[4] ;
  1676.    day_st : string[3] ;
  1677.    jdt_st : juldatestring ;
  1678. begin
  1679.    with jdt do
  1680.       if (yr=0) and (day = 0) then
  1681.          jdt_st := 'YYYY/DDD'
  1682.       else
  1683.          begin
  1684.          str(yr:4,yr_st);
  1685.          str(day:3,day_st);
  1686.          jdt_st := concat (yr_st,'/',day_st)
  1687.       end ;
  1688.    mk_jul_dt_st := jdt_st
  1689. end ;  { function mk_jul_dt_st }
  1690.  
  1691. { ------------------------------------------------------------ }
  1692.  
  1693. function leapyear (yr : integer) : boolean ;
  1694. { Whether the year is a leap year or not.
  1695.   The year is year and century, e.g. year '1984' is 1984, not 84 }
  1696. begin
  1697.    leapyear := ((yr mod 4 = 0) and (not(yr mod 100 = 0)))
  1698.              or ( yr mod 400 = 0 )
  1699. end ;
  1700.  
  1701. { ------------------------------------------------------------ }
  1702.  
  1703. procedure get_dt_val(tpdate:longint;var yr,mo,dy:integer);
  1704. { breaks the tpdate into the global integer values }
  1705.  
  1706. var
  1707.    result       :longint;
  1708.  
  1709. begin
  1710.    dy := (tpdate mod 100);
  1711.    result := (tpdate - dy); { subtract the number of days }
  1712.    result := result div 100;  { move to right }
  1713.    mo := (result mod 100);  { get the month }
  1714.    yr := (result div 100); { get year }
  1715. end;  {function get_dt_val}
  1716.  
  1717. { ------------------------------------------------------------ }
  1718.  
  1719. function valid_date (dt:longint) : boolean ;
  1720. { Test whether date is valid }
  1721. var
  1722.     bad_fld  :integer ;
  1723.     yr,mo,dy :integer;
  1724.  
  1725. begin
  1726.    get_dt_val(dt,yr,mo,dy);   { puts the date in local variables }
  1727.    bad_fld := 0 ;
  1728.    if (mo = 0) and (dy = 0) and (yr = 0) then
  1729.       bad_fld := 0
  1730.    else if not (mo in [1 .. 12]) then
  1731.       bad_fld := 1
  1732.    else
  1733.       if (dy > 31) or (dy < 1) or ((mo in [4,6,9,11]) and (dy > 30)) then
  1734.          bad_fld := 2
  1735.    else
  1736.       if mo = 2 then
  1737.          begin
  1738.          if (leapyear(yr) and (dy > 29)) or
  1739.             ((not leapyear(yr)) and (dy > 28)) then
  1740.             bad_fld := 2
  1741.       end
  1742.    else
  1743.       if yr = 0 then
  1744.          bad_fld := 3;
  1745.    valid_date := (bad_fld = 0)
  1746. end ; { function valid_date }
  1747.  
  1748. { ------------------------------------------------------------ }
  1749.  
  1750. procedure read_date(var dt: longint ; col, row: integer);
  1751.  
  1752. { Read date at column and row specified.  If the user enters only
  1753.   two digits for the year, the procedure plugs the century as 1900 or
  1754.   2000, but the user can enter all four digits to override the plug. }
  1755.  
  1756. var
  1757.    ch       : char ;
  1758.    savefld,
  1759.    bad_fld,
  1760.    key,
  1761.    p        : integer ;
  1762.    yr,mo,dy :integer;
  1763.    s,
  1764.    template : datestring ;
  1765.  
  1766.    { ==================== }
  1767.  
  1768.    procedure add_to_str ;
  1769.    var
  1770.       l : integer ;
  1771.    begin
  1772.       l := length(s);
  1773.       if l = 10 then
  1774.          beep
  1775.       else if (l=1) or (l=4) then
  1776.          begin
  1777.          s := concat(s,ch,'/');
  1778.          write (ch,'/')
  1779.       end
  1780.       else
  1781.          begin
  1782.          s := concat(s,ch);
  1783.          write (ch)
  1784.       end
  1785.    end ; { proc add_to_str }
  1786.  
  1787.    { ==================== }
  1788.  
  1789.    procedure adjust_dt_str ;
  1790.    var
  1791.       l : integer ;
  1792.    begin
  1793.       case key of
  1794.          del_fld :begin
  1795.                      s := '' ;
  1796.                      gotoxy(col,row);
  1797.                      write(template);
  1798.                      gotoxy (col,row)
  1799.                   end ;
  1800.          del_left,
  1801.         prev_char:begin   { prev_char is destructive backspace! }
  1802.                      l := length(s);
  1803.                      if l = 0 then
  1804.                         beep
  1805.                      else
  1806.                         if (l=3) or (l=6) then
  1807.                            begin
  1808.                            write (^H,^H,chr(filler),^H);
  1809.                            delete (s,l-1,2)
  1810.                         end
  1811.                      else
  1812.                         begin
  1813.                         write (^H,chr(filler),^H);
  1814.                         delete (s,l,1)
  1815.                      end
  1816.                   end
  1817.       end { case }
  1818.    end ; { proc adjust_dt_str }
  1819.  
  1820.    { ==================== }
  1821.  
  1822.    procedure convert_date ;
  1823.    { convert the string to a date -- longint }
  1824.    var
  1825.       code     :integer ;
  1826.       result   :longint;
  1827.       i        :byte;
  1828.  
  1829.    begin
  1830.       for i := 1 to 8 do  { fill to 2 digits of year }
  1831.          begin
  1832.          if length(s) < i then s := concat(s,'0');
  1833.          if s[i] = ' ' then s[i] := '0'; { fill any spaces with 0 }
  1834.       end;
  1835.       val (copy(s,1,2),mo,code);
  1836.       if code <> 0 then
  1837.          begin
  1838.          write ('** MONTH CONVERSION ERROR ',code);
  1839.          halt
  1840.       end ;
  1841.       val (copy(s,4,2),dy,code);
  1842.       if code <> 0 then
  1843.          begin
  1844.          write ('** DAY CONVERSION ERROR ',code);
  1845.          halt
  1846.       end ;
  1847.       val (copy(s,7,4),yr,code);
  1848.       if code <> 0 then
  1849.          begin
  1850.          write ('** YEAR CONVERSION ERROR ',code);
  1851.          halt
  1852.       end ;
  1853.       if ((yr = 0) and (mo = 0) and (dy = 0)) then
  1854.          begin                      { default to nodate }
  1855.          dt := 0;
  1856.       end
  1857.       else
  1858.          begin                       { plug century }
  1859.          if yr < 80 then
  1860.             yr := 2000 + yr
  1861.          else if yr < 100 then
  1862.             yr := 1900 + yr;
  1863.          result := yr;
  1864.          result := (result * 100) + mo;
  1865.          result := (result * 100) + dy;
  1866.          dt := result;
  1867.       end;
  1868.       result := yr;
  1869.       result := (result * 100) + mo;
  1870.       result := (result * 100) + dy;
  1871.       dt := result;
  1872.    end ; { proc convert_date}
  1873.  
  1874.    { ==================== }
  1875.  
  1876.    procedure edit_date ;                  { Edit for valid date }
  1877.    begin
  1878.       bad_fld := 0 ;
  1879.       if (yr = 0) and (mo = 0) and (dy = 0) then
  1880.          bad_fld := 0
  1881.       else if not (mo in [1 .. 12]) then
  1882.            bad_fld := 1
  1883.       else if (dy > 31) or (dy < 1) or ((mo in [4,6,9,11]) and (dy > 30)) then
  1884.            bad_fld := 2
  1885.       else if mo = 2 then
  1886.          begin
  1887.          if (leapyear(yr) and (dy > 29)) or ((not leapyear(yr)) and
  1888.             (dy > 28)) then
  1889.             bad_fld := 2
  1890.       end
  1891.       else
  1892.          if yr = 0 then
  1893.             bad_fld := 3
  1894.    end ; { proc edit_date }
  1895.  
  1896.    { ==================== }
  1897.  
  1898. begin { proc read_date }
  1899.    savefld := fld ;
  1900.    ch := chr(filler);
  1901.    template := concat(ch,ch,'/',ch,ch,'/',ch,ch,ch,ch);
  1902.    if (dt = 0) then
  1903.       begin
  1904.       write_str (template,col,row);
  1905.       s := '' ;
  1906.       gotoxy (col,row)
  1907.    end
  1908.    else
  1909.       begin
  1910.       s := mk_dt_st(dt);
  1911.       p := pos(' ',s);
  1912.       while p <> 0 do
  1913.          begin
  1914.          s[p] := '0' ;
  1915.          p := pos(' ',s)
  1916.       end ;
  1917.       write_str (s,col,row)
  1918.    end ;
  1919.    repeat
  1920.       keyin(ch);
  1921.       key := ord(ch);
  1922.       if ch in ['0'..'9'] then
  1923.          add_to_str
  1924.       else if key in adjusting then
  1925.          adjust_dt_str
  1926.       else if key in terminating then
  1927.          begin
  1928.          convert_date ;  { uses local yr, mo, and dy }
  1929.          edit_date ;
  1930.          do_fld_ctl (key);
  1931.          if (fld < maxint) and (fld > savefld) then
  1932.             begin                          { edit only going forward }
  1933.             if bad_fld <> 0 then
  1934.                begin
  1935.                case bad_fld of
  1936.                   1 : show_msg ('INVALID MONTH');
  1937.                   2 : show_msg ('INVALID DAY');
  1938.                   3 : show_msg ('INVALID YEAR')
  1939.                end ; { case }
  1940.                fld := savefld
  1941.             end
  1942.          end
  1943.       end
  1944. (*      else
  1945.           beep  *)
  1946.    until key in terminating ;
  1947.    write_date (dt,col,row)
  1948. end ; { proc read_date }
  1949.  
  1950. { ------------------------------------------------------------ }
  1951.  
  1952. function greater_date(dt1, dt2 : longint) : integer;
  1953. { Compares two dates, returns 0 if both equal, 1 if first is
  1954.   greater, 2 if second is greater.
  1955. }
  1956.  
  1957. begin
  1958.    if dt1 > dt2 then
  1959.       greater_date := 1
  1960.    else if dt2 > dt1 then
  1961.       greater_date := 2
  1962.    else { both equal }
  1963.       greater_date := 0
  1964. end ; { --- of greater_date --- }
  1965.  
  1966. { ------------------------------------------------------------ }
  1967.  
  1968. procedure greg_to_jul(dt : longint ; var jdt : juldate);
  1969. { converts a gregorian date to a julian date }
  1970. var
  1971.    yr,mo,dy :integer;
  1972. begin
  1973.    get_dt_val(dt,yr,mo,dy);   { get the global dates }
  1974.    jdt.yr := yr ;
  1975.    if (yr = 0) and (mo = 0) and (dy = 0) then
  1976.       jdt.day := 0
  1977.    else
  1978.       begin
  1979.       if (leapyear(yr)) and (mo > 2) then
  1980.          jdt.day := 1
  1981.       else
  1982.          jdt.day := 0 ;
  1983.       jdt.day := jdt.day + monthtotal[mo] + dy
  1984.    end
  1985. end ;  { --- procedure greg_to_jul --- }
  1986.  
  1987. { ------------------------------------------------------------ }
  1988.  
  1989. procedure jul_to_greg(jdt : juldate ; var dt : longint);
  1990. { converts a julian date to a gregorian date }
  1991. var
  1992.    i, workday :integer ;
  1993.    yr,mo,dy   :integer;
  1994. begin
  1995.    yr := jdt.yr ;
  1996.    if (jdt.yr = 0) and (jdt.day = 0) then
  1997.       begin
  1998.       mo := 0 ; dy := 0
  1999.    end
  2000.    else
  2001.       begin
  2002.       workday := jdt.day ;
  2003.       if (leapyear(jdt.yr)) and (workday > 59) then
  2004.          workday := workday - 1 ;   { make it look like a non-leap year }
  2005.       i := 1 ;
  2006.       repeat
  2007.          i := i + 1
  2008.       until not (workday > monthtotal[i]);
  2009.       i := i - 1 ;
  2010.       mo := i ;
  2011.       dy := workday - monthtotal[i] ;
  2012.       if leapyear(jdt.yr) and (jdt.day = 60) then
  2013.          dy := dy + 1
  2014.       end;
  2015.    { need to convert the globals back to longint }
  2016.    dt := yr;
  2017.    dt := (dt * 100) + mo;
  2018.    dt := (dt * 100) + dy;
  2019. end ;  { --- procedure jul_to_greg --- }
  2020.  
  2021. { ------------------------------------------------------------ }
  2022.  
  2023. procedure next_day(var dt : longint);
  2024. { Adds one day to the date }
  2025. var
  2026.    jdt  : juldate ;
  2027.    leap : boolean ;
  2028.    yr,mo,dy :integer;
  2029.  
  2030. begin
  2031.    get_dt_val(dt,yr,mo,dy);
  2032.    greg_to_jul (dt,jdt);
  2033.    jdt.day := jdt.day + 1 ;
  2034.    leap := leapyear (yr);
  2035.    if (leap and (jdt.day = 367)) or (not leap and (jdt.day = 366)) then
  2036.       begin
  2037.       jdt.yr := jdt.yr + 1 ;
  2038.       jdt.day := 1
  2039.    end ;
  2040.    jul_to_greg (jdt,dt)
  2041. end ;  { --- procedure next_day --- }
  2042.  
  2043. { ------------------------------------------------------------ }
  2044.  
  2045. procedure prev_day(var dt : longint);
  2046. { Subtracts one day from the date }
  2047. var
  2048.    jdt : juldate ;
  2049. begin
  2050.    greg_to_jul (dt,jdt);
  2051.    jdt.day := jdt.day - 1 ;
  2052.    if jdt.day < 1 then
  2053.       begin
  2054.       jdt.yr := jdt.yr - 1 ;
  2055.       if leapyear (jdt.yr) then
  2056.          jdt.day := 366
  2057.       else
  2058.          jdt.day := 365
  2059.    end ;
  2060.    jul_to_greg (jdt,dt)
  2061. end ;  { --- procedure prev_day --- }
  2062.  
  2063. { ------------------------------------------------------------ }
  2064.  
  2065. function date_diff(dt1, dt2 : longint) : longint;
  2066. { computes the number of days between two dates }
  2067.  
  2068. var
  2069.    jdt1, jdt2 : juldate ;
  2070.    i, num_leap_yrs,
  2071.    yr1,mo1,dy1,
  2072.    yr2,mo2,dy2  : integer ;
  2073.  
  2074. begin
  2075.    greg_to_jul (dt1, jdt1);
  2076.    greg_to_jul (dt2, jdt2);
  2077.    get_dt_val(dt1,yr1,mo1,dy1);
  2078.    get_dt_val(dt2,yr2,mo2,dy2);
  2079.    num_leap_yrs := 0 ;         { adjust for leap years }
  2080.    if yr2 > yr1 then
  2081.       begin
  2082.       for i := yr1 to yr2 - 1 do
  2083.          if leapyear(i) then
  2084.             num_leap_yrs := num_leap_yrs + 1
  2085.    end
  2086.    else
  2087.       if yr1 > yr2 then
  2088.          begin
  2089.          for i := yr2 to yr1 - 1 do
  2090.             if leapyear(i) then
  2091.                num_leap_yrs := num_leap_yrs - 1
  2092.    end ;
  2093.  
  2094.    date_diff := jdt2.day - jdt1.day +
  2095.                 ((jdt2.yr - jdt1.yr) * 365) + num_leap_yrs;
  2096. end ;
  2097.  
  2098. { ------------------------------------------------------------ }
  2099.  
  2100. function month_diff(dt1, dt2 : longint ) : integer;
  2101. { Computes number of months between two dates, rounded.
  2102.   30.4167 = 356/12, average number of days in a month. }
  2103. begin
  2104.    month_diff := round((date_diff(dt1, dt2) + 1) / 30.4167)
  2105. end ;
  2106.  
  2107. { ------------------------------------------------------------ }
  2108.  
  2109. function equal_date(dt1, dt2 : longint) : boolean;
  2110. { Tests whether two dates are equal }
  2111. begin
  2112.    if (dt1 = dt2) then
  2113.       equal_date := true
  2114.    else
  2115.       equal_date := false;
  2116. end ;
  2117.  
  2118. { ------------------------------------------------------------ }
  2119.  
  2120. function zeller (dt : longint) : integer ;
  2121. { Compute the day of the week using Zeller's Congruence.
  2122.   From ROS 3.4 source code }
  2123. var
  2124.    century: integer ;
  2125.    yr,mo,dy :integer;
  2126.  
  2127. begin
  2128.    get_dt_val(dt,yr,mo,dy);
  2129.    if mo > 2
  2130.       then mo := mo - 2
  2131.    else
  2132.       begin
  2133.       mo := mo + 10 ;
  2134.       yr := pred(yr)
  2135.    end ;
  2136.    century := yr div 100 ;
  2137.    yr := yr mod 100 ;
  2138.    zeller := (dy - 1 + ((13 * mo - 1) div 5) + (5 * yr div 4) +
  2139.               century div 4 - 2 * century + 1) mod 7
  2140. end ;  { function zeller }
  2141.  
  2142. { ------------------------------------------------------------ }
  2143.  
  2144. function build_full_date_str(dt : longint) : fulldatestring;
  2145. { Build printable string of current date -- from ROS 3.4 source code. }
  2146. const
  2147.    day: array [0..6] of string[6] =
  2148.               ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
  2149.    month: array [1..12] of string[9] =
  2150.               ('January','February','March','April','May','June','July',
  2151.                'August','September','October','November','December');
  2152. var
  2153.    i: integer ;
  2154.    s: fulldatestring ;
  2155.    yr,mo,dy :integer;
  2156.  
  2157.    function intstr(n, w: integer): string ;
  2158.    { Return a string value of width w for the input integer n }
  2159.    var
  2160.       st: string ;
  2161.    begin
  2162.       str(n:w, st);
  2163.       st := purgech (st,' ');
  2164.       intstr := st
  2165.    end ;
  2166.  
  2167. begin { build_full_date_str }
  2168.    get_dt_val(dt,yr,mo,dy);
  2169.    if  (mo = 0) and (dy = 0) and (yr = 0) then
  2170.       s := 'No Date'
  2171.    else
  2172.       s := day[zeller(dt)] + 'day, ' +
  2173.             month[mo] + ' ' + intstr(dy, 2) + ', ' + intstr(yr, 4);
  2174.    if length (s) < fdslen then
  2175.       s := pad (s,' ',fdslen);
  2176.    build_full_date_str := s
  2177. end ; { function build_full_date_str }
  2178.  
  2179. { ---------------------------------------------------------------- }
  2180.  
  2181. procedure get_date;
  2182. { puts the system date in the sys_date date variable. }
  2183. var
  2184.    year,month,day,dow :word;
  2185. begin
  2186.    getdate(year,month,day,dow);
  2187.    sys_date := year;
  2188.    sys_date := (sys_date * 100) + month;
  2189.    sys_date := (sys_date * 100) + day;
  2190. end; { procedure get_date }
  2191.  
  2192. { ---------------------------------------------------------------- }
  2193.  
  2194. function month(dt:longint):integer;
  2195. { returns the month portion of a date.}
  2196. var
  2197.    lo_date :integer;
  2198. begin
  2199.    lo_date := dt mod 10000;
  2200.    month := (lo_date div 100);
  2201. end; {function month }
  2202.  
  2203. { ---------------------------------------------------------------- }
  2204.  
  2205. function day(dt:longint):integer;
  2206. { returns the day from the date }
  2207. var
  2208.    lo_date :integer;
  2209. begin
  2210.    lo_date := dt mod 10000;
  2211.    day := lo_date mod 100;
  2212. end;  { function day }
  2213.  
  2214. { ---------------------------------------------------------------- }
  2215.  
  2216. function year(dt:longint;centry:boolean):integer;
  2217. { returns the year of a date.  if the centry flag is true
  2218.   returns 4 digit year otherwise returns two digit year. }
  2219. var
  2220.    hi_date,
  2221.    result  :integer;
  2222. begin
  2223.    hi_date := dt div 10000;
  2224.    if(centry) then year := hi_date
  2225.    else year := hi_date mod 100;
  2226. end; {function year}
  2227.  
  2228. { ----- End of Date routines  ------Start of initialization ----- }
  2229.  
  2230. begin  {unit initialization}
  2231.    null_date := 0;
  2232.    null_date_str := 'MM/DD/YYYY' ;
  2233.    get_date;   { put todays date in sys_date }
  2234.    inv_flag := false;  { default to normal screen writes }
  2235.    inv_color := green; { default color for high lighted items if color monitor}
  2236.    numwindows := 0;
  2237.    reserv_wind := 0;
  2238.    regs.ah := 15;  { prepare for dos interrupt }
  2239.    intr($10,regs); { determine current video mode }
  2240.    case regs.al of
  2241.       0..3 :begin
  2242.                vidstart := $B800;  { start of color video memory }
  2243.                col_inv_flag := true;
  2244.             end;
  2245.          7 :begin
  2246.                vidstart := $B000;  { start of mono video memory }
  2247.                col_inv_flag := false;
  2248.             end;
  2249.       else vidstart := $B000;      { unknown try mono video ?? }
  2250.    end; {case}
  2251.    in_window := false; { default to not in windows }
  2252. end.  { tp4wio unit }
  2253.