home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MCGA#04.ZIP / MCGA04.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-06-12  |  6.8 KB  |  314 lines
  1. Unit MCGA04;
  2.  
  3. interface
  4.  
  5. type
  6.   PCXHeaderPtr=  ^PCXHeader;
  7.   PCXHeader   =  record
  8.                    Signature      :  Char;
  9.                    Version        :  Char;
  10.                    Encoding       :  Char;
  11.                    BitsPerPixel   :  Char;
  12.                    XMin,YMin,
  13.                    XMax,YMax      :  Integer;
  14.                    HRes,VRes      :  Integer;
  15.                    Palette        :  Array [0..47] of byte;
  16.                    Reserved       :  Char;
  17.                    Planes         :  Char;
  18.                    BytesPerLine   :  Integer;
  19.                    PaletteType    :  Integer;
  20.                    Filler         :  Array [0..57] of byte;
  21.                  end;
  22.  
  23. Procedure SetGraphMode (Num:Byte);
  24. Procedure SetPixel     (X,Y:Integer;Color:Byte);
  25.  
  26. Procedure LineEqu      (X1,Y1,X2,Y2:Integer;Color:Byte);
  27. Procedure LineIndiv    (X1,Y1,X2,Y2:Integer;Color:Byte);
  28. Procedure Line         (X1,Y1,X2,Y2:Integer;Color:Byte);
  29.  
  30. Procedure DisplayPCXPas (X,Y:Integer;Buf:Pointer);
  31. Procedure DisplayPCXAsm (X,Y:Integer;Buf:Pointer);
  32.  
  33. implementation
  34.  
  35. uses
  36.   Dos;
  37.  
  38. var
  39.   ScreenWide  :  Integer;
  40.   ScreenAddr  :  Word;
  41.  
  42. Procedure SetGraphMode (Num:Byte);
  43. begin
  44.   asm
  45.     mov al,Num
  46.     mov ah,0
  47.     int 10h
  48.     end;
  49.   Case Num of
  50.     $13 : ScreenWide := 320;
  51.     end;
  52.   ScreenAddr := $A000;
  53. end;
  54.  
  55. Procedure SetPixel (X,Y:Integer;Color:Byte);
  56. begin
  57.   asm
  58.     push ds
  59.     mov  ax,ScreenAddr
  60.     mov  ds,ax
  61.  
  62.     mov  ax,Y
  63.     mov  bx,320
  64.     mul  bx
  65.     mov  bx,X
  66.     add  bx,ax
  67.  
  68.     mov  al,Color
  69.     mov  byte ptr ds:[bx],al
  70.     pop  ds
  71.     end;
  72. end;
  73.  
  74. Procedure LineEqu (X1,Y1,X2,Y2:Integer;Color:Byte);
  75. var
  76.   Slope  :  Real;
  77.   D,X,Y  :  Integer;
  78. begin
  79.   If (X1 = X2) or (Y1 = Y2) then Exit;
  80.   If X1 > X2 then begin
  81.     D  := X1;
  82.     X1 := X2;
  83.     X2 := D;
  84.     D  := Y1;
  85.     Y1 := Y2;
  86.     Y2 := D;
  87.     end;
  88.   Slope := (Y2-Y1)/(X2-X1);
  89.   If Abs(Y2-Y1) > Abs(X2-X1) then begin
  90.     Slope := (X2-X1)/(Y2-Y1);
  91.     For Y := Y1 to X2 do
  92.       SetPixel (Trunc(Slope*(Y-Y1)+X1),Y,Color);
  93.     end
  94.   Else begin
  95.     Slope := (Y2-Y1)/(X2-X1);
  96.     For X := X1 to X2 do
  97.       SetPixel (X,Trunc(Slope*(X-X1)+Y1),Color);
  98.     end;
  99. end;
  100.  
  101. Procedure LineIndiv (X1,Y1,X2,Y2:Integer;Color:Byte);
  102. var
  103.   X,Y,
  104.   YIncr,
  105.   D,DX,DY,
  106.   AIncr,BIncr :  Integer;
  107.   Ofs         :  Word;
  108. begin
  109.   If X1 > X2 then begin
  110.     D  := X1;
  111.     X1 := X2;
  112.     X2 := D;
  113.     D  := Y1;
  114.     Y1 := Y2;
  115.     Y2 := D;
  116.     end;
  117.   If Y2 > Y1 then YIncr :=  1
  118.              else YIncr := -1;
  119.   DX := X2 - X1;
  120.   DY := Abs (Y2-Y1);
  121.   D := 2 * DY - DX;
  122.   AIncr := 2 * (DY - DX);
  123.   BIncr := 2 * DY;
  124.  
  125.   X := X1;
  126.   Y := Y1;
  127.   SetPixel (X,Y,Color);
  128.  
  129.   For X := X1 + 1 to X2 do begin
  130.     If D >= 0 then begin
  131.       Inc (Y,YIncr);
  132.       Inc (D,AIncr);
  133.       end
  134.     Else Inc (D,BIncr);
  135.     SetPixel (X,Y,Color);
  136.     end;
  137. end;
  138.  
  139. Procedure Line (X1,Y1,X2,Y2:Integer;Color:Byte);
  140. var
  141.   I,
  142.   YIncr,
  143.   D,DX,DY,
  144.   AIncr,BIncr :  Integer;
  145.   Ofs         :  Word;
  146. begin
  147.  If X1 > X2 then begin
  148.     D  := X1;
  149.     X1 := X2;
  150.     X2 := D;
  151.     D  := Y1;
  152.     Y1 := Y2;
  153.     Y2 := D;
  154.     end;
  155.   If Y2 > Y1 then YIncr :=  320
  156.              else YIncr := -320;
  157.   DX := X2 - X1;
  158.   DY := Abs (Y2-Y1);
  159.   D := 2 * DY - DX;
  160.   AIncr := 2 * (DY - DX);
  161.   BIncr := 2 * DY;
  162.  
  163.   Ofs := Word(Y1) * 320 + Word(X1);
  164.  
  165.   Mem [$A000:Ofs] := Color;
  166.  
  167.   For I := X1 + 1 to X2 do begin
  168.     If D >= 0 then begin
  169.       Inc (Ofs,YIncr);
  170.       Inc (D,AIncr);
  171.       end
  172.     Else Inc (D,BIncr);
  173.     Inc (Ofs);
  174.     Mem [$A000:Ofs] := Color;
  175.     end;
  176. end;
  177.  
  178. Procedure ExtractLinePas (BytesWide:Integer;Var Source,Dest:Pointer);
  179. var
  180.   DestIdx,
  181.   SourceIdx   :  Integer;
  182.   InCode,
  183.   RunCount    :  Byte;
  184. begin
  185.   DestIdx := 0;
  186.   SourceIdx := 0;
  187.  
  188.   While DestIdx < BytesWide do begin
  189.     InCode := Mem [Seg(Source^):Ofs(Source^)+SourceIdx];
  190.     Inc (SourceIdx);
  191.  
  192.     If (InCode and $C0) = $C0 then begin
  193.       RunCount := InCode and $3F;
  194.       InCode := Mem [Seg(Source^):Ofs(Source^)+SourceIdx];
  195.       Inc (SourceIdx);
  196.       FillChar (Mem[Seg(Dest^):Ofs(Dest^)+DestIdx],RunCount,InCode);
  197.       Inc (DestIdx,RunCount);
  198.       end
  199.     Else begin
  200.       Mem [Seg(Dest^):Ofs(Dest^)+DestIdx] := InCode;
  201.       Inc (DestIdx);
  202.       end;
  203.     end;
  204.   If Odd (BytesWide) then Source := Ptr(Seg(Source^),Ofs(Source^)+SourceIdx+2)
  205.                      else Source := Ptr(Seg(Source^),Ofs(Source^)+SourceIdx);
  206.   Dest   := Ptr(Seg(Dest^),Ofs(Dest^)+DestIdx);
  207. end;
  208.  
  209. Procedure ExtractLineASM (BytesWide:Integer;Var Source,Dest:Pointer);
  210. var
  211.   DestSeg,
  212.   DestOfs,
  213.   SourceSeg,
  214.   SourceOfs   :  Word;
  215. begin
  216.   SourceSeg := Seg (Source^);
  217.   SourceOfs := Ofs (Source^);
  218.   DestSeg   := Seg (Dest^);
  219.   DestOfs   := Ofs (Dest^);
  220.  
  221.   asm
  222.     push  ds
  223.     push  si
  224.  
  225.     mov   ax,DestSeg
  226.     mov   es,ax
  227.     mov   di,DestOfs     { es:di -> destination pointer }
  228.     mov   ax,SourceSeg
  229.     mov   ds,ax
  230.     mov   si,SourceOfs   { ds:si -> source buffer }
  231.  
  232.     mov   bx,di
  233.     add   bx,BytesWide   { bx holds position to stop for this row }
  234.     xor   cx,cx
  235.  
  236.   @@GetNextByte:
  237.     cmp   bx,di          { are we done with the line }
  238.     jbe   @@ExitHere
  239.  
  240.     lodsb                { al contains next byte }
  241.  
  242.     mov   ah,al
  243.     and   ah,0C0h
  244.     cmp   ah,0C0h
  245.     jne   @@SingleByte
  246.                          { must be a run of bytes }
  247.     mov   cl,al
  248.     and   cl,3Fh
  249.     lodsb
  250.     rep   stosb
  251.     jmp   @@GetNextByte
  252.  
  253.   @@SingleByte:
  254.     stosb
  255.     jmp   @@GetNextByte
  256.  
  257.   @@ExitHere:
  258.     mov   SourceSeg,ds
  259.     mov   SourceOfs,si
  260.     mov   DestSeg,es
  261.     mov   DestOfs,di
  262.  
  263.     pop   si
  264.     pop   ds
  265.   end;
  266.  
  267.   If Odd(BytesWide) then Source := Ptr (SourceSeg,SourceOfs+2)
  268.                     else Source := Ptr (SourceSeg,SourceOfs);
  269.  
  270.   Dest := Ptr (DestSeg,DestOfs);
  271. end;
  272.  
  273. Procedure DisplayPCXAsm (X,Y:Integer;Buf:Pointer);
  274. var
  275.   I,NumRows,
  276.   BytesWide   :  Integer;
  277.   Header      :  PCXHeaderPtr;
  278.   DestPtr     :  Pointer;
  279.   Offset      :  Word;
  280. begin
  281.   Header := Ptr (Seg(Buf^),Ofs(Buf^));
  282.   Buf := Ptr (Seg(Buf^),Ofs(Buf^)+128);
  283.   Offset := Y * 320 + X;
  284.   NumRows := Header^.YMax - Header^.YMin + 1;
  285.   BytesWide := Header^.XMax - Header^.XMin + 1;
  286.   For I := 1 to NumRows do begin
  287.     DestPtr := Ptr ($A000,Offset);
  288.     ExtractLineASM (BytesWide,Buf,DestPtr);
  289.     Inc (Offset,320);
  290.     end;
  291. end;
  292.  
  293. Procedure DisplayPCXPas (X,Y:Integer;Buf:Pointer);
  294. var
  295.   I,NumRows,
  296.   BytesWide   :  Integer;
  297.   Header      :  PCXHeaderPtr;
  298.   DestPtr     :  Pointer;
  299.   Offset      :  Word;
  300. begin
  301.   Header := Ptr (Seg(Buf^),Ofs(Buf^));
  302.   Buf := Ptr (Seg(Buf^),Ofs(Buf^)+128);
  303.   Offset := Y * 320 + X;
  304.   NumRows := Header^.YMax - Header^.YMin + 1;
  305.   BytesWide := Header^.XMax - Header^.XMin + 1;
  306.   For I := 1 to NumRows do begin
  307.     DestPtr := Ptr ($A000,Offset);
  308.     ExtractLinePas (BytesWide,Buf,DestPtr);
  309.     Inc (Offset,320);
  310.     end;
  311. end;
  312.  
  313. end.
  314.