unit WMF;

{$MODE OBJFPC}
{$M+}

// MIME content-type "application/x-msmetafile".
// MIME content-type: application/x-msmetafile, application/x-wmf, image/x-wmf, image/x-win-metafile, zz-application/zz-winassoc-wmf

// FIXME signed/unsigned.
// TODO check checksums.

// Die Maßeinheit der WMF-Objekte ist ein twip (twentieth of a point = 1/1440 Zoll).

interface
uses classes, type_fixes, contnrs;

{$PACKRECORDS C}
{$MINENUMSIZE 2}
{$DEFINE in_interface}
{$INCLUDE on-disk/INC/head.INC}
{$UNDEF in_interface}

type
{
TODO vorne: weiterer 22 Byte großer Header. 
Dieser beginnt mit der Zeichenkette 9ac6cdd7 (hexadezimal) und enthält Informationen, die benötigt werden, um die WMF-Datei zwischen verschiedenen Applikationen auszutauschen.
}

  TOperator =    (
                  opEndOfFile = 0,
                  opSaveDC = $001E,
                  opRealizePalette = $0035,
                  opSetPaletteEntries = $0037,
                  opCreatePalette = $00F7,
                  opSetBkMode = $0102,
                  opSetMapMode = $0103,
                  opSetRop2 = $0104,
                  opSetRelAbs = $0105, // ????
                  opSetPolyFillMode = $0106, // 4
                  opSetStretchBLTMode = $0107, // 3
                  opSetTextCharExtra = $0108, // 4
                  opRestoreDC = $0127,
                  opInvertRegion = $012A, // 4
                  opPaintRegion = $012B, // 4
                  opSelectClipRegion = $012C, // 4
                  opSelectObject = $012D,
                  opSetTextAlign = $012E,
                  opResizePalette = $0139,
                  opDeleteObject = $01F0,
                  opCreatePatternBrush = $01F9,
                  opSetBkColor = $0201,
                  opSetTextColor = $0209,
                  opSetTextJustification = $020A, // 4
                  opSetWindowOrg = $020B,
                  opSetWindowExt = $020C,
                  opSetViewportOrg = $020D, // 4
                  opSetViewportExt = $020E, // 4
                  opOffsetWindowOrg = $020F, // 4
                  opOffsetViewportOrg = $0211, // 4 // ????
                  opLineTo = $0213,
                  opMoveTo = $0214,
                  opOffsetClipRGN = $0220,
                  opFillRegion = $0228,
                  opSetMapperFlags = $0231, // 3
                  opSelectPalette = $0234,
                  opCreatePenIndirect = $02FA,
                  opCreateFontIndirect = $02FB, // no.
                  opCreateBrushIndirect = $02FC,
                  opPolygon = $0324,
                  opPolyline = $0325,
                  opScaleWindowExt = $0410, // 4
                  opScaleViewportExt = $0412, // 4
                  opExcludeClipRect = $0415,
                  opIntersectClipRect = $0416,
                  opEllipse = $0418,
                  opFloodFill = $0419, // 4
                  opRectangle = $041B,
                  opSetPixel = $041F,
                  opFrameRegion = $0429,
                  opAnimatePalette = $0436,
                  opTextOut = $0521,
                  opPolyPolygon = $0538,
                  opExtFloodFill = $0548, // 4
                  opRoundRect = $061C,
                  opPatBLT = $061D, // 4, 6
                  opEscape = $0626, // 5
                  opCreateRegion = $06FF, // 4
                  opArc = $0817,
                  opPie = $081A,
                  opChord = $0830,
                  opBitBLT = $0922,
                  opDIBBitBLT = $0940, // 7
                  opExtTextOut = $0A32,
                  opStretchBLT = $0B23, // 7
                  opDIBStretchBlt = $0B41, // 7
                  opSetDIBToDev = $0D33, // 4
                  opStretchDIB = $0F43
);

{
2 What on earth is this ?
3 Personally considered unimportant, to be dealt with at my leisure.
4 Untested
5 Has no effect on the output of the wmf file.
6 Full support pending palette handling.
7 Uses ROP, see ROP SUPPORT.
}

// libwmf, <Caolan.McNamara@ul.ie>.

