home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / turbopas / pstui100.zip / PTUIAPP.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-18  |  4KB  |  208 lines
  1. {
  2.  
  3.                                                       ╔══════════════════╗
  4.                                                       ║    PTUI Apps     ║
  5.                                                       ║     Inlcude      ║
  6.                                                       ║    Rev. 1.00     ║
  7.                                                       ╚══════════════════╝
  8.  
  9. }
  10.  
  11. Procedure DrawOutline(X1,Y1,X2,Y2:Word;LStyle:LineStyles);
  12.  
  13.   Procedure DrawDoubleOutline;
  14.  
  15.   Var
  16.     Y     :Word;
  17.  
  18.   Begin
  19.     GotoXY(X1,Y1);
  20.     WriteChr('╔');
  21.     GotoXY(X2,Y1);
  22.     WriteChr('╗');
  23.     GotoXY(X1,Y2);
  24.     WriteChr('╚');
  25.     GotoXY(X2,Y2);
  26.     WriteChr('╝');
  27.  
  28.     GotoXY(X1+1,Y1);
  29.     Pad(X2-X1-1,'═');
  30.     GotoXY(X1+1,Y2);
  31.     Pad(X2-X1-1,'═');
  32.  
  33.     For Y:=Y1+1 to Y2-1 do
  34.     Begin
  35.       GotoXY(X1,Y);
  36.       WriteChr('║');
  37.       GotoXY(X2,Y);
  38.       WriteChr('║');
  39.     End;
  40.   End;
  41.  
  42.   Procedure DrawSingleOutline;
  43.  
  44.   Var
  45.     Y     :Word;
  46.  
  47.   Begin
  48.     GotoXY(X1,Y1);
  49.     WriteChr('┌');
  50.     GotoXY(X2,Y1);
  51.     WriteChr('┐');
  52.     GotoXY(X1,Y2);
  53.     WriteChr('└');
  54.     GotoXY(X2,Y2);
  55.     WriteChr('┘');
  56.  
  57.     GotoXY(X1+1,Y1);
  58.     Pad(X2-X1-1,'─');
  59.     GotoXY(X1+1,Y2);
  60.     Pad(X2-X1-1,'─');
  61.  
  62.     For Y:=Y1+1 to Y2-1 do
  63.     Begin
  64.       GotoXY(X1,Y);
  65.       WriteChr('│');
  66.       GotoXY(X2,Y);
  67.       WriteChr('│');
  68.     End;
  69.   End;
  70.  
  71.   Procedure DrawNoLineOutline;
  72.  
  73.   Var
  74.     Y     :Word;
  75.  
  76.   Begin
  77.     GotoXY(X1,Y1);
  78.     WriteChr(' ');
  79.     GotoXY(X2,Y1);
  80.     WriteChr(' ');
  81.     GotoXY(X1,Y2);
  82.     WriteChr(' ');
  83.     GotoXY(X2,Y2);
  84.     WriteChr(' ');
  85.  
  86.     GotoXY(X1+1,Y1);
  87.     Pad(X2-X1-1,' ');
  88.     GotoXY(X1+1,Y2);
  89.     Pad(X2-X1-1,' ');
  90.  
  91.     For Y:=Y1+1 to Y2-1 do
  92.     Begin
  93.       GotoXY(X1,Y);
  94.       WriteChr(' ');
  95.       GotoXY(X2,Y);
  96.       WriteChr(' ');
  97.     End;
  98.   End;
  99.  
  100. Begin
  101.   If Cursor Then PushXYPos;
  102.   Case LStyle Of
  103.     DoubleLine:DrawDoubleOutline;
  104.     SingleLine:DrawSingleOutline;
  105.     NoLine    :DrawNoLineOutline;
  106.   End;
  107.   If Cursor Then PopXYPos;
  108. End;
  109.  
  110. Procedure DrawShadow(X1,Y1,X2,Y2:Word;SStyle:ShadowStyles);
  111.  
  112. Var
  113.   HashChar      :Char;
  114.   OldColors     :Word;
  115.   Q             :Pointer;
  116.  
  117. Label
  118.   CopyLoop;
  119.  
  120. Begin
  121.   If SStyle=NoShade Then Exit;
  122.  
  123.   If SStyle in [LightHash,MediumHash,DarkHash] Then
  124.   Begin
  125.     Case SStyle Of
  126.       LightHash  :HashChar:=#176;
  127.       MediumHash :HashChar:=#177;
  128.       DarkHash   :HashChar:=#178;
  129.     End;
  130.     FillBlock(X1+2,Y2+1,X2+1,Y2+1,HashChar);
  131.     FillBlock(X2+1,Y1+1,X2+2,Y2+1,HashChar);
  132.   End
  133.   Else
  134.     If SStyle=Solid Then
  135.     Begin
  136.       OldColors:=TextAttr;
  137.       TextColor(BackgroundColor);
  138.       FillBlock(X2+1,Y1+1,X2+1,Y2,#32);
  139.       TextAttr:=OldColors;
  140.       Q:=VideoWriteAddress(X1+1,Y2+1);
  141.       Asm
  142.         cld
  143.         push    ds
  144.         mov     bh, TextAttr
  145.         and     bh, 0f0h
  146.         shr     bh, 1
  147.         shr     bh, 1
  148.         shr     bh, 1
  149.         shr     bh, 1
  150.         mov     bl, '▀'
  151.         les     di, Q
  152.         lds     si, Q
  153.         mov     cx, X2
  154.         sub     cx, X1
  155.         inc     cx
  156.  
  157. CopyLoop:
  158.         lodsw
  159.         and     ah, 0f0h
  160.         or      ah, bh
  161.         mov     al, bl
  162.         stosw
  163.         loop    CopyLoop
  164.  
  165.         pop     ds
  166.       End;
  167. {
  168. Pascal Equivalent:
  169.  
  170.       For X:=X1+1 to X2 do
  171.       Begin
  172.         NewValue:=(((Q^ And 240) Or Shade) Shl 8) Or 223;    [VideoColor(Q^ And 240, Shade);]
  173.         Q :=Ptr(Seg(Q^),Ofs(Q^)-1);
  174.         Move(NewValue,Q^,2);                                 [Write('▀');]
  175.         Q :=Ptr(Seg(Q^),Ofs(Q^)+3);
  176.       End;
  177. }
  178.     End;
  179. End;
  180.  
  181. Procedure DrawShadowWindow(X1,Y1,X2,Y2:Word;ShadForg,ShadBack:Byte;
  182.                            LStyle:LineStyles;SStyle:ShadowStyles);
  183.  
  184. Begin
  185.   DrawOutLine  (X1,Y1,X2,Y2,LStyle);
  186.   FillBlock    (X1+1,Y1+1,X2-1,Y2-1,#32);
  187.   VideoColor   (ShadForg,ShadBack);
  188.   DrawShadow   (X1,Y1,X2,Y2,SStyle);
  189. End;
  190.  
  191. Procedure Barometer(X,Y:Word;MaxLen:Byte;WithMe:Char;
  192.                     Current,EndPoint:LongInt);
  193.  
  194. Const
  195.   Previous:Byte = 0;
  196.  
  197. Var
  198.   HowFar:Byte;
  199.  
  200. Begin
  201.   GotoXY(X,Y);
  202.   HowFar:=(Current*MaxLen) Div EndPoint;
  203.   If HowFar<>Previous Then Pad(HowFar,WithMe);
  204.   Previous:=HowFar;
  205. End;
  206.  
  207. { Copyright 1993, Michael Gallias }
  208.