unit VGAMem;

{ unit VGAMem
  Copyright 1993, 1998 by Matthias K"oppe

  $Id: vgamem.pas 1.3 1999/02/09 11:12:26 mkoeppe Exp $
 
  This library is free software; you can redistribute it and/or
  modify it under the terms of the GNU Library General Public
  License as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This library is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this library; if not, write to the Free
  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}

interface

{$ifdef FPK}
'Not implemented for Free Pascal; use bgi.pp instead.'
{$endif}

{$A+,B-,D+,F+,G+,O-,R-,S-,X+,I-}

uses Objects;

{ Restspeicherverwaltung
}
procedure InitVgaMem;
procedure DoneVgaMem;
function GetVgaMem(Size: Word): Word;
procedure FreeVgaMem(P, Size: Word);

{ Restspeicherpufferung
}
type
  TVgaBuf = record
    Bounds: TRect;
    Mem: Word;
    Size: Word;
  end;

const
  pbNone  = 0;
  pbCopy  = 1;
  pbClear = 2;

function PrepBuf(var R: TRect; Action: Word; var Buf: TVgaBuf): Boolean;
procedure EndBufDraw;
procedure ReleaseBuf(var Buf: TVgaBuf);
procedure PasteRect(var R: TRect; var Buf: TVgaBuf);
procedure PasteRectAt(var R: TRect; P: TPoint; var Buf: TVgaBuf);

{ Kopierroutinen
}
function GetSize(x1, y1, x2, y2: Integer): Word;
function GetBPL(x1, x2: Integer): Word;
procedure SaveScreen(x1, y1, x2, y2: Integer; Addr: Word);
procedure RestoreScreen(x1, y1, x2, y2, x3, y3: Integer; Addr: Word);
procedure CopyScreen(x1, y1, x2, y2, x3, y3: Integer);

{ Icon-Darstellung

  Only for non-mapped 16-color modes.
  For general routines, use ExtGraph unit.
}
procedure PutIconAnd16(x1, y1: Integer; MapMask: Byte; Icon: Pointer);
procedure PutIconOr16(x1, y1: Integer; MapMask: Byte; Icon: Pointer);

{ BGI-like Image routines
}
const
  NormalPut     = 0;    { MOV }
  CopyPut       = 0;    { MOV }
  XORPut        = 1;    { XOR }
  OrPut         = 2;    { OR  }
  AndPut        = 3;    { AND }
  NotPut        = 4;    { NOT, add to one of the above constants }
  BackPut	= 8;	{ BkColor sensitivity, add to one of the above const }

const
  ImageChunkSize: LongInt = 65520;

{ High-level routines
}
function CopyImage(Image: pointer): pointer;
function CutImage(x1, y1, x2, y2: Integer): pointer;
procedure FreeImage(Image: pointer);
procedure GetImageExtent(Image: pointer; var Extent: TPoint);
function LoadImage(var S: TStream): pointer;
function MaskedImage(Image: pointer): pointer;
procedure PasteImage(X, Y: Integer; Image: pointer; BitBlt: Word);
procedure StoreImage(var S: TStream; Image: pointer);

{ Low-level routines
}
procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
function GetImageLong(Image: pointer): LongInt;
function GetImageSize(Image: pointer): Word;
function ImageLong(x1, y1, x2, y2: Integer): LongInt;
function ImageSize(x1, y1, x2, y2: Integer): Word;
procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);

{ Storing screen regions
}
type
  PScreenBuf = ^TScreenBuf;
  TScreenBuf = record
    Mode: Word;
    Rect: TRect;
    Size: LongInt;
    Info: LongInt
  end;

function StoreScreen(x1, y1, x2, y2: Integer): PScreenBuf;
procedure FreeScreenBuf(Buf: PScreenBuf);
procedure DrawScreenBufAt(Buf: PScreenBuf; x3, y3: Integer);
procedure DrawScreenBuf(Buf: PScreenBuf);

{ nicht initialisierte Variablen
}
var
  BlockList: Pointer;
  ListSize: Word;
  VgaMemSeg: Word;

{ initialisierte Variablen
}
const
  SourcePage: Word = 0;
  DestPage: Word = 0;
  CopyDeltaHack: Word = 0;

{ Retrieves the capabilities for the current mode
}
const
  vmcImage       = 1;
  vmcCopy        = 2;
  vmcSaveRestore = 4;
  vmcBuffer      = 8;
  vmcBackPut	 = 16;

function GetVgaMemCaps: Word;

{ Old-style functions
}
procedure InitVGAMan;
procedure DoneVGAMan;
function GetSize16(x1, y1, x2, y2: Integer): Word;
function GetBPL16(x1, x2: Integer): Word;
procedure SaveScreen16(x1, y1, x2, y2: Integer; Addr: Word);
procedure RestoreScreen16(x1, y1, x2, y2, x3, y3: Integer; Addr: Word);
procedure CopyScreen16(x1, y1, x2, y2, x3, y3: Integer);
procedure CopyMem16(Source, Dest, Count: Word);

implementation

{$ifdef FPK}
{$i vgamemf.ppi}
{$else}
{$ifdef Windows}
{$i VgaMemW.pas}
{$else}

