Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/STAY50.ZIP/DEMO.PAS

Pascal/Delphi Source File | 1988-11-28 | 19.4 KB | 498 lines

{$I direct.inc}
  {──────────────────────────────────────────────────────────────────────}
  {         Turbo Pascal Stay Resident Shell Demonstation                }
  {               Copyright (C) 1988 Lane  Ferris                        }
  {──────────────────────────────────────────────────────────────────────}
  {    Send Suggestions and Bug reports to COMPUSERVE ID: 70357,2716     }
  {    or write:  4268 26th St. SanFrancisco, Ca 94131                   }
  {──────────────────────────────────────────────────────────────────────}

 uses
      crt,dos,
      macros,          { assorted inlines }
      SR50,            { stayres kernel   }
      SR50subs,        { stayres subs     }
      SRmsgu  ,        { mailbox unit     }
      FListu    ;      { file list unit   }


  const
   AltD       : word = $2000         ; { AltD int 16 keycode            }
   AltL       : word = $2600         ; { AltL int 16 keycode            }
  var
   Attr       : byte    ;

  {────────────────────────────────────────────────────────────────}
  {                           Clock                                }
  {────────────────────────────────────────────────────────────────}
  {         Displays digital clock in upper right of screen        }
  {────────────────────────────────────────────────────────────────}
 {$F+}Procedure Clock ; {$F-}

  var
    SystemTimer  : longint absolute $40:$6c ;
    Hours        : longint   ;
    minutes,
    seconds      : longint   ;
    ticks        : longint   ;

    Hoursstr    : string[2]  ;
    Minutesstr  : string[2]  ;
    secondsstr  : string[2]  ;
    ampm        : string[2]  ;
    ClockStr    : string[11] ;
    SaveWindow  : array[1..4] of byte ;

    SaveCurPos  : word       ;
    BiosCurPos   : word absolute $40:$50 ; { BIOS cursor position page 1  }

  BEGIN
   While true do begin                  { do forever }
      ticks   := SystemTimer     ;
      Hours   := ticks div 65543 ;      { 65543 ticks per hour  }
      dec(ticks,Hours*65543)     ;
      minutes := ticks div 1092  ;      { 1092 ticks per minute }
      dec(ticks,minutes*1092)    ;
      seconds := ticks div 18    ;      { 18.2 ticks per second }
 (**                                    { account for .2 tick error }
      seconds := seconds - (seconds div 20) ; { as 1 tick in 20 err }
  **)
      if seconds >59 then seconds := 59 ;
      if Hours > 12 then begin
        dec(Hours,12)   ;
        ampm := 'pm'    ;
        end
      else ampm := 'am' ;

      str(Hours  :2,hoursstr   ) ;
      str(Minutes:2,minutesstr ) ;
      str(seconds:2,secondsstr ) ;
                                               { force leading zeros }
      Hoursstr[1]   := char(ord(hoursstr[1])   or ord('0')) ;
      Minutesstr[1] := char(ord(Minutesstr[1]) or ord('0')) ;
      Secondsstr[1] := char(ord(Secondsstr[1]) or ord('0')) ;

      ClockStr := Hoursstr+':'+Minutesstr+':'+secondsstr+ampm  ;
      resource(reserve,_crt)     ;
      move(Windmin,SaveWindow,4) ;
      SaveCurPos := BiosCurPos   ;
      window(68,1,79,2)          ; { a window resets cursor posn etc }
      write( ClockStr)           ;
      move(SaveWindow,Windmin,4) ;
      BiosCurPos := SaveCurPos   ;
      resource(rlse,_crt)        ;
      Yield                      ;  { give up cpu control }

   end {while true }         ;
  END; {Clock}

  {───────────────────────────────────────────────────────────────}
  {                       ShowDir                                 }
  {───────────────────────────────────────────────────────────────}
  {           Yet another directory display routine               }
  {───────────────────────────────────────────────────────────────}
  const
   maxentries = 78 ; {≈1024 bytes}
  var
   Filenames    : array[1..maxentries] of string[13] ;
   OldWindowPtr : pointer ; { pointer to old window on heap }
  const
   DirContents  : pointer = nil ; { process window contents to restore }
  {───────────────────────────────────────────────────────────────}
  {                       DirPop                                  }
  {───────────────────────────────────────────────────────────────}
  {       popup/dn maintenance routine called from SR50           }
  {     each time the hotkey is activated from the keyboard       }
  {───────────────────────────────────────────────────────────────}
   {$F+} Procedure DirPop(popupdn:boolean) ; {$F-}

    Begin
      resource(reserve,_crt)     ;
     case popupdn of
       True : Begin { This is a popup }
              SaveWindow(1,1,68,20,OldWindowPtr) ; { save forgound window    }
              BorderWindow(1,1,68,20,border) ;     { make window with border }
              if DirContents <> nil then             { restore contents if any }
                 RestoreWindow(2,2,67,19,DirContents) ;
              end {popup} ;
       false: Begin { this is a popdown}
              SaveWindow(2,2,67,19,DirContents) ;       { save window contents }
              RestoreWindow(1,1,68,20,OldWindowPtr) ; { restore foreground   }
              end {popdown}
     end {case};;
      resource(rlse,_crt)     ;
   End {DirPop} ;
  {───────────────────────────────────────────────────────────────}
  {                       Sort em                                 }
  {───────────────────────────────────────────────────────────────}
  {          Insertion sort filenames into alpa order             }
  {───────────────────────────────────────────────────────────────}
  Procedure Sortem(entries : integer ) ;
   var
   i, j, lowest, highest, center : integer ;
   tempstr : string[13]                ;

  begin
   for i := 2 to entries do begin
     tempstr := Filenames[i] ;
     lowest  := 1            ;
     highest := i - 1        ;

     while lowest <= highest do begin
      center := (lowest + highest) div 2 ;
      if tempstr < filenames[center] then
         highest := center - 1
         else lowest := center +1   ;
     end {while lowest..}   ;

     for j := i - 1 downto lowest do
         filenames[j+1] := filenames[j] ;
     filenames[lowest] := tempstr       ;
   end {for i..}            ;
  end {Sortem}        ;

  {───────────────────────────────────────────────────────────────}
  {                       Show em                                 }
  {───────────────────────────────────────────────────────────────}
  {       display partial sorted directory entries on video       }
  {───────────────────────────────────────────────────────────────}
  Procedure Showem(entries : integer ) ;
   var
   i, j : integer ;
  begin
    clrscr  ;
    j  := 0 ;
    for i := 1 to entries do begin
      Resource(reserve,_CRT) ;
      write(filenames[i])    ;
      Resource( rlse,_CRT)   ;
      inc(j)                 ;
      if j = 5 then begin
        Resource(reserve,_CRT)  ;
        writeln                 ;
        Resource(rlse,_CRT)     ;
        j := 0                  ;
      end{if j}
    end {for i}                   ;
  end{showem} ;

  {───────────────────────────────────────────────────────────────}
  {                  ShowDir         (main procedure)             }
  {───────────────────────────────────────────────────────────────}
  Procedure ShowDir ;
   const
    blanks : string[13] = '             ' ;
   var
    FilePath      : string    ;
    FileAttr      : byte      ;
    FileSearchRec : SearchRec ;
    i             : integer   ;
    ch            : char      ;

   begin {ShowDir}
    FilePath  := '*.*'   ;
    FileAttr  := AnyFile ;
    i         := 1       ;

    FindFirst(FilePath,FileAttr,FileSearchRec) ;


    while DosError = 0 do begin
      With FileSearchRec do begin
        blanks[0]    := char(13-length(name)) ;
        Filenames[i] := Name+blanks           ;
        inc(i)                         ;
        if i = maxentries+1 then begin
           sortem(i-1)                 ;
           showem(i-1)                 ;
           Resource(reserve,_CRT)      ;
           writeln;write('Count was: ',i-1) ;
           Resource(rlse,_CRT)         ;
           while not keypressed do Yield    ;
           ch := readkey               ; { eat the key       }
           i  := 1                     ; { restart the array }
        end {if i..}                   ;
      end {with file..}                ;
      FindNext( FileSearchRec )   ;
   end{while DosError..}          ;

   sortem(i-1)                    ;
   showem(i-1)                    ;
   Resource(reserve,_CRT)         ;
   writeln;writeln('Count was: ',i-1) ;
   Resource(rlse,_CRT)                ;

   while not keypressed do yield      ;
   ch := readkey                      ;

   End {ShowDir}                      ;

  {────────────────────────────────────────────────────────────────}
  {                         DirTask                                }
  {────────────────────────────────────────────────────────────────}
  {    Hotkey task in infinite loop with Yield to SR50 at bottom   }
  {────────────────────────────────────────────────────────────────}
  Procedure DirTask              ;
   begin
   While true do begin
    ShowDir                      ; { Display the Directory  }
    Yield                        ; { tell SR50 its finished }
   end {while true..}            ;
  end {DirTask}                  ;
  {────────────────────────────────────────────────────────────────}
  {                         ListFile                               }
  {────────────────────────────────────────────────────────────────}
  {  If you're one who believes that Dinasours died of their own   }
  {  stupditiy.. you'll love this.                                 }
  {────────────────────────────────────────────────────────────────}
  { This is an exercise in mailbox maintenance. It sends commands  }
  { to a mailbox, and receives the results. Message passing is fun }
  { .. but, ever so slow..  Dinasaurs dont care .                  }
  {────────────────────────────────────────────────────────────────}
  Const
   ListContents : pointer = nil    ;  { contents of window }
  {───────────────────────────────────────────────────────────────}
  {                       ListPop                                 }
  {───────────────────────────────────────────────────────────────}
  {       popup/down maintenance routine called from SR50         }
  {───────────────────────────────────────────────────────────────}
   {$F+} Procedure ListPop(popupdn:boolean) ; {$F-}

    Begin
      resource(reserve,_crt)     ;
     case popupdn of
       True : Begin { This is a popup }
              SaveWindow(4,4,68,21,OldWindowPtr) ; { save forgound window    }
              BorderWindow(4,4,68,21,border) ;     { make window with border }
              if ListContents <> nil then          { restore contents if any }
                 RestoreWindow(5,5,67,20,ListContents) ;
              end {popup} ;
       false: Begin { this is a popdown}
              SaveWindow(5,5,67,20,ListContents) ;    { save window contents }
              RestoreWindow(4,4,68,21,OldWindowPtr) ; { restore foreground   }
              end {popdown}
     end {case};;
      resource(rlse,_crt)     ;
   End {ListPop} ;
  {───────────────────────────────────────────────────────────────}
  {                       ListTask                                }
  {───────────────────────────────────────────────────────────────}
  {       Alt-L popup Showing lines of a file in window           }
  {───────────────────────────────────────────────────────────────}
   Procedure ListTask ;

     const
       esc     =  27 ;
       pgup    =  73 + 128 ;
       pgdn    =  81 + 128 ;
       uparr   =  72 + 128 ;
       dnarr   =  80 + 128 ;
       ctlpgup = 132 + 128 ;
       ctlpgdn = 118 + 128 ;
       ctlhome = 119 + 128 ;
       ctlend  = 117 + 128 ;

       pagesize = 10 ;

     var
       i          : integer ;
       key        : integer ;   { keyboard input + 128 }
       LineNr     : integer ;   { File line number     }
       LastLineNr : integer ;   { Last line in file    }
       Nrtoshow   : integer ;   { Num lines to show    }
       result     : integer ;   { perverbial round can }
       StrPtr     : pointer ;   { utility pointer      }
       message    : string  ;   { utility string       }
       done       : boolean ;   { utility boolean      }
       textwidth  : byte    ;   { max text to write    }

    begin {main}

     MakeMailbox('ListMail')           ;  { Make a listing mailbox }

     While True do Begin       { repeat forever }
      textwidth := lo(windmax) - lo(windmin) - 6 ;
      Clrscr ;

      REPEAT {until done }
        resource(reserve,_CRT)       ;
        write('Enter Filename to List:');
        resource(rlse,_CRT)          ;
        Readln(Message)              ;
        Message := 'Open '+Message   ;  { create Open file command  }
        Send('ListMail',@Message)    ;  { Send command to mailbox   }
        Receive('ListMail',strptr)   ;  { wait for message reply    }
        if integer(strptr^) = 0
         then done := true
         else done := false ;
      UNTIL  done = true    ;
      LineNr := 1            ;
      LastLineNr := maxint   ;
      NrtoShow   := pagesize ;
      resource(reserve,_CRT) ;
      clrscr                 ;
      gotoxy((lo(windmax)-lo(windmin))shr 1-7,
             (hi(windmax)-hi(windmin))shr 1) ;
      writeln( '<pgup><pgdn><'#24#25'>') ;
      gotoxy(1,1)                        ;
      resource(rlse,_CRT) ;

      REPEAT
        key := byte(readkey) ;
        if key = 0 then key := 128 + byte(readkey) ;
        case key of

         uparr   : begin
                   dec(LineNr,1)        ;
                   Nrtoshow := 1        ;
                   end                  ;
         dnarr   : begin
                   inc(LineNr)          ;
                   Nrtoshow := 1        ;
                   end                  ;
         pgup    : begin
                   dec(LineNr,pagesize) ;
                   Nrtoshow := pagesize ;
                   end                  ;
         pgdn    : begin
                   inc(LineNr,pagesize) ;
                   NrtoShow := pagesize ;
                   end                  ;
         ctlPgup,
         ctlHome : begin
                   LineNr := 1          ;
                   Nrtoshow := 1        ;
                   end                  ;
         ctlpgdn,
         ctlEnd  : begin
                   LineNr := maxint     ;
                   Nrtoshow := 1        ;
                   end                  ;
         esc     :                      ;
         else      key := 0             ;
       end {case}                       ;

       if key <> 0 then begin
         if LineNr > LastLineNr then LineNr := LastLineNr - 1;
         if LineNr < 1 then LineNr := 1 ;
         if LineNr-1+Nrtoshow > LastLineNr then
            Nrtoshow := LastLineNr-LineNr+1 ;
         for i := LineNr to LineNr-1+Nrtoshow do
           begin
           str(i,Message) ;
           Message := 'Read '+Message      ;
           Strptr  := @Message             ;
           Send('ListMail',Strptr)         ; { Send readfile to mailbox }
           Receive('ListMail',strptr)      ; { wait for message reply   }
                                             { Strptr := FLgetNr(i) ;   }
           if Strptr <> nil then begin
            if string(Strptr^)[1] = #26 then
               val(copy(string(Strptr^),2,5),LastLineNr,result) ;
            if byte(Strptr^) > textwidth     { truncate string &  write }
               then byte(Strptr^) := textwidth ;
            if string(strptr^)[length(string(strptr^))-1] = ^M
              then dec(string(strptr^)[0],2)     ;
            resource(reserve,_crt)       ;
            writeln(i:3,string(Strptr^)) ;
            resource(rlse,_crt)          ;
            end                          ;

           if (Strptr = nil) then            { an error has occured     }
              LastLineNr := 1 ;
          end {for..}                  ;
       end {if key..}                  ;
     UNTIL key = esc ;
                                         { FLclose('test.dat') ;}
      Message := 'Close sr50.pas'  ;
      Send('ListMail',@Message)    ;  { Send open file to mailbox }
      Receive('ListMail',strptr)   ;  { wait for message reply   }

     End {while True} ;
    End {ListTask} ;
  {────────────────────────────────────────────────────────────────}
  {                  List Send/Receive task                        }
  {────────────────────────────────────────────────────────────────}
  {   Execute commands from 'ListMail' box and send back results   }
  {────────────────────────────────────────────────────────────────}
   Procedure ListCmds ;
    var
     Strptr : pointer   ;
     result : integer   ;
     lineNr : word      ;
     Cmdstr : string[5] ;

    Begin

    While true do begin {forever}


     REPEAT
       { loop until Mailbox is created and a message is waiting }
       Receive('ListMail',Strptr) ;
       if Strptr = nil then yield      ;
     UNTIL Strptr <> nil               ;


     Cmdstr := copy(string(Strptr^),1,pos(' ',string(Strptr^))-1) ;
     Caps(Cmdstr) ;

     If Cmdstr = 'OPEN'  then begin
       result := FLopen(copy(string(Strptr^),6,sizeof(Filenamestr)-1)) ;
       Send('ListMail',@result) ;
       end {if..open} ;

     If Cmdstr = 'CLOSE' then begin
       FLclose(copy(string(Strptr^),7,sizeof(Filenamestr)-1)) ;
       result := 0                   ;
       Send('ListMail',@result) ;
       end {if..close} ;

     If CmdStr = 'READ' then begin
 {$R-} val(copy(string(Strptr^),6,5),lineNr,result) ; {$R+}
       if result <>0 then Strptr := nil
         else  FLgetNr(lineNr,string(Strptr^)) ;   { get data string or  }
       Send('ListMail',Strptr)        ;   { nil if end of file  }
       end {if..read}                 ;

    end {while..forever} ;
   End {ListSR} ;
  {────────────────────────────────────────────────────────────────}
  {                         Main                                   }
  {────────────────────────────────────────────────────────────────}
  begin {main}

    { Debug should be false to allow SR to go resident   }
    { else it runs as a normal (if that's the word) task }

    SR50.Debug := false ;  { turn off/on debugging }
    if paramstr(1) = 'debug' then SR50.Debug := true ;

    writeln ;
    writeln(RUTidBlk.RUTidStr, ' is active'    ) ;
    writeln;
    writeln( '<AltD> toggles a directory list' ) ;
    writeln( '<AltL> toggles a program list'   ) ;
    writeln;
    writeln('"DEMO quit" will terminate the demonstation')        ;
    writeln;
    writeln( ' copyright (c) 1988 Lane Ferris '       )        ;
    writeln( '      The Hunters'' Helper'             )        ;
    writeln ;

    Attr := textattr or $08 ;               ; { bright clock color    }

    Attach(@Clock,TimerType,18,NIL,'CLOCK') ; { Add Clock as a task   }

    Attach(@DirTask,KeyType,AltD,             { Add ShowDir task      }
                        @DirPop,'DIRPOP')   ;
    Attach(@ListTask,KeyType,AltL,            { Add List Display task }
                      @ListPop,'LISTPOP')   ;
    Attach(@ListCmds,TimerType,1,             { Add File Read task    }
                          NIL,'LISTCMDS')   ;
    StartTSR                                ; { jump to TSR code      }
                                              { never to return here  }
  end.  {main}

      (**)FREEZE;NMI;(**)