home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PAVT110.ZIP / A0DEMO.PAS next >
Encoding:
Pascal/Delphi Source File  |  1991-09-07  |  5.7 KB  |  246 lines
  1. program A_0_Demo; { Demo of Avatar level 0 console using Crt routines }
  2.                   { Public Domain.  Author: Greg Smith                }
  3.                   { Modification History:                             }
  4.                   {        09/06/91   First Coding                    }
  5. {$D-,L-,R-,F-,M 4096,2048,2048}
  6. Uses Dos, Crt, PAvt0;
  7.  
  8. type
  9.   ScreenWord = record
  10.                  chr  : char;
  11.                  attr : byte;
  12.                end;
  13.   ScreenPtr = ^Screen;
  14.   Screen = Array[1..25,1..80] of ScreenWord;
  15.  
  16. var
  17.   ScrPtr : ScreenPtr; { for direct screen writes }
  18.  
  19. {$IFDEF VER55}
  20. Function DV_Get_Video_Buffer(cseg:word): word;
  21. begin
  22.   if DESQview_version = 0 then DV_Get_Video_Buffer := 0
  23.    else
  24.     InLine(
  25.       $b4/$fe/    {  MOV    AH,0FEH          DV's get video buffer function }
  26.       $cd/$10/    {  INT    10H              Returns ES:DI of alt buffer }
  27.       $8c/$c0);   {  MOV    AX,ES            Return video buffer }
  28. end; { DV_Get_Video_Buffer }
  29. {$ELSE}
  30. Function DV_Get_Video_Buffer(cseg:word): word; assembler;
  31. asm
  32.   MOV    ES,cseg            { Put current segment into ES }
  33.   CALL   DESQview_version   { Returns AX=0 if not in DV }
  34.   TEST   AX,AX              { In DV? }
  35.   JZ     @DVGVB_X           { Jump if not }
  36.   MOV    AH,0FEH            { DV's get video buffer function }
  37.   INT    10H                { Returns ES:DI of alt buffer }
  38.   MOV    AX,ES              { Return video buffer }
  39.   JMP    @DVGVB_E           { Exit and return DV buffer }
  40. @DVGVB_X:
  41.   MOV    AX,cseg            { Load old buffer for return to caller }
  42. @DVGVB_E:
  43. end; { DV_Get_Video_Buffer }
  44. {$ENDIF}
  45.  
  46. Procedure SetScrPtr;
  47. var
  48.   sg : word;
  49. begin
  50.   if LastMode = 7 then sg := $B000
  51.    else sg := $B800;
  52.   sg := DV_Get_Video_Buffer(sg);
  53.   ScrPtr := Ptr(sg,$0000);
  54. end;
  55.  
  56. (* Hooks *)
  57.  
  58. {$F+}
  59. procedure SetXY(x,y:byte);
  60. begin
  61.   GotoXY(x,y);
  62. end;
  63.  
  64. procedure WriteAT(x,y,a:byte;ch:char);
  65. begin
  66.   with ScrPtr^[y,x] do
  67.    begin
  68.      attr := a;
  69.      chr := ch;
  70.    end;
  71. end;
  72.  
  73. procedure GetXY(var x,y:byte);
  74. begin
  75.   x := WhereX;
  76.   y := WhereY;
  77. end;
  78.  
  79. procedure FillArea(x1,y1,x2,y2,a:byte;ch:char);
  80. var
  81.   w,z : byte;
  82. begin
  83.   for w := y1 to y2 do
  84.    for z := x1 to x2 do
  85.     WriteAT(z,w,a,ch);
  86. end;
  87.  
  88. procedure Scroll(dir,x1,y1,x2,y2,n,a:byte);
  89. var
  90.   t : byte;
  91. begin
  92.   if n = 0 then
  93.    begin
  94.      FillArea(x1,y1,x2,y2,a,' ');
  95.      exit;
  96.    end;
  97.   case dir of
  98.     1 : begin { up }
  99.           if n > succ(y2-y1) then n := succ(y2-y1);
  100.           for t := y1+n to y2 do
  101.            Move(ScrPtr^[t,x1], ScrPtr^[t-n,x1], succ(x2-x1)*2); { move a line }
  102.           FillArea(x1,succ(y2-n),x2,y2,a,' ');
  103.         end;
  104.     2 : begin { down }
  105.           if n > succ(y2-y1) then n := succ(y2-y1);
  106.           for t := y2-n downto y1 do
  107.            Move(ScrPtr^[t,x1], ScrPtr^[t+n,x1], succ(x2-x1)*2); { move a line }
  108.           FillArea(x1,y1,x2,pred(y1+n),a,' ');
  109.         end;
  110.     3 : begin { left }
  111.           if n > succ(x2-x1) then n := succ(x2-x1);
  112.           for t := y1 to y2 do
  113.            Move(ScrPtr^[t,x1+n], ScrPtr^[t,x1], succ(x2-(x1+n))*2);
  114.           FillArea(succ(x2-n),y1,x2,y2,a,' ');
  115.         end;
  116.     4 : begin { right }
  117.           if n > succ(x2-x1) then n := succ(x2-x1);
  118.           for t := y1 to y2 do
  119.            Move(ScrPtr^[t,x1], ScrPtr^[t,x1+n], succ(x2-(x1+n))*2);
  120.           FillArea(x1,y1,pred(x1+n),y2,a,' ');
  121.         end;
  122.   end; { case dir }
  123. end;
  124.  
  125. procedure GetScrChar(x,y:byte;var a:byte;var c:char);
  126. begin
  127.   with ScrPtr^[y,x] do
  128.    begin
  129.      a := attr;
  130.      c := chr;
  131.    end;
  132. end;
  133.  
  134. procedure HighArea(x1,y1,x2,y2,a:byte);
  135. var
  136.   i,j,m : byte;
  137.   c : char;
  138. begin
  139.   for i := x1 to x2 do
  140.    for j := y1 to y2 do
  141.     begin
  142.       GetScrChar(i,j,m,c);
  143.       WriteAT(i,j,a,c);
  144.     end;
  145. end;
  146. {$F-}
  147.  
  148. (* End Hook Definitions *)
  149.  
  150. procedure SetHooks;
  151. begin
  152. { Query_Hook := <defualt null hook for this application> }
  153.   HighAreah := HighArea;
  154.   GetATh := GetScrChar;
  155.   FillAreah := FillArea;
  156.   Scrollh := Scroll;
  157.   GotoXYh := SetXY;
  158.   WriteATh := WriteAT;
  159. end;
  160.  
  161. function UpStr(s:string): string;
  162. var
  163.   ns : string;
  164.   i : integer;
  165. begin
  166.   for i := 1 to length(s) do
  167.    ns[i] := upcase(s[i]);
  168.   ns[0] := s[0];
  169.   UpStr := ns;
  170. end;
  171.  
  172. procedure Help;
  173. begin
  174.   Writeln('A-0 Demo  Copr. 1991 Greg Smith');
  175.   Writeln;
  176.   Writeln('Usage:  A0DEMO [params] input_file [params]');
  177.   Writeln;
  178.   Writeln(' parameters:');
  179.   Writeln('   /ANSI         Start with ANSI child active.');
  180.   Writeln('   /SLOW         Slow down emulation for viewing.');
  181.   halt;
  182. end;
  183.  
  184. var
  185.   fname : pathstr;
  186.  
  187. const
  188.   slowdown : byte = 0; { milliseconds between characters. }
  189.  
  190. procedure ProcessParams;
  191. const
  192.   Prms = '/ANSI/SLOW/?/HELP';
  193. var
  194.   i,p : integer;
  195. begin
  196.   p := paramcount;
  197.   while p > 0 do
  198.    begin
  199.      i := pos(UpStr(ParamStr(p)),Prms);
  200.      case i of
  201.        1  : ANSI_Only;
  202.        6 : Slowdown := 2; { set to ms between chars. }
  203.        11..13 : Help;
  204.      else
  205.       fname := ParamStr(p);
  206.      end; { case }
  207.      dec(p);
  208.    end; { while }
  209. end;  { processed in reverse so that first non-parameter is the filename }
  210.  
  211. Procedure ProgBody;
  212. var
  213.   f : file;
  214.   buf : Array[1..1024] of char;
  215.   i,z : word;
  216. begin
  217.   Assign(Output,''); Rewrite(Output);
  218.   Assign(Input,''); Reset(Input);
  219.   fname := '';
  220.   SetScrPtr;
  221.   SetHooks;
  222.   ProcessParams;
  223.   if fname = '' then Help;
  224.   FillArea(1,1,80,25,0,' '); { Clear Screen }
  225.   Assign(f,fname);
  226.   Reset(f,1);
  227.   if slowdown = 0 then
  228.    repeat
  229.      BlockRead(f,buf,1024,z);
  230.      for i := 1 to z do AVTInterp(buf[i]);
  231.    until EOF(f)
  232.   else
  233.    repeat
  234.      BlockRead(f,buf,1024,z);
  235.      for i := 1 to z do
  236.       begin
  237.         Delay(slowdown);
  238.         AVTInterp(buf[i]);
  239.       end;
  240.    until EOF(f); { end else }
  241. end;
  242.  
  243. begin
  244.   ProgBody;
  245. end.
  246.