uses Gr, Memory, WinRes;

type
  TVgaMemProcs = record
    _CapsNoMap: Word;
    _CapsMap: Word;
    _GetBPL: Word;
    _GetSize: Word;
    _CS_Addr: Word;
    _CS_Copy: Word;
    _SaveScreen: Word;
    _RestoreScreen: Word;
    _ImageLong: Word;
    _GetImage: Word;
    _PutImage: Word;		{ _PutImage is far-coded. }
    _MaskImage: Word
  end;

var
  VgaMemProcs: TVgaMemProcs;
  Temp: Pointer;
  NextNotify: TNotifyProc;
  SavedFree: LongInt;
  RealCaps, Caps: Word;

const
  VgaMemHandle: Integer = 0;

procedure Copyright; near; assembler;
Asm
	RET
	DB	"VGAMem (C) Matthias Kppe"
End;

{ Routines for 16 colors ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
}

{$L vmem16.obj     (vmem16.asm)		VgaMem, 16 colors }

{ Service table
}
procedure Table_16; near; external;

{ Copy memory proc
}
procedure CopyMem16(Source, Dest, Count: Word); external;

{ Compatibility aliases
}
function GetSize16(x1, y1, x2, y2: Integer): Word; external;
function GetBPL16(x1, x2: Integer): Word; external;
procedure SaveScreen16(x1, y1, x2, y2: Integer; Addr: Word); external;
procedure RestoreScreen16(x1, y1, x2, y2, x3, y3: Integer; Addr: Word); external;
procedure CopyScreen16(x1, y1, x2, y2, x3, y3: Integer); external;

{ Routines for 256 colors ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
}

{$L vmem256.obj    (vmem256.asm)		VgaMem, 256 colors }

procedure Table_256; near; external;

{ General routines ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
}

{$L vmemcopy.obj   (vmemcopy.asm)		VgaMem, copying routines }

function GetSize(x1, y1, x2, y2: Integer): Word; external;
function GetBPL(x1, x2: Integer): Word; external;
{procedure SaveScreen(x1, y1, x2, y2: Integer; Addr: Word); external;
procedure RestoreScreen(x1, y1, x2, y2, x3, y3: Integer; Addr: Word); external;}
procedure CopyScreen(x1, y1, x2, y2, x3, y3: Integer); external;

{ SaveScreen/RestoreScreen emulation ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
}

procedure SaveScreen(x1, y1, x2, y2: Integer; Addr: Word);
var
  BPL: Word;
  y: Integer;
begin
  if RealCaps and vmcSaveRestore <> 0
  then asm
		leave
		pop	WORD PTR Temp[0]
		pop	WORD PTR Temp[2]
		call	VgaMemProcs._SaveScreen
		jmp	Temp
  end;
  BPL := GetBPL(x1, x2);
  SetDrawOrigin(0, 0);
  SetClipRect(0, 0, x2 - x1, y2 - y1);
  for y := y1 to y2 - 1 do
  begin
    SetActivePage(0);
    GetImage(x1, y, x2 - 1, y, TempMem^);
    ActiveSeg := Page0Seg + Addr;
    SetActivePage(2);
    BytesPerLine := BPL;
    PutImage(0, y - y1, TempMem^, NormalPut);
    BytesPerLine := RealBytesPerLine;
  end;
  SetActivePage(0);
end;

function Min(x, y: Integer): Integer; assembler;
asm
	MOV	AX, X
	CMP	AX, Y
	JLE	@@1
	MOV	AX, Y
@@1:
end;

function Max(x, y: Integer): Integer; assembler;
asm
	MOV	AX, X
	CMP 	AX, Y
	JGE	@@1
	MOV	AX, Y
@@1:
end;

procedure RestoreScreen(x1, y1, x2, y2, x3, y3: Integer; Addr: Word);
var
  BPL: Word;
  y, yc, dy: Integer;
begin
  if RealCaps and vmcSaveRestore <> 0
  then asm
		leave
		pop	WORD PTR Temp[0]
		pop	WORD PTR Temp[2]
		call	VgaMemProcs._RestoreScreen
		jmp	Temp
  end;
  BPL := GetBPL(x1, x2);
  SetDrawOrigin(0, 0);
  y2 := min(ClipRect.B.y - y3, y2 - y1);
  y1 := max(ClipRect.A.y - y3, 0);
  yc := (TempMemSize - 16) div BPL;
  If yc = 0 then Exit; {Error}
  y := y1;
  while y < y2 do
  begin
    dy := min(y2 - y, yc);
    ActiveSeg := Page0Seg + Addr;
    SetActivePage(2);
    BytesPerLine := BPL;
    GetImage(0, y, x2 - x1 - 1, y + dy - 1, TempMem^);
    SetActivePage(0);
    BytesPerLine := RealBytesPerLine;
    PutImage(x3, y3 + y, TempMem^, NormalPut);
    Inc(y, dy)
  end
end;

(******************************* Icon-Darstellung **************************)

procedure PutIconAnd16; assembler;
var
  Mask: LongInt;
