ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/BONUS507.ZIP/PSCREEN.ARC/PSCREEN.PAS

Pascal/Delphi Source File | 1988-12-13 | 12.9 KB | 477 lines

{$S-,R-,V-,I-,B-,F-}
{$M 4096,0,20000}

{*********************************************************}
{*                  PSCREEN.PAS 5.02                     *}
{*        Copyright (c) TurboPower Software 1988.        *}
{*                 All rights reserved.                  *}
{*********************************************************}

program PackedScreenUtility;
  {-Utility for saving and displaying packed windows}

uses
  Dos, TpCrt, TpString, TpEdit, TpTsr;

type
  String64 = string[64];
const
  ModuleName : string[7] = 'PSCREEN'; {module name for standard interface}
  OurHotKey : Word = $0619;  {Ctrl + LeftShift, 'P'}
  ProgName : string[64] = 'PSCREEN 5.02: A Utility for Saving and Displaying Packed Screens';
  Copyright : string[41] = 'Copyright (c) 1988 by TurboPower Software';
  LoadError : string[25] = 'Unable to install PSCREEN';
  Disable   : Boolean = False;
var
  PWP : PackedWindowPtr;
  MainBufPtr : Pointer;
  Bright,                    {video attributes}
  Dim,
  Border,
  Reverse : Byte;
  MaxRows : Word;
  MaxCols : Word;
  MaxParas : Word;           {maximum space needed for saving the screen}

  procedure SetAttributes;
    {-Set the attributes to be used based on the current video mode}
  begin
    case CurrentMode of
     0,                      {BW40}
     2,                      {BW80}
     7 :                     {monochrome}
       begin
         Bright := $F;
         Border := $F;
         Dim := $7;
         Reverse := $70;
        end;
    else                     {color}
     begin
      Bright := $1F;
      Border := $1A;
      Dim := $1B;
      Reverse := $21;
     end;
    end;
    TextAttr := Dim;
  end;

  {$F+}
  function GetKey : Word;
    {-Routine to return next keystroke}
  var
    ChWord : Word;
  begin
    ChWord := ReadKeyWord;
    {check for Alt-U}
    if ChWord = $1600 then begin
      {translate to ESC and set flag to disable the TSR}
      ChWord := $001B;
      Disable := True;
    end;
    GetKey := ChWord;
  end;
  {$F-}

  function GetFileName(var FName : String64) : Boolean;
    {-Prompt for a file name}
  const
    Prompt = 'File to write: ';
  var
    Escaped : Boolean;
  begin
    ForceUpper := True;
    EditSize := ScreenWidth-(Length(Prompt)+4);
    ReadString(Prompt, 2, 3, 64, Bright, Dim, Dim, Escaped, FName);

    GetFileName := (Length(FName) <> 0) and not Escaped;
  end;

  procedure ErrorMessage(Msg : String);
    {-Display an error message and wait for a keypress}
  const
    PressAnyKey = '. Press any key...';
  begin
    if Length(Msg)+Length(PressAnyKey)+4 <= ScreenWidth then
      Msg := Msg+PressAnyKey;
    FastWrite(Pad(Msg, ScreenWidth-4), 2, 3, Bright);
    if ReadKeyWord = 0 then {};
  end;

  {$F+}
  procedure PopupEntryPoint(var Regs : Registers);
    {-This is the entry point for the popup}
  type
    VideoWord =
      record
        Ch : Char; Attr : Byte;
      end;
    ScreenType = array[1..50, 1..80] of VideoWord; {50 rows * 80 columns}
  const
    FName : String64 = '';
  var
    ScreenPtr : ^ScreenType;
    ScreenBufPtr : ^ScreenType absolute MainBufPtr;
    SaveXY, SaveSL : Word;   {for storing cursor position and shape}
    CurRow, CurCol,          {current cursor coordinates}
    StartRow, StartCol,      {start of marked block}
    Row, Cols, I : Byte;
    ChWord : Word;
    Ch : Char absolute ChWord;
    Highlight,               {true if initial point has been marked}
    WinSelected : Boolean;   {true after window was selected}
    NewRow : Word;

    procedure MarkBlock(TopRow, BotRow, LeftCol, RightCol : Byte);
      {-Mark the specified block}
    var
      Row, Cols : Word;
    begin
      Cols := Succ(RightCol-LeftCol);
      for Row := TopRow to BotRow do
        ChangeAttribute(Cols, Row, LeftCol, Reverse);
    end;

    procedure RestoreBlock(TopRow, BotRow, LeftCol, RightCol : Byte);
      {-Unmark the specified block}
    var
      Row, Cols : Word;
    begin
      Cols := Succ(RightCol-LeftCol);
      for Row := TopRow to BotRow do
        MoveScreen(ScreenBufPtr^[Row, LeftCol], ScreenPtr^[Row, LeftCol], Cols);
    end;

    procedure IncRow(N : Word);
      {-Move the cursor N rows down}
    var
      I : Word;
    begin
      for I := 1 to N do begin
        {make sure we don't go too far down}
        if CurRow = ScreenHeight then
          Exit;

        Inc(CurRow);
        if Highlight then
          if (CurRow > StartRow) and (CurCol >= StartCol) then
            MarkBlock(Pred(CurRow), CurRow, StartCol, CurCol);
      end;
    end;

    procedure DecRow(N : Integer);
      {-Move the cursor N rows up}
    var
      OldRow, I : Word;
    begin
      for I := 1 to N do begin
        {make sure we don't go too far up}
        if CurRow = 1 then
          Exit;

        OldRow := CurRow;
        Dec(CurRow);
        if Highlight then
          if (OldRow > StartRow) and (CurCol >= StartCol) then
            RestoreBlock(OldRow, OldRow, StartCol, CurCol);
      end;
    end;

    procedure IncCol(N : Word);
      {-Move the cursor N columns to the right}
    var
      I : Word;
    begin
      for I := 1 to N do begin
        {make sure we don't go too far right}
        if CurCol = ScreenWidth then
          Exit;

        Inc(CurCol);
        if Highlight then
          if (CurCol > StartCol) and (CurCol >= StartCol) then
            MarkBlock(StartRow, CurRow, Pred(CurCol), CurCol);
      end;
    end;

    procedure DecCol(N : Word);
      {-Move the cursor N columns to the left}
    var
      OldCol, I : Word;
    begin
      for I := 1 to N do begin
        {make sure we don't go too far left}
        if CurCol = 1 then
          Exit;

        OldCol := CurCol;
        Dec(CurCol);
        if Highlight then
          if (OldCol > StartCol) and (CurCol >= StartCol) then
            RestoreBlock(StartRow, CurRow, OldCol, OldCol);
      end;
    end;

    procedure TabRight;
      {-Moves the cursor to the next tab stop}
    var
      NewCol : Word;
    begin
      if CurCol < ScreenWidth then begin
        NewCol := Succ(Succ(Pred(CurCol) shr 3) shl 3); {shr 3 = div 8}
        IncCol(NewCol-CurCol);
      end;
    end;

    procedure TabLeft;
      {-Moves the cursor back to the last tab stop}
    var
      NewCol : Word;
    begin
      NewCol := CurCol;
      if (Pred(NewCol) and 7) = 0 then
        if NewCol > 8 then
          Dec(NewCol, 8)
        else
          NewCol := 1
      else
        NewCol := Succ(Pred(NewCol) and $F8);
      DecCol(CurCol-NewCol);
    end;

    procedure DrawOurWindow;
      {-Draw our window}
    begin
      Window(1, 1, ScreenWidth, 3);
      ClrScr;
      FrameWindow(1, 1, ScreenWidth, 3, Border, Reverse, ' PSCREEN 5.02 ');
    end;

    procedure RestoreWholeScreen;
      {-Restore the whole screen}
    begin
      RestoreWindow(1, 1, ScreenWidth, ScreenHeight, False, MainBufPtr);
    end;

  begin
    {re-initialize CRT}
    ReInitCrt;

    if InTextMode and (ScreenWidth <= MaxCols) and (ScreenHeight <= MaxRows) then begin
      {initialize screen stuff}
      SetAttributes;
      GetCursorState(SaveXY, SaveSL);

      {save the screen}
      if SaveWindow(1, 1, ScreenWidth, ScreenHeight, False, MainBufPtr) then
        {can't fail};
      ScreenPtr := Ptr(VideoSegment, 0);

      WinSelected := False;  {Window is not selected now}
      Highlight := False;
      CurCol := WherexAbs;   {Get cursor pos to start with}
      CurRow := WhereyAbs;
      BlockCursor;

      repeat
        {Move to position}
        GotoxyAbs(CurCol, CurRow);
        ChWord := GetKey;
        if Ch = #0 then
          case Hi(ChWord) of
            72 :             {Up}
              DecRow(1);
            80 :             {Down}
              IncRow(1);
            75 :             {Left}
              DecCol(1);
            77 :             {Right}
              IncCol(1);
            115,             {^Left}
            15 :             {Shift-Tab}
              TabLeft;
            116 :            {^Right}
              TabRight;
            119,             {^Home}
            132 :            {^PgUp}
              DecRow(Pred(ScreenHeight));
            117,             {^End}
            118 :            {^PgDn}
              IncRow(Pred(ScreenHeight));
            73 :             {PgUp}
              begin
                NewRow := CurRow;
                if (CurRow mod 5) = 0 then
                  Dec(NewRow, 5)
                else
                  Dec(NewRow, CurRow mod 5);
                DecRow(CurRow-NewRow);
              end;
            81 :             {PgDn}
              begin
                NewRow := Succ(CurRow div 5)*5;
                IncRow(NewRow-CurRow);
              end;
            71 :             {Home}
              DecCol(ScreenWidth);
            79 :             {End}
              IncCol(ScreenWidth);
          end
        else
          case Ch of
            ^H :             {BkSp}
              DecCol(1);
            ' ' :            {space}
              IncCol(1);
            ^I :             {Tab}
              TabRight;
            #27 :            {Esc}
              begin
                Highlight := False;
                WinSelected := True;
              end;
            ^M :             {Enter}
              if not Highlight then begin
                {save starting point}
                StartCol := CurCol;
                StartRow := CurRow;
                Highlight := True;

                {change attribute to reverse video at cursor}
                ChangeAttribute(1, CurRow, CurCol, Reverse);
              end
              else
                WinSelected := True;
          end;
      until WinSelected;

      if Highlight then
        {draw our window}
        DrawOurWindow;

      {get name of file to save screen in}
      if Highlight and GetFileName(FName) then begin
        {restore the screen}
        RestoreWholeScreen;

        {save the packed window}
        PWP := PackWindow(StartCol, StartRow, CurCol, CurRow);
        if PWP <> nil then begin
          {try to write the packed window to disk}
          WritePackedWindow(PWP, FName);
          if CrtError <> 0 then begin
            DrawOurWindow;
            ErrorMessage('Error while writing packed window to disk');
            RestoreWholeScreen;
          end;

          {dispose of the packed window}
          DisposePackedWindow(PWP);
        end;
      end
      else begin
        {restore the screen}
        RestoreWholeScreen;

        {try to disable TSR if requested}
        if Disable then
          if not DisableTSR then begin
            Disable := False;
            Write(^G);
          end;
      end;

      {restore cursor state}
      RestoreCursorState(SaveXY, SaveSL);
    end
    else
      Write(^G);
  end;
  {$F-}

  procedure Abort(Msg : string);
    {-Display an error message and halt}
  begin
    WriteLn(Msg);
    Halt(1);
  end;

  procedure Initialize;
    {-Initialize and check for command line parameters}
  var
    PWP : PackedWindowPtr;
    FName : String64;
  begin
    {initialize}
    EditKeyPtr := @GetKey;

    {resident mode if no parameters specified}
    if ParamCount = 0 then
      Exit;

    {get the filename and display it}
    FName := ParamStr(1);
    PWP := ReadPackedWindow(FName);
    if PWP = nil then
      Abort('Error reading '+FName);
    DispPackedWindow(PWP);
    Halt;
  end;

begin
  {see if there is a file to display}
  Initialize;

  {signon message}
  HighVideo;
  WriteLn(^M^J, ProgName, ^M^J, Copyright, ^M^J);
  LowVideo;

  {check to see if SideKick is loaded}
  if SideKickLoaded then
    Abort('Can''t be loaded after SideKick!');

  {check to see if we're already installed}
  if ModuleInstalled(ModuleName) then
    Abort('PSCREEN is already loaded. Aborting...');

  {install the module}
  InstallModule(ModuleName, nil);

  {go resident}
  if DefinePop(OurHotKey, @PopupEntryPoint, Ptr(SSeg, SPtr), True) then begin
    WriteLn('PSCREEN loaded. Press Ctrl-LeftShift-P to activate.');

    {Enable popups}
    PopupsOn;

    {$IFDEF Ver40}
    {restore INT $1B, captured by TPCRT}
    SetIntVec($1B, SaveInt1B);
    {$ENDIF}

    {calculate amount of heap space to set aside}
    case EnhancedDisplay of
      EGA : MaxRows := 43;
      VGA : MaxRows := 50;
      else MaxRows := 25;
    end;
    if ScreenWidth > 80 then
      MaxCols := ScreenWidth
    else
      MaxCols := 80;
    MaxParas := (MaxRows*MaxCols*2)+(SizeOf(PackedWindow)-SizeOf(PackedScreen));
    MaxParas := (MaxParas+$F) div 16;

    {allocate main screen buffer}
    GetMem(MainBufPtr, MaxRows*MaxCols*2);

    {terminate and stay resident}
    if not TerminateAndStayResident(ParagraphsToKeep+MaxParas, 0) then {} ;
  end;

  {if we get here we failed}
  Abort(LoadError);
end.