home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / PNL010.ZIP / MDP8.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-29  |  4.6 KB  |  165 lines
  1. program mdp8;
  2.  
  3. {This program performs exactly the same functions as mdp7.pas, except that }
  4. {it allows the use of the cursor keys, PgUp, PgDn, Home, End, ESC, etc.,   }
  5. {plus it allows you to specify a line number to jump to, by pressing #.    }
  6. {Note that while the functionality is similar, it has been moderately re-  }
  7. {written.                                                                  }
  8.  
  9. {$G+,R-,S-,N+,M 16384,0,0}
  10.  
  11. uses Test186, crt,Textutl2, DosMem, BigArray;
  12.  
  13. const TBuffSize = 20; {k}
  14.       ScreenLen = 24;
  15.       LineCount:word = 0;
  16.       WinTop:longint = 1;
  17.  
  18. type TBuffPtr  = ^TBuffType;
  19.      TBuffType = array [1..TBuffSize*1024] of byte; {20k text buffer}
  20.  
  21. var LineBank:BigDOSArray;
  22.     TBuff:TBuffPtr;
  23.     LinePtr:^longint;
  24.     Loop,LNum:word;
  25.     f:text;
  26.  
  27.   function Min (a,b:word):word;
  28.  
  29.   begin
  30.     if a < b then Min := a else Min := b;
  31.   end;
  32.  
  33.   procedure PrLn (var s:string);
  34.  
  35.   begin
  36.     write (copy (s,1,79));
  37.     if length (s) < 79 then write (' ':79-length(s));
  38.     writeln;
  39.   end;
  40.  
  41.   procedure ReadFile;
  42.  
  43.   var MaxLines:longint;
  44.       FSize:longint;
  45.       FPos:longint;
  46.  
  47.   begin
  48.     {Set up text buffer}
  49.     TBuff := ptr (DosMem.Alloc (TBuffSize * 64),0); { * 64 turns K into paras}
  50.     {Initialise the line arrays}
  51.     with linebank do begin
  52.       SetElemSize (sizeof (longint));
  53.       MaxLines := GetMaxSize;
  54.       writeln ('There''s room for ',MaxLines,' lines in memory.');
  55.       Init (MaxLines);
  56.     end;
  57.     writeln ('Please wait while the file is read...');
  58.     assign (f,paramstr (1)); SetTextBuf (f,TBuff^); reset (f);
  59.     FSize := TextFileSize (f);
  60.     while not (eof (f) or (LineCount = MaxLines)) do begin
  61.       inc (LineCount);
  62.       write (LineCount);
  63.       LinePtr := LineBank.Elem (LineCount);
  64.       FPos := TextFilePos (f);
  65.       if lo (LineCount) = 0 then write ('  ',FPos * 100 div FSize,'%');
  66.       write (#13);
  67.       LinePtr^ := FPos;
  68.       readln (f);
  69.     end;
  70.     clreol; writeln;
  71.   end;
  72.  
  73.   procedure ShowFromLine (var line:longint);
  74.  
  75.   var LinePtr:^longint;
  76.       Buffer:string;
  77.  
  78.   begin
  79.     gotoxy (1,1);
  80.     LinePtr := LineBank.Elem (line);
  81.     TextSeek (f,LinePtr^);
  82.     for loop := 1 to min (ScreenLen,LineCount-WinTop+1) do begin
  83.       readln (f,buffer);
  84.       prLn (buffer);
  85.     end;
  86.     write ('            Use keypad to manoeuvre, ''ESC'' to quit, ''#'' to jump.'#13);
  87.     write (WinTop:5,'/',LineCount,#13);
  88.   end;
  89.  
  90.   procedure showfile;
  91.  
  92.   var quit,moved,extended:boolean;
  93.       ch:char;
  94.       LSL:longint; {last screen line}
  95.  
  96.   begin
  97.     quit := false; lsl := LineCount - ScreenLen; moved := true;
  98.     repeat
  99.       if moved then ShowFromLine (WinTop);
  100.       ch := readkey;
  101.       extended := ch = #0; {was it a function key?}
  102.       if extended then begin {yes}
  103.         ch := readkey; {get the scan code}
  104.         moved := false;
  105.         {When the scan code is treated as a char, it APPEARS to be a letter}
  106.         {This is why the case below uses letters to identify the key.      }
  107.         case ch of
  108.           'H':if WinTop > 1 then begin {H is the up arrow}
  109.                 dec (WinTop);
  110.                 moved := true;
  111.               end;
  112.           'P':if WinTop < lsl+1 then begin {P is the down arrow}
  113.                 inc (WinTop);
  114.                 moved := true;
  115.               end;
  116.           'I':if WinTop > 1 then begin {I is the PgUp key}
  117.                 dec (WinTop,ScreenLen-1);
  118.                 if WinTop < 1 then WinTop := 1;
  119.                 moved := true;
  120.               end;
  121.           'Q':if WinTop < lsl then begin {Q is the PgDn key}
  122.                 inc (WinTop,ScreenLen-1);
  123.                 if WinTop >= lsl then WinTop := lsl+1;
  124.                 moved := true;
  125.               end;
  126.            'G':if WinTop > 1 then begin {G is the Home key}
  127.                  WinTop := 1;
  128.                  moved := true;
  129.                end;
  130.            'O':if WinTop < LSL+1 then begin {O is the End key}
  131.                  WinTop := LSL+1;
  132.                  moved := true;
  133.                end;
  134.           else write (#7);
  135.         end;
  136.       end else case ch of
  137.         '#':begin
  138.               ClrEol; {clears this line}
  139.               write ('Move to what line? (1-',LSL+1,'): ');
  140.               readln (WinTop);
  141.               moved := true;
  142.             end;
  143.         #27:quit := true;
  144.         else write (#7);
  145.       end;
  146.     until quit;
  147.   end;
  148.  
  149. begin
  150.   clrscr;
  151.   ReadFile;
  152.   if Linecount = 0 then begin
  153.     writeln ('File is empty.');
  154.     close (f);
  155.     DosMem.Free (seg(TBuff^)); {not really needed, but here for looks.}
  156.     LineBank.Done;
  157.     halt;
  158.   end;
  159.   ShowFile;
  160.   close (f);
  161.   DosMem.Free (seg(TBuff^));
  162.   LineBank.Done;
  163. end.
  164.  
  165.