Asm
	TEST	MetaState, ms_Record
	JZ	@@NR
	PUSH	4			{ Locals }
	PUSH	10			{ Params }
	PUSH	0
	MOV	AX, 3			{ pushed }
	CALL	[ExtSave]
	TEST	MetaState, ms_Record
	JNZ	@@NR
	MOV	AX, MetaOrigin.x
	ADD	x1, AX
	MOV	AX, MetaOrigin.y
	ADD	y1, AX
@@NR:	TEST	MetaState, ms_Draw
	JZ	@@ND
	test	grflags, 1
	jnz	@@nd
	CALL	SaveRegs
	MOV	BX, BytesPerLine.Word
	MOV	AX, y1
	MOV	CX, ClipRect.A.y
	SUB	CX, AX
	JLE	@@3
	MOV	AX, ClipRect.A.y
	JMP	@@4
@@3:    XOR	CX, CX
@@4:	push	ax
	MUL	BX
	MOV	DI, x1
	SAR	DI, 3
	ADD	DI, AX
	pop	ax

	MOV	DX, ClipRect.B.y
	sub	dx, ax			{ maximale Lnge }
	JLE	@@5
	LES	SI, Icon
	SEGES LODSW
	SUB	AX, CX			{ oben abgeschnitten }
	JLE	@@5
	SHL	CX, 1
	ADD	SI, CX			{ Beginn korrigieren }
	CMP	AX, DX
	JLE	@@2
	MOV	AX, DX			{ Lnge korrigieren }
@@2:	MOV	CH, AL

	MOV	CL, BYTE PTR x1
	AND	CL, 7

	MOV	DX, 03CEH		{ GC }
	MOV     AX, 0803H		{ Data Rotate: AND }
	OUT     DX, AX
	MOV     AX, 0FF08H		{ Bit Mask Reg: Unmasked }
	OUT	DX, AX
	MOV     AX, 0001H		{ Enable Set/Reset: All from CPU }
	OUT     DX, AX
	MOV	AX, 0005H		{ Write Mode 0 }
	OUT	DX, AX
	MOV     DX, 03C4H		{ SC }
	MOV     AL, 02H			{ Map Mask Reg }
	MOV	AH, MapMask
	OUT     DX, AX

	MOV	DX, x1
	SAR	DX, 3
	MOV	AX, ClipRect.A.x
	SAR	AX, 3
	SUB	AX, DX
	JNL	@@7
	MOV	BH, 0FFH
	JMP	@@8
@@7:	CMP	AX, 2
	JG	@@5
	MOV	BH, AL
@@8:	MOV	AX, ClipRect.B.x
	SAR	AX, 3
	SUB	AX, DX
	JL	@@5
	MOV	DX, BX
	MOV	DL, AL
	XOR	BH, BH

	CMP	DH, 0FFH
	JNZ	@@9
	CMP	DL, 2
	JNA	@@9

	ADD	DI, ActivePOfs		{ unmaskiert }
	PUSH	DS
	MOV	DS, ActivePSeg
@@1:	SEGES LODSW
	MOV	DH, AL
	XOR	DL, DL
	SHR	AX, CL
	SHR	DX, CL
	NOT	AX
	NOT	DL
	XCHG	[DI], AH
	XCHG	[DI+1], AL
	XCHG	[DI+2], DL
	ADD	DI, BX
	DEC	CH
	JNZ	@@1
	JMP	@@6

@@9:	MOV	AX, 0FFFFH		{ universelle Maskengenerierung }
	MOV	WORD PTR Mask, AX
	MOV	WORD PTR Mask+2, AX
	PUSH	CX
	PUSH	SI
	MOV	AL, DH
	CMP	AL, 0FFH
	JZ	@@10
	XOR	AH, AH
	MOV	SI, AX
	MOV	CX, ClipRect.A.x
	AND	CL, 7
	MOV	AX, 0FF00H
	SHR	AX, CL
	MOV	BYTE PTR [Mask][SI], AH
	OR	SI, SI
	JZ	@@10
@@11:	DEC	SI
	MOV	BYTE PTR [Mask][SI], 0
	JNZ	@@11
@@10:   MOV	AL, DL
	XOR	AH, AH
	CMP	AX, 2
	JA	@@14
	MOV	SI, AX
	MOV	CX, ClipRect.B.x
	AND	CL, 7
	MOV	AX, 0FF00H
	SHR	AX, CL
	AND	BYTE PTR [Mask][SI], AL
@@13:	INC	SI
	CMP	SI, 2
	JA	@@14
	MOV	BYTE PTR [Mask][SI], 0
	JMP	@@13
@@14:   POP	SI
	POP	CX

	ADD	DI, ActivePOfs
	PUSH	DS
	MOV	DS, ActivePSeg

@@12:	SEGES LODSW			{ Maskiert }
	MOV	DH, AL
	XOR	DL, DL
	SHR	AX, CL
	SHR	DX, CL
	AND	AH, BYTE PTR Mask
	AND	AL, BYTE PTR Mask+1
	AND	DL, BYTE PTR Mask+2
	NOT	AX
	NOT	DL
	XCHG	[DI], AH
	XCHG	[DI+1], AL
	XCHG	[DI+2], DL
	ADD	DI, BX
	DEC	CH
	JNZ	@@12

