home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MCGA#05.ZIP / MCGA05.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-06-12  |  9.4 KB  |  467 lines
  1. Unit MCGA04;
  2.  
  3. interface
  4.  
  5. type
  6.   PointerType =  array [0..65500] of byte;
  7.   NewPointer  =  ^PointerType;
  8.  
  9.   PCXHeaderPtr=  ^PCXHeader;
  10.   PCXHeader   =  record
  11.                    Signature      :  Char;
  12.                    Version        :  Char;
  13.                    Encoding       :  Char;
  14.                    BitsPerPixel   :  Char;
  15.                    XMin,YMin,
  16.                    XMax,YMax      :  Integer;
  17.                    HRes,VRes      :  Integer;
  18.                    Palette        :  Array [0..47] of byte;
  19.                    Reserved       :  Char;
  20.                    Planes         :  Char;
  21.                    BytesPerLine   :  Integer;
  22.                    PaletteType    :  Integer;
  23.                    Filler         :  Array [0..57] of byte;
  24.                  end;
  25.  
  26. Procedure SetGraphMode (Num:Byte);
  27. Procedure SetPixel     (X,Y:Integer;Color:Byte);
  28.  
  29. Procedure LineEqu      (X1,Y1,X2,Y2:Integer;Color:Byte);
  30. Procedure LineIndiv    (X1,Y1,X2,Y2:Integer;Color:Byte);
  31. Procedure Line         (X1,Y1,X2,Y2:Integer;Color:Byte);
  32.  
  33. Procedure DisplayPCXPas (X,Y:Integer;Buf:Pointer);
  34. Procedure DisplayPCXAsm (X,Y:Integer;Buf:Pointer);
  35.  
  36. Procedure GetImagePas (X1,Y1,X2,Y2:Integer;P:Pointer);
  37. Procedure PutImagePas (X1,Y1:Integer;P:Pointer);
  38. Procedure GetImageAsm (X1,Y1,X2,Y2:Integer;P:Pointer);
  39. Procedure PutImageAsm (X1,Y1:Integer;P:Pointer);
  40.  
  41. implementation
  42.  
  43. uses
  44.   Dos;
  45.  
  46. var
  47.   ScreenWide  :  Integer;
  48.   ScreenAddr  :  Word;
  49.  
  50. Procedure Move (Var Source,Dest;Count:Word);
  51. begin
  52.   asm
  53.     push ds
  54.     lds  si,Source
  55.     les  di,Dest
  56.     mov  cx,Count
  57.     shr  cx,1
  58.     rep  movsw
  59.  
  60.     mov  cx,Count
  61.     test cl,1
  62.     jz   @@EvenCount
  63.     movsb
  64.   @@EvenCount:
  65.     pop  ds
  66.   end;
  67. end;
  68.  
  69. Procedure SetGraphMode (Num:Byte);
  70. begin
  71.   asm
  72.     mov al,Num
  73.     mov ah,0
  74.     int 10h
  75.     end;
  76.   Case Num of
  77.     $13 : ScreenWide := 320;
  78.     end;
  79.   ScreenAddr := $A000;
  80. end;
  81.  
  82. Procedure SetPixel (X,Y:Integer;Color:Byte);
  83. begin
  84.   asm
  85.     push ds
  86.     mov  ax,ScreenAddr
  87.     mov  ds,ax
  88.  
  89.     mov  ax,Y
  90.     mov  bx,320
  91.     mul  bx
  92.     mov  bx,X
  93.     add  bx,ax
  94.  
  95.     mov  al,Color
  96.     mov  byte ptr ds:[bx],al
  97.     pop  ds
  98.     end;
  99. end;
  100.  
  101. Procedure LineEqu (X1,Y1,X2,Y2:Integer;Color:Byte);
  102. var
  103.   Slope  :  Real;
  104.   D,X,Y  :  Integer;
  105. begin
  106.   If (X1 = X2) or (Y1 = Y2) then Exit;
  107.   If X1 > X2 then begin
  108.     D  := X1;
  109.     X1 := X2;
  110.     X2 := D;
  111.     D  := Y1;
  112.     Y1 := Y2;
  113.     Y2 := D;
  114.     end;
  115.   Slope := (Y2-Y1)/(X2-X1);
  116.   If Abs(Y2-Y1) > Abs(X2-X1) then begin
  117.     Slope := (X2-X1)/(Y2-Y1);
  118.     For Y := Y1 to X2 do
  119.       SetPixel (Trunc(Slope*(Y-Y1)+X1),Y,Color);
  120.     end
  121.   Else begin
  122.     Slope := (Y2-Y1)/(X2-X1);
  123.     For X := X1 to X2 do
  124.       SetPixel (X,Trunc(Slope*(X-X1)+Y1),Color);
  125.     end;
  126. end;
  127.  
  128. Procedure LineIndiv (X1,Y1,X2,Y2:Integer;Color:Byte);
  129. var
  130.   X,Y,
  131.   YIncr,
  132.   D,DX,DY,
  133.   AIncr,BIncr :  Integer;
  134.   Ofs         :  Word;
  135. begin
  136.   If X1 > X2 then begin
  137.     D  := X1;
  138.     X1 := X2;
  139.     X2 := D;
  140.     D  := Y1;
  141.     Y1 := Y2;
  142.     Y2 := D;
  143.     end;
  144.   If Y2 > Y1 then YIncr :=  1
  145.              else YIncr := -1;
  146.   DX := X2 - X1;
  147.   DY := Abs (Y2-Y1);
  148.   D := 2 * DY - DX;
  149.   AIncr := 2 * (DY - DX);
  150.   BIncr := 2 * DY;
  151.  
  152.   X := X1;
  153.   Y := Y1;
  154.   SetPixel (X,Y,Color);
  155.  
  156.   For X := X1 + 1 to X2 do begin
  157.     If D >= 0 then begin
  158.       Inc (Y,YIncr);
  159.       Inc (D,AIncr);
  160.       end
  161.     Else Inc (D,BIncr);
  162.     SetPixel (X,Y,Color);
  163.     end;
  164. end;
  165.  
  166. Procedure Line (X1,Y1,X2,Y2:Integer;Color:Byte);
  167. var
  168.   I,
  169.   YIncr,
  170.   D,DX,DY,
  171.   AIncr,BIncr :  Integer;
  172.   Ofs         :  Word;
  173. begin
  174.  If X1 > X2 then begin
  175.     D  := X1;
  176.     X1 := X2;
  177.     X2 := D;
  178.     D  := Y1;
  179.     Y1 := Y2;
  180.     Y2 := D;
  181.     end;
  182.   If Y2 > Y1 then YIncr :=  320
  183.              else YIncr := -320;
  184.   DX := X2 - X1;
  185.   DY := Abs (Y2-Y1);
  186.   D := 2 * DY - DX;
  187.   AIncr := 2 * (DY - DX);
  188.   BIncr := 2 * DY;
  189.  
  190.   Ofs := Word(Y1) * 320 + Word(X1);
  191.  
  192.   Mem [$A000:Ofs] := Color;
  193.  
  194.   For I := X1 + 1 to X2 do begin
  195.     If D >= 0 then begin
  196.       Inc (Ofs,YIncr);
  197.       Inc (D,AIncr);
  198.       end
  199.     Else Inc (D,BIncr);
  200.     Inc (Ofs);
  201.     Mem [$A000:Ofs] := Color;
  202.     end;
  203. end;
  204.  
  205. Procedure ExtractLinePas (BytesWide:Integer;Var Source,Dest:Pointer);
  206. var
  207.   DestIdx,
  208.   SourceIdx   :  Integer;
  209.   InCode,
  210.   RunCount    :  Byte;
  211. begin
  212.   DestIdx := 0;
  213.   SourceIdx := 0;
  214.  
  215.   While DestIdx < BytesWide do begin
  216.     InCode := Mem [Seg(Source^):Ofs(Source^)+SourceIdx];
  217.     Inc (SourceIdx);
  218.  
  219.     If (InCode and $C0) = $C0 then begin
  220.       RunCount := InCode and $3F;
  221.       InCode := Mem [Seg(Source^):Ofs(Source^)+SourceIdx];
  222.       Inc (SourceIdx);
  223.       FillChar (Mem[Seg(Dest^):Ofs(Dest^)+DestIdx],RunCount,InCode);
  224.       Inc (DestIdx,RunCount);
  225.       end
  226.     Else begin
  227.       Mem [Seg(Dest^):Ofs(Dest^)+DestIdx] := InCode;
  228.       Inc (DestIdx);
  229.       end;
  230.     end;
  231.   If Odd (BytesWide) then Source := Ptr(Seg(Source^),Ofs(Source^)+SourceIdx+2)
  232.                      else Source := Ptr(Seg(Source^),Ofs(Source^)+SourceIdx);
  233.   Dest   := Ptr(Seg(Dest^),Ofs(Dest^)+DestIdx);
  234. end;
  235.  
  236. Procedure ExtractLineASM (BytesWide:Integer;Var Source,Dest:Pointer);
  237. var
  238.   DestSeg,
  239.   DestOfs,
  240.   SourceSeg,
  241.   SourceOfs   :  Word;
  242. begin
  243.   SourceSeg := Seg (Source^);
  244.   SourceOfs := Ofs (Source^);
  245.   DestSeg   := Seg (Dest^);
  246.   DestOfs   := Ofs (Dest^);
  247.  
  248.   asm
  249.     push  ds
  250.     push  si
  251.  
  252.     mov   ax,DestSeg
  253.     mov   es,ax
  254.     mov   di,DestOfs     { es:di -> destination pointer }
  255.     mov   ax,SourceSeg
  256.     mov   ds,ax
  257.     mov   si,SourceOfs   { ds:si -> source buffer }
  258.  
  259.     mov   bx,di
  260.     add   bx,BytesWide   { bx holds position to stop for this row }
  261.     xor   cx,cx
  262.  
  263.   @@GetNextByte:
  264.     cmp   bx,di          { are we done with the line }
  265.     jbe   @@ExitHere
  266.  
  267.     lodsb                { al contains next byte }
  268.  
  269.     mov   ah,al
  270.     and   ah,0C0h
  271.     cmp   ah,0C0h
  272.     jne   @@SingleByte
  273.                          { must be a run of bytes }
  274.     mov   cl,al
  275.     and   cl,3Fh
  276.     lodsb
  277.     rep   stosb
  278.     jmp   @@GetNextByte
  279.  
  280.   @@SingleByte:
  281.     stosb
  282.     jmp   @@GetNextByte
  283.  
  284.   @@ExitHere:
  285.     mov   SourceSeg,ds
  286.     mov   SourceOfs,si
  287.     mov   DestSeg,es
  288.     mov   DestOfs,di
  289.  
  290.     pop   si
  291.     pop   ds
  292.   end;
  293.  
  294.   If Odd(BytesWide) then Source := Ptr (SourceSeg,SourceOfs+2)
  295.                     else Source := Ptr (SourceSeg,SourceOfs);
  296.  
  297.   Dest := Ptr (DestSeg,DestOfs);
  298. end;
  299.  
  300. Procedure DisplayPCXAsm (X,Y:Integer;Buf:Pointer);
  301. var
  302.   I,NumRows,
  303.   BytesWide   :  Integer;
  304.   Header      :  PCXHeaderPtr;
  305.   DestPtr     :  Pointer;
  306.   Offset      :  Word;
  307. begin
  308.   Header := Ptr (Seg(Buf^),Ofs(Buf^));
  309.   Buf := Ptr (Seg(Buf^),Ofs(Buf^)+128);
  310.   Offset := Y * 320 + X;
  311.   NumRows := Header^.YMax - Header^.YMin + 1;
  312.   BytesWide := Header^.XMax - Header^.XMin + 1;
  313.   For I := 1 to NumRows do begin
  314.     DestPtr := Ptr ($A000,Offset);
  315.     ExtractLineASM (BytesWide,Buf,DestPtr);
  316.     Inc (Offset,320);
  317.     end;
  318. end;
  319.  
  320. Procedure DisplayPCXPas (X,Y:Integer;Buf:Pointer);
  321. var
  322.   I,NumRows,
  323.   BytesWide   :  Integer;
  324.   Header      :  PCXHeaderPtr;
  325.   DestPtr     :  Pointer;
  326.   Offset      :  Word;
  327. begin
  328.   Header := Ptr (Seg(Buf^),Ofs(Buf^));
  329.   Buf := Ptr (Seg(Buf^),Ofs(Buf^)+128);
  330.   Offset := Y * 320 + X;
  331.   NumRows := Header^.YMax - Header^.YMin + 1;
  332.   BytesWide := Header^.XMax - Header^.XMin + 1;
  333.   For I := 1 to NumRows do begin
  334.     DestPtr := Ptr ($A000,Offset);
  335.     ExtractLinePas (BytesWide,Buf,DestPtr);
  336.     Inc (Offset,320);
  337.     end;
  338. end;
  339.  
  340. Procedure GetImagePas (X1,Y1,X2,Y2:Integer;P:Pointer);
  341. var
  342.   I           :  Integer;
  343.   Count,
  344.   ScnPos,
  345.   Wide,High   :  Word;
  346.   Buf         :  NewPointer absolute P;
  347. begin
  348.   Wide   := (X2 - X1) + 1;
  349.   High   := (Y2 - Y1) + 1;
  350.   ScnPos := (Y1 * 320) + X1;
  351.   Count  := 4;
  352.  
  353.   Move (Wide,Buf^[0],SizeOf(Wide));
  354.   Move (High,Buf^[2],SizeOf(High));
  355.  
  356.   For I := 1 to High do begin
  357.     Move (Mem[$A000:ScnPos],Buf^[Count],Wide);
  358.     Inc (ScnPos,ScreenWide);
  359.     Inc ( Count,Wide);
  360.     end;
  361. end;
  362.  
  363. Procedure PutImagePas (X1,Y1:Integer;P:Pointer);
  364. var
  365.   I           :  Integer;
  366.   Count,
  367.   ScnPos,
  368.   Wide,High   :  Word;
  369.   Buf         :  NewPointer absolute P;
  370. begin
  371.   ScnPos := (Word(Y1) * 320) + Word(X1);
  372.   Count  := 4;
  373.  
  374.   Move (Buf^[0],Wide,SizeOf(Wide));
  375.   Move (Buf^[2],High,SizeOf(High));
  376.  
  377.   For I := Y1 to Y1+High-1 do begin
  378.     Move (Buf^[Count],Mem[$A000:ScnPos],Wide);
  379.     Inc (ScnPos,ScreenWide);
  380.     Inc ( Count,Wide);
  381.     end;
  382. end;
  383.  
  384. Procedure GetImageAsm (X1,Y1,X2,Y2:Integer;P:Pointer); assembler;
  385. asm
  386.     mov  bx,ScreenWide
  387.     push ds
  388.     les  di,P
  389.  
  390.     mov  ax,0A000h
  391.     mov  ds,ax
  392.     mov  ax,Y1
  393.     mov  dx,320
  394.     mul  dx
  395.     add  ax,X1
  396.     mov  si,ax
  397.  
  398.     mov  ax,X2
  399.     sub  ax,X1
  400.     inc  ax
  401.     mov  dx,ax
  402.     stosw
  403.  
  404.     mov  ax,Y2
  405.     sub  ax,Y1
  406.     inc  ax
  407.     stosw
  408.     mov  cx,ax
  409.  
  410.   @@1:
  411.     mov  cx,dx
  412.  
  413.     shr  cx,1
  414.     rep  movsw
  415.  
  416.     test dx,1
  417.     jz   @@2
  418.     movsb
  419.   @@2:
  420.     add  si,bx
  421.     sub  si,dx
  422.  
  423.     dec  ax
  424.     jnz  @@1
  425.  
  426.     pop  ds
  427. end;
  428.  
  429. Procedure PutImageAsm (X1,Y1:Integer;P:Pointer); assembler;
  430. asm
  431.     mov  bx,ScreenWide
  432.     push ds
  433.     lds  si,P
  434.  
  435.     mov  ax,0A000h
  436.     mov  es,ax
  437.     mov  ax,Y1
  438.     mov  dx,320
  439.     mul  dx
  440.     add  ax,X1
  441.     mov  di,ax
  442.  
  443.     lodsw
  444.     mov  dx,ax
  445.  
  446.     lodsw
  447.  
  448.   @@1:
  449.     mov  cx,dx
  450.  
  451.     shr  cx,1
  452.     rep  movsw
  453.  
  454.     test dx,1
  455.     jz   @@2
  456.     movsb
  457.   @@2:
  458.     add  di,bx
  459.     sub  di,dx
  460.  
  461.     dec  ax
  462.     jnz  @@1
  463.  
  464.     pop  ds
  465. end;
  466.  
  467. end.