type
  TDCObjects = class
  private
    fList : TObjectList;
  protected
    function GetItem(aIndex : TCardinal) : TObject; inline;
    function GetItemCount() : TCardinal; inline;
  published
    constructor Create();
  public
    destructor Destroy(); override;
  published
    function Store(aItem : TObject) : TCardinal;
    procedure Remove(aItem : TObject);
  public
    property Item[aIndex : TCardinal] : TObject read GetItem;
    property ItemCount : TCardinal read GetItemCount;
  end;

implementation
uses sysutils;

procedure Ensure(aTruth : TBoolean); inline;
begin
  if not aTruth then
    raise EReadError.Create('validation failed.');
end;

{$DEFINE in_implementation}
{$INCLUDE on-disk/INC/head.INC}
{$UNDEF in_implementation}

// array size $0C00

type
  TType = (tyINT16, tyINT32, tyCOLORREF{32bit}, tyPOINT32, tySIZE32, tyObjectNr);
  TParameterReader = function(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
  TTypeArray = array of TType;
  TCommandDeclaration = record
    Opcode : TOperator;
    ParameterTypes : TTypeArray; // implies count. In normal FUNCall order, without the HDC.
    ParameterReader : TParameterReader; // can be NIL is ParameterTypes is valid.
    // TODO function...
  end;
  TInstruction = record
    Opcode : TOperator;
    Arguments : array of TINT16;
    // TODO other args.
  end;

var
  CommandDeclarations : array[0..$0FFF] of TCommandDeclaration;

procedure AddCommandDeclaration(aOpcode : TOperator; aParameterReader : TParameterReader); overload;
begin
  assert(Integer(CommandDeclarations[Integer(aOpcode)].Opcode) = 0); // not used yet.
  with CommandDeclarations[Integer(aOpcode)] do begin
    Opcode := aOpcode;
    SetLength(ParameterTypes, 0);
    ParameterReader := aParameterReader;
  end;
end;

procedure AddCommandDeclaration(aOpcode : TOperator; aParameterTypes : array of TType); overload;
var
  fParameterIndex : Integer;
begin
  assert(Integer(CommandDeclarations[Integer(aOpcode)].Opcode) = 0); // not used yet.
  with CommandDeclarations[Integer(aOpcode)] do begin
    Opcode := aOpcode;
    SetLength(ParameterTypes, Length(aParameterTypes));

    if Length(aParameterTypes) > 0 then
      for fParameterIndex := Low(aParameterTypes) to High(aParameterTypes) do
        ParameterTypes[fParameterIndex - Low(aParameterTypes)] := aParameterTypes[fParameterIndex];
    
    // = ParameterTypes := aParameterTypes;
    
    ParameterReader := nil;
  end;
end;


{

|32bit size of total record|0x041B |bottom|right|top|left|
  ^^in words.

note that for 16 bit WMF, the 16 bit Windows API calls are used and the fields "bottom", "right", "top" and "left" are each 16 bits long.

magic:
0       ('0xd7', '0xcd', '0xc6', '0x9a')
0       (2, 0, 9, 0)
0       (1, 0, 11, 0)

}

function LoadInstruction(aStream : TStream) : TInstruction;
var
  fSizeR : TSizeR;
  fSize : TUINT32;
  fRawRecord : array of TByte;
begin
  Load(aStream, fSizeR);
  fSize := fSizeR.Size;
  if fSize < 2 then
    raise EReadError.Create('Windows Metafile instruction size is invalid.');
    
  Dec(fSize, 2); // skip the size field.
  if fSize > $7FFF then
    raise EReadError.Create('Windows Metafile instruction is too big.');
  fSize := fSize shl 1; // in bytes now.
  SetLength(fRawRecord, fSize);
  aStream.ReadBuffer(fRawRecord[0], fSize);
  if fSize < 1 then
    raise EReadError.Create('Windows Metafile instruction is too small.');
    
  SetLength(Result.Arguments, 0);
  
  // FIXME TOperator args...

  Result.Opcode := TOperator(fRawRecord[0]);
{   TInstruction = record
       Opcode : TOperator;
           Arguments : array of TINT16;
               // TODO other args.
                 end;
}
end;

procedure LoadFile(aStream : TStream); // FIXME result.
var
  fMagicHeaderR : TMagicHeaderR;
  fPlaceableHeaderR : TPlaceableHeaderR;
  fHeaderR : THeaderR;
  //fObjectIndex : TUINT16;
  fInstruction : TInstruction;
  //ObjectCount
  // RecordSizeMaximum
begin
  Load(aStream, fMagicHeaderR);
  if fMagicHeaderR.Magic = $9AC6CDD7 then begin
    Load(aStream, fPlaceableHeaderR); // TODO optional.
    Load(aStream, fMagicHeaderR);
  end;
  if fMagicHeaderR.Magic = $9AC6CDD7 then
    raise EReadError.Create('Windows Metafile contained more than one placeable header.'); // not again...

  Load(aStream, fHeaderR);
  {if fHeaderR.ObjectCount > 0 then
    for fObjectIndex := 0 to fHeaderR.ObjectCount - 1 do 
      ;
  }
  repeat
    fInstruction := LoadInstruction(aStream);
    // FIXME store...
  until fInstruction.Opcode = opEndOfFile;
end;

function SkipArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadPolygonArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadTextOutArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME [tyINT16, tyINT16, string, tyINT16]
  Result := nil;
end;
 
function ReadPolylineArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadExtTextOutArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadSetDIBToDevArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadPolyPolygonArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadDIBBitBLTArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadDIBStretchBLTArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadExtFloodFillArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadCreateRegionArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadStretchDIBArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

function ReadSetTextJustificationArgs(aInputFile : TStream; aRemainderSize : TCardinal; aOpCode : TOperator) : TList; // of object;
begin
  // FIXME
  Result := nil;
end;

{ TDCObjects }

constructor TDCObjects.Create();
begin
  fList := TObjectList.Create(True);
end;

destructor TDCObjects.Destroy();
begin
  FreeAndNil(fList);
  inherited Destroy();
end;

function TDCObjects.GetItem(aIndex : TCardinal) : TObject;
begin
  Result := fList[aIndex];
end;

function TDCObjects.GetItemCount() : TCardinal;
begin
  Result := fList.Count;
end;

function TDCObjects.Store(aItem : TObject) : TCardinal;
var
  fIndex : TCardinal;
begin
  if fList.Count > 0 then
    for fIndex := 0 to fList.Count - 1 do begin
      if fList[fIndex] = nil then begin
         fList[fIndex] := aItem;
         Result := fIndex;
         Exit;
      end;
    end;

  Result := fList.Count;
  fList.Add(aItem);
end;

procedure TDCObjects.Remove(aItem : TObject);
var
  fIndex : TCardinal;
begin
  if fList.Count > 0 then
    for fIndex := 0 to fList.Count - 1 do begin
      if fList[fIndex] = aItem then begin
        fList[fIndex].Free();
        fList[fIndex] := nil;
        Exit;
      end;
    end;
end;


initialization
  {$ASSERTIONS ON}
  assert(Sizeof(TPlaceableHeaderR) = 22 - 4{magic});
  assert(Sizeof(THeaderR) = 18 - 4{magic});

  AddCommandDeclaration(opSetBkColor, [tyCOLORREF]);
  AddCommandDeclaration(opSetBkMode, [tyINT16]);
  AddCommandDeclaration(opSetMapMode, [tyINT16]);
  AddCommandDeclaration(opSetROP2, [tyINT16]);
  AddCommandDeclaration(opSetPolyFillMode, [tyINT16]);
  AddCommandDeclaration(opSetStretchBLTMode, [tyINT16]);
  AddCommandDeclaration(opSetTextColor, [tyCOLORREF]);
  AddCommandDeclaration(opSetTextCharExtra, [tyINT16]);
  AddCommandDeclaration(opSetWindowOrg, [tyINT16, tyINT16]);
  AddCommandDeclaration(opSetWindowExt, [tyINT16, tyINT16]);
  AddCommandDeclaration(opSetViewportOrg, [tyINT16, tyINT16]);
  AddCommandDeclaration(opSetViewportExt, [tyINT16, tyINT16]);
  AddCommandDeclaration(opOffsetWindowOrg, [tyINT16, tyINT16]); // diff
  AddCommandDeclaration(opScaleWindowExt, [tyINT16, tyINT16, tyINT16, tyINT16]); // XNum, XDenom, YNum, YDenom.
  AddCommandDeclaration(opOffsetViewportOrg, [tyINT16, tyINT16]); // diff
  AddCommandDeclaration(opScaleViewportExt, [tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opLineTo, [tyINT16, tyINT16]);
  AddCommandDeclaration(opMoveTo, [tyINT16, tyINT16]);
  AddCommandDeclaration(opExcludeClipRect, [tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opIntersectClipRect, [tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opArc, [tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opEllipse, [tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opFloodFill, [tyINT16, tyINT16, tyCOLORREF]);
  AddCommandDeclaration(opPie, [tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opRectangle, [tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opRoundRect, [tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16]);
  AddCommandDeclaration(opPatBLT, [tyINT16, tyINT16, tyINT16, tyINT16, tyINT32]);
  AddCommandDeclaration(opSaveDC, []);
  AddCommandDeclaration(opSetPixel, [tyINT16, tyINT16, tyCOLORREF]);
  AddCommandDeclaration(opOffsetClipRGN, [tyINT16, tyINT16]);
  AddCommandDeclaration(opPolygon, @ReadPolygonArgs); // count, x,y, ...
  AddCommandDeclaration(opPolyline, @ReadPolylineArgs); // count, x,y, ...
  AddCommandDeclaration(opEscape, @SkipArgs); // ?!?!             opEscape, $0626, // 5
  AddCommandDeclaration(opRestoreDC, [tyINT16]); // level
  AddCommandDeclaration(opFillRegion, [tyObjectNr, tyObjectNr]); // region, brush. FIXME order?
  AddCommandDeclaration(opFrameRegion, [tyObjectNr, tyObjectNr, tyINT16, tyINT16]);
  AddCommandDeclaration(opInvertRegion, [tyObjectNr]); // region
  AddCommandDeclaration(opPaintRegion, [tyObjectNr]); // region.
  AddCommandDeclaration(opSelectClipRegion, [tyObjectNr]); // region.
  AddCommandDeclaration(opSelectObject, [tyObjectNr]); // OBJ_PEN,OBJ_BRUSH,OBJ_PAL,OBJ_FONT & OBJ_REGION
  AddCommandDeclaration(opSetTextAlign, [tyINT16]);
  AddCommandDeclaration(opChord, [tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16, tyINT16]); // like arc, but not auto-closed.
  //AddCommandDeclaration(opSetMapperFlags, SkipArgs); // something related to fonts.
  AddCommandDeclaration(opTextOut, @ReadTextOutArgs); // x,y, string, length
  AddCommandDeclaration(opExtTextOut, @ReadExtTextOutArgs);
  AddCommandDeclaration(opSetDIBToDev, @ReadSetDIBToDevArgs); // 4
  AddCommandDeclaration(opPolyPolygon, @ReadPolyPolygonArgs);
  AddCommandDeclaration(opDIBBitBLT, @ReadDIBBitBLTArgs); // 7
  AddCommandDeclaration(opDIBStretchBLT, @ReadDIBStretchBLTArgs); // 7
  AddCommandDeclaration(opExtFloodFill, @ReadExtFloodFillArgs); // 4
  AddCommandDeclaration(opDeleteObject, [tyObjectNr]);
  AddCommandDeclaration(opCreatePenIndirect, [tyCOLORREF, tyINT16, tyINT16]);
  // unsupported: opCreateFontIndirect.
  AddCommandDeclaration(opCreateBrushIndirect, [tyINT16, tyCOLORREF, tyINT16]);
  AddCommandDeclaration(opCreateRegion, @ReadCreateRegionArgs); // 4
  AddCommandDeclaration(opStretchDIB, @ReadStretchDIBArgs);
  AddCommandDeclaration(opSetTextJustification, @ReadSetTextJustificationArgs); // 4
//These opcodes are not seen in the wild, so realworld instances of these are welcome, they all appear to get translated into the equivalent that is prefixed with DIB
     //opBitBLT = $0922,
     //opStretchBLT = $0B23, // 7
     //opCreatePatternBrush = $01F9,
//These opcodes are all related to palettes, and i dont think they matter at all, information to the contrary is welcome, these are only implemented to the degree that they dont mess up object counting
     //opSelectPalette = $0234,
     //opRealizePalette = $0035,
     //opAnimatePalette = $0436,
     //opSetPALEntries = $0037,
     //opResizePalette = $0139,
     //opCreatePalette = $00f7,
//These opcodes are unimplemented, for the reason that i dont know what they are, no known documentation
//     opSetRelAbs = $0105


end.