@@6:	POP	DS
@@5:	CALL	RestoreRegs
@@ND:
End;

procedure PutIconOr16; assembler;
var
  Mask: LongInt;
Asm
	TEST	MetaState, ms_Record
	JZ	@@NR
	PUSH	4			{ Locals }
	PUSH	10			{ Params }
	PUSH	0
	MOV	AX, 3			{ pushed }
	CALL	[ExtSave]
	TEST	MetaState, ms_Record
	JNZ	@@NR
	MOV	AX, MetaOrigin.x
	ADD	x1, AX
	MOV	AX, MetaOrigin.y
	ADD	y1, AX
@@NR:	TEST	MetaState, ms_Draw
	JZ	@@ND
	test	grflags, 1
	jnz	@@nd
	CALL	SaveRegs
	MOV	BX, BytesPerLine.Word
	MOV	AX, y1
	MOV	CX, ClipRect.A.y
	SUB	CX, AX
	JLE	@@3
	MOV	AX, ClipRect.A.y
	JMP	@@4
@@3:    XOR	CX, CX
@@4:    push	ax
	MUL	BX
	MOV	DI, x1
	SAR	DI, 3
	ADD	DI, AX
	pop	ax

	MOV	DX, ClipRect.B.y
	sub	dx, ax			{ maximale Lnge }
	JLE	@@5
	LES	SI, Icon
	SEGES LODSW
	SUB	AX, CX			{ oben abgeschnitten }
	JLE	@@5
	SHL	CX, 1
	ADD	SI, CX			{ Beginn korrigieren }
	CMP	AX, DX
	JLE	@@2
	MOV	AX, DX			{ Lnge korrigieren }
@@2:	MOV	CH, AL

	MOV	CL, BYTE PTR x1
	AND	CL, 7

	MOV	DX, 03CEH		{ GC }
	MOV     AX, 1003H		{ Data Rotate: OR }
	OUT     DX, AX
	MOV     AX, 0FF08H		{ Bit Mask Reg: Unmasked }
	OUT	DX, AX
	MOV     AX, 0001H		{ Enable Set/Reset: All from CPU }
	OUT     DX, AX
	MOV	AX, 0005H		{ Write Mode 0 }
	OUT	DX, AX
	MOV     DX, 03C4H		{ SC }
	MOV     AL, 02H			{ Map Mask Reg }
	MOV	AH, MapMask
	OUT     DX, AX

	MOV	DX, x1
	SAR	DX, 3
	MOV	AX, ClipRect.A.x
	SAR	AX, 3
	SUB	AX, DX
	JNL	@@7
	MOV	BH, 0FFH
	JMP	@@8
@@7:	CMP	AX, 2
	JG	@@5
	MOV	BH, AL
@@8:	MOV	AX, ClipRect.B.x
	SAR	AX, 3
	SUB	AX, DX
	JL	@@5
	MOV	DX, BX
	MOV	DL, AL
	XOR	BH, BH

	CMP	DH, 0FFH
	JNZ	@@9
	CMP	DL, 2
	JNA	@@9

	ADD	DI, ActivePOfs		{ unmaskiert }
	PUSH	DS
	MOV	DS, ActivePSeg
@@1:	SEGES LODSW
	MOV	DH, AL
	XOR	DL, DL
	SHR	AX, CL
	SHR	DX, CL
	XCHG	[DI], AH
	XCHG	[DI+1], AL
	XCHG	[DI+2], DL
	ADD	DI, BX
	DEC	CH
	JNZ	@@1
	JMP	@@6

@@9:	MOV	AX, 0FFFFH		{ universelle Maskengenerierung }
	MOV	WORD PTR Mask, AX
	MOV	WORD PTR Mask+2, AX
	PUSH	CX
	PUSH	SI
	MOV	AL, DH
	CMP	AL, 0FFH
	JZ	@@10
	XOR	AH, AH
	MOV	SI, AX
	MOV	CX, ClipRect.A.x
	AND	CL, 7
	MOV	AX, 0FF00H
	SHR	AX, CL
	MOV	BYTE PTR [Mask][SI], AH
	OR	SI, SI
	JZ	@@10
@@11:	DEC	SI
	MOV	BYTE PTR [Mask][SI], 0
	JNZ	@@11
@@10:   MOV	AL, DL
	XOR	AH, AH
	CMP	AX, 2
	JA	@@14
	MOV	SI, AX
	MOV	CX, ClipRect.B.x
	AND	CL, 7
	MOV	AX, 0FF00H
	SHR	AX, CL
	AND	BYTE PTR [Mask][SI], AL
@@13:	INC	SI
	CMP	SI, 2
	JA	@@14
	MOV	BYTE PTR [Mask][SI], 0
	JMP	@@13
@@14:   POP	SI
	POP	CX

	ADD	DI, ActivePOfs
	PUSH	DS
	MOV	DS, ActivePSeg

