Path: utzoo!attcan!uunet!lll-winken!elroy.jpl.nasa.gov!jarthur!ucivax!gateway
From: jduarte@BONNIE.ICS.UCI.EDU (J o s e D u a r t e !!!)
Newsgroups: comp.lang.pascal
Subject: (none)
Message-ID: <9007271154.aa01160@BONNIE.ICS.UCI.EDU>
Date: 27 Jul 90 18:59:43 GMT
Lines: 547

------------------------------------------------------
*                 Pop-Up Windows UNIT                *
------------------------------------------------------

This is a TP 5.0 UNIT which helps me to do pop-up
window interfaces for my PC applications...


It is designed to be used only with 100% IBM PC
compatible *CGA* monitors & it does have some flaws...


1. If there is NO more heap memory available, then
   a run-time error is generated.

2. I re-coded the ClrScr function especially for my
   CGA to stop it from flickering...It *was* flickering
   whenever I used Borland's ClrScr routine.


3. Have fun...There are NO comments in it & it's
   probably a software engineer's nightmare, but "it
   works for me."

4. Someone asked about how a highlighting menu system is
   programmed...So I have also included a small demo
   program which uses my W unit to show how a programmer
   can create *totally awesome* user-interfaces with the
   W unit.


5. If you write a pratical application w/my unit, I would
   be interested in a copy !!!


6. Whenever you write an application using this unit, it
   automatically saves the current screen...so make sure that
   you have allocated enough heap memory for your application
   using {$M ... } directives.


7. Please...NO FLAMES.


Thanks,

Jose Duarte

-------------- CUT HERE ------------------------------

UNIT W;

{$R-,D-,A-,S+,I-,F-,O-,V-,B-,L-}



interface



type

  ScreenPointer = ^Screen;

  Screen = record
    P        : Pointer;
    SX1,
    SY1,
    SX2,
    SY2,
    X,
    Y,
    Attr     : Byte;
    WinMin,
    WinMax,
    HeapSize : Word;
    Next     : ScreenPointer;
  end;

  ScreenString = string[80];





var
  Break     : Boolean;
  Original,
  Head      : ScreenPointer;



{ ------------------------------------------------------------- }

Procedure HideCursor;

Procedure ShowCursor;

Procedure MediumCursor;

Procedure BigCursor;

Procedure Box(x1,y1,x2,y2: Byte; fg,bg: Byte);

Procedure Header(Message: ScreenString; fg,bg: Byte);

Procedure SaveScreen(X1,Y1,X2,Y2: Byte);

Procedure ReturnScreen(var Head : ScreenPointer);

Procedure OriginalScreen;

Procedure ClrScr;




implementation


USES CRT,DOS;

{ ------------------------------------------------------------- }

Procedure ClrScr;

var
  X1, Y1, X2, Y2, I  : Byte;
  It, J              : Word;

begin
  x1 := Lo(WindMin);
  y1 := Hi(WindMin);
  x2 := Lo(WindMax);
  y2 := Hi(WindMax);
  It := ((TextAttr Shl 8) + 32);
  For I := Y1 to Y2 do
     For J := ((I * 80) + X1) to ((I*80) + X2) do
        MemW[47104:J Shl 1] := It;
  GotoXY(1,1);
end;


{ ------------------------------------------------------------- }

Procedure Box(x1,y1,x2,y2 : Byte; fg,bg : Byte );

var i      : Byte;

begin
  TextAttr := bg * 17;
  Window(x1,y1,x2,y2);
  W.ClrScr;
  TextAttr := fg + (bg Shl 4);
  for i := (x1+1) to (x2-1) do
     begin
       MemW[47104:(((y1-1) * 80 + (i-1)) shl 1)] := TextAttr Shl 8 + 196;
       MemW[47104:(((y2-1) * 80 + (i-1)) shl 1)] := TextAttr Shl 8 + 196;
     end;
  for i := (y1+1) to (y2-1) do
     begin
       MemW[47104:(((i-1) * 80 + (x1-1)) shl 1)] := TextAttr Shl 8 + 179;
       MemW[47104:(((i-1) * 80 + (x2-1)) shl 1)] := TextAttr Shl 8 + 179;
     end;
  MemW[47104:(((y1-1) * 80 + (x1-1)) shl 1)] := TextAttr Shl 8 + 218;
  MemW[47104:(((y1-1) * 80 + (x2-1)) shl 1)] := TextAttr Shl 8 + 191;
  MemW[47104:(((y2-1) * 80 + (x1-1)) shl 1)] := TextAttr Shl 8 + 192;
  MemW[47104:(((y2-1) * 80 + (x2-1)) shl 1)] := TextAttr Shl 8 + 217;
  Window(x1+2,y1+1,x2-2,y2-1);
  HideCursor;
