home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TTT405.ZIP / FASTTTT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-07-18  |  8.1 KB  |  280 lines
  1. {$S-,R-,V-,D-,T-}
  2. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  3. {         TechnoJocks Turbo Toolkit v4.05           Released: Jul 18, 1988    }
  4. {                                                                             }
  5. {         Module: FastTTT   --  fast screen update procedures                 }
  6. {         Credits: Brian Foley and Marshall Brain for ASM concept             }
  7. {                                                                             }
  8. {                  Copyright R. D. Ainsbury (c) 1986-88                       }
  9. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  10.  
  11. unit FastTTT;
  12.  
  13. interface
  14.  
  15. type
  16.   DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);
  17. var
  18.   BaseOfScreen : Word;       {Base address of video memory}
  19.   WaitForRetrace : Boolean;  {Check for snow on color cards?}
  20.   Speed : longint;           {delay factor for growbox routine}
  21.  
  22. Function  Attr(F,B:byte):byte;
  23. Procedure FastWrite(Col,Row,Attr:byte; St:string);
  24. Procedure PlainWrite(Col,Row:byte; St:string);
  25. Function  CurrentDisplay: DisplayType;
  26. Function  Replicate(N:byte; Character:char):string;
  27. Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  28. Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  29. Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  30. Procedure HorizLine(X1,X2,Y,F,B,lineType:byte);
  31. Procedure VertLine(X,Y1,Y2,F,B,lineType:byte);
  32. Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  33. Procedure ClearLine(Y,F,B:integer);
  34. Procedure WriteAT(X,Y,F,B:integer; St:string);
  35. Procedure WriteBetween(X1,X2,Y,F,B:byte; St:string);
  36. Procedure WriteCenter(LineNO,F,B:integer; St:string);
  37. Procedure WriteVert(X,Y,F,B:integer; St:string);
  38. Procedure ReinitFastWrite;
  39.  
  40. implementation
  41.  
  42.   {$L FASTTTT}
  43.  
  44.   {$F+}
  45.   Procedure FastWrite(Col,Row,Attr:byte; St:string); external;
  46.   Procedure PlainWrite(Col,Row:byte; St:string); external;
  47.   Function CurrentDisplay: DisplayType; external;
  48.   Function CurrentVideoMode: Byte; external;
  49.   {$F-}
  50.  
  51.   Function Attr(F,B:byte):byte;
  52.   {converts foreground(F) and background(B) colors to combined Attribute byte}
  53.   begin
  54.       Attr := (B Shl 4) or F;
  55.   end;  {Func Attr}
  56.  
  57.   Function Replicate(N : byte; Character:char):string;
  58.   {returns a string with Character repeated N times}
  59.   var tempstr : string;
  60.   begin
  61.       If not (N in [1..80]) then N := 1;
  62.       fillchar(tempstr,N+1,Character);
  63.       Tempstr[0] := chr(N);
  64.       Replicate := Tempstr;
  65.   end;
  66.  
  67.   Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  68.   var
  69.     Y : integer;
  70.     attrib : byte;
  71.   begin
  72.       If x2 > 80 then x2 := 80;
  73.       Attrib := attr(F,B);
  74.       For Y := y1 to y2 do
  75.           Fastwrite(X1,Y,attrib,replicate(X2-X1+1,' '));
  76.   end;   {cleartext}
  77.  
  78.   Procedure ClearLine(Y,F,B:integer);
  79.   begin
  80.       Fastwrite(1,Y,attr(F,B),replicate(80,' '));
  81.   end;
  82.  
  83.   Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  84.   {Draws a box on the screen}
  85.   var
  86.     I:integer;
  87.     corner1,corner2,corner3,corner4,
  88.     horizline,
  89.     vertline : char;
  90.     attrib : byte;
  91.   begin
  92.       case boxtype of
  93.       0:begin
  94.             corner1:=' ';
  95.             corner2:=' ';
  96.             corner3:=' ';
  97.             corner4:=' ';
  98.             horizline:=' ';
  99.             vertline:=' ';
  100.         end;
  101.       1:begin
  102.             corner1:='┌';
  103.             corner2:='┐';
  104.             corner3:='└';
  105.             corner4:='┘';
  106.             horizline:='─';
  107.             vertline:='│';
  108.         end;
  109.       2:begin
  110.             corner1:='╔';
  111.             corner2:='╗';
  112.             corner3:='╚';
  113.             corner4:='╝';
  114.             horizline:='═';
  115.             vertline:='║';
  116.         end;
  117.       3:begin
  118.             corner1:='╓';
  119.             corner2:='╖';
  120.             corner3:='╙';
  121.             corner4:='╜';
  122.             horizline:='─';
  123.             vertline:='║';
  124.         end;
  125.       4:begin
  126.             corner1:='╒';
  127.             corner2:='╕';
  128.             corner3:='╘';
  129.             corner4:='╛';
  130.             horizline:='═';
  131.             vertline:='│';
  132.         end;
  133.     else
  134.        corner1:=chr(ord(Boxtype));
  135.        corner2:=chr(ord(Boxtype));
  136.        corner3:=chr(ord(Boxtype));
  137.        corner4:=chr(ord(Boxtype));
  138.        horizline:=chr(ord(Boxtype));
  139.        vertline:=chr(ord(Boxtype));
  140.     end;{case}
  141.     attrib := attr(F,B);
  142.     FastWrite(X1,Y1,attrib,corner1);
  143.     FastWrite(X1+1,Y1,attrib,replicate(X2-X1-1,horizline));
  144.     FastWrite(X2,Y1,attrib,corner2);
  145.     For I := Y1+1 to Y2-1 do
  146.     begin
  147.         FastWrite(X1,I,attrib,vertline);
  148.         FastWrite(X2,I,attrib,vertline);
  149.     end;
  150.     FastWrite(X1,Y2,attrib,corner3);
  151.     FastWrite(X1+1,Y2,attrib,replicate(X2-X1-1,horizline));
  152.     FastWrite(X2,Y2,attrib,corner4);
  153.   end; {Proc Box}
  154.  
  155.   Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  156.   {Draws a box and clears text within Box frame}
  157.   begin
  158.       Box(X1,Y1,X2,Y2,F,B,boxtype);
  159.       ClearText(succ(X1),succ(Y1),pred(X2),pred(Y2),F,B);
  160.   end;
  161.  
  162.   Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  163.   {Draws exploding filled box!}
  164.   var I,TX1,TY1,TX2,TY2,Ratio : integer;
  165.   begin
  166.       If 2*(Y2 -Y1 +1) > X2 - X1 + 1 then
  167.          Ratio :=   2
  168.       else
  169.          Ratio :=  1;
  170.       TX2 := (X2 - X1) div 2 + X1 + 2;
  171.       TX1 := TX2 - 3;                 {needs a box 3 by 3 minimum}
  172.       TY2 := (Y2 - Y1) div 2 + Y1 + 2;
  173.       TY1 := TY2 - 3;
  174.       If (X2-X1) < 3 then
  175.       begin
  176.          TX2 := X2;
  177.          TX1 := X1;
  178.       end;
  179.       If (Y2-Y1) < 3 then
  180.       begin
  181.          TY2 := Y2;
  182.          TY1 := Y1;
  183.       end;
  184.       repeat
  185.            FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  186.            If TX1 >= X1 + (1*Ratio) then TX1 := TX1 - (1*Ratio) else TX1 := X1;
  187.            If TY1 > Y1  then TY1 := TY1 - 1;
  188.            If TX2 + (1*Ratio) <= X2 then TX2 := TX2 + (1*Ratio) else TX2 := X2;
  189.            If TY2 + 1 <= Y2 then TY2 := TY2 + 1;
  190.            For I := 1 to Speed*1000 do {nothing};
  191.       Until (TX1 = X1) and (TY1 = Y1) and (TX2 = X2) and (TY2 = Y2);
  192.       FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  193.   end;
  194.  
  195.   procedure HorizLine(X1,X2,Y,F,B,lineType : byte);
  196.   var
  197.     I : integer;
  198.     Horizline : char;
  199.     attrib : byte;
  200.   begin
  201.       If (lineType in [2,4]) then
  202.          horizline := '═'
  203.       else
  204.          horizline := '─';
  205.       Attrib := attr(F,B);
  206.       If X2 > X1 then
  207.          FastWrite(X1,Y,attrib,replicate(X2-X1+1,Horizline))
  208.       else
  209.          FastWrite(X1,Y,attrib,replicate(X1-X2+1,Horizline));
  210.   end;   {horizline}
  211.  
  212.   Procedure VertLine(X,Y1,Y2,F,B,lineType : byte);
  213.   var
  214.     I : integer;
  215.     vertline : char;
  216.     attrib : byte;
  217.   begin
  218.       If (linetype in [2,4])then
  219.          vertline := '║'
  220.       else
  221.          vertline := '│';
  222.       Attrib := attr(F,B);
  223.       If Y2 > Y1 then
  224.          For I := Y1 to Y2 do Fastwrite(X,I,Attrib,Vertline)
  225.       else
  226.          For I := Y2 to Y1 do Fastwrite(X,I,Attrib,Vertline);
  227.   end;   {vertline}
  228.  
  229.   Procedure WriteAT(X,Y,F,B:integer;St:string);
  230.   begin
  231.       Fastwrite(X,Y,attr(F,B),St);
  232.   end;
  233.  
  234.   Procedure WriteCenter(LineNO,F,B:integer;St:string);
  235.   begin
  236.       Fastwrite(40 - length(St) div 2,Lineno,attr(F,B),St);
  237.   end;
  238.  
  239.   Procedure WriteBetween(X1,X2,Y,F,B:byte;St:string);
  240.   var X : integer;
  241.   begin
  242.       If length(St) >= X2 - X1 + 1 then
  243.          WriteAT(X1,Y,F,B,St)
  244.       else
  245.       begin
  246.           x := X1 + (X2 - X1 + 1 - length(St)) div 2 ;
  247.           WriteAT(X,Y,F,B,St);
  248.       end;
  249.   end;
  250.  
  251.   Procedure WriteVert(X,Y,F,B:integer;ST : string);
  252.   var
  253.     I:integer;
  254.     Tempstr:string;
  255.   begin
  256.       If length(St) > 26 - Y then delete(St,27 - Y,80);
  257.       For I := 1 to length(St) do
  258.       begin
  259.           Tempstr := st[I];
  260.           Fastwrite(X,Y-1+I,attr(F,B),St[I]);
  261.       end;
  262.   end;
  263.  
  264.  
  265.   Procedure ReinitFastWrite;
  266.     {-Initializes WaitForRetrace and BaseOfScreen}
  267.   begin                      {InitFastWrite}
  268.     {initialize WaitForRetrace and BaseOfScreen}
  269.     if CurrentVideoMode = 7 then
  270.        BaseOfScreen := $B000  {Mono}
  271.     else
  272.        BaseOfScreen := $B800; {Color}
  273.     WaitForRetrace := (CurrentDisplay = CGA);
  274.  end;                       {InitFastWrite}
  275.  
  276. begin   {the following is always called when the unit is loaded}
  277.     ReinitFastWrite;
  278.     Speed := 200;
  279. end.
  280.