@@12:	SEGES LODSW			{ Maskiert }
	MOV	DH, AL
	XOR	DL, DL
	SHR	AX, CL
	SHR	DX, CL
	AND	AH, BYTE PTR Mask
	AND	AL, BYTE PTR Mask+1
	AND	DL, BYTE PTR Mask+2
	XCHG	[DI], AH
	XCHG	[DI+1], AL
	XCHG	[DI+2], DL
	ADD	DI, BX
	DEC	CH
	JNZ	@@12

@@6:	POP	DS
@@5:	CALL	RestoreRegs
@@ND:
End;

(******************************* Image routines ****************************)

{$L vmemimg.obj (vmemimg.asm) }

function CompoundImage(Image: PImage): Boolean;
begin
  CompoundImage := Image^.imSizeXm1 = -1
end;

function CompoundSize(Image: PImage): Word;
begin
  CompoundSize := SizeOf(TImage) + (Image^.imCount - 1) * SizeOf(pointer)
end;

function CopyImage(Image: pointer): pointer;
var
  Size: Word;
  Copy: pointer;
  i: Integer;
  Failed: Boolean;
begin
  If Image = nil
  then CopyImage := nil
  else begin
    If CompoundImage(Image)
    then begin
      { Compound Image }
      Size := CompoundSize(Image);
      Copy := MemAlloc(Size);
      If Copy <> nil
      then begin
        Move(Image^, Copy^, Size);
        Failed := false;
        with PImage(Copy)^ do
          For i := 0 to imCount - 1 do
          begin
            If Failed
            then imPtrs[i] := nil
            else begin
              imPtrs[i] := CopyImage(imPtrs[i]);
              Failed := imPtrs[i] = nil
            end
          end;
        If Failed
        then begin
	  FreeImage(Copy);
          Copy := nil
        end;
      end
    end
    else begin
      { Simple Image }
      Size := GetImageSize(Image);
      Copy := MemAlloc(Size);
      If Copy <> nil
      then Move(Image^, Copy^, Size);
    end;
    CopyImage := Copy
  end
end;

function CutImage(x1, y1, x2, y2: Integer): pointer;
var
  Size: LongInt;
  y, ChunkHeight: Integer;
  ChunkSize, ChunkCount: Word;
  Image: PImage;
  p, q: pointer;
  Failed: Boolean;
begin
  Size := ImageLong(x1, y1, x2, y2);
  If Size > ImageChunkSize
  then begin
    ChunkHeight := ((y2 - y1 + 1) * ImageChunkSize) div Size;
    ChunkCount := (y2 - y1 + ChunkHeight) div ChunkHeight;
    Image := MemAlloc(SizeOf(TImage) + (ChunkCount - 1) * SizeOf(pointer));
    If Image <> nil
    then begin
      with Image^ do
      begin
        imSizeXm1 := -1;
        imSizeYm1 := -1;
        imCount := ChunkCount;
        p := @imPtrs;
      end;
      Failed := false;
      while y1 <= y2 do
      begin
        y := y1 + ChunkHeight - 1;
        If y > y2 then y := y2;
	ChunkSize := ImageSize(x1, y1, x2, y);
        q := MemAlloc(ChunkSize);
        If q <> nil
        then GetImage(x1, y1, x2, y, q^)
        else Failed := true;
        pointer(p^) := q;
        Inc(PtrRec(p).Ofs, SizeOf(pointer));
        Inc(y1, ChunkHeight);
      end;
      If Failed
      then begin
        FreeImage(Image);
        Image := nil
      end
    end
  end
  else begin
    Image := MemAlloc(Size);
    If Image <> nil
    then GetImage(x1, y1, x2, y2, Image^);
  end;
  CutImage := Image
end;

procedure FreeImage(Image: pointer);
var
  i: Integer;
Begin
  If Image <> nil
  then begin
    If CompoundImage(Image)
    then begin
      with PImage(Image)^ do
        For i := 0 to imCount - 1 do
          FreeImage(imPtrs[i]);
      FreeMem(Image, CompoundSize(Image))
    end
    else
      FreeMem(Image, GetImageSize(Image))
  end
End;

procedure GetImage(x1, y1, x2, y2: Integer; var BitMap); external;

procedure GetImageExtent(Image: pointer; var Extent: TPoint);
var
  i: Integer;
  P: TPoint;
begin
  Extent.X := 0; Extent.Y := 0;
  If Image <> nil then
  if CompoundImage(Image) then
    with PImage(Image)^ do
      For i := 0 to imCount - 1 do
      begin
        GetImageExtent(imPtrs[i], P);
        If P.X > Extent.X then Extent.X := P.X;
        Inc(Extent.Y, P.Y);
      end
  else
    with Extent do
    begin
      X := PImage(Image)^.imSizeXm1 + 1;
      Y := PImage(Image)^.imSizeYm1 + 1
    end
end;

function GetImageLong(Image: pointer): LongInt; external;
function GetImageSize(Image: pointer): Word; external;
function ImageLong(x1, y1, x2, y2: Integer): LongInt; external;
function ImageSize(x1, y1, x2, y2: Integer): Word; external;

function LoadImage(var S: TStream): pointer;
var
  storedSize, Size: Word;
  Header: TImage;
  Image: pointer;
  Failed: Boolean;
  i: Integer;