end;

{ ------------------------------------------------------------- }

Procedure ShowCursor;

var Regs: Registers;

begin
  With Regs do
     begin
       AX := $0100;
       CX := 1543;
       Intr($10,Regs);
     end;
end;

{ ------------------------------------------------------------- }

Procedure MediumCursor;

var Regs: Registers;

begin
  With Regs do
    begin
      AX := $0100;
      CX := 1031;
      Intr($10,Regs);
    end;
end;

{ ------------------------------------------------------------- }

Procedure BigCursor;

var Regs: Registers;

begin
  With Regs do
    begin
      AX := $0100;
      CX := 7;
      Intr($10,Regs);
    end;
end;

{ ------------------------------------------------------------- }

Procedure HideCursor;

var Regs: Registers;

begin
  With Regs do
    begin
      AX := $0100;
      CX := 2055;
      Intr($10,Regs);
    end;
end;

{ ------------------------------------------------------------- }

Procedure Header(Message: ScreenString; fg,bg: Byte);

var
  SavedAttr,
  Position,
  SaveX,
  SaveY     : Byte;
  SavedMax,
  SavedMin  : Word;

begin
  SavedAttr := TextAttr;
  SavedMax  := WindMax;
  SavedMin  := WindMin;
  SaveX := WhereX;
  SaveY := WhereY;
  Window(Lo(WindMin)-1,Hi(WindMin),Lo(WindMax)+3,Hi(WindMax)+2);
  TextAttr := fg + (bg Shl 4);
  Position := (((Lo(WindMax) - Lo(WindMin)) DIV 2) - (Length(Message) DIV 2));
  GotoXY(Position+1,1);
  Write(' ',Message,' ');
  WindMax := SavedMax;
  WindMin := SavedMin;
  GotoXY(SaveX,SaveY);
  TextAttr := SavedAttr;
end;

{ ------------------------------------------------------------- }

procedure Create_Buffer(var P: pointer; Size: Word);

begin
  If (MaxAvail < (Size + 512)) then
    begin
      TextAttr := 0;
      W.ClrScr;
      TextAttr := White;
      Writeln('WINDOS UNIT run-time error : not enough heap memory to continue.');
      Writeln;
      Halt(1);
    end
  else
    GetMem(P,Size);
end;

{ ------------------------------------------------------------- }

Procedure SaveScreen(X1,Y1,X2,Y2: Byte);

var
  I           : Byte;
  J,
  ArrayIndex,
  Size        : Word;

  Buffer      : array[1..2000] of Word;

  P           : ScreenPointer;


begin
  New(P);
  P^.Next := nil;
  If (Head = nil) Then Head := P
    else begin
      P^.Next := Head;
      Head    := P;
    end;
  Size := (((X2-X1)+1) * ((Y2-Y1)+1) * 2);
  With P^ do
    begin
      Create_Buffer(P,Size);
      X        := WhereX;
      Y        := WhereY;
      Attr     := TextAttr;
      WinMin   := WindMin;
      WinMax   := WindMax;
      HeapSize := Size;
      SX1      := X1;
      SY1      := Y1;
      SX2      := X2;
      SY2      := Y2;
    end;
  ArrayIndex := 0;
  For I := (Y1-1) to (Y2-1) do
    For J := ((I * 80) + (X1-1)) to ((I * 80) + (X2-1)) do
       begin
         Inc(ArrayIndex);
         Buffer[ArrayIndex] := MemW[47104:J shl 1];
       end;
  Move(Buffer,Head^.P^,Size);
end;

{ ------------------------------------------------------------- }

Procedure ReturnScreen;

var
  Buffer   : array[1..2000] of Word;

  I        : Byte;

  J,
  Index    : Word;

  Temp     : ScreenPointer;


begin
  If (Head = nil) then exit;
  With Head^ do
    begin
      WindMin := WinMin;
      WindMax := WinMax;
      TextAttr := Attr;
      GotoXY(X,Y);
    end;
  Move(Head^.P^,Buffer,Head^.HeapSize);
  index := 0;
  For I := (Head^.SY1-1) to (Head^.SY2-1) do
     For J := ((I * 80) + (Head^.SX1-1)) to ((I * 80) + (Head^.SX2-1)) do
        begin
          Inc(index);
          MemW[47104:J shl 1] := Buffer[index];
        end;
  FreeMem(Head^.P,Head^.HeapSize);
  Temp := Head;
  Head := Head^.Next;
  Dispose(Temp);
  HideCursor;
