Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FIBMCM.ZIP/SCRN_MGR.PAS

Pascal/Delphi Source File | 1989-05-09 | 27.6 KB | 861 lines

{$UNDEF MEMORY_METER} unit SCRN_MGR;
  (* Various utility functions for dealing with strings and a timer,
   together so that time spent waiting for a user response is not
   charged to the executing program. *)

  interface
    uses
      DOS (* dirstr, extstr, FSplit, GetTime, namestr, pathstr *);

    const
      nullstring = '';

      DOWN_ARROW_KEY  = #128;
      END_KEY         = #129;
      LEFT_ARROW_KEY  = #130;
      HOME_KEY        = #131;
      PAGE_DOWN_KEY   = #132;
      PAGE_UP_KEY     = #133;
      RIGHT_ARROW_KEY = #134;
      UP_ARROW_KEY    = #135;

    type
      ch_set = set of char;

      color_scheme = record
        FOREGROUND, BACKGROUND: byte
        end (* color_scheme *);

    var
      OLD_SCHEME (* on entry to program           *): color_scheme;
      DEBUG      (* controls loquacity everywhere *): integer;

    procedure BEEP;
    function EQUAL(var STRUCT1, STRUCT2; SIZE: word): boolean;
    procedure ERROR_EXIT(S: string);
    function FILE_EXISTS(FNAME: pathstr): boolean;
    function GET_CHAR(ACCEPTABLE: ch_set): char;
    procedure HOLD_TIMER;
    procedure IGNORE_Q(LEGEND: string);
    procedure INIT_SCRN_MGR;
    procedure LOUD_WRITE(S: string);
    procedure OUT_OF_MEMORY;
    function OWN_PATH: pathstr;
    function OWN_TITLE: pathstr;
    procedure PAUSE;
    function POS_INT_VALUE(S: string): integer;
    procedure READ_STRING(LEGEND: string; var S: string);
    function READ_TIMER: longint;
    procedure REWRITE_STRING(PROMPT, REPLACED: string);
    procedure RESUME_TIMER;
    function STR_FN(N: longint): string;
    function YES: boolean;
    procedure ZERO_TIMER;

      (* eject *)
  implementation
    uses
      CRT (* Black, ClrEol, ClrScr, Delay, GotoXY, LightGray, NoSound,
               ReadKey, Sound, TextAttr, TextBackground, TextColor, WhereX,
               WhereY, White, WindMax, WindMin *);

    const
      BACKSLASH  = '\';
      BLANK      = ' ';
      COLON      = ':';
      DOWN_ARROW = #25;
      ESCAPE     = #27;
      HORIZONTAL = #196;
      L_CORNER   = #218;
      LPAR       = '(';
      R_CORNER   = #191;
      RPAR       = ')';
      SHARP      = '#';
      T_PIECE    = #194;
      VERTICAL   = #179;

      DB_TRIGGER =  5 (* speak when DEBUG mod this is 1 *);
      MIDNIGHT = 86400;

      TEST_PATTERN = 314159265;
      VERSION_AT_COMPILE = 420505;

    type
      color_record = record
        VERSION_AT_RUN: longint;
        LOUD_SCHEME, NORMAL_SCHEME: color_scheme;
        BEEP_DURATION, BEEP_FREQUENCY: word
        end (* color_record *);

    var
      INITIALIZED    (* not twice                          *): boolean;
      COLOR_OPTIONS  (* set in INIT_SCRN_MGR               *): color_record;
      REWRITE_FROM_X (* from READ_STRING to REWRITE_STRING *),
      REWRITE_FROM_Y (* from READ_STRING to REWRITE_STRING *): integer;
      LAST_ZERO_TIME (* clock value, last time we looked   *),
      TIME_PAST      (* time accumulated before timeout    *): longint;
      SAVE_EXIT      (* for the great exit chain           *): pointer;
      {$IFDEF MEMORY_METER}
      RUNNER_SEG     (* MEM subscript for heap-use test    *): word;
      {$ENDIF}

    procedure SET_COLOR_SCHEME(SCHEME: color_scheme); forward;
    function TIME_NOW: longint;                       forward;

    procedure BEEP;
      (* avoid irritating use of BEL character *)

      begin (* BEEP *)
        with COLOR_OPTIONS do
          begin (* with *)
            Sound(BEEP_FREQUENCY);
            Delay(BEEP_DURATION);
            NoSound
          end   (* with *)
      end   (* BEEP *);

    function ELAPSED_TIME: longint;
      (* returns time since LAST_ZERO_TIME *)

      var
        MY_TIME: longint;

      begin (* ELAPSED_TIME *)
        MY_TIME := TIME_NOW - LAST_ZERO_TIME;
        if MY_TIME < 0 then
          MY_TIME := MY_TIME + MIDNIGHT;
        ELAPSED_TIME := MY_TIME
      end   (* ELAPSED_TIME *);

      (* eject *)
    {$F+}
    procedure EPILOGUE;
    {$F-}
      (* Part of the great exit chain *)

      var
        IN_PI_BLOCK: boolean;
        LENGTH_ZENITH, THIS_LENGTH: longint;
        I, RUNNER_SEG: word;

      begin (* EPILOGUE *)
        {$IFDEF MEMORY_METER}
          if DEBUG mod DB_TRIGGER = 1 then
            begin (* nondegenerate *)
              I := 0;

              while I < sptr do
                if mem[sseg:I] <> $AA then
                  begin (* found untouched stack *)
                    writeln(I:8, ' bytes of stack space unused.');
                    I := sptr
                  end   (* found untouched stack *)
                else
                  inc(I);

              IN_PI_BLOCK := false;
              LENGTH_ZENITH := 0;
              for RUNNER_SEG := succ(seg(heapptr^)) to pred(seg(freeptr^)) do
                if (meml[RUNNER_SEG:0] = TEST_PATTERN) and
                   (meml[RUNNER_SEG:4] = TEST_PATTERN) and
                   (meml[RUNNER_SEG:8] = TEST_PATTERN) and
                   (meml[RUNNER_SEG:12] = TEST_PATTERN) then
                  if IN_PI_BLOCK then
                    begin (* extend *)
                      inc(THIS_LENGTH, 16);
                      if THIS_LENGTH > LENGTH_ZENITH then
                        LENGTH_ZENITH := THIS_LENGTH
                    end   (* extend *)
                  else
                    begin (* start *)
                      IN_PI_BLOCK := true;
                      THIS_LENGTH := 16
                    end   (* start *)
                else
                  IN_PI_BLOCK := false;

              writeln(LENGTH_ZENITH:8, ' bytes of heap space unused.')
            end   (* nondegenerate *);
        {$ENDIF}

        ExitProc := SAVE_EXIT
      end   (* EPILOGUE *);

      (* eject *)
    function EQUAL(var STRUCT1, STRUCT2; SIZE: word): boolean;
      (* Cribbed from Turbo Pascal manual, p. 268 *)

      type
        bytes = array[0 .. maxint] of byte;

      var
        I: integer;

      begin (* EQUAL *)
        I := 0;
        while (I < SIZE) and (bytes(STRUCT1)[I] = bytes(STRUCT2)[I]) do
          inc(I);
        EQUAL := (I = SIZE)
      end   (* EQUAL *);

    procedure ERROR_EXIT(S: string);
      (* Write S to console, then die *)

      begin (* ERROR_EXIT *)
        if length(S) > 0 then
          begin (* error message *)
            writeln;
            ClrEol;
            LOUD_WRITE(S)
          end   (* error message *);
        PAUSE;
        halt(1)
      end   (* ERROR_EXIT *);

    function FILE_EXISTS(FNAME: pathstr): boolean;
      (* No promise that file is of NZ length. *)

      var
        F: file;

      begin (* FILE_EXISTS *)
        FILE_EXISTS := false;
        if length(FNAME) > 0 then
          begin (* nondegenerate *)
            {$I-}
            assign(F, FNAME);
            reset(F);
            if ioresult = 0 then
              begin (* success *)
                FILE_EXISTS := true;
                close(F)
              end   (* success *)
            {$I+}
          end   (* nondegenerate *)
      end   (* FILE_EXISTS *);

    function GET_CHAR(ACCEPTABLE: ch_set): char;
      (* Return an upper-case character from ACCEPTABLE, or abort on <esc> *)

      var
        CH: char;

      begin (* GET_CHAR *)
        repeat (* get a character *)
          HOLD_TIMER;
          CH := upcase(ReadKey);
          case CH of
            #0: case ReadKey of
                  #71: CH := HOME_KEY;
                  #72: CH := UP_ARROW_KEY;
                  #73: CH := PAGE_UP_KEY;
                  #75: CH := LEFT_ARROW_KEY;
                  #77: CH := RIGHT_ARROW_KEY;
                  #79: CH := END_KEY;
                  #80: CH := DOWN_ARROW_KEY;
                  #81: CH := PAGE_DOWN_KEY
                  end (* case on ReadKey *);
            #8: CH := LEFT_ARROW_KEY
            end (* case on CH *);
          RESUME_TIMER
        until  (* get a character *) CH in ACCEPTABLE;

        GET_CHAR := CH
      end   (* GET_CHAR *);

    {$F+}
    function HEAP_FUNCTION(SIZE: word): integer;
    {$F-}
      (* regain control on heap overflow *)

      begin  (* HEAP_FUNCTION *)
        HEAP_FUNCTION := 1
      end    (* HEAP_FUNCTION *);

    procedure HOLD_TIMER;
      (* Until a call to RESUME_TIMER, time seen by READ_TIMER will
      not accumulate *)

      begin (* HOLD_TIMER *)
        TIME_PAST := TIME_PAST + ELAPSED_TIME
      end   (* HOLD_TIMER *);

    procedure IGNORE_Q(LEGEND: string);
      (* Tell user what you are ignoring. *)

      var
        SAVED_X: integer;

      begin (* IGNORE_Q *)
        SAVED_X := WhereX;
        writeln;
        LOUD_WRITE(LEGEND);
        writeln;
        LOUD_WRITE('Type <space> to continue, <esc> to abort: ');
        if GET_CHAR([BLANK, ESCAPE]) = ESCAPE then
          ERROR_EXIT(nullstring);

        GotoXY(1, pred(WhereY));
        ClrEol;
        writeln;
        ClrEol;
        GotoXY(SAVED_X, WhereY-2)
      end   (* IGNORE_Q *);

    procedure INIT_SCRN_MGR;
      (* Initialize private variables, effectively starting the clock.
      Set the colors of text and loud text *)

      const
        COLOR_FILE_NAME = 'HUES_TO.USE';

      var
        COLORS_SET: boolean;
        COLOR_FILE: file of color_record;

      procedure CREATE_COLOR_FILE;
        (* Allow user to select colors of normal & loud text *)

        const
          INTENSITY = 8;

        procedure CHOOSE_BEEP;
          (* Kludge to shorten CREATE_COLOR_FILE *)

          var
            CHANGES_MADE: boolean;
            LINE: string;
            NEW_DURATION, NEW_FREQUENCY: word;

          begin (* CHOOSE_BEEP *)
            writeln;
            writeln('  (Iterated until you stop making changes)');

            with COLOR_OPTIONS do
              repeat (* let user choose beep *)
                CHANGES_MADE := false;
                BEEP;
                LOUD_WRITE('Beep duration in milliseconds ['+
                           STR_FN(BEEP_DURATION) +
                           ']: ');
                readln(LINE);
                if length(LINE) > 0 then
                  begin (* suggestion made *)
                    NEW_DURATION := POS_INT_VALUE(LINE);
                    if NEW_DURATION <> BEEP_DURATION then
                      begin (* got one *)
                        BEEP_DURATION := NEW_DURATION;
                        CHANGES_MADE := true
                      end   (* got one *);
                  end   (* suggestion made *);

                BEEP;
                LOUD_WRITE('Beep frequency in Hertz [' +
                           STR_FN(BEEP_FREQUENCY) +
                           ']: ');
                readln(LINE);
                if length(LINE) > 0 then
                  begin (* suggestion made *)
                    NEW_FREQUENCY := POS_INT_VALUE(LINE);
                    if NEW_FREQUENCY <> BEEP_FREQUENCY then
                      begin (* got one *)
                        BEEP_FREQUENCY := NEW_FREQUENCY;
                        CHANGES_MADE := true
                      end   (* got one *)
                  end   (* suggestion made *)
              until  (* let user choose beep *) not CHANGES_MADE
          end   (* CHOOSE_BEEP *);

        procedure CHOOSE_COLORS;
          (* Kludge to shorten CREATE_COLOR_FILE *)

          const
            SAMPLE_LINE = 15 (* after palette *);
            ASK_LINE    = 18 (* after sample *);

          var
            SATISFIED (* no changes *): boolean;
            Y         (* coordinate *): integer;

          procedure GET_BYTE(FOREBACK, LEGEND: string;
                             CTX: byte;
                             var VAL: byte);
            (* pursue user *)

            var
              LOOKING: boolean;
              LIMIT, TRY: byte;
              LINE: string;

            begin (* GET_BYTE *)
              LOOKING := true;
              if FOREBACK = 'fore' then
                LIMIT := 16
              else
                LIMIT := 8;
              with COLOR_OPTIONS do
                while LOOKING do
                  begin (* keep looking *)
                    SET_COLOR_SCHEME(NORMAL_SCHEME);
                    ClrEol;
                    SET_COLOR_SCHEME(LOUD_SCHEME);
                    if length(LEGEND) = 6 then
                      write('  ');
                    write('New ', LEGEND, BLANK, FOREBACK, 'ground [',
                          VAL, ']: ');
                    SET_COLOR_SCHEME(NORMAL_SCHEME);
                    readln(LINE);
                    if length(LINE) = 0 then
                      LOOKING := false
                    else
                      begin (* new offer *)
                        TRY := POS_INT_VALUE(LINE);
                        if (TRY < LIMIT) and (TRY <> CTX) then
                          begin (* got one *)
                            LOOKING := false;
                            if TRY <> VAL then
                              begin (* nondegenerate *)
                                SATISFIED := false;
                                VAL := TRY
                              end   (* nondegenerate *)
                          end   (* got one *)
                        else
                          GotoXY(1, pred(WhereY))
                      end   (* new offer *)
                  end   (* keep looking *)
            end   (* GET_BYTE *);

          procedure PALETTE;
            (* Menu of colors *)

            var
              BKGD (* runner *),
              FGD  (* runner *): byte;

            begin (* PALETTE *)
              writeln('        One-time choice of text colors');
              writeln;
              writeln(BLANK, L_CORNER, HORIZONTAL, HORIZONTAL, 'Background');
              write(BLANK, VERTICAL, nullstring:5, L_CORNER);
              for FGD := 1 to 6 do
                write(HORIZONTAL, HORIZONTAL, HORIZONTAL, T_PIECE);
              write(HORIZONTAL, 'Foreground', T_PIECE);
              for FGD := 10 to 14 do
                write(HORIZONTAL, HORIZONTAL, HORIZONTAL, T_PIECE);
              writeln(HORIZONTAL, HORIZONTAL, HORIZONTAL, R_CORNER);
              write(BLANK, DOWN_ARROW, BLANK, BLANK);
              for FGD := BLACK to WHITE do
                write(DOWN_ARROW:4);
              writeln;
              for BKGD := Black to LightGray do
                begin (* BKGD *)
                  write(BKGD:2, ': ');
                  TextBackground(BKGD);
                  for FGD := Black to White do
                    begin (* FGD *)
                      TextColor(FGD);
                      write(FGD:4)
                    end   (* FGD *);
                  SET_COLOR_SCHEME(OLD_SCHEME);
                  ClrEol;
                  writeln
                end   (* BKGD *)
            end   (* PALETTE *);

          begin (* CHOOSE_COLORS *)
            ClrScr;
            GotoXY(1, 1);
            PALETTE;

            with COLOR_OPTIONS do
              repeat (* elicit choice *)
                SATISFIED := true;
                GotoXY(1, SAMPLE_LINE);
                ClrEol;
                SET_COLOR_SCHEME(NORMAL_SCHEME);
                with NORMAL_SCHEME do
                  write('            Ordinary text (', FOREGROUND,
                        ' on ', BACKGROUND, ')  ');
                SET_COLOR_SCHEME(LOUD_SCHEME);
                with LOUD_SCHEME do
                  writeln('     Urgent text (', FOREGROUND,
                          ' on ', BACKGROUND, RPAR);

                SET_COLOR_SCHEME(NORMAL_SCHEME);
                for Y := succ(SAMPLE_LINE) to ASK_LINE+3 do
                  begin (* clear old lines *)
                    ClrEol;
                    writeln
                  end   (* clear old lines *);
                GotoXY(1, pred(ASK_LINE));
                writeln('  (Iterated until you stop making changes)');

                with NORMAL_SCHEME do
                  begin (* new values *)
                    GET_BYTE('back', 'ordinary', FOREGROUND, BACKGROUND);
                    GET_BYTE('fore', 'ordinary', BACKGROUND, FOREGROUND)
                  end   (* new values *);
                with LOUD_SCHEME do
                  begin (* new values *)
                    GET_BYTE('back', 'urgent', FOREGROUND, BACKGROUND);
                    GET_BYTE('fore', 'urgent', BACKGROUND, FOREGROUND)
                  end   (* new values *)
              until  (* elicit choice *) SATISFIED
          end   (* CHOOSE_COLORS *);

        begin (* CREATE_COLOR_FILE *)
          with COLOR_OPTIONS do
            begin (* with *)
              VERSION_AT_RUN := VERSION_AT_COMPILE;
              NORMAL_SCHEME := OLD_SCHEME;
              LOUD_SCHEME := NORMAL_SCHEME;
              with LOUD_SCHEME do
                begin (* minimal change *)
                  FOREGROUND := FOREGROUND xor INTENSITY;
                  if FOREGROUND = BACKGROUND then
                    FOREGROUND := succ(FOREGROUND) mod 16
                end   (* minimal change *);
              BEEP_DURATION := 500;
              BEEP_FREQUENCY := 150;

              CHOOSE_COLORS;
              CHOOSE_BEEP;

              assign(COLOR_FILE, OWN_PATH + COLOR_FILE_NAME);
              rewrite(COLOR_FILE);
              write(COLOR_FILE, COLOR_OPTIONS);
              close(COLOR_FILE)
            end   (* with *);
        end   (* CREATE_COLOR_FILE *);

        (* eject *)
      begin (* INIT_SCRN_MGR *)
        if not INITIALIZED then
          begin (* nondegenerate case *)
            with OLD_SCHEME do
              begin (* colors on entry *)
                BACKGROUND := (TextAttr shr 4) mod 8;
                FOREGROUND := TextAttr mod 16
              end   (* colors on entry *);

            COLORS_SET := false;
            assign(COLOR_FILE, OWN_PATH + COLOR_FILE_NAME);
            repeat (* seek or create file *)
              {$I-}
              reset(COLOR_FILE);
              if ioresult <> 0 then
                CREATE_COLOR_FILE
              else if eof(COLOR_FILE) then
                begin (* short file *)
                  close(COLOR_FILE);
                  CREATE_COLOR_FILE
                end   (* short file *)
              else
                with COLOR_OPTIONS do
                  begin (* try to use it *)
                    read(COLOR_FILE, COLOR_OPTIONS);
                    close(COLOR_FILE);
                    if VERSION_AT_RUN <> VERSION_AT_COMPILE then
                      erase(COLOR_FILE)
                    else
                      begin (* looks good *)
                        SET_COLOR_SCHEME(NORMAL_SCHEME);
                        COLORS_SET := true
                      end   (* looks good *)
                  end   (* try to use it *)
              {$I+}
            until  (* seek or create file *) COLORS_SET;

            ZERO_TIMER;
            INITIALIZED := true
          end   (* nondegenerate case *)
      end   (* INIT_SCRN_MGR *);

    procedure LOUD_WRITE(S: string);
      (* Write the string S to the console, using whatever means of
      emphasis are available. *)

      begin (* LOUD_WRITE *)
        with COLOR_OPTIONS do
          begin (* with *)
            SET_COLOR_SCHEME(LOUD_SCHEME);
            write(S);
            SET_COLOR_SCHEME(NORMAL_SCHEME)
          end   (* with *)
      end   (* LOUD_WRITE *);

    procedure OUT_OF_MEMORY;
      (* Common exit for various heap-exhausted conditions *)

      begin (* OUT_OF_MEMORY *)
        ERROR_EXIT('Out of memory')
      end   (* OUT_OF_MEMORY *);

    function OWN_PATH: pathstr;
      (* Return DOS directory in which this .EXE file was found *)

      var
        RESULT: dirstr;
        EXT: extstr;
        I: integer;
        NAME: namestr;

      begin (* OWN_PATH *)
        FSplit(paramstr(0), RESULT, NAME, EXT);
        OWN_PATH := RESULT
      end   (* OWN_PATH *);

      (* eject *)
    function OWN_TITLE: pathstr;
      (* Return name of the executing .EXE file *)

      var
        PATH: dirstr;
        EXT: extstr;
        NAME: namestr;

      begin (* OWN_TITLE *)
        FSplit(paramstr(0), PATH, NAME, EXT);
        OWN_TITLE := NAME + EXT
      end   (* OWN_TITLE *);

    procedure PAUSE;
      (* Make sure user has read the last message *)

      begin (* PAUSE *)
        writeln;
        ClrEol;
        while KeyPressed do
          if ReadKey = #0 then
            (* loop will get 2nd portion *);

        LOUD_WRITE('Type <space> to continue');

        repeat (* wait for <space> *)
        until  (* wait for <space> *) ReadKey = BLANK;

        GotoXY(1, WhereY);
        ClrEol
      end   (* PAUSE *);

    function POS_INT_VALUE(S: string): integer;
      (* Return the natural number represented by the string S *)

      var
        I, RESULT: integer;

      begin (* POS_INT_VALUE *)
        RESULT := 0;

        for I := 1 to length(S) do
          case S[I] of
            '0' .. '9': if RESULT < maxint div 10 then
                          RESULT := 10 * RESULT + ord(S[I]) - ord('0')
            end (* case on S[I] *);

        POS_INT_VALUE := RESULT
      end   (* POS_INT_VALUE *);

      (* eject *)
    procedure READ_STRING(LEGEND: string; var S: string);
      (* LOUD_WRITE(LEGEND (or <esc> to abort))
         If ESC received then
           exit(program)
         else
           build S
      *)
      const
        DEL_KEY = #83;
        LEFT_ARROW_KEY = #75;

        BS = #8;
        CR = #13;

      var
        CH: char;

        S_RECORD: record
          case boolean of
            false: (S_STRING: string);
             true: (S_ARRAY: packed array[0 .. 255] of char)
          end (* S_RECORD *);

          (* eject *)
      procedure BACKSPACE;
        (* Destructive version of SC_LEFT *)

        procedure LEFT;
          (* SC_LEFT, with reverse wraparound if needed *)

          begin (* LEFT *)
            if WhereX = 1 then
              GotoXY(succ(lo(WindMax) - lo(WindMin)), WhereY-1)
            else
              GotoXY(WhereX-1, WhereY)
          end   (* LEFT *);

        begin (* BACKSPACE *)
          LEFT;
          write(BLANK);
          LEFT;
          with S_RECORD do
            S_ARRAY[0] := pred(S_ARRAY[0])
        end   (* BACKSPACE *);

        (* eject *)
      begin (* READ_STRING *)
        REWRITE_FROM_X := WhereX;
        REWRITE_FROM_Y := WhereY;
        LOUD_WRITE(LEGEND + ' (or <esc> to abort): ');

        with S_RECORD do
          begin (* with *)
            S_STRING := nullstring;

            repeat (* get line *)
              HOLD_TIMER;
              CH := ReadKey;
              RESUME_TIMER;

              case CH of
                         #0: begin (* special key *)
                               CH := ReadKey;
                               case CH of
                                        DEL_KEY: while length(S_STRING) > 0 do
                                                   BACKSPACE;
                                 LEFT_ARROW_KEY: if length(S_STRING) > 0 then
                                                   BACKSPACE
                                 end (* case on CH *)
                             end   (* special key *);

                         BS: if length(S_STRING) > 0 then
                               BACKSPACE;

                         CR: S := S_STRING;

                     ESCAPE: halt(2);

                #32 .. #126: if length(S_STRING) < 255 then
                               begin (* extend S *)
                                 S_ARRAY[0] := succ(S_ARRAY[0]);
                                 S_ARRAY[ord(S_ARRAY[0])] := CH;
                                 write(CH)
                               end   (* extend S *)
                end (* outer case on CH *)
            until  (* get line *) CH = CR
          end   (* with *);

        writeln;
        if WhereY = REWRITE_FROM_Y then (* scrolled *)
          dec(REWRITE_FROM_Y)
      end   (* READ_STRING *);

    function READ_TIMER: longint;
      (* returns time since last call to ZERO_TIMER in longints *)

      begin (* READ_TIMER *)
        READ_TIMER := TIME_PAST + ELAPSED_TIME
      end   (* READ_TIMER *);

      (* eject *)
    procedure RESUME_TIMER;
      (* Restart the clock after waiting for keyboard *)

      begin (* RESUME_TIMER *)
        LAST_ZERO_TIME := TIME_NOW
      end   (* RESUME_TIMER *);

    procedure REWRITE_STRING(PROMPT, REPLACED: string);
      (* Following call to READ_STRING, overwrite offering with interpretation
      *)

      begin (* REWRITE_STRING *)
        GotoXY(REWRITE_FROM_X, REWRITE_FROM_Y);
        ClrEol;
        write(PROMPT, ': ', REPLACED)
      end   (* REWRITE_STRING *);

    procedure SET_COLOR_SCHEME(SCHEME: color_scheme);
      (* isolate Turbo dependencies *)

      begin (* SET_COLOR_SCHEME *)
        TextBackground(SCHEME.BACKGROUND);
        TextColor(SCHEME.FOREGROUND)
      end   (* SET_COLOR_SCHEME *);

    function STR_FN(N: longint): string;
      (* function version of STR intrinsic *)

      var
        RESULT: string;

      begin (* STR_FN *)
        str(N, RESULT);
        STR_FN := RESULT
      end   (* STR_FN *);

    function TIME_NOW: longint;
      (* Returns time (seconds since midnight) as longint. *)

      var
        HOUR, MINUTE, SECOND, SEC100: word;

      begin (* TIME_NOW *)
        GetTime(HOUR, MINUTE, SECOND, SEC100);
        TIME_NOW := 3600*longint(HOUR) + 60*MINUTE + SECOND + (SEC100 div 50)
      end   (* TIME_NOW *);

    function YES;
      (* Get Yes or No from the console *)

      begin (* YES *)
        case GET_CHAR([ESCAPE, 'Y', 'N']) of
          ESCAPE: ERROR_EXIT(nullstring);

             'N': begin (* no *)
                    writeln('No');
                    YES := false
                  end   (* no *);

             'Y': begin (* yes *)
                    writeln('Yes');
                    YES := true
                  end   (* yes *)
          end (* case *)
      end   (* YES *);

    procedure ZERO_TIMER;
      (* Start timer now *)

      begin (* ZERO_TIMER *)
        LAST_ZERO_TIME := TIME_NOW;
        TIME_PAST := 0
      end   (* ZERO_TIMER *);

      (* eject *)
    begin (* SCREEN_MGR *)
      DEBUG := 0;
      INITIALIZED := false;
      SAVE_EXIT := ExitProc;
      ExitProc := @EPILOGUE;
      heaperror := @HEAP_FUNCTION;

      {$IFDEF MEMORY_METER}
        fillchar(mem[sseg:0], sptr-20, $AA);

        for RUNNER_SEG := seg(heapptr^)+3 to seg(freeptr^)-3 do
          begin (* fill with test pattern *)
            meml[RUNNER_SEG:0] := TEST_PATTERN;
            meml[RUNNER_SEG:4] := TEST_PATTERN;
            meml[RUNNER_SEG:8] := TEST_PATTERN;
            meml[RUNNER_SEG:12] := TEST_PATTERN
          end   (* fill with test pattern *)
      {$ENDIF}
    end   (* SCREEN_MGR *) .

END
T-------T-------T-------T-------T-------T-------T-------T-------T-------T-------T
$cursor=28167,20;$tag=11112,24;$last=19602,24;a=22378,9;
FTL0R79P5.F0B7