// // This unit is part of the GLScene Engine, http://glscene.org // (*------------------------------------------------------------------------------- Unit Name: Lightwave Author: Brian Johns brianjohns1@hotmail.com Purpose: Lightwave object support unit for Delphi. Notes: For the Lightwave Object File Format documentation please refer to http://www.lightwave3d.com/developer. License: This unit is distributed under the Mozilla Public License. For license details, refer to http://www.mozilla.org Lightwave3D is a registered trademark of Newtek Incorporated. -------------------------------------------------------------------------------*) unit FileLWObjects; interface {$I GLScene.inc} uses System.Classes, System.SysUtils, System.Math, GLVectorGeometry; type TID4 = array[0..3] of AnsiChar; PID4 = ^TID4; TID4DynArray = array of TID4; const ID_NULL = '#0#0#0#0'; // NULL ID ID_LWSC: TID4 = 'LWSC'; // Lightwave scene file ID_FORM: TID4 = 'FORM'; // IFF Form ID_LWOB: TID4 = 'LWOB'; // Lightwave Object version 1.0 - 5.x ID_LWLO: TID4 = 'LWLO'; // Lightwave Layered Object ID_LAYR: TID4 = 'LAYR'; // LAYER ID_PNTS: TID4 = 'PNTS'; // Points chunk ID_SRFS: TID4 = 'SRFS'; // Surface Names chunk ID_POLS: TID4 = 'POLS'; // Polygons chunk ID_CRVS: TID4 = 'CRVS'; // Curves chunk ID_PCHS: TID4 = 'PCHS'; // Patches chunk ID_SURF: TID4 = 'SURF'; // Surfaces chunk ID_COLR: TID4 = 'COLR'; // Color chunk ID_FLAG: TID4 = 'FLAG'; // Surface Flags ID_LUMI: TID4 = 'LUMI'; // Luminosity ID_DIFF: TID4 = 'DIFF'; // Diffuse ID_SPEC: TID4 = 'SPEC'; // Specular ID_REFL: TID4 = 'REFL'; // Reflective ID_TRAN: TID4 = 'TRAN'; // Transparency ID_VLUM: TID4 = 'VLUM'; // Luminosity ID_VDIF: TID4 = 'VDIF'; // Diffuse ID_VSPC: TID4 = 'VSPC'; // Specularity ID_VRFL: TID4 = 'VRFL'; // Reflective ID_VTRN: TID4 = 'VTRN'; // Transparency ID_GLOS: TID4 = 'GLOS'; // Glossiness SmallInt ID_SIDE: TID4 = 'SIDE'; // Sidedness ID_RFLT: TID4 = 'RFLT'; // REFLECTION MODE (PRE 6.0) ID_RFOP: TID4 = 'RFOP'; // REFLECTION OPTIONS ID_RIMG: TID4 = 'RIMG'; // REFLECTION IMAGE ID_RSAN: TID4 = 'RSAN'; // REFLECTION MAP SEAM ANGLE ID_RIND: TID4 = 'RIND'; // REFRACTIVE INDEX ID_EDGE: TID4 = 'EDGE'; // EDGE TRANSPARENCY THRESHOLD ID_SMAN: TID4 = 'SMAN'; // SMOOTHING ANGLE RADIANS ID_ALPH: TID4 = 'ALPH'; // ALPHA MODE ID_CTEX: TID4 = 'CTEX'; // COLOR TEXTURE ID_DTEX: TID4 = 'DTEX'; // DIFFUSE TEXTURE ID_STEX: TID4 = 'STEX'; // SPECULAR TEXTURE ID_RTEX: TID4 = 'RTEX'; // REFLECTIION TEXTURE ID_TTEX: TID4 = 'TTEX'; // TRANSPARENCY TEXTURE ID_LTEX: TID4 = 'LTEX'; // LUMINANCE TEXTURE ID_BTEX: TID4 = 'BTEX'; // BUMP TEXTURE ID_TFLG: TID4 = 'TFLG'; // TEXTURE FLAGS ID_TSIZ: TID4 = 'TSIZ'; // TEXTURE SIZE ID_TCTR: TID4 = 'TCTR'; // TEXTURE CENTER ID_TFAL: TID4 = 'TFAL'; // TEXTURE FALLOFF ID_TVEL: TID4 = 'TVAL'; // TEXTURE VALUE ID_TREF: TID4 = 'TREF'; // TEXTURE REFERENCE ID_TCLR: TID4 = 'TCLR'; // TEXTURE COLOR ID_TVAL: TID4 = 'TVAL'; // TEXTURE VALUE ID_TAMP: TID4 = 'TAMP'; // TEXTURE AMPLITUDE ID_TFP0: TID4 = 'TFP0'; // TEXTURE PARAMETERS ID_TFP1: TID4 = 'TFP1'; // ID_TFP2: TID4 = 'TFP2'; // ID_TIP0: TID4 = 'TIP0'; // ID_TIP1: TID4 = 'TIP1'; // ID_TIP2: TID4 = 'TIP2'; // ID_TSP0: TID4 = 'TSP0'; // ID_TSP1: TID4 = 'TSP1'; // ID_TSP2: TID4 = 'TSP2'; // ID_TFRQ: TID4 = 'TFRQ'; // ID_TIMG: TID4 = 'TIMG'; // TEXTURE IMG ID_TALP: TID4 = 'TALP'; // ID_TWRP: TID4 = 'TWRP'; // TEXTURE WRAP ID_TAAS: TID4 = 'TAAS'; // ID_TOPC: TID4 = 'TOPC'; // ID_SHDR: TID4 = 'SHDR'; // ID_SDAT: TID4 = 'SDAT'; // ID_IMSQ: TID4 = 'IMSQ'; // IMAGE SEQUENCE ID_FLYR: TID4 = 'FLYR'; // FLYER SEQUENCE ID_IMCC: TID4 = 'IMCC'; // SURF_FLAG_LUMINOUS = 1; SURF_FLAG_OUTLINE = 2; SURF_FLAG_SMOOTHING = 4; SURF_FLAG_COLORHIGHLIGHTS = 8; SURF_FLAG_COLORFILTER = 16; SURF_FLAG_OPAQUEEDGE = 32; SURF_FLAG_TRANSPARENTEDGE = 64; SURF_FLAG_SHARPTERMINATOR = 128; SURF_FLAG_DOUBLESIDED = 256; SURF_FLAG_ADDITIVE = 512; SURF_FLAG_SHADOWALPHA = 1024; CURV_CONTINUITY_FIRST = 1; CURV_CONTINUITY_LAST = 2; IMSQ_FLAG_LOOP = 1; IMSQ_FLAG_INTERLACE = 2; ID_LWO2: TID4 = 'LWO2'; // OBJECT ID_VMAP: TID4 = 'VMAP'; // VERTEX MAP ID_TAGS: TID4 = 'TAGS'; // TAGS? ID_PTAG: TID4 = 'PTAG'; // POLYGON TAG MAP ID_VMAD: TID4 = 'VMAD'; // DISCONTINUOUS VERTEX MAP ID_ENVL: TID4 = 'ENVL'; // ENVELOPE ID_CLIP: TID4 = 'CLIP'; // CLIP ID_BBOX: TID4 = 'BBOX'; // BOUNDING BOX ID_DESC: TID4 = 'DESC'; // DESCRIPTION ID_TEXT: TID4 = 'TEXT'; // TEXT ID_ICON: TID4 = 'ICON'; // ICON ENVL_PRE: TID4 = 'PRE'#0; // PRE-BEHAVIOUR ENVL_POST: TID4 = 'POST'; // POST ENVL_KEY: TID4 = 'KEY'#0; // KEY ENVL_SPAN: TID4 = 'SPAN'; // SPAN ENVL_CHAN: TID4 = 'CHAN'; // CHAN ENVL_NAME: TID4 = 'NAME'; // NAME ID_STIL: TID4 = 'STIL'; // STILL IMAGE FILENAME ID_ISEQ: TID4 = 'ISEQ'; // IMAGE SEQUENCE ID_ANIM: TID4 = 'ANIM'; // PLUGIN ANIMATION ID_STCC: TID4 = 'STCC'; // COLOR CYCLING STILL ID_CONT: TID4 = 'CONT'; // CONTRAST ID_BRIT: TID4 = 'BRIT'; // BRIGHTNESS ID_SATR: TID4 = 'SATR'; // SATURATION ID_HUE: TID4 = 'HUE'#0; // HUE ID_GAMMA: TID4 = 'GAMM'; // GAMMA ID_NEGA: TID4 = 'NEGA'; // NEGATIVE IMAGE ID_IFLT: TID4 = 'IFLT'; // IMAGE PLUG-IN FILTER ID_PFLT: TID4 = 'PFLT'; // PIXEL PLUG-IN FILTER POLS_TYPE_FACE: TID4 = 'FACE'; // FACES POLS_TYPE_CURV: TID4 = 'CURV'; // CURVE POLS_TYPE_PTCH: TID4 = 'PTCH'; // PATCH POLS_TYPE_MBAL: TID4 = 'MBAL'; // METABALL POLS_TYPE_BONE: TID4 = 'BONE'; // SKELEGON? VMAP_TYPE_PICK: TID4 = 'PICK'; // SELECTION SET VMAP_TYPE_WGHT: TID4 = 'WGHT'; // WEIGHT MAP VMAP_TYPE_MNVW: TID4 = 'MNVW'; // SUBPATCH WEIGHT MAP VMAP_TYPE_TXUV: TID4 = 'TXUV'; // UV MAP VMAP_TYPE_RGB: TID4 = 'RGB'#0; // RGB MAP VMAP_TYPE_RGBA: TID4 = 'RGBA'; // RGBA MAP VMAP_TYPE_MORF: TID4 = 'MORF'; // MORPH MAP: RELATIVE VERTEX DISPLACEMENT VMAP_TYPE_SPOT: TID4 = 'SPOT'; // SPOT MAP: ABSOLUTE VERTEX POSITIONS PTAG_TYPE_SURF: TID4 = 'SURF'; // SURFACE PTAG_TYPE_PART: TID4 = 'PART'; // PARENT PART PTAG_TYPE_SMGP: TID4 = 'SMGP'; // SMOOTH GROUP PRE_POST_RESET = 0; // RESET PRE_POST_CONSTANT = 1; // CONSTANT PRE_POST_REPEAT = 2; // REPEAT PRE_POST_OSCILLATE = 3; // OSCILLATE PRE_POST_OFFSET = 4; // OFFSET REPEAT PRE_POST_LINEAR = 5; // LINEAR POLS_VCOUNT_MASK = $3FF; POLS_FLAGS_MASK = $FC00; SIDE_FRONT = 1; SIDE_BACK = 2; SIDE_FRONT_AND_BACK = SIDE_FRONT and SIDE_BACK; RFOP_BACKDROP = 0; RFOP_RAYTRACEANDBACKDROP = 1; RFOP_SPHERICALMAP = 2; RFOP_RAYTRACEANDSPHERICALMAP = 3; type TI1 = ShortInt; PI1 = ^TI1; TI2 = SmallInt; PI2 = ^TI2; TI4 = LongInt; PI4 = ^TI4; TU1 = Byte; PU1 = ^TU1; TU1DynArray = array of TU1; TU2 = Word; PU2 = ^TU2; TU2Array = array [0..65534] of TU2; PU2Array = ^TU2Array; TU2DynArray = array of TU2; TU4 = LongWord; PU4 = ^TU4; TU4Array = array [0..65534] of TU4; PU4Array = ^TU4Array; TU4DynArray = array of TU4; TF4 = Single; PF4 = ^TF4; TF4Array = array [0..65534] of TF4; PF4Array = ^TF4Array; TF4DynArray = array of TF4; TANG4 = TF4; PANG4 = ^TANG4; // TS0 = PAnsiChar; TVec12 = array[0..2] of TF4; PVec12 = ^TVec12; TVec12Array = array [0..65534] of TVec12; PVec12Array = ^TVec12Array; TVec12DynArray = array of TVec12; TColr12 = TVec12; PColr12 = ^TColr12; TColr12DynArray = array of TColr12; TColr4 = array[0..3] of TU1; PColr4 = ^TColr4; { Lightwave Chunk Struct - Used in TLWOReadCallback } PLWChunkRec = ^TLWChunkRec; TLWChunkRec = record id: TID4; size: TU4; data: Pointer; end; { Lightwave SubChunk Struct - Used in TLWOReadCallback } PLWSubChunkRec = ^TLWSubChunkRec; TLWSubChunkRec = record id: TID4; size: TU2; data: Pointer; end; TLWPolsInfo = record norm: TVec12; vnorms: TVec12DynArray; surfid: TU2; end; TLWPolsInfoDynArray = array of TLWPolsInfo; TLWPntsInfo = record npols: TU2; pols: TU2DynArray; end; TLWPntsInfoDynArray = array of TLWPntsInfo; TLWPolsDynArray = TU2DynArray; TLWPolyTagMapDynArray = TU2DynArray; TLWPolyTagMap = record poly: TU2; tag: TU2; end; PLWPolyTagMap = ^TLWPolyTagMap; { Value Map } TLWVertexMap = record vert: TU2; values: TF4DynArray; end; TLWVertexMapDynArray = array of TLWVertexMap; TLWChunkList = class; TLWParentChunk = class; TLWChunk = class (TPersistent) private FData: Pointer; FID: TID4; FSize: TU4; FParentChunk: TLWParentChunk; FOwner: TLWChunkList; function GetRootChunks: TLWChunkList; function GetIndex: Integer; protected procedure Clear; virtual; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); virtual; procedure Loaded; virtual; public destructor Destroy; override; class function GetID: TID4; virtual; procedure LoadFromStream(AStream: TStream); virtual; property Data: Pointer read FData; property ID: TID4 read FID; property Size: TU4 read FSize; { ParentChunk may be nil indicating this is a root chunk. ie. TLWLayr } property ParentChunk: TLWParentChunk read FParentChunk; property RootChunks: TLWChunkList read GetRootChunks; property Index: Integer read GetIndex; property Owner: TLWChunkList read FOwner; end; TLWChunkClass = class of TLWChunk; TLWSubChunk = class (TLWChunk) public procedure LoadFromStream(AStream: TStream); override; end; TLWChunkFind = procedure(AChunk: TLWChunk; Criteria: Pointer; var Found: boolean); TLWChunkList = class (TList) private FOwnsItems: Boolean; FOwner: TObject; function GetItem(Index: Integer): TLWChunk; protected procedure Loaded; virtual; public constructor Create(AOwnsItems: boolean; AOwner: TObject); destructor Destroy; override; function Add(AChunk: TLWChunk): Integer; procedure Clear; override; procedure Delete(Index: Integer); function FindChunk(ChunkFind: TLWChunkFind; Criteria: Pointer; StartIndex: Integer = 0): Integer; property Items[Index: Integer]: TLWChunk read GetItem; default; property OwnsItems: Boolean read FOwnsItems; property Owner: TObject read FOwner; end; TLWParentChunk = class (TLWChunk) private FItems: TLWChunkList; function GetItems: TLWChunkList; function GetFloatParam(Param: TID4): Single; function GetWordParam(Param: TID4): Word; function GetVec3Param(Param: TID4): TVec12; function GetLongParam(Param: TID4): LongWord; function GetVXParam(Param: TID4): Word; protected function GetParamAddr(Param: TID4): Pointer; virtual; procedure Clear; override; procedure Loaded; override; public property Items: TLWChunkList read GetItems; property ParamAddr[Param: TID4]: Pointer read GetParamAddr; property FloatParam[Param: TID4]: Single read GetFloatParam; property WordParam[Param: TID4]: Word read GetWordParam; property LongParam[Param: TID4]: LongWord read GetLongParam; property Vec3Param[Param: TID4]: TVec12 read GetVec3Param; property VXParam[Param: TID4]: Word read GetVXParam; end; TLWVMap = class; TLWPnts = class (TLWParentChunk) private FPnts: TVEC12DynArray; FPntsInfo: TLWPntsInfoDynArray; function GetPntsCount: LongWord; function AddPoly(PntIdx, PolyIdx: Integer): Integer; protected procedure Clear; override; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public class function GetID: TID4; override; function GetVMap(VMapID: TID4; out VMap: TLWVMap): Boolean; property PntsCount: LongWord read GetPntsCount; property Pnts: TVEC12DynArray read FPnts; property PntsInfo: TLWPntsInfoDynArray read FPntsInfo; end; TLWPols = class (TLWParentChunk) private FPolsType: TID4; FPols: TLWPolsDynArray; FPolsInfo: TLWPolsInfoDynArray; FPolsCount: Integer; function GetPolsByIndex(AIndex: TU2): Integer; function GetIndiceCount: TU4; function GetIndice(AIndex: Integer): TU2; function GetPolsCount: Integer; procedure CalcPolsNormals; procedure CalcPntsNormals; protected procedure Clear; override; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; procedure Loaded; override; public class function GetID: TID4; override; function GetPolsByPntIdx(VertIdx: TU2; var VertPolys: TU2DynArray): Integer; property PolsByIndex[AIndex: TU2]: Integer read GetPolsByIndex; property IndiceCount: TU4 read GetIndiceCount; property Indices[AIndex: Integer]: TU2 read GetIndice; property PolsType: TID4 read FPolsType; property PolsCount: Integer read GetPolsCount; property PolsInfo: TLWPolsInfoDynArray read FPolsInfo; end; TLWVMap = class (TLWChunk) private FDimensions: TU2; FName: string; FValues: TLWVertexMapDynArray; FVMapType: TID4; function GetValue(AIndex: TU2): TLWVertexMap; function GetValueCount: Integer; protected procedure Clear; override; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public class function GetID: TID4; override; property Dimensions: TU2 read FDimensions; property Name: string read FName; property Value[AIndex: TU2]: TLWVertexMap read GetValue; property ValueCount: Integer read GetValueCount; property VMapType: TID4 read FVMapType; end; TLWTags = class (TLWChunk) private FTags: TStrings; function GetTags: TStrings; protected procedure Clear; override; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public destructor Destroy; override; class function GetID: TID4; override; function TagToName(Tag: TU2): string; property Tags: TStrings read GetTags; end; TLWSurf = class (TLWParentChunk) private FName: string; FSource: string; function GetSurfId: Integer; protected function GetParamAddr(Param: TID4): Pointer; override; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public destructor Destroy; override; class function GetID: TID4; override; property SurfId: Integer read GetSurfId; property Name: string read FName; property Source: string read FSource; end; TLWLayr = class (TLWParentChunk) private FFlags: TU2; FName: string; FNumber: TU2; FParent: TU2; FPivot: TVec12; protected procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public destructor Destroy; override; class function GetID: TID4; override; property Flags: TU2 read FFlags; property Name: string read FName; property Number: TU2 read FNumber; property Parent: TU2 read FParent; property Pivot: TVec12 read FPivot; end; TLWPTag = class (TLWChunk) private FMapType: TID4; FTagMaps: TLWPolyTagMapDynArray; FTags: TU2DynArray; function AddTag(Value: TU2): Integer; function GetTag(AIndex: Integer): TU2; function GetTagCount: Integer; function GetTagMapCount: Integer; function GetTagMaps(AIndex: Integer): TLWPolyTagMap; procedure ValidateTagInfo; protected procedure Clear; override; procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public constructor Create; function GetPolsByTag(Tag: TU2; var PolyIndices: TU2DynArray): Integer; class function GetID: TID4; override; property MapType: TID4 read FMapType; property TagCount: Integer read GetTagCount; property TagMapCount: Integer read GetTagMapCount; property TagMaps[AIndex: Integer]: TLWPolyTagMap read GetTagMaps; default; property Tags[AIndex: Integer]: TU2 read GetTag; end; TLWObjectFile = class (TObject) private FChunks: TLWChunkList; FFileName: string; function GetChunks: TLWChunkList; function GetCount: Integer; function GetSurfaceByName(Index: string): TLWSurf; function GetSurfaceByTag(Index: TU2): TLWSurf; public constructor Create; destructor Destroy; override; function TagToName(Tag: TU2): string; procedure LoadFromFile(const AFilename: string); procedure LoadFromStream(AStream: TStream); property ChunkCount: Integer read GetCount; property Chunks: TLWChunkList read GetChunks; property FileName: string read FFileName; property SurfaceByName[Index: string]: TLWSurf read GetSurfaceByName; property SurfaceByTag[Index: TU2]: TLWSurf read GetSurfaceByTag; end; TLWClip = class(TLWParentChunk) private FClipIndex: TU4; protected procedure LoadData(AStream: TStream; DataStart, DataSize: LongWord); override; public class function GetID: TID4; override; property ClipIndex: TU4 read FClipIndex; end; TLWContentNotify = procedure(Sender: TObject; var Content: string) of object; TLWContentDir = class private FSubDirs: TStrings; FRoot: string; function GetSubDirs: TStrings; procedure SetRoot(const Value: string); procedure SetSubDirs(const Value: TStrings); // function ContentSearch(AFilename: string): string; public destructor Destroy; override; function FindContent(AFilename: string): string; property Root: string read FRoot write SetRoot; property SubDirs: TStrings read GetSubDirs write SetSubDirs; end; TLWOReadCallback = procedure(Chunk: TLWChunkRec; Data: Pointer); cdecl; procedure RegisterChunkClass(ChunkClass: TLWChunkClass); function LoadLW0FromStream(Stream: TStream; ReadCallback: TLWOReadCallback; UserData: Pointer): LongWord; cdecl; function LoadLWOFromFile(const AFilename: string; ReadCallback: TLWOReadCallback; UserData: Pointer): LongWord; procedure ReadMotorolaNumber(Stream: TStream; Data: Pointer; ElementSize: Integer; Count: Integer = 1); function WriteMotorolaNumber(Stream: TStream; Data: Pointer; ElementSize: Integer; Count: Integer = 1): Integer; function ReadS0(Stream: TStream; out Str: string): Integer; procedure WriteS0(Stream: TStream; Data: string); procedure WriteU4AsVX(Stream:TStream; Data: Pointer; Count: Integer); function ReadVXAsU4(Stream: TStream; Data: Pointer; Count: Integer = 1): Integer; procedure ReverseByteOrder(ValueIn: Pointer; Size: Integer; Count: Integer = 1); function ToDosPath(const Path: string): string; function ToUnixPath(const Path: string): string; function ID4ToInt(const Id: TID4): Integer; // ChunkFind procedures procedure FindChunkById(AChunk: TLWChunk; Data: Pointer; var Found: boolean); procedure FindSurfaceByName(AChunk: TLWChunk; AName: Pointer; var Found: boolean); procedure FindSurfaceByTag(AChunk: TLWChunk; ATag: Pointer; var Found: boolean); procedure FindVMapByName(AChunk: TLWChunk; AName: Pointer; var Found: boolean); procedure FindClipByClipIndex(AChunk: TLWChunk; AIndex: Pointer; var Found: boolean); function GetContentDir: TLWContentDir; //-------------------------------------------------------------------- //-------------------------------------------------------------------- //-------------------------------------------------------------------- implementation //-------------------------------------------------------------------- //-------------------------------------------------------------------- //-------------------------------------------------------------------- uses GLApplicationFileIO; type PWord = ^Word; PLongWord = ^LongWord; var ChunkClasses: TList; ContentDir: TLWContentDir; function ToDosPath(const Path: string): string; var i: Integer; begin result := Path; for i := 1 to Length(result) do if result[i] = '/' then result[i] := '\'; end; function ToUnixPath(const Path: string): string; var i: Integer; begin result := Path; for i := 1 to Length(result) do if result[i] = '\' then result[i] := '/'; end; function GetContentDir: TLWContentDir; begin if ContentDir = nil then ContentDir := TLWContentDir.Create; result := ContentDir; end; procedure FindChunkById(AChunk: TLWChunk; Data: Pointer; var Found: boolean); begin if AChunk.FID = PID4(Data)^ then Found := true else Found := false; end; procedure FindClipByClipIndex(AChunk: TLWChunk; AIndex: Pointer; var Found: boolean); begin if (AChunk is TLWClip) and (TLWClip(AChunk).ClipIndex = PU2(AIndex)^) then Found := true; end; procedure FindSurfaceByName(AChunk: TLWChunk; AName: Pointer; var Found: boolean); begin if (AChunk is TLWSurf) and (TLWSurf(AChunk).Name = PString(AName)^) then Found := true; end; procedure FindSurfaceByTag(AChunk: TLWChunk; ATag: Pointer; var Found: boolean); begin if (AChunk is TLWSurf) and (TLWSurf(AChunk).SurfId = PU2(ATag)^) then Found := true; end; procedure FindVMapByName(AChunk: TLWChunk; AName: Pointer; var Found: boolean); begin if (AChunk is TLWVMap) and (TLWVMap(AChunk).Name = PString(AName)^) then Found := true; end; function VecAdd(v1,v2: TVec12):TVec12; begin result[0]:=v1[0]+v2[0]; result[1]:=v1[1]+v2[1]; result[2]:=v1[2]+v2[2]; end; function VecSub(v1,v2: TVec12): TVec12; begin result[0]:=v1[0]-v2[0]; result[1]:=v1[1]-v2[1]; result[2]:=v1[2]-v2[2]; end; function VecCross(v1,v2: TVec12): TVec12; begin result[0]:=v1[1]*v2[2]-v1[2]*v2[1]; result[1]:=v1[2]*v2[0]-v1[0]*v2[2]; result[2]:=v1[0]*v2[1]-v1[1]*v2[0]; end; function VecDot(v1, v2: TVec12): TF4; begin result:=v1[0]*v2[0]+v1[1]*v2[1]+v1[2]*v2[2]; end; function VecNorm(v: TVec12) : TVec12; var mag: TF4; begin mag := Sqrt(VecDot(v,v)); if mag >0 then mag := 1/mag; result[0]:=v[0]*mag; result[1]:=v[1]*mag; result[2]:=v[2]*mag; end; function CalcPlaneNormal(v1,v2,v3: TVec12): TVec12; var e1, e2: TVec12; begin e1:=VecSub(v2,v1); e2:=VecSub(v3,v1); result:=VecCross(e1,e2); result:=VecNorm(result); end; procedure FindSurfByName(Chunk: TLWChunk; var Found: boolean); begin end; {----------------------------------------------------------------------------- Procedure: GetChunkClasses Date: 08-Aug-2002 Arguments: None Result: TClassList Singleton access for the chunk class list. -----------------------------------------------------------------------------} function GetChunkClasses: TList; begin if ChunkClasses=nil then ChunkClasses:=TList.Create; result:=ChunkClasses; end; procedure UnRegisterChunkClasses; var i: Integer; begin with GetChunkClasses do for i:=0 to Count-1 do UnregisterClass(TPersistentClass(Items[i])); end; {----------------------------------------------------------------------------- Procedure: RegisterChunkClass Date: 08-Aug-2002 Arguments: ChunkClass: TLWChunkClass Result: None Adds a user defined chunk class to the chunk class list. -----------------------------------------------------------------------------} procedure RegisterChunkClass(ChunkClass: TLWChunkClass); begin GetChunkClasses.Add(ChunkClass); // if FindClass(ChunkClass.ClassName) <> nil then // UnRegisterClass(ChunkClass); // RegisterClass(ChunkClass); end; {----------------------------------------------------------------------------- Procedure: GetChunkClass Date: 08-Aug-2002 Arguments: ChunkID: TID4 Result: TLWChunkClass Returns the chunk class associated with ChunkID. -----------------------------------------------------------------------------} function GetChunkClass(ChunkID: TID4; ADefault: TLWChunkClass): TLWChunkClass; var i: Integer; begin if ADefault = nil then result:=TLWChunk else result:=ADefault; for i:=0 to ChunkClasses.Count-1 do begin if TLWChunkClass(ChunkClasses.Items[i]).GetID=ChunkID then begin result:=TLWChunkClass(ChunkClasses.Items[i]); Exit; end; end; end; {----------------------------------------------------------------------------- Procedure: Tokenize Date: 08-Aug-2002 Arguments: const Src: string; Delimiter: Char; Dst: TStrings Result: None Breaks up a string into TStrings items when the Delimiter character is encountered. -----------------------------------------------------------------------------} procedure Tokenize(const Src: string; Delimiter: Char; Dst: TStrings); var i,L,SL: Integer; SubStr: string; begin if Dst=nil then Exit; L:=Length(Src); if (L=0) or (Dst=nil) then Exit; SubStr:=''; for i:=1 to L do begin if (Src[i]<>Delimiter) then SubStr:=SubStr+Src[i] else begin SL:=Length(SubStr); if SL>0 then begin Dst.Add(SubStr); SubStr:=''; end; end; end; if Length(SubStr)>0 then Dst.Add(SubStr); end; {----------------------------------------------------------------------------- Procedure: LoadLW0FromStream Date: 08-Aug-2002 Arguments: Stream: TStream; ReadCallback: TLWOReadCallback; UserData: Pointer Result: LongWord -----------------------------------------------------------------------------} function LoadLW0FromStream(Stream: TStream; ReadCallback: TLWOReadCallback; UserData: Pointer): LongWord; var Chunk: TLWChunkRec; CurId: TID4; StartPos, CurSize: TU4; begin try Stream.Read(CurId,4); ReadMotorolaNumber(Stream,@CurSize,4); if UpperCase(string(CurId)) = 'FORM' then begin Stream.Read(CurId,4); end else raise Exception.Create('Invalid magic number. Not a valid Lightwave Object'); with Stream do while Position < Size do begin Read(Chunk,8); ReverseByteOrder(@Chunk.size,4); StartPos:=Position; GetMem(Chunk.data,Chunk.size); Stream.Read(Chunk.data^,Chunk.size); if Assigned(ReadCallback) then ReadCallback(Chunk,UserData); FreeMem(Chunk.data,Chunk.size); Position:=StartPos+Chunk.size+(StartPos+Chunk.size) mod 2; end; Stream.Free; result:=High(LongWord); except On E: Exception do begin Stream.Free; result := 0; end; end; end; // LoadLWOFromFile // function LoadLWOFromFile(const aFilename : String; readCallback : TLWOReadCallback; userData : Pointer) : LongWord; var stream : TStream; begin stream:=CreateFileStream(aFilename, fmOpenRead); try Result:=LoadLW0FromStream(stream, readCallback, userData); finally stream.Free; end; end; procedure ReverseByteOrder(ValueIn: Pointer; Size: Integer; Count: Integer = 1); var W: Word; pB: PByte; Blo, Bhi: Byte; L: LongWord; i: Integer; begin i:=0; case Size of 2: begin while i < Count do begin W := PU2Array(ValueIn)^[i]; pB := @W; Blo := pB^; Inc(pB); Bhi := pB^; pB^ := Blo; Dec(pB); pB^ := Bhi; PU2Array(ValueIn)^[i] := w; Inc(i); end; end; 4: begin while i < Count do begin L := PU4Array(ValueIn)^[i]; pB := @W; Blo := pB^; Inc(pB); Bhi := pB^; pB^ := Blo; Dec(pB); pB^ := Bhi; PU4Array(ValueIn)^[i] := l; Inc(i); end; end; else raise Exception.Create('Lightwave.ReverseByteOrder: Invalid Size = ' + IntToStr(Size)); end; end; procedure ReadMotorolaNumber(Stream: TStream; Data: Pointer; ElementSize: Integer; Count: Integer = 1); begin Stream.Read(Data^,Count * ElementSize); if (ElementSize = 2) or (ElementSize = 4) then ReverseByteOrder(Data,ElementSize,Count); end; function WriteMotorolaNumber(Stream: TStream; Data: Pointer; ElementSize: Integer; Count: Integer = 1): Integer; var TempData: Pointer; begin result := 0; if Data <> nil then begin TempData := AllocMem(ElementSize * Count); try if (ElementSize = 2) or (ElementSize = 4) then ReverseByteOrder(TempData,ElementSize,Count); result := Stream.Write(Data,Count * ElementSize); except on E: Exception do begin FreeMem(TempData,Count * ElementSize); raise; end; end; end; end; function ReadS0(Stream: TStream; out Str: string): Integer; var Buf: array[0..1] of AnsiChar; StrBuf: string; begin Stream.Read(Buf,2); StrBuf:=''; while Buf[1] <> #0 do begin StrBuf := StrBuf + string(Buf); Stream.Read(Buf,2); end; if Buf[0] <> #0 then StrBuf := StrBuf + Char(Buf[0]); Str := Copy(StrBuf,1,Length(StrBuf)); result := Length(Str) + 1; result := result + (result mod 2); end; function ValueOfVX(VX: Pointer): TU4; var TmpU2: TU2; TmpU4: TU4; begin if PU1(VX)^ = $FF then begin TmpU4 := TU4(PU1(VX)^) and $FFFFFFF0; ReverseByteOrder(@TmpU4,4); end else begin TmpU2 := TU2(PU2(VX)^); ReverseByteOrder(@TmpU2,2); TmpU4 := TmpU2; end; result := TmpU4; end; function ReadVXAsU4(Stream: TStream; Data: Pointer; Count: Integer = 1): Integer; var i, ReadCount: Integer; BufByte: byte; TempU2: TU2; begin ReadCount := 0; for i := 0 to Count -1 do begin Stream.Read(BufByte,1); Stream.Position := Stream.Position - 1; if BufByte = 255 then begin Stream.Read(Data^,SizeOf(TU4)); PU4Array(Data)^[i] := PU4Array(Data)^[i] and $FFFFFFF0; ReverseByteOrder(Data,SizeOf(TU4)); Inc(ReadCount,4); end else begin Stream.Read(TempU2,SizeOf(TU2)); ReverseByteOrder(@TempU2,SizeOf(TU2)); PU4Array(Data)^[i] := TempU2; Inc(ReadCount,2); end; end; result := ReadCount; end; function ReadVXAsU2(Stream: TStream; Data: Pointer; Count: Integer = 1): Integer; var i, ReadCount: Integer; BufByte: byte; TempU2: TU2; begin ReadCount := 0; for i := 0 to Count -1 do begin Stream.Read(BufByte,1); Stream.Position := Stream.Position - 1; if BufByte = 255 then begin Stream.Position := Stream.Position + 4; PU2Array(Data)^[i] := 0; Inc(ReadCount,4); end else begin Stream.Read(TempU2,SizeOf(TU2)); ReverseByteOrder(@TempU2,SizeOf(TU2)); PU2Array(Data)^[i] := TempU2; Inc(ReadCount,2); end; end; result := ReadCount; end; procedure WriteS0(Stream: TStream; Data: string); begin {ToDo: WriteS0} end; procedure WriteU4AsVX(Stream:TStream; Data: Pointer; Count: Integer); var i: Integer; TempU2: TU2; begin for i := 0 to Count - 1 do begin if PU4Array(Data)^[i] < 65280 then begin TempU2 := PU4Array(Data)^[i]; WriteMotorolaNumber(Stream,@TempU2,SizeOf(TU2)); end else WriteMotorolaNumber(Stream,Data,SizeOf(TU4)); end; end; type PInteger = ^Integer; function ID4ToInt(const Id: TId4): Integer; var TmpId: AnsiString; begin TmpId := Id; TmpId := AnsiString(UpperCase(string(Id))); result := PInteger(@TmpId)^; end; { TLWChunk } { *********************************** TLWChunk *********************************** } destructor TLWChunk.Destroy; begin Clear; inherited; end; procedure TLWChunk.Clear; begin FreeMem(FData,FSize); FSize := 0; FData := nil; end; class function TLWChunk.GetID: TID4; begin result := #0#0#0#0; end; procedure TLWChunk.LoadData(AStream: TStream; DataStart, DataSize: LongWord); begin GetMem(FData,DataSize); AStream.Read(PByteArray(FData)^[0],DataSize); end; procedure TLWChunk.LoadFromStream(AStream: TStream); var DataStart: Integer; DataSize: TU4; begin with AStream do begin ReadMotorolaNumber(AStream,@DataSize,4); DataStart := Position; FSize := DataSize; LoadData(AStream, DataStart,DataSize); Position := Cardinal(DataStart) + DataSize + (Cardinal(DataStart) + DataSize) mod 2; end; end; { TLWChunks } { ********************************* TLWChunkList ********************************* } constructor TLWChunkList.Create(AOwnsItems: boolean; AOwner: TObject); begin inherited Create; FOwnsItems := AOwnsItems; FOwner := AOwner; end; destructor TLWChunkList.Destroy; begin Clear; inherited; end; procedure TLWChunkList.Clear; begin while Count > 0 do Delete(Count - 1); inherited; end; procedure TLWChunkList.Delete(Index: Integer); begin if FOwnsItems then Items[Index].Free; inherited Delete(Index); end; function TLWChunkList.GetItem(Index: Integer): TLWChunk; begin result := TLWChunk(inherited Items[Index]); end; { TLWObjectFile } { ******************************** TLWObjectFile ********************************* } constructor TLWObjectFile.Create; begin inherited; end; destructor TLWObjectFile.Destroy; begin FreeAndNil(FChunks); inherited; end; function TLWObjectFile.GetChunks: TLWChunkList; begin if FChunks = nil then FChunks := TLWChunkList.Create(true,Self); result := FChunks; end; function TLWObjectFile.GetCount: Integer; begin result := Chunks.Count; end; function TLWObjectFile.GetSurfaceByName(Index: string): TLWSurf; var SurfIdx: Integer; begin SurfIdx := Chunks.FindChunk(@FindSurfaceByName,@Index,0); if SurfIdx <> -1 then result := TLWSurf(Chunks[SurfIdx]) else result := nil; end; function TLWObjectFile.GetSurfaceByTag(Index: TU2): TLWSurf; var TagName: string; begin TagName := TagToName(Index); result := SurfaceByName[TagName]; end; procedure TLWObjectFile.LoadFromFile(const AFilename: string); var Stream: TMemoryStream; begin Stream := TMemoryStream.Create; try Stream.LoadFromFile(AFilename); LoadFromStream(Stream); Stream.Free; FFileName := AFilename; except on E: Exception do begin Stream.Free; raise; end; end; end; procedure TLWObjectFile.LoadFromStream(AStream: TStream); var CurId: TID4; CurSize: LongWord; CurPnts, CurPols, CurItems: TLWChunkList; begin CurPols:=nil; CurPnts:=nil; AStream.Read(CurId,4); ReadMotorolaNumber(AStream,@CurSize,4); if UpperCase(string(CurId)) = 'FORM' then begin AStream.Read(CurId,4); if CurId <> 'LWO2' then raise Exception.Create('Only Version 6.0+ version objects are supported.'); end else raise Exception.Create('Invalid magic number. Not a valid Lightwave Object'); CurItems := Chunks; while AStream.Position < AStream.Size do begin AStream.Read(CurId,4); if (CurId = ID_PTAG) then begin CurPols.Add(GetChunkClass(CurId, TLWChunk).Create); with CurPols[CurPols.Count - 1] do begin FID := CurId; LoadFromStream(AStream); end; end else if (CurId = ID_VMAP) or (CurId = ID_VMAD) then begin CurPnts.Add(GetChunkClass(CurId, TLWChunk).Create); with CurPnts[CurPnts.Count - 1] do begin FID := CurId; LoadFromStream(AStream); end; end else begin if (CurId = ID_LAYR) or (CurId = ID_SURF) or (CurId = ID_TAGS) or (CurId = ID_CLIP) then CurItems := Chunks; CurItems.Add(GetChunkClass(CurId, TLWChunk).Create); with CurItems[CurItems.Count - 1] do begin FID := CurId; LoadFromStream(AStream); end; end; if CurId = ID_LAYR then CurItems := TLWParentChunk(CurItems[CurItems.Count - 1]).Items else if CurId = ID_POLS then CurPols := TLWParentChunk(CurItems[CurItems.Count - 1]).Items else if CurId = ID_PNTS then CurPnts := TLWParentChunk(CurItems[CurItems.Count - 1]).Items; end; Chunks.Loaded; end; { TLWPnts } { *********************************** TLWPnts ************************************ } function TLWPnts.AddPoly(PntIdx, PolyIdx: Integer): Integer; var i,L: Integer; begin {DONE: Pnts.AddPoly} for i := 0 to FPntsInfo[PntIdx].npols -1 do begin if FPntsInfo[PntIdx].pols[i] = PolyIdx then begin result := i; Exit; end; end; L := Length(FPntsInfo[PntIdx].pols); SetLength(FPntsInfo[PntIdx].pols,L + 1); FPntsInfo[PntIdx].npols := L + 1; FPntsInfo[PntIdx].pols[L] := PolyIdx; result := L; end; procedure TLWPnts.Clear; var i: Integer; begin for i := 0 to PntsCount -1 do SetLength(FPntsInfo[i].pols,0); SetLength(FPntsInfo,0); SetLength(FPnts,0); end; function TLWPnts.GetPntsCount: LongWord; begin result := Length(FPnts); end; class function TLWPnts.GetID: TID4; begin result := ID_PNTS; end; function TLWPnts.GetVMap(VMapID: TID4; out VMap: TLWVMap): Boolean; var i: Integer; begin result := false; for i := 0 to Items.Count - 1 do begin if (Items[i] is TLWVMap) and (TLWVMap(Items[i]).VMapType = VMapID) then begin result := true; VMap := TLWVMap(Items[i]); Exit; end; end; end; procedure TLWPnts.LoadData(AStream: TStream; DataStart, DataSize: LongWord); begin SetLength(FPnts,DataSize div 12); // allocate storage for DataSize div 12 points SetLength(FPntsInfo,DataSize div 12); // Point info ReadMotorolaNumber(AStream,@FPnts[0],4,DataSize div 4); // read the point data end; { TLWPols } { *********************************** TLWPols ************************************ } procedure TLWPols.CalcPolsNormals; var i,j,PolyIdx: Integer; Pnts: TLWPnts; begin if IndiceCount = 0 then Exit; with ParentChunk as TLWLayr do Pnts := TLWPnts(Items[Items.FindChunk(@FindChunkById,@ID_PNTS,0)]); for PolyIdx := 0 to FPolsCount - 1 do begin {DONE: call Pnts.AddPoly} i := PolsByIndex[PolyIdx]; with Pnts do begin for j := 1 to Indices[i] do AddPoly(Indices[i + j],PolyIdx); SetLength(FPolsInfo[PolyIdx].vnorms,Indices[i]); if Indices[PolyIdx]>2 then FPolsInfo[PolyIdx].norm:=CalcPlaneNormal(Pnts[Indices[i+1]],Pnts[Indices[i+2]],Pnts[Indices[i+3]]) else FPolsInfo[PolyIdx].norm := VecNorm(Pnts[Indices[i+1]]); end; end; end; procedure TLWPols.Clear; var i: Integer; begin for i := 0 to FPolsCount-1 do SetLength(FPolsInfo[i].vnorms,0); SetLength(FPolsInfo,0); SetLength(FPols,0); end; function TLWPols.GetPolsByIndex(AIndex: TU2): Integer; var i, cnt: Cardinal; begin result := -1; i := 0; cnt := 0; if AIndex = 0 then begin result := 0; Exit; end; while (i < IndiceCount - 1) and (cnt <> AIndex) do begin Inc(i,Indices[i]+1); Inc(cnt); end; if cnt = AIndex then result := i; end; class function TLWPols.GetID: TID4; begin result := ID_POLS; end; function TLWPols.GetIndiceCount: TU4; begin result := Length(FPols); end; function TLWPols.GetIndice(AIndex: Integer): TU2; begin result := FPols[AIndex]; end; function TLWPols.GetPolsCount: Integer; begin result := FPolsCount; end; procedure TLWPols.LoadData(AStream: TStream; DataStart, DataSize: LongWord); var EndPos: Integer; Idx: TU4; TmpU2: TU2; begin Idx := 0; EndPos := DataStart + DataSize; with AStream do begin Read(FPolsType,4); // To avoid memory manager hits, set an estimate length of indices SetLength(FPols,(DataSize - 4) div 2); while Position < EndPos do begin ReadMotorolaNumber(AStream,@FPols[Idx],2); TmpU2 := FPols[Idx] and POLS_VCOUNT_MASK; ReadVXAsU2(AStream,@FPols[Idx + 1],TmpU2); Inc(Idx,FPols[Idx] + 1); Inc(FPolsCount); end; // correct length estimate errors if any if (Idx + 1) < Cardinal(Length(FPols)) then SetLength(FPols,Idx + 1); end; SetLength(FPolsInfo,FPolsCount); CalcPolsNormals; end; { TLWVMap } { *********************************** TLWVMap ************************************ } procedure TLWVMap.Clear; var i: Integer; begin for i := 0 to Length(FValues) - 1 do SetLength(FValues[i].values,0); SetLength(FValues,0); end; class function TLWVMap.GetID: TID4; begin result := ID_VMAP; end; function TLWVMap.GetValue(AIndex: TU2): TLWVertexMap; begin result := FValues[AIndex]; end; function TLWVMap.GetValueCount: Integer; begin result := Length(FValues); end; procedure TLWVMap.LoadData(AStream: TStream; DataStart, DataSize: LongWord); var Idx: TU4; begin Idx := 0; with AStream do begin Read(FVMapType,4); ReadMotorolaNumber(AStream,@FDimensions,2); ReadS0(AStream,FName); if FDimensions > 0 then begin while Cardinal(Position) < (DataStart + DataSize) do begin SetLength(FValues,Length(FValues) + 1); ReadVXAsU2(AStream,@FValues[Idx].vert,1); SetLength(FValues[Idx].values,Dimensions * 4); ReadMotorolaNumber(AStream,@FValues[Idx].values[0],4,Dimensions); Inc(Idx); end; end; end; end; { TLWTags } { *********************************** TLWTags ************************************ } destructor TLWTags.Destroy; begin inherited; end; procedure TLWTags.Clear; begin FreeAndNil(FTags); end; class function TLWTags.GetID: TID4; begin result := ID_TAGS; end; function TLWTags.GetTags: TStrings; begin if FTags = nil then FTags := TStringList.Create; result := FTags; end; procedure TLWTags.LoadData(AStream: TStream; DataStart, DataSize: LongWord); var EndPos: TU4; TmpStr: string; begin EndPos := DataStart + DataSize; while Cardinal(AStream.Position) < Cardinal(EndPos) do begin ReadS0(AStream,TmpStr); Tags.Add(TmpStr); TmpStr := ''; end; end; function TLWTags.TagToName(Tag: TU2): string; begin result := Tags[Tag]; end; { TLWSubChunk } { ********************************* TLWSubChunk ********************************** } procedure TLWSubChunk.LoadFromStream(AStream: TStream); var DataStart: Integer; DataSize: TU2; begin with AStream do begin ReadMotorolaNumber(AStream,@DataSize,2); DataStart := Position; FSize := DataSize; LoadData(AStream,DataStart,DataSize); Position := DataStart + DataSize + (DataStart + DataSize) mod 2; end; end; { *********************************** TLWLayr ************************************ } destructor TLWLayr.Destroy; begin inherited; end; class function TLWLayr.GetID: TID4; begin result := ID_LAYR; end; procedure TLWLayr.LoadData(AStream: TStream; DataStart, DataSize: LongWord); begin ReadMotorolaNumber(AStream,@FNumber,2); ReadMotorolaNumber(AStream,@FFlags,2); ReadMotorolaNumber(AStream,@FPivot,4,3); ReadS0(AStream,FName); if ((DataStart + DataSize) - Cardinal(AStream.Position)) > 2 then ReadMotorolaNumber(AStream,@FParent,2); end; { TLWSurf } { *********************************** TLWSurf ************************************ } destructor TLWSurf.Destroy; begin inherited; end; class function TLWSurf.GetID: TID4; begin result := ID_SURF; end; function TLWSurf.GetParamAddr(Param: TID4): Pointer; var Idx: Integer; sParam: string; begin result:=inherited GetParamAddr(Param); if (result=nil) and (Source<>'') then begin sParam := string(Param); Idx:=RootChunks.FindChunk(@FindSurfaceByName,@sParam,0); if Idx<>-1 then result:=TLWSurf(RootChunks[Idx]).ParamAddr[Param]; end; end; function TLWSurf.GetSurfId: Integer; var c, SurfIdx: Integer; begin c := 0; SurfIdx := Owner.FindChunk(@FindChunkById,@ID_SURF); while (SurfIdx <> -1) and (Owner[SurfIdx] <> Self) do begin SurfIdx := Owner.FindChunk(@FindChunkById,@ID_SURF,SurfIdx + 1); Inc(c); end; result := c; end; procedure TLWSurf.LoadData(AStream: TStream; DataStart, DataSize: LongWord); var CurId: TID4; begin ReadS0(AStream,FName); ReadS0(AStream,FSource); while Cardinal(AStream.Position) < (DataStart + DataSize) do begin AStream.Read(CurId,4); Items.Add(GetChunkClass(CurId, TLWSubChunk).Create); with Items[Items.Count - 1] do begin FID:=CurId; LoadFromStream(AStream); end; end; end; { TLWPTag } { *********************************** TLWPTag ************************************ } constructor TLWPTag.Create; begin inherited; end; function TLWPTag.AddTag(Value: TU2): Integer; var i, L: Integer; begin result := -1; L := Length(FTags); for i := 0 to L - 1 do if Value = FTags[i] then begin result := i; Exit; end; if result = -1 then begin SetLength(FTags,L + 1); FTags[L] := Value; result := L; end; end; procedure TLWPTag.Clear; begin SetLength(FTagMaps,0); SetLength(FTags,0); end; function TLWPTag.GetPolsByTag(Tag: TU2; var PolyIndices: TU2DynArray): Integer; var i: Integer; procedure AddPoly(Value: TU2); var L: Integer; begin L := Length(PolyIndices); SetLength(PolyIndices,L+1); PolyIndices[L] := Value; end; begin for i := 0 to TagMapCount -1 do if TagMaps[i].tag = Tag then AddPoly(TagMaps[i].poly); result := Length(PolyIndices); end; class function TLWPTag.GetID: TID4; begin result := ID_PTAG; end; function TLWPTag.GetTag(AIndex: Integer): TU2; begin ValidateTagInfo; result := FTags[AIndex]; end; function TLWPTag.GetTagCount: Integer; begin ValidateTagInfo; result := Length(FTags); end; function TLWPTag.GetTagMapCount: Integer; begin result := Length(FTagMaps) div 2; end; function TLWPTag.GetTagMaps(AIndex: Integer): TLWPolyTagMap; begin result := PLWPolyTagMap(@FTagMaps[AIndex * 2])^; end; procedure TLWPTag.LoadData(AStream: TStream; DataStart, DataSize: LongWord); var Idx: Integer; begin Idx := 0; with AStream do begin Read(FMapType,4); SetLength(FTagMaps,(DataSize - 4) div 2); while Cardinal(Position) < (DataStart + DataSize) do begin ReadVXAsU2(AStream, @FTagMaps[Idx]); ReadMotorolaNumber(AStream,@FTagMaps[Idx + 1],2); Inc(Idx, 2); end; // correct length guestimate errors if any if (Idx + 1) < Length(FTagMaps) then SetLength(FTagMaps,Idx + 1); end; end; procedure TLWPTag.ValidateTagInfo; var i: Integer; begin if Length(FTags) > 0 then Exit; for i := 0 to TagMapCount -1 do AddTag(TagMaps[i].tag); end; { TLWParentChunk } { ******************************** TLWParentChunk ******************************** } procedure TLWParentChunk.Clear; begin FreeAndNil(FItems); inherited; end; function TLWParentChunk.GetFloatParam(Param: TID4): Single; var pdata: Pointer; begin pdata:=ParamAddr[Param]; if pdata <> nil then begin result:=PF4(pdata)^; ReverseByteOrder(@result,4); end else result:=0.0; end; function TLWParentChunk.GetItems: TLWChunkList; begin if FItems = nil then FItems := TLWChunkList.Create(true,Self); result := FItems; end; function TLWParentChunk.GetLongParam(Param: TID4): LongWord; var pdata: Pointer; begin pdata:=ParamAddr[Param]; if pdata <> nil then begin result:=PU4(pdata)^; ReverseByteOrder(@result,4); end else result:=0; end; function TLWParentChunk.GetParamAddr(Param: TID4): Pointer; var Idx: Integer; begin result := nil; Idx := Items.FindChunk(@FindChunkById,@Param,0); if Idx <> -1 then result := Items[Idx].Data; end; function TLWPols.GetPolsByPntIdx(VertIdx: TU2; var VertPolys: TU2DynArray): Integer; var i,j,L: Integer; begin L:=0; if Length(VertPolys) >0 then SetLength(VertPolys,0); for i := 0 to PolsCount -1 do begin for j := 1 to Indices[PolsByIndex[i]] do begin if Indices[PolsByIndex[i] + j] = VertIdx then begin L := Length(VertPolys); SetLength(VertPolys, L + 1); VertPolys[L] := i; end; end; end; result := L; end; function TLWChunkList.Add(AChunk: TLWChunk): Integer; begin if (FOwner<>nil) and (FOwner is TLWParentChunk) then AChunk.FParentChunk := TLWParentChunk(FOwner); AChunk.FOwner := self; result := inherited Add(AChunk); end; procedure TLWPols.CalcPntsNormals; var i,j,k,PntIdx,PolyIdx,SurfIdx: Integer; Pnts: TLWPnts; // PTags: TLWPTag; TmpAddr: Pointer; sman: TF4; begin {Todo: CalcPntsNormals} if IndiceCount = 0 then Exit; with ParentChunk as TLWLayr do Pnts := TLWPnts(Items[Items.FindChunk(@FindChunkById,@ID_PNTS,0)]); for PolyIdx := 0 to PolsCount-1 do begin i := PolsByIndex[PolyIdx]; SurfIdx := RootChunks.FindChunk(@FindSurfaceByTag,@FPolsInfo[PolyIdx].surfid); TmpAddr := TLWSurf(RootChunks[SurfIdx]).ParamAddr[ID_SMAN]; if TmpAddr <> nil then begin sman := PF4(TmpAddr)^; ReverseByteOrder(@sman,4); end else sman := 0; for j := 1 to Indices[i] do begin FPolsInfo[PolyIdx].vnorms[j-1] := FPolsInfo[PolyIdx].norm; if sman <= 0 then continue; PntIdx := Indices[i + j]; for k := 0 to Pnts.PntsInfo[PntIdx].npols -1 do begin if Pnts.PntsInfo[PntIdx].pols[k] = PolyIdx then continue; if ArcCos(VecDot(FPolsInfo[PolyIdx].norm,FPolsInfo[Pnts.PntsInfo[PntIdx].pols[k]].norm)) > sman then continue; FPolsInfo[PolyIdx].vnorms[j-1]:=VecAdd(FPolsInfo[PolyIdx].vnorms[j-1],FPolsInfo[Pnts.PntsInfo[PntIdx].pols[k]].norm); end; FPolsInfo[PolyIdx].vnorms[j-1]:=VecNorm(FPolsInfo[PolyIdx].vnorms[j-1]); end; end; end; function TLWChunk.GetRootChunks: TLWChunkList; var Parent: TLWParentChunk; begin result := nil; if (FParentChunk = nil) then begin if (FOwner is TLWChunkList) then begin result := FOwner; Exit; end; end else begin Parent := FParentChunk; while not(Parent.ParentChunk = nil) do Parent := Parent.ParentChunk; result := Parent.Owner; end; end; function TLWChunkList.FindChunk(ChunkFind: TLWChunkFind; Criteria: Pointer; StartIndex: Integer): Integer; var Found: boolean; begin Found := false; result := -1; while (StartIndex < Count) and (not Found) do begin ChunkFind(Items[StartIndex],Criteria,Found); if Found then begin result := StartIndex; Exit; end; Inc(StartIndex); end; end; function TLWChunk.GetIndex: Integer; begin result := Owner.IndexOf(Self); end; procedure TLWChunk.Loaded; begin // do nothing end; procedure TLWChunkList.Loaded; var i: Integer; begin for i := 0 to Count-1 do begin Items[i].Loaded; end; end; function TLWParentChunk.GetVec3Param(Param: TID4): TVec12; var pdata: Pointer; begin pdata:=ParamAddr[Param]; if pdata <> nil then begin result:=PVec12(pdata)^; ReverseByteOrder(@result,4,3); end else begin result[0]:=0; result[1]:=1; result[2]:=2; end; end; function TLWParentChunk.GetVXParam(Param: TID4): Word; var pdata: Pointer; begin pdata:=ParamAddr[Param]; if pdata <> nil then result:=ValueOfVX(pdata) else result:=0; end; function TLWParentChunk.GetWordParam(Param: TID4): Word; var pdata: Pointer; begin pdata:=ParamAddr[Param]; if pdata <> nil then begin result:=PU4(pdata)^; ReverseByteOrder(@result,2); end else result:=0; end; procedure TLWParentChunk.Loaded; begin Items.Loaded; end; procedure TLWPols.Loaded; begin inherited; CalcPntsNormals; end; function TLWObjectFile.TagToName(Tag: TU2): string; var TagsIdx: Integer; begin TagsIdx := Chunks.FindChunk(@FindChunkById,@ID_TAGS); if TagsIdx <> -1 then result := TLWTags(Chunks[TagsIdx]).TagToName(Tag); end; { TLWClip } class function TLWClip.GetID: TID4; begin result := ID_CLIP; end; procedure TLWClip.LoadData(AStream: TStream; DataStart, DataSize: LongWord); var CurId: TID4; begin ReadMotorolaNumber(AStream,@FClipIndex,4); while Cardinal(AStream.Position) < (DataStart + DataSize) do begin AStream.Read(CurId,4); Items.Add(GetChunkClass(CurId, TLWSubChunk).Create); with Items[Items.Count - 1] do begin FID:=CurId; LoadFromStream(AStream); end; end; end; { TLWContentDir } {function TLWContentDir.ContentSearch(AFilename: string): string; var i: Integer; begin if not FileExists(AFilename) then begin result := ExtractFileName(AFilename); if not FileExists(result) then begin for i := 0 to SubDirs.Count - 1 do begin if FileExists(Root+'\'+SubDirs[i]+'\'+result) then begin result:=Root+'\'+SubDirs[i]+'\'+result; Exit; end; end; result := ''; end; end; end;} destructor TLWContentDir.Destroy; begin FreeAndNil(FSubDirs); inherited; end; function TLWContentDir.FindContent(AFilename: string): string; var i: Integer; begin if not FileExists(AFilename) then begin result := ExtractFileName(AFilename); if not FileExists(result) then begin for i := 0 to SubDirs.Count - 1 do begin if FileExists(Root+'\'+SubDirs[i]+'\'+result) then begin result:=Root+'\'+SubDirs[i]+'\'+result; Exit; end; end; result := ''; end; end; end; function TLWContentDir.GetSubDirs: TStrings; begin if FSubDirs = nil then FSubDirs := TStringList.Create; result := FSubDirs; end; procedure TLWContentDir.SetRoot(const Value: string); begin FRoot := Value; end; procedure TLWContentDir.SetSubDirs(const Value: TStrings); begin SubDirs.Assign(Value); end; initialization { Pnts } RegisterChunkClass(TLWPnts); { Pols } RegisterChunkClass(TLWPols); { VMap } RegisterChunkClass(TLWVMap); { Tags } RegisterChunkClass(TLWTags); { PTAG } RegisterChunkClass(TLWPTAG); { SURF } RegisterChunkClass(TLWSurf); { LAYR } RegisterChunkClass(TLWLayr); { CLIP } RegisterChunkClass(TLWClip); finalization // UnRegisterChunkClasses; FreeAndNil(ChunkClasses); FreeAndNil(ContentDir); end.