Begin
  { Read stored size
  }
  S.Read(storedSize, SizeOf(Word));
  If storedSize = 0
  then begin
    LoadImage := nil;
    Exit
  end;
  { Read header
  }
  S.Read(Header, 2 * SizeOf(Word));
  If CompoundImage(@Header)
  then begin
    GetMem(Image, storedSize);
    LongInt(Image^) := -1;
    S.Read(PImage(Image)^.imCount, SizeOf(TImage) - 2 * SizeOf(Word) - SizeOf(pointer));
    Failed := false;
    with PImage(Image)^ do
      For i := 0 to imCount - 1 do
        If Failed
        then imPtrs[i] := nil
        else begin
          imPtrs[i] := LoadImage(S);
          If imPtrs[i] = nil then Failed := true
        end;
    If Failed
    then begin
      FreeImage(Image);
      LoadImage := nil
    end
    else
      LoadImage := Image
  end
  else begin
    Size := VGAMem.GetImageSize(@Header);
    if storedSize <> Size
    then begin
      { Image must be from wrong graphics mode }
      S.Seek(S.GetPos + storedSize - 2 * SizeOf(Word));
      LoadImage := nil
    end
    else begin
      { Image is OK }
      Image := MemAlloc(Size);
      If Image <> nil
      then begin
        LongInt(Image^) := LongInt(pointer(@Header)^);
        S.Read(PImage(Image)^.imBitmap, storedSize - 2 * SizeOf(Word));
      end
      else
        S.Seek(S.GetPos + storedSize - 2 * SizeOf(Word));
      LoadImage := Image
    end
  end
end;

procedure MaskImage(Src, Dst: pointer); {$ifndef FPK}far;{$endif} external;

function MaskedImage(Image: pointer): pointer;
var
  Dest: pointer;
  Size: Word;
  i: Integer;
begin
  If Image = nil
  then MaskedImage := nil else
  if CompoundImage(Image)
  then begin
    Size := CompoundSize(Image);
    Dest := MemAlloc(Size);
    If Dest <> nil
    then begin
      Move(Image^, Dest^, Size);
      with PImage(Dest)^ do
        For i := 0 to imCount - 1 do
	  If imPtrs[i] <> nil
          then imPtrs[i] := MaskedImage(imPtrs[i]);
    end;
    MaskedImage := Dest
  end
  else begin
    Dest := MemAlloc(GetImageSize(Image));
    If Dest <> nil
    then MaskImage(Image, Dest);
    MaskedImage := Dest
  end
end;

procedure PasteImage(X, Y: Integer; Image: pointer; BitBlt: Word);
var
  Extent: TPoint;
  i: Integer;
begin
  If Image <> nil then
  if CompoundImage(Image) then
    with PImage(Image)^ do
      For i := 0 to imCount - 1 do
      begin
	PasteImage(X, Y, imPtrs[i], BitBlt);
	GetImageExtent(imPtrs[i], Extent);
	Inc(Y, Extent.Y);
      end
  else
    PutImage(X, Y, Image^, BitBlt)
end;

procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word); external;

procedure StoreImage(var S: TStream; Image: pointer);
var
  Size: Word;
  i: Integer;
begin
  If Image = nil
  then begin
    size := 0;
    S.Write(size, SizeOf(Word))
  end else
  if CompoundImage(Image)
  then begin
    size := CompoundSize(Image);
    S.Write(size, SizeOf(Word));
    S.Write(Image^, SizeOf(TImage) - SizeOf(pointer));
    with PImage(Image)^ do
      For i := 0 to imCount - 1 do
        StoreImage(S, imPtrs[i]);
  end
  else begin
    size := GetImageSize(Image);
    S.Write(size, SizeOf(Word));
    S.Write(Image^, size)
  end
end;

(***************************************************************************)

function StoreScreen(x1, y1, x2, y2: Integer): PScreenBuf;
var
  s: LongInt;
  Handle: Word;
  p: pointer;
  SaveOrigin: TPoint;

 procedure NewScreenBuf(AMode: Word; AnInfo: LongInt);
 var
   p: PScreenBuf;
 Begin
   New(p);
   with p^ do Begin
     Mode := AMode;
     Size := s;
     Rect.Assign(x1, y1, x2, y2);
     Info := AnInfo
   End;
   StoreScreen := p
 End;

Begin
  { Rest video memory }
  s := GetSize(x1, y1, x2, y2);
  Handle := GetVgaMem(s);
  If Handle <> 0 then Begin
    SaveScreen(x1, y1, x2, y2, Handle);
    NewScreenBuf(1, Handle);
    Exit
  End;
  { General Images }
  s := 0;
  SaveOrigin := DrawOrigin;
  SetDrawOrigin(0, 0);
  p := CutImage(x1, y1, x2-1, y2-1);    { will use compound image if needed }
  SetDrawOriginP(SaveOrigin);
  If p <> nil
  then NewScreenBuf(2, LongInt(p))
  else StoreScreen := nil
End;

