home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / AFVIEW.ZIP / AFVIEW.PAS next >
Pascal/Delphi Source File  |  1995-03-01  |  13KB  |  387 lines
  1. program afVIEW;
  2.  
  3. {$M $4000, 0, 0}
  4.  
  5. uses crt,dos;
  6.  
  7. type
  8.    SegOfs = record           {structure of a pointer}
  9.       Ofst, Segm : Word;
  10.       end;
  11.  
  12. function Normalized(P : Pointer) : pointer; inline
  13.    ($58/                    {pop ax    ;pop offset into AX}
  14.    $5A/                     {pop dx    ;pop segment into DX}
  15.    $89/$C3/                 {mov bx,ax ;BX = Ofs(P^)}
  16.    $B1/$04/                 {mov cl,4  ;CL = 4}
  17.    $D3/$EB/                 {shr bx,cl ;BX = Ofs(P^) div 16}
  18.    $01/$DA/                 {add dx,bx ;add BX to segment}
  19.    $25/$0F/$00);            {and ax,$F ;mask out unwanted bits in offset}
  20.  
  21. function Linear(P : Pointer) : LongInt;
  22.    {-Converts a pointer to a linear address to allow differences in addresses
  23.      to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.}
  24.    begin
  25.    with SegOfs(P) do
  26.       Linear := (LongInt(Segm) shl 4)+LongInt(Ofst);
  27.    end;
  28.  
  29. function LinearToPointer(L : LongInt) : Pointer;
  30.    {-Return linear address L as a normalized pointer}
  31.    begin
  32.    LinearToPointer := Ptr(Word(L shr 4), Word(L and $0000000F));
  33.    end;
  34.  
  35. function PtrDiff(P1, P2 : Pointer) : LongInt;
  36.    {-Return the number of bytes between P1^ and P2^}
  37.    begin
  38.    PtrDiff := Abs(Linear(P1)-Linear(P2));
  39.    end;
  40.  
  41. procedure HugeGetMem(var Pt; Bytes : LongInt);
  42.    var
  43.       P : Pointer absolute Pt;
  44.       So : SegOfs absolute P;
  45.       Paras : word;
  46.    begin
  47.    P:=Nil;
  48.    Paras:=Bytes div 16;
  49.    asm
  50.    mov  bx, Paras
  51.    mov  ah, 48h
  52.    int  21h
  53.    mov  Paras, 0
  54.    jc   @end
  55.    mov  Paras, ax
  56.    @end:
  57.    end;
  58.    if Paras > 0 then So.Segm:=Paras;
  59.    end;
  60.  
  61. procedure HugeFreeMem(var Pt; Bytes : LongInt);
  62.     {-Deallocate a block of memory of size Bytes pointed to by Pt, a pointer
  63.       variable. Pt is set to nil on Exit. Does nothing if Pt is nil.}
  64.    var
  65.       P : Pointer absolute Pt;
  66.       So : SegOfs absolute P;
  67.       Tmp:word;
  68.    begin
  69.    {exit if P is nil}
  70.    if (P = nil) then
  71.       Exit;
  72.    Tmp:=So.Segm;
  73.    asm
  74.    mov  es, Tmp
  75.    mov  ah, 49h
  76.    int  21h
  77.    end;
  78.    end;
  79.  
  80. procedure FillWord(var x; count:integer; w:word);
  81.    begin
  82.    Inline(
  83.    $c4/$be/x/
  84.    $8b/$86/w/
  85.    $8b/$8e/count/
  86.    $fc/
  87.    $f2/$ab);
  88.    (*  LES  DI,x              { load target address }
  89.    MOV  AX,w              { load word to fill in }
  90.    MOV  CX,count          { number of words to move }
  91.    CLD                    { clear direction flag }
  92.    REPNZ STOSW            { copy the data } *)
  93.    end;
  94.  
  95. procedure LoadFile(FileN:string; Mem:pointer; NumL:word; var MaxLine:word);
  96.    var
  97.       CurLine:word;
  98.       Tmp2:byte;
  99.       TFileIn:file;
  100.       AbsPtr:longint;
  101.       TmpPtr:longint;
  102.       TmpStr:array[1..8192] of char;
  103.       Actual:word;
  104.       Tmp:word;
  105.       TmpBuf:pointer;
  106.       Attr:byte; X,Y,SX,SY:word;
  107.       AnsiLevel:byte;
  108.       ParamCnt:byte;
  109.       Params:array[1..10] of byte;
  110.    procedure PutCh(Ch:char);
  111.       begin
  112.       case Ch of
  113.          #8: begin
  114.              if x>1 then
  115.                 begin
  116.                 dec(X);
  117.                 TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
  118.                 char(LinearToPointer(TmpPtr)^):=' ';
  119.                 byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
  120.                 end;
  121.               end;
  122.          #10: begin
  123.               if Y < (NumL-1) then inc(Y);
  124.               end;
  125.          #13: begin
  126.               X:=1;
  127.               end;
  128.          #1..#7,#11,#14..#255:
  129.               begin
  130.               TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
  131.               char(LinearToPointer(TmpPtr)^):=Ch;
  132.               byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
  133.               inc(x); if X > 80 then begin X:=1; inc(Y); if y > (NumL-1) then dec(y) end;
  134.               end;
  135.          end;
  136.       end;
  137.    procedure SetColors;
  138.       var
  139.          Cntr : byte;
  140.       begin
  141.       for Cntr := 1 to ParamCnt do
  142.          begin
  143.          case Params[Cntr] of
  144.          0 :  TextAttr := $07;
  145.          1 :  TextAttr:=TextAttr or $08;{asm or Attr, 08h end;}
  146.          5 :  TextAttr:=TextAttr or $80;{asm or Attr, 80h end;}
  147.          7 :  asm
  148.               mov  ax, word ptr TextAttr
  149.               mov  bx, ax
  150.               and  ax, 0707h
  151.               xchg ah, al
  152.               and  bx, 80h
  153.               add  ax, bx
  154.               mov  word ptr TextAttr, bx
  155.               end;
  156.          25 : TextAttr := (TextAttr AND (NOT $80)); {blink off}
  157.          30 : TextAttr := (TextAttr AND $F8) + black;
  158.          31 : TextAttr := (TextAttr AND $f8) + red;
  159.          32 : TextAttr := (TextAttr AND $f8) + green;
  160.          33 : TextAttr := (TextAttr AND $f8) + brown;
  161.          34 : TextAttr := (TextAttr AND $f8) + blue;
  162.          35 : TextAttr := (TextAttr AND $f8) + magenta;
  163.          36 : TextAttr := (TextAttr AND $f8) + cyan;
  164.          37 : TextAttr := (TextAttr AND $f8) + Lightgray;
  165.          40 : TextAttr := (TextAttr AND $8F) + (black shl 4);
  166.          41 : TextAttr := (TextAttr AND $8F) + (red shl 4);
  167.          42 : TextAttr := (TextAttr AND $8F) + (green shl 4);
  168.          43 : TextAttr := (TextAttr AND $8F) + (brown shl 4);
  169.          44 : TextAttr := (TextAttr AND $8F) + (blue shl 4);
  170.          45 : TextAttr := (TextAttr AND $8F) + (magenta shl 4);
  171.          46 : TextAttr := (TextAttr AND $8F) + (cyan shl 4);
  172.          47 : TextAttr := (TextAttr AND $8F) + (lightgray shl 4);
  173.          end;
  174.       end;
  175.       end;
  176.    begin
  177.    Assign(TFileIn,FileN);
  178.    Reset(TFileIn,1);
  179.    AbsPtr:=Linear(Mem);
  180.    for CurLine:=0 to NumL-1 do
  181.       begin
  182.       FillWord(LinearToPointer(AbsPtr+(longint(CurLine)*160))^,80,$0720);
  183.       end;
  184.    CurLine:=0;
  185.    TextAttr:=$07;
  186.    X:=1; Y:=1; AnsiLevel:=0; MaxLine:=1;
  187.    repeat
  188.       {ReadLn(TFileIn, TmpStr);}
  189.       BlockRead(TFileIn, TmpStr, 4096, Actual);
  190.       for Tmp:=1 to Actual do
  191.          begin{
  192.             TmpPtr:=AbsPtr+(longint(CurLine)*160)+(Tmp*2);
  193.             char(LinearToPointer(TmpPtr)^):=TmpStr[Tmp+1];
  194.             byte(LinearToPointer(TmpPtr+1)^):=$0F;}
  195.             if TmpStr[Tmp]=#26 then break;
  196.             case ANSILevel of
  197.                0: begin
  198.                   case TmpStr[Tmp] of
  199.                      #27: ANSILevel := 1;
  200.                      #9: if X < 80-8 then X:=( (X div 8) + 1 ) * 8;
  201.                   else
  202.                      PutCh(TmpStr[Tmp]);
  203.                      end;
  204.                   end;
  205.                1: begin
  206.                   if TmpStr[Tmp] = '[' then
  207.                      begin
  208.                      ANSILevel := 2;
  209.                      ParamCnt := 1;
  210.                      Params[1] := 0;
  211.                      end
  212.                   else
  213.                      begin
  214.                      {Write(#27+StIn[Cntr]);}
  215.                      PutCH(TmpStr[Tmp]);
  216.                      ANSILevel := 0;
  217.                      end;
  218.                   end;
  219.                2: begin
  220.                   case TmpStr[Tmp] of
  221.                      '0'..'9': Params[ParamCnt]:=(Params[ParamCnt]*10)+(byte(TmpStr[Tmp])-48);
  222.                      ';': begin
  223.                           inc(ParamCnt);
  224.                           Params[ParamCnt] := 0;
  225.                           end;
  226.                      'H',
  227.                      'f': begin
  228.                           if Params[2] > 80 then x:=80 else x:=Params[2];
  229.                           if Params[1] > (NumL-1) then y:=NumL-1 else y:=Params[1];
  230.                           ANSILevel := 0;
  231.                           end;
  232.                      'A': begin
  233.                           if Params[1] = 0 then Params[1] := 1;
  234.                           if (Y - Params[1]) < 1 then Y:=1 else Y:=Y - Params[1];
  235.                           ANSILevel := 0;
  236.                           end;
  237.                      'B': begin
  238.                           if Params[1] = 0 then Params[1] := 1;
  239.                           if (Y + Params[1]) > (NumL-1) then Y:=NumL-1 else Y:=Y+Params[1];
  240.                           ANSILevel := 0;
  241.                           end;
  242.                      'D': begin
  243.                           if Params[1] = 0 then Params[1] := 1;
  244.                           if (X - Params[1]) < 1 then X:=1 else X:=X - Params[1];
  245.                           ANSILevel := 0;
  246.                           end;
  247.                      'C': begin
  248.                           if Params[1] = 0 then Params[1] := 1;
  249.                           if (X + Params[1]) > 80 then X:=80 else X:=X+Params[1];
  250.                           ANSILevel := 0;
  251.                           end;
  252.                      'J': begin
  253.                           case Params[1] of
  254.                              0: for Tmp2:=X to 80 do
  255.                                    begin
  256.                                    TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((Tmp2-1)*2);
  257.                                    char(LinearToPointer(TmpPtr)^):=' ';
  258.                                    byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
  259.                                    end;
  260.                              1, {I just didn't bother today.}
  261.                              2: begin
  262.                                 for CurLine:=0 to NumL-1 do
  263.                                    FillWord(LinearToPointer(AbsPtr+(longint(CurLine)*160))^,80,$0720);
  264.                                 x:=1; y:=1;
  265.                                 end;
  266.                              end;
  267.                           ANSILevel := 0;
  268.                           end;
  269.                      'K': begin
  270.                           for Tmp2:=X to 80 do
  271.                              begin
  272.                              TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
  273.                              char(LinearToPointer(TmpPtr)^):=' ';
  274.                              byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
  275.                              end;
  276.                           ANSILevel := 0;
  277.                           end;
  278.                      'm': begin
  279.                           SetColors;
  280.                           ANSILevel := 0;
  281.                           end;
  282.                      's': begin
  283.                           SX:=X; SY:=Y;
  284.                           ANSILevel := 0;
  285.                           end;
  286.                      'u': begin
  287.                           X:=SX; Y:=SY;
  288.                           ANSILevel := 0;
  289.                           end;
  290.                      end;
  291.                   end;
  292.                end;
  293.             end;
  294.       if y>MaxLine then MaxLine:=y;
  295.    until eof(TFileIn) or (actual<4096);
  296.    Close(TFileIn);
  297.    end;
  298.  
  299. procedure Scroll(Ptr:pointer; NumL:word);
  300.    var
  301.       Done:boolean;
  302.       CurLine:word;
  303.       CurPtr:longint;
  304.    begin
  305.    Done:=False;
  306.    CurPtr:=Linear(Ptr);
  307.    CurLine:=0;
  308.    TextAttr:=$7;
  309.    ClrScr;
  310.    repeat
  311.       Move(LinearToPointer(CurPtr+(longint(CurLine)*160))^,Mem[$B800:$0000],160*25);
  312.       GotoXY(77,1);
  313.       Write(CurLine:4);
  314.       case ReadKey of
  315.          #0: case ReadKey of
  316.                 #71: CurLine:=0;
  317.                 #72: if CurLine>0 then dec(CurLine);
  318.                 #73: if (integer(CurLine)-25)>0 then dec(CurLine,25) else CurLine:=0;
  319.                 #79: CurLine:=NumL-25;
  320.                 #80: if CurLine+25<NumL then inc(CurLine);
  321.                 #81: if (CurLine+25+25)<NumL then inc(CurLine,25) else CurLine:=NumL-25;
  322.                 end;
  323.          #27: Done:=True;
  324.          end;
  325.    until Done;
  326.    end;
  327.  
  328. var videopage : byte;
  329.  
  330. {$L CurShape.OBJ}
  331. function  getcursorshape : word; far; external;
  332. procedure setcursorshape(scanlines : word); far; external;
  333.  
  334. procedure normalcursor;
  335.    begin
  336.    setcursorshape($0607);
  337.    end;
  338.  
  339. procedure hidecursor;
  340.   begin
  341.   setcursorshape($2000);
  342.   end;
  343.  
  344. var
  345.    LngInt:longint;
  346.    TmpPtr:pointer;
  347.    NumLines:word;
  348.    FileName:string;
  349.    D : DirStr;
  350.    N : NameStr;
  351.    E : ExtStr;
  352.  
  353. const
  354.    BuffLines=1500;
  355.    BuffSize=BuffLines*160;
  356.  
  357. begin
  358. videopage:=0;
  359. WriteLn('afVIEW -- 1500 line Real Mode ANSi');
  360. WriteLn('viewer by FAT Slayer [CiA/afSOFT]');
  361. if ParamCount<>1 then
  362.    begin
  363.    WriteLn(^J'Incorrect syntax, correct syntax:'^M^J^J'   AFVIEW FileName[.Ext]'^M^J^J+
  364.            'The extension is optional and will be assumed to be .ANS');
  365.    Halt(1);
  366.    end;
  367. FileName:=ParamStr(1);
  368. FSplit(FileName,D,N,E);
  369. if E='' then FileName:=FileName+'.ANS';
  370. if FSearch(FileName,'')='' then
  371.    begin
  372.    WriteLn(ParamStr(1),' not found.');
  373.    Halt(1);
  374.    end;
  375. HugeGetMem(TmpPtr,BuffSize);
  376. if TmpPtr=nil then begin WriteLn('Memory allocation error.'); halt; end;
  377. LoadFile(ParamStr(1),TmpPtr,BuffLines,NumLines);
  378. HideCursor;
  379. Scroll(TmpPtr,NumLines);
  380. NormalCursor;
  381. HugeFreeMem(TmpPtr,0);
  382. TextAttr:=$07;
  383. ClrScr;
  384. WriteLn('afVIEW -- 1500 line Real Mode ANSi');
  385. WriteLn('viewer by FAT Slayer [CiA/afSOFT]');
  386. end.
  387.