end;


{ ------------------------------------------------------------- }

Procedure OriginalScreen;

begin
  ReturnScreen(Original);
  ShowCursor;
  CheckBreak := Break;
  Release (HeapOrg);
end;


{ ------------------------------------------------------------- }

begin
  Break := CheckBreak;
  CheckBreak := False;
  Head := nil;
  SaveScreen(1,1,80,25);
  Original := Head;
end.



{
------------------------------------------------------
--                   SAMPLE APPLICATION             --
------------------------------------------------------
}



{$M 8000,16000,16000}
Program Games_Menu;
uses CRT,DOS,W;

var
  P: BYTE;
 Ch: CHAR;

const
   O1  = ' Qubert                ';
   O2  = ' Bugs !!!              ';
   O3  = ' Centipede             ';
   O4  = ' Tic-Tac-Toe           ';
   O5  = ' Digger                ';
   O6  = ' 3D Tic-Tac-Toe        ';
   O7  = ' Piano Music           ';
   O8  = ' Pac-Worm              ';
   O9  = ' Mexican Hatdance      ';
   O10 = ' William Tell Overture ';

   Home       = #71;
   UpArrow    = #72;
   PgUp       = #73;
   LeftArrow  = #75;
   RightArrow = #77;
   EndKey     = #79;
   Down       = #80;
   PgDn       = #81;
   Esc        = #27;

   GoodSet = [#71,#72,#73,#79,#80,#81,#27,#32,#13];



{ ---------------------------------------------------- }
procedure Init;

begin
   TextMode(CO80);
   ReturnScreen(Head);
   SaveScreen(1,1,80,25);
   Box(10,5,37,18,BLUE,LIGHTGRAY);
   Header('[Games]',WHITE,RED);
   Writeln;
   TextAttr := 79;
   Writeln(O1);
   TextAttr := 113;
   Writeln(O2);
   Writeln(O3);
   Writeln(O4);
   Writeln(O5);
   Writeln(O6);
   Writeln(O7);
   Writeln(O8);
   Writeln(O9);
   Writeln(O10);
   P := 1;
end;


{ ---------------------------------------------------- }
procedure Execute_It;

var
  X: STRING;

begin
   case P of
     1 : X := 'QUBERT.EXE';
     2 : X := 'BUGS.EXE';
     3 : X := 'CTP.EXE';
     4 : X := 'BASIC TTT.BAS';
     5 : X := 'DIGGER.COM';
     6 : X := 'BASIC 3DTTT.BAS';
     7 : X := 'BASIC MUSIC.BAS';
     8 : X := 'BASIC PACWORM.BAS';
     9 : X := 'BASIC HATDANCE.BAS';
    10 : X := 'BASIC HUANGS.BAS';
   end;
   SwapVectors;
   TextMode(CO80);
   TextAttr := 14;
   Writeln('Running '+X);
   TextAttr := WHITE;
   {$I-}
   Exec(GetEnv('COMSPEC'), '/C'+X);
   {$I+}
   SwapVectors;
end;


{ ---------------------------------------------------- }
Procedure Print_Option(P: BYTE);

begin
  Case P of
       1 :   Writeln(O1);
       2 :   Writeln(O2);
       3 :   Writeln(O3);
       4 :   Writeln(O4);
       5 :   Writeln(O5);
       6 :   Writeln(O6);
       7 :   Writeln(O7);
       8 :   Writeln(O8);
       9 :   Writeln(O9);
      10 :   Writeln(O10);
  end;
end;


{ ---------------------------------------------------- }
begin
   Init;
   repeat
      repeat
           Ch := ReadKey;
           If (Ch = #0) then Ch := ReadKey;
      until Ch IN GoodSet;
      GotoXY(1,P+1);
      TextAttr := 113;
      Print_Option(P);
      case Ch of
         #32,
         Down       : If (P = 10) then
                         P := 1
                      else
                         Inc(P);
         PgUp,
         Home       : P := 1;
         PgDn,
         EndKey     : P := 10;
         UpArrow    : If (P = 1) then
                         P := 10
                      else
                         Dec(P);
      end; { case }
      GotoXY(1,P+1);
      TextAttr := 79;
      Print_Option(P);
      If (Ch = #13) then
         begin
            Execute_It;
            Init;
         end;
   until (Ch = Esc);
   ReturnScreen(Head);
   ShowCursor;
end.