procedure FreeScreenBuf(Buf: PScreenBuf);
Begin
  If Buf <> nil then Begin
    with Buf^ do
    case Mode of
      1: FreeVgaMem(Info, Size);
      2: FreeImage(pointer(Info));
    end;
    Dispose(Buf)
  End
End;

procedure DrawScreenBufAt(Buf: PScreenBuf; x3, y3: Integer);
var
  SaveOrigin: TPoint;
Begin
  If Buf <> nil then
  with Buf^ do
  case Mode of
    1:
      with Rect do
	RestoreScreen(A.x, A.y, B.x, B.y, x3, y3, Info);
    2:
      begin
	SaveOrigin := DrawOrigin;
	SetDrawOrigin(0, 0);
	PasteImage(x3, y3, pointer(Info), NormalPut);
	SetDrawOriginP(SaveOrigin);
      end
  end
End;

procedure DrawScreenBuf(Buf: PScreenBuf);
Begin
  If Buf <> nil then
  with Buf^.Rect.A do
    DrawScreenBufAt(Buf, x, y)
End;

(********************** Verwaltung des freien Speichers ********************)

function GetVGAMem(Size: Word): Word; assembler;
Asm
	LES	SI, BlockList
	mov	ax, es
	or	ax, si
	jz	@@8

	MOV	BX, SI
	MOV	AH, 9
	MOV	DX, Size
	MOV	CX, ListSize
@@7:	PUSH	CX
	MOV	CX, 8
	SEGES LODSB
@@3:	SHL	AL, 1
	JC	@@1
	DEC	DX
	JZ	@@4
	JMP	@@2
@@1:	MOV	DX, Size
	MOV	BX, SI			{ Adresse speichern }
	MOV	AH, CL			{ Bitpos speichern }
@@2:	LOOP	@@3
	POP	CX
	LOOP	@@7
	XOR	AX, AX			{ Kein Platz }
	JMP	@@8
@@4:	DEC	AH			{ Korrigieren }
	JZ	@@11
	CMP	AH, 8
	JNZ	@@5
	JMP	@@6
@@11:	MOV	AH, 8
	JMP	@@6
@@5:	DEC	BX
@@6:    MOV	DI, BX
	MOV	SI, WORD PTR BlockList
	SUB	SI, DI
	NEG	SI
	SHL	SI, 3
	ADD	SI, VgaMemSeg
	SUB	SI, Page0Seg
	MOV	DX, Size		{ Bereich mit 1 fllen }
	MOV	CL, AH
	XOR	CH, CH
	SUB	SI, CX
	ADD	SI, 8
	CMP	CX, DX
	JA	@@9
	MOV	BX, 01FFH		{ Linke Randmaske }
	SHL	BX, CL			{ CL Bits bereitstellen }
	OR	[ES:DI], BH
	INC	DI
	SUB	DX, CX
	MOV	CX, DX			{ mittlere Bytes }
	SHR	CX, 3
	MOV	AL, 0FFH
	REP STOSB
	AND	DL, 7
	MOV	CL, DL
	MOV	AX, 0FF00H
	SHR	AX, CL
	OR	[ES:DI], AL
	JMP	@@10
@@9:	MOV	AX, 00FFH
	XCHG	CL, DL
	SHL	AX, CL
	SUB	CL, DL
	NEG	CL
	SHL	AH, CL
	OR	[ES:DI], AH
@@10:	MOV	AX, SI
@@8:
End;

procedure FreeVGAMem(P, Size: Word); assembler;
Asm
	LES	DI, BlockList
	mov	ax, es
	or	ax, di
	jz	@@8

	MOV	CX, P
	ADD	CX, Page0Seg
	SUB	CX, VgaMemSeg
	MOV	AX, CX
	SHR	AX, 3
	AND	CL, 7
	ADD	DI, AX
	SUB	CL, 8
	NEG	CL
	MOV	DX, Size		{ Bereich mit 0 fllen }
	XOR	CH, CH
	CMP	CX, DX
	JA	@@9
	MOV	BX, 00FFH		{ Linke Randmaske }
	SHL	BX, CL			{ CL Bits bereitstellen }
	NOT	BH
	AND	[ES:DI], BH
	INC	DI
	SUB	DX, CX
	MOV	CX, DX			{ mittlere Bytes }
	SHR	CX, 3
	XOR	AL, AL
	REP STOSB
	AND	DL, 7
	MOV	CL, DL
	MOV	AX, 0FF00H
	SHR	AX, CL
	NOT	AL
	AND	[ES:DI], AL
	JMP	@@10
@@9:	MOV	AX, 00FFH
	XCHG	CL, DL
	SHL	AX, CL
	SUB	CL, DL
	NEG	CL
	SHL	AH, CL
	NOT	AH
	AND	[ES:DI], AH
@@10:	MOV	AX, SI
@@8:
End;

procedure ClearBuf(Mem, Size: Word); assembler;
Asm
	CALL	SaveRegs
	MOV	AX, Page0Seg
	ADD	AX, Mem
	PUSH	AX
	PUSH	0
	CALL	SelOfs
	MOV	ES, DX
	MOV	DI, AX
	MOV	DX, 03CEH
	MOV	AX, 0001H
	OUT	DX, AX
	MOV	AX, 0003H
	OUT	DX, AX
	MOV	AX, 0FF08H
	OUT	DX, AX
	MOV	AX, 0005H
	OUT	DX, AX
	MOV	DX, 03C4H
	MOV	AX, 0F02H
	MOV	CX, Size
	SHL	CX, 3
	XOR	AX, AX
	REP
	STOSW
	CALL	RestoreRegs
End;

function PrepBuf;
Begin
  PrepBuf := false;
  with Buf do Begin
    Bounds.Copy(R);
    with R do
      Size := GetSize(A.x, A.y, B.x, B.y);
    If Size = 0 then Exit;
    Mem := GetVgaMem(size);
    If Mem = 0 then Exit;
    with R do Begin
      case Action of
	pbNone:  ;
	pbCopy:  SaveScreen(A.x, A.y, B.x, B.y, Mem);
	pbClear: ClearBuf(Mem, Size);
      end;
      with DrawOrigin do Begin
	If GrFlags and gf256 = 0
	then x := - (A.x and $FFF8)
	else x := - A.x;
	y := - A.y;
	with ClipRect do Begin
	  Copy(R);
	  Move(x, y)
	End
      End;
      BytesPerLine := GetBPL(A.x, B.x);
    End;
    ActiveSeg := Page0Seg + Mem;
    SetActivePage(2);
  End;
  PrepBuf := true
End;

procedure EndBufDraw;
Begin
  BytesPerLine := RealBytesPerLine;
  SetActivePage(0);
End;

procedure ReleaseBuf;
Begin
  with Buf do
    FreeVgaMem(Mem, Size);
End;

procedure PasteRect;
Begin
  with Buf do Begin
    ClipRect.Copy(R);
    with Bounds do
      RestoreScreen(A.x, A.y, B.x, B.y, A.x, A.y, Mem)
  End;
End;

procedure PasteRectAt;
Begin
  with Buf do Begin
    ClipRect.Copy(R);
    with Bounds do
      RestoreScreen(A.x, A.y, B.x, B.y, P.x, P.y, Mem)
  End;
End;

{ Management
}

procedure CopyTable(Ofs: Word); assembler;
asm
	mov	si, Ofs
	mov	cx, TYPE VgaMemProcs / 2
	mov	ax, ds
	mov	es, ax
	mov	di, OFFSET VgaMemProcs
	cld
	segcs
	rep	movsw
end;

procedure VgaMemTable(Flags: Word);
Begin
  If Flags and gf256 <> 0
  then CopyTable(Ofs(Table_256))
  else CopyTable(Ofs(Table_16));
End;

procedure VgaMemInitGraphics;
var
  x: LongInt;
  y: record Seg: Word; Size: Word end absolute x;
Begin
  If GrActive then Begin
    VgaMemTable(GrFlags);

    If GrFlags and gfMap <> 0
    then RealCaps := VgaMemProcs._CapsMap
    else RealCaps := VgaMemProcs._CapsNoMap;
    Caps := RealCaps;

{ Copy emulation support
}
    (*If Caps and (vmcSaveRestore + vmcCopy + vmcImage)
       <> (vmcSaveRestore + vmcCopy + vmcImage)
    then begin
      GetTempMem(VgaMemHandle, {ImageSize(0, 0, SizeX - 1, 0)} 32768);
      Caps := Caps or (vmcCopy {+ vmcSaveRestore})
    end;*)

    If Caps and vmcSaveRestore <> 0
    then begin
      SavedFree := GetFreeSegs;
      x := ReserveSegs(-1);
      ListSize := (y.Size + 7) div 8;
      VgaMemSeg := y.Seg;
      GetMem(BlockList, ListSize);
      FillChar(BlockList^, ListSize, 0);
    end
    else
      BlockList := nil;
  End
  else VgaMemTable(0)
End;

procedure VgaMemCloseGraphics;
Begin
  If BlockList <> nil then Begin
    FreeMem(BlockList, ListSize);
    BlockList := nil;
    SetFreeSegsBack(SavedFree);
  End;
  GetTempMem(VgaMemHandle, 0)
End;

function NotifyVgaMem(Notice: Word; Info: LongInt): LongInt; {$ifndef FPK}far;{$endif}
Begin
  case Notice of
    gnpInitGraphics:
      VgaMemInitGraphics;
    gnpCloseGraphics:
      VgaMemCloseGraphics;
  end;
  NotifyVgaMem := DefaultNotify(Notice, Info, NotifyVgaMem, NextNotify, 20)
End;

procedure InitVGAMem;
Begin
  VgaMemInitGraphics;
  InstallNotifyProc(GrNotifyProc, NotifyVgaMem)
End;

procedure InitVgaMan;
begin
  InitVGAMem
end;

procedure DoneVGAMem;
Begin
  UnInstallNotifyProc(GrNotifyProc, NotifyVgaMem);
  VgaMemCloseGraphics
End;

procedure DoneVgaMan;
begin
  DoneVgaMem
end;

function GetVgaMemCaps: Word;
begin
  GetVgaMemCaps := Caps
end;

Begin
  Copyright;
  VgaMemTable(0)
{$endif}
{$endif}
End.
