Advertisement
LarsFosdal

Object type as record structures

Jul 17th, 2015
424
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Delphi 24.41 KB | None | 0 0
  1. {$I SWITCHES.PAS}
  2. UNIT FDBArrays;
  3. {
  4.            FILE: FDBArray.pas
  5.        ABSTRACT: General flat memory array "objects".
  6.  
  7.                  Copyright (c) 1994- Falcon AS
  8.  
  9.          SYSTEM: General ("Falcon System IV")
  10.          MODULE: Database related
  11.  
  12.   RELATED FILES:
  13.  
  14.         WARNING: Do not add Constructors, Destructors, or Virtual methods to
  15.                  the objects in this unit.  It will break the source by adding
  16.                  a VMT and make it impossible to export/import these objects
  17.                  as flat array data from f.x. DLL's.
  18.  
  19.   REVISION HISTORY:
  20.  
  21.   VERSION DATE    COMMENT                                   BY
  22.   ------- ------  ----------------------------------------- -----------
  23.   1.0.000         Initial version                           Lars Fosdal
  24.  
  25. }
  26.  
  27. INTERFACE
  28. USES
  29.   TypeDefs;
  30.  
  31. CONST
  32.   MaxArrayItems = 8000; {Allow upto 8000 doubles in a 64K block}
  33.                         {When 32-bit flat memory arrives, it might be desirable
  34.                          to increase this limit :-) }
  35.  
  36. TYPE
  37.   IDInfo = RECORD {Block "Header-Header" :-)}
  38.     CASE Integer OF
  39.       0 : (Position : OpenByteTable); {x  x} {Typecast for indexed access}
  40.       1 : (ID       : Word;           {2  2} {Data dependant ID}
  41.            TypeID   : Word;           {2  4} {Type dependant ID}
  42.            Version  : Word;           {2  6} {Type ID dependant version number}
  43.            Format   : Word;           {2  8} {Compression type, etc.}
  44.            Flags    : LongInt);       {4 12} {Dirty, etc}
  45.   END; {Rec IDInfo}
  46.  
  47.   pBlockHeader = ^TBlockHeader;
  48.   TBlockHeader = OBJECT(TRecord)
  49.     Block    : IDInfo;                {12 12} {Block ID/Version}
  50.     CompSize : LongInt;               { 4 16} {Compressed size (incl.header)}
  51.     TrueSize : LongInt;               { 4 20} {Uncompressed size (incl.header)}
  52.     CompSum  : LongInt;               { 4 24} {Compressed chksum (excl.header)}
  53.     TrueSum  : LongInt;               { 4 28} {Uncompressed chksum (excl.header)}
  54.     Reserved : ARRAY[1..4] OF LongInt;{16 44} {Reserved for future use}
  55.     PROCEDURE AssignID(DataID, TypeID, Version, Format:Word);
  56.     FUNCTION  IsDirty:Boolean;
  57.     PROCEDURE SetDirty;
  58.     PROCEDURE ClearDirty;
  59.     FUNCTION  IsCompressed:Boolean;
  60.     FUNCTION  Size:LongInt;
  61.     FUNCTION Duplicate:Pointer;
  62.     FUNCTION CheckSum(SizeOfHeader:LongInt):LongInt;
  63.     FUNCTION Compress(SizeOfHeader:LongInt; Format:Word):Pointer;
  64.     FUNCTION Uncompress(SizeOfHeader:LongInt):Pointer;
  65.   END; {OBJ TBlockHeader}
  66.  
  67. TYPE
  68.   pArrayBase = ^TArrayBase;
  69.   TArrayBase = OBJECT(TBlockHeader)     {44 44} {Standard array header}
  70.     ItemSize   : Word;                   { 2 46} {Data item size}
  71.     Rsvd       : Word;                   { 2 48} {Reserved}
  72.     Count      : LongInt;                { 4 52} {Number of Items utilized}
  73.     Limit      : LongInt;                { 4 56} {Max. number of Items}
  74.     Spare      : ARRAY[1..2] OF LongInt; { 8 64} {Reserved}
  75.     PROCEDURE InitArray(_ItemSize:Word; _Limit:LongInt);
  76.     FUNCTION ItemAddress(Index:LongInt):Pointer;
  77.     FUNCTION Append(CONST NewItem):LongInt;
  78.     PROCEDURE Get(Index:LongInt; VAR Item);
  79.     FUNCTION Put(Index:LongInt; CONST Item):LongInt;
  80.     FUNCTION Insert(Index:LongInt; CONST NewItem):LongInt;
  81.     FUNCTION Delete(Index:LongInt):LongInt;
  82.     FUNCTION AppendBlock(CONST NewArrayBase):LongInt;
  83.     FUNCTION InsertBlock(Index:LongInt; CONST NewArrayBase):LongInt;
  84.     FUNCTION DeleteBlock(Index,Items:LongInt):LongInt;
  85.     FUNCTION DuplicateBlock(Index, Items:LongInt):Pointer;
  86.     FUNCTION DeleteAll:LongInt;
  87.     FUNCTION FreeCount:LongInt;
  88.     FUNCTION isEmpty:Boolean;
  89.     FUNCTION isFull:Boolean;
  90.     PROCEDURE Inspect(VAR oFile:Text);
  91.   END; {TArrayBase}
  92.  
  93. TYPE
  94.   pByteArray = ^TByteArray;
  95.   TByteArray = OBJECT(TArrayBase)
  96.     Item : ARRAY [0..MaxArrayItems-1] OF Byte;
  97.     FUNCTION Append(NewItem:Byte):LongInt;
  98.     FUNCTION Insert(Index:LongInt; NewItem:Byte):LongInt;
  99.   END; {REC TByteArray}
  100.  
  101. TYPE
  102.   pSmallIntArray = ^TSmallIntArray;
  103.   TSmallIntArray = OBJECT(TArrayBase)
  104.     Item : ARRAY [0..MaxArrayItems-1] OF SmallInt;
  105.     FUNCTION Append(NewItem:SmallInt):LongInt;
  106.     FUNCTION Insert(Index:LongInt; NewItem:SmallInt):LongInt;
  107.   END; {REC TSmallIntArray}
  108.  
  109. TYPE
  110.   pWordArray = ^TWordArray;
  111.   TWordArray = OBJECT(TArrayBase)
  112.     Item : ARRAY [0..MaxArrayItems-1] OF Word;
  113.     FUNCTION Append(NewItem:Word):LongInt;
  114.     FUNCTION Insert(Index:LongInt; NewItem:Word):LongInt;
  115.   END; {REC TWordArray}
  116.  
  117. TYPE
  118.   pLongIntArray = ^TLongIntArray;
  119.   TLongIntArray = OBJECT(TArrayBase)
  120.     Item : ARRAY [0..MaxArrayItems-1] OF LongInt;
  121.     FUNCTION Append(NewItem:LongInt):LongInt;
  122.     FUNCTION Insert(Index:LongInt; NewItem:LongInt):LongInt;
  123.   END; {REC TLongIntArray}
  124.  
  125. TYPE
  126.   pTimeArray = ^TTimeArray;
  127.   TTimeArray = OBJECT(TArrayBase)
  128.     Item : ARRAY [0..MaxArrayItems-1] OF TTime;
  129.     FUNCTION Append(NewItem:TTime):LongInt;
  130.     FUNCTION Insert(Index:LongInt; NewItem:TTime):LongInt;
  131.   END; {REC TTimeArray}
  132.  
  133. TYPE
  134.   pRealArray = ^TRealArray;
  135.   TRealArray = OBJECT(TArrayBase)
  136.     Item : ARRAY [0..MaxArrayItems-1] OF Real;
  137.     FUNCTION Append(NewItem:Real):LongInt;
  138.     FUNCTION Insert(Index:LongInt; NewItem:Real):LongInt;
  139.     FUNCTION PackToLFD:pRealArray;
  140.     FUNCTION UnpackLFD:pRealArray;
  141.   END; {REC TRealArray}
  142.  
  143. TYPE
  144.   pDoubleArray = ^TDoubleArray;
  145.   TDoubleArray = OBJECT(TArrayBase)
  146.     Item : ARRAY [0..MaxArrayItems-1] OF Double;
  147.     FUNCTION Append(NewItem:Double):LongInt;
  148.     FUNCTION Insert(Index:LongInt; NewItem:Double):LongInt;
  149.     FUNCTION PackToLFD:pDoubleArray;
  150.     FUNCTION UnpackLFD:pDoubleArray;
  151.   END; {REC TDoubleArray}
  152.  
  153. FUNCTION BlockNew(BlockSize:LongInt; VAR Block):LongInt;
  154. FUNCTION BlockDuplicate(VAR Block):Pointer;
  155. PROCEDURE BlockDispose(VAR Block);
  156.  
  157. FUNCTION  ArraySize(ItemSize:Word; Limit:LongInt):LongInt;
  158. FUNCTION  ArrayNew(CONST ItemSize:Word; VAR ArrayBase; ItemLimit:LongInt):LongInt;
  159. PROCEDURE ArrayDispose(VAR ArrayBase);
  160. FUNCTION  ArrayResize(VAR ArrayBase; ItemLimit:LongInt):LongInt;
  161.  
  162. {$IFNDEF NoLog}
  163. FUNCTION DateTimeStr(PDT:TTime):String;
  164. FUNCTION SplitIDStr(PDT:TTime):String;
  165. {$ENDIF}
  166.  
  167. IMPLEMENTATION
  168. USES
  169. {$IFNDEF NoLog}
  170.   LFErrLog, WinInfo, LFString,
  171. {$ENDIF}
  172.   FDBMagic,
  173. {$IFNDEF Win32}
  174.   PKWare,
  175. {$ENDIF}
  176.   WinDate;
  177.  
  178. {$IFNDEF NoLog}
  179. FUNCTION DateTimeStr(PDT:TTime):String;
  180. VAR
  181.   DT : TUnpackedTime;
  182.   sep : String[3];
  183. {$IFNDEF Delphi}
  184.   Result : String;
  185. {$ENDIF}
  186. BEGIN
  187.   UnpackDT(PDT, DT);
  188.   sep := WinIntl^.sDate[0];
  189.   Result:=SwapAll(' ','0',IntStr(DT.Year ,4)+Sep+IntStr(DT.Month,2)+Sep+IntStr(DT.Day,2));
  190.   IF PDT.Time<>0
  191.   THEN Result:=Result+' '+SwapAll(' ','0',IntStr(DT.Hour,2)+Char(WinIntl^.sTime^)
  192.                               +IntStr(DT.Min,2)+Char(WinIntl^.sTime^)
  193.                               +IntStr(DT.Sec,2));
  194. {$IFNDEF Delphi}
  195.   DateTimeStr:=Result;
  196. {$ENDIF}
  197. END; {FUNC DateTimeStr}
  198.  
  199. FUNCTION SplitIDStr(PDT:TTime):String;
  200. VAR
  201.   DT : TUnpackedTime;
  202.   sep : String[3];
  203. {$IFNDEF Delphi}
  204.   Result : String;
  205. {$ENDIF}
  206. BEGIN
  207.   UnpackDT(PDT, DT);
  208.   sep := WinIntl^.sDate[0];
  209.   Result:=SwapAll(' ','0',IntStr(DT.Year ,4)+Sep+IntStr(DT.Month,2)+Sep+IntStr(DT.Day,2));
  210.   Result:=Result+' '+IntStr(PDT.Time,0);
  211. {$IFNDEF Delphi}
  212.   SplitIDStr:=Result;
  213. {$ENDIF}
  214. END; {FUNC SplitIDStr}
  215.  
  216. {$ENDIF}
  217.  
  218.  
  219. {------------------------------------------------------------ Block Primitives ---}
  220.  
  221. FUNCTION BlockNew(BlockSize:LongInt; VAR Block):LongInt;
  222. VAR
  223.   ItemPtr : pBlockHeader Absolute Block;
  224. BEGIN
  225.   GetMem(ItemPtr, BlockSize);
  226.   IF Assigned(ItemPtr)
  227.   THEN BEGIN
  228.     BlockNew:=BlockSize;
  229.     FillChar(ItemPtr^, BlockSize, 0);
  230.     ItemPtr^.TrueSize:=BlockSize;
  231.   END
  232.   ELSE BlockNew:=0;
  233. END; {FUNC BlockNew}
  234.  
  235. PROCEDURE BlockDispose(VAR Block);
  236. VAR
  237.   ItemPtr : pBlockHeader Absolute Block;
  238. BEGIN
  239.   IF Assigned(ItemPtr)
  240.   THEN BEGIN
  241.     FreeMem(ItemPtr, ItemPtr^.Size);
  242.     ItemPtr:=nil;
  243.   END;
  244. END; {PROC BlockDispose}
  245.  
  246. FUNCTION BlockDuplicate(VAR Block):Pointer;
  247. VAR
  248.   Original : pBlockHeader Absolute Block;
  249.   Replica  : pBlockHeader;
  250. BEGIN
  251.   BlockNew(Original^.Size, Replica);
  252.   IF Assigned(Replica)
  253.   THEN Move(Original^, Replica^, Original^.Size);
  254.   BlockDuplicate:=Replica;
  255. END; {FUNC BlockDuplicate}
  256.  
  257.  
  258.  
  259. {------------------------------------------------------ Array Block Primitives ---}
  260.  
  261. TYPE
  262.   pDummyArray = ^TDummyArray;
  263.   TDummyArray = OBJECT(TArrayBase) {for manipulation purposes}
  264.     Data  : OpenByteTable;
  265.   END;
  266.  
  267. FUNCTION ArraySize(ItemSize:Word; Limit:LongInt):LongInt;
  268. { - Calculate memory needed for an array}
  269. BEGIN
  270.   ArraySize:=SizeOf(TArrayBase)+(ItemSize*Limit);
  271. END; {FUNC ArraySize}
  272.  
  273. FUNCTION ArrayNew(CONST ItemSize:Word; VAR ArrayBase; ItemLimit:LongInt):LongInt;
  274. { - Allocate a new array - Returns New Array pointer and size in bytes}
  275. VAR
  276.   Arry : pArrayBase Absolute ArrayBase;
  277. BEGIN
  278.   ArrayNew:=BlockNew( ArraySize(ItemSize, ItemLimit), Arry);
  279.   IF Assigned(Arry)
  280.   THEN Arry^.InitArray(ItemSize, ItemLimit);
  281. END; {FUNC ArrayNew}
  282.  
  283. PROCEDURE ArrayDispose(VAR ArrayBase);
  284. { - DeAllocate an existing array}
  285. BEGIN
  286.   BlockDispose(ArrayBase);
  287. END; {PROC ArrayDispose}
  288.  
  289. FUNCTION ArrayResize(VAR ArrayBase; ItemLimit:LongInt):LongInt;
  290. { - Shrink or grow an Array - Returns new Array pointer and size in bytes}
  291. VAR
  292.   Size    : LongInt;
  293.   CopyLen : LongInt;
  294.   Old     : pArrayBase Absolute ArrayBase;
  295.   Arry    : pArrayBase;
  296. BEGIN
  297.   Size:=ArrayNew(Old^.ItemSize, Arry, ItemLimit);
  298.   IF Size>Old^.Size
  299.   THEN CopyLen:=Old^.Size
  300.   ELSE CopyLen:=Size;
  301.   Move(Old^, Arry^, CopyLen);
  302.   Arry^.TrueSize:=Size;
  303.   Arry^.Limit:=ItemLimit;
  304.   IF Arry^.Count>ItemLimit
  305.   THEN Arry^.Count:=ItemLimit;
  306.   ArrayDispose(Old);
  307.   Old:=Arry;
  308.   ArrayResize:=Size;
  309. END; {FUNC ArrayResize}
  310.  
  311.  
  312. {------------------------------------------------------------- TBlockHeader ---}
  313.  
  314. FUNCTION TBlockHeader.IsDirty:Boolean;
  315. BEGIN
  316.   IsDirty:=Block.Flags and $0001 = $0001;
  317. END; {FUNC TBlockHeader.IsDirty}
  318.  
  319. PROCEDURE TBlockHeader.SetDirty;
  320. BEGIN
  321.   Block.Flags:=Block.Flags or $0001;
  322. END; {PROC TBlockHeader.SetDirty}
  323.  
  324. PROCEDURE TBlockHeader.ClearDirty;
  325. BEGIN
  326.   Block.Flags:=Block.Flags and $FFFE;
  327. END; {PROC TBlockHeader.ClearDirty}
  328.  
  329. FUNCTION TBlockHeader.IsCompressed:Boolean;
  330. BEGIN
  331.   IsCompressed:=Block.Format<>0;
  332. END; {FUNC TBlockHeader.IsCompressed}
  333.  
  334. FUNCTION TBlockHeader.Size:LongInt;
  335. BEGIN
  336.   IF IsCompressed
  337.   THEN Size:=CompSize
  338.   ELSE Size:=TrueSize;
  339. END; {FUNC TBlockHeader.Size}
  340.  
  341. FUNCTION TBlockHeader.Duplicate:Pointer;
  342. { - Duplicate a block - Returns pointer to new block}
  343. VAR
  344.   ptr : Pointer;
  345. BEGIN
  346.   ptr:=@Self;
  347.   Duplicate:=BlockDuplicate(ptr);
  348. END; {FUNC TBlockHeader.Duplicate}
  349.  
  350. FUNCTION TBlockHeader.CheckSum(SizeOfHeader:LongInt):LongInt;
  351. BEGIN
  352.   CheckSum:=0;
  353. END; {FUNC TBlockHeader.CheckSum}
  354.  
  355. FUNCTION TBlockHeader.Compress(SizeOfHeader:LongInt; Format:Word):Pointer;
  356. VAR
  357.   NewBlock : pBlockHeader;
  358.   Original : pBlockHeader;
  359. BEGIN
  360.   NewBlock:=nil;
  361.   Original:=pBlockHeader(@Self);
  362.   {$IFNDEF Win32}
  363.   IF Original^.TrueSize > SizeOfHeader
  364.   THEN BEGIN
  365.  
  366.     IF (Format and icp_LZW = icp_LZW)
  367.     THEN BEGIN
  368.     {$IFOPT R+}{$R-}{$DEFINE RPlus}{$ENDIF}
  369.       ImplodeInit(Original^.TrueSize - SizeOfHeader,
  370.                   @Original^.Block.Position[SizeOfHeader]);
  371.     {$IFDef Rplus}{$R+}{$UNDEF RPlus}{$ENDIF}
  372.       IF ImplodeData
  373.       THEN BEGIN
  374.         WITH PKZ
  375.         DO BEGIN
  376.           BlockNew(TargetPos + SizeOfHeader, NewBlock);
  377.           Move(Original^, NewBlock^, SizeOfHeader);
  378.       {$IFOPT R+}{$R-}{$DEFINE RPlus}{$ENDIF}
  379.           Move(Target^, NewBlock^.Block.Position[SizeOfHeader], TargetPos);
  380.       {$IFDef Rplus}{$R+}{$UNDEF RPlus}{$ENDIF}
  381.           NewBlock^.CompSize:=TargetPos + SizeOfHeader;
  382.           NewBlock^.Block.Format:=NewBlock^.Block.Format or icp_LZW;
  383.         END;
  384.         Format:=Format and not icp_LZW;
  385.       END
  386.     {$IFNDEF NoLog}
  387.       ELSE LogError('PKZ compression failed - Leaving data uncompressed!')
  388.     {$ENDIF};
  389.       ImplodeDone;
  390.      END; {icp_LZW}
  391.   END;
  392.   {$ENDIF}
  393.   IF not Assigned(NewBlock)
  394.   THEN NewBlock:=Original^.Duplicate;
  395.   IF Assigned(Original)  and (Original<>NewBlock) and (Original<>@Self)
  396.   THEN BlockDispose(Original);
  397.   Compress:=NewBlock;
  398. END; {FUNC TBlockHeader.Compress}
  399.  
  400. FUNCTION TBlockHeader.Uncompress(SizeOfHeader:LongInt):Pointer;
  401. VAR
  402.   NewBlock : pBlockHeader;
  403.   Original : pBlockHeader;
  404. BEGIN
  405.   NewBlock:=nil;
  406.   Original:=pBlockHeader(@Self);
  407. {$IFDEF Win32}
  408.   {//Incomplete}
  409. {$ELSE}
  410.   IF (Original^.Block.Format and icp_LZW = icp_LZW)
  411.   THEN BEGIN
  412.     BlockNew(Original^.TrueSize, NewBlock);
  413.     Move(Original^, NewBlock^, SizeOfHeader);
  414.   {$IFOPT R+}{$R-}{$DEFINE RPlus}{$ENDIF}
  415.     ExplodeInit(Original^.CompSize - SizeOfHeader,
  416.                @Original^.Block.Position[SizeOfHeader],
  417.                Original^.TrueSize - SizeOfHeader,
  418.                @NewBlock^.Block.Position[SizeOfHeader]);
  419.   {$IFDef Rplus}{$R+}{$UNDEF RPlus}{$ENDIF}
  420.     IF ExplodeData
  421.     THEN BEGIN
  422.       NewBlock^.CompSize:=0;
  423.       NewBlock^.Block.Format:=NewBlock^.Block.Format and not icp_LZW;
  424.     END
  425.     ELSE BEGIN
  426.     {$IFNDEF NoLog}
  427.       LogError('PKZ decompression failed - Leaving data compressed!');
  428.     {$ENDIF}
  429.       BlockDispose(NewBlock);
  430.     END;
  431.     ExplodeDone;
  432.   END; {icp_LZW}
  433. {$ENDIF}
  434.  
  435.   IF not Assigned(NewBlock)
  436.   THEN NewBlock:=Original^.Duplicate;
  437.   IF Assigned(Original)  and (Original<>NewBlock) and (Original<>@Self)
  438.   THEN BlockDispose(Original);
  439.   Uncompress:=NewBlock;
  440. END; {FUNC TBlockHeader.Uncompress}
  441.  
  442. PROCEDURE TBlockHeader.AssignID(DataID, TypeID, Version, Format:Word);
  443. BEGIN
  444.   Block.ID:=DataID;
  445.   Block.TypeID:=TypeID;
  446.   Block.Version:=Version;
  447.   Block.Format:=Format;
  448. END; {PROC TBlockHeader.AssignID}
  449.  
  450.  
  451. {------------------------------------------------------------ TArrayBase ---}
  452. {$IFOPT R+} {$DEFINE RPlus} {$R-} {$ENDIF}
  453.  
  454. PROCEDURE TArrayBase.InitArray(_ItemSize:Word; _Limit:LongInt);
  455. BEGIN
  456.   ItemSize:=_ItemSize;
  457.   Limit:=_Limit;
  458. END; {PROC TArrayBase.Init}
  459.  
  460. FUNCTION TArrayBase.DuplicateBlock(Index,Items:LongInt):Pointer;
  461. { - Copy a partial Array - Returns pointer to new array}
  462. VAR
  463.   Original : TDummyArray Absolute Self;
  464.   Arry     : pDummyArray;
  465. BEGIN
  466.   Arry:=nil;
  467.   WITH Original
  468.   DO BEGIN
  469.     IF (Count>0) and (Index<Count)
  470.     THEN BEGIN
  471.       IF Index+Items>Count
  472.       THEN Items:=Count-Index+1;
  473.       ArrayNew(ItemSize, Arry, Items);
  474.       IF Assigned(Arry)
  475.       THEN BEGIN
  476.         Arry^.Block:=Original.Block;
  477.         Move(Data[Index*ItemSize], Arry^.Data[0], Items*ItemSize);
  478.         Arry^.Count:=Items;
  479.       END;
  480.     END
  481.     ELSE Arry:=nil;
  482.   END;
  483.   DuplicateBlock:=Arry;
  484. END; {FUNC TArrayBase.DuplicateBlock}
  485.  
  486. FUNCTION TArrayBase.ItemAddress(Index:LongInt):Pointer;
  487. VAR
  488.   Original : TDummyArray Absolute Self;
  489. BEGIN
  490.   IF (Index<Count) and (Index>-1)
  491.   THEN ItemAddress:=@Original.Data[Index*ItemSize]
  492.   ELSE ItemAddress:=nil;
  493. END; {FUNC TArrayBase.ItemAddress}
  494.  
  495. FUNCTION TArrayBase.Append(CONST NewItem):LongInt;
  496. { - Append an item to the array - return number of items or -1 if failure}
  497. VAR
  498.   Original : TDummyArray Absolute Self;
  499. BEGIN
  500.   IF Count<Limit
  501.   THEN BEGIN
  502.     Move(NewItem, Original.Data[Count*ItemSize], ItemSize);
  503.     SetDirty;
  504.     Inc(Count);
  505.     Append:=Count;
  506.   END
  507.   ELSE Append:=-1;
  508. END; {FUNC TArrayBase.Append}
  509.  
  510. PROCEDURE TArrayBase.Get(Index:LongInt; VAR Item);
  511. VAR
  512.   Original : TDummyArray Absolute Self;
  513. BEGIN
  514.   IF (Index<Count)
  515.   THEN BEGIN
  516.     Move(Original.Data[Index*ItemSize], Item, ItemSize);
  517.   END;
  518. END; {PROC TArrayBase.Get}
  519.  
  520. FUNCTION TArrayBase.Put(Index:LongInt; CONST Item):LongInt;
  521. VAR
  522.   Original : TDummyArray Absolute Self;
  523. BEGIN
  524.   IF (Index<Count)
  525.   THEN BEGIN
  526.     Move(Item, Original.Data[Index*ItemSize], ItemSize);
  527.     SetDirty;
  528.     Put:=Index;
  529.   END
  530.   ELSE Put:=-1;
  531. END; {FUNC TArrayBase.Put}
  532.  
  533. FUNCTION TArrayBase.Insert(Index:LongInt; CONST NewItem):LongInt;
  534. { - Insert an item in the array - Return number of items or -1 if failure}
  535. VAR
  536.   Original : TDummyArray Absolute Self;
  537. BEGIN
  538.   IF Count<Limit
  539.   THEN BEGIN
  540.     IF Index>Count
  541.     THEN Index:=Count;
  542.     IF Index<>Count
  543.     THEN Move(Original.Data[Index*ItemSize],
  544.               Original.Data[(Index+1)*ItemSize], (Count-Index)*ItemSize);
  545.     Move(NewItem, Original.Data[Index*ItemSize], ItemSize);
  546.     Inc(Count);
  547.     Insert:=Count;
  548.     SetDirty;
  549.   END
  550.   ELSE Insert:=-1;
  551. END; {FUNC TArrayBase.Insert}
  552.  
  553. FUNCTION TArrayBase.Delete(Index:LongInt):LongInt;
  554. { - Delete an item from the array - return number of items or -1 if failure}
  555. VAR
  556.   Original : TDummyArray Absolute Self;
  557. BEGIN
  558.   IF Count>0
  559.   THEN BEGIN
  560.     IF Index<=Count
  561.     THEN BEGIN
  562.       IF Index<>Count-1
  563.       THEN Move(Original.Data[(Index+1)*ItemSize],
  564.                 Original.Data[Index*ItemSize], ((Count-Index)-1)*ItemSize);
  565.       Dec(Count);
  566.       FillChar(Original.Data[Count*ItemSize], ItemSize, 0);
  567.       SetDirty;
  568.     END;
  569.     Delete:=Count;
  570.   END
  571.   ELSE Delete:=-1;
  572. END; {FUNC TArrayBase.Delete}
  573.  
  574. FUNCTION TArrayBase.AppendBlock(CONST NewArrayBase):LongInt;
  575. { - Append another array, return number of items or -1 if failure}
  576. VAR
  577.   Original : TDummyArray Absolute Self;
  578.   Apnd : pDummyArray Absolute NewArrayBase;
  579. BEGIN
  580.   IF Count+Apnd^.Count <= Limit
  581.   THEN BEGIN
  582.     Move(Apnd^.Data, Original.Data[Count*ItemSize], Apnd^.Count*ItemSize);
  583.     Count:=Count+Apnd^.Count;
  584.     AppendBlock:=Count;
  585.     SetDirty;
  586.   END
  587.   ELSE AppendBlock:=-1;
  588. END; {FUNC TArrayBase.AppendBlock}
  589.  
  590. FUNCTION TArrayBase.InsertBlock(Index:LongInt; CONST NewArrayBase):LongInt;
  591. { - Insert another array - return number of items or -1 if failure}
  592. VAR
  593.   Original : TDummyArray Absolute Self;
  594.   Apnd : pDummyArray Absolute NewArrayBase;
  595. BEGIN
  596.   IF (Count+Apnd^.Count <= Limit) and (Apnd^.Count>0)
  597.   THEN BEGIN
  598.     IF Index>Count
  599.     THEN Index:=Count;
  600.     IF Index<>Count
  601.     THEN Move(Original.Data[(Index)*ItemSize],
  602.               Original.Data[(Index+Apnd^.Count)*ItemSize],
  603.               (Count-Index)*ItemSize);
  604.     Move(Apnd^.Data, Original.Data[Index*ItemSize], Apnd^.Count*ItemSize);
  605.     Count:=Count+Apnd^.Count;
  606.     InsertBlock:=Count;
  607.     SetDirty;
  608.   END
  609.   ELSE InsertBlock:=-1;
  610. END; {FUNC TArrayBase.InsertBlock}
  611.  
  612. FUNCTION TArrayBase.DeleteBlock(Index,Items:LongInt):LongInt;
  613. { - Delete a section of an array, return number of items or -1 if failure}
  614. VAR
  615.   Original : TDummyArray Absolute Self;
  616. BEGIN
  617.   IF (Count>0) and (Items>0)
  618.   THEN BEGIN
  619.     IF Index<Count
  620.     THEN BEGIN
  621.       IF (Index+Items)>Count
  622.       THEN Items:=Count-Index
  623.       ELSE IF (Index+Items) < Count
  624.       THEN Move(Original.Data[(Index+Items)*ItemSize],
  625.            Original.Data[Index*ItemSize], ((Count-Index)-Items)*ItemSize);
  626.       Count:=Count-Items;
  627.       FillChar(Original.Data[Count*ItemSize], Items*ItemSize, 0);
  628.       SetDirty;
  629.     END;
  630.     DeleteBlock:=Count;
  631.   END
  632.   ELSE DeleteBlock:=-1;
  633. END; {FUNC TArrayBase.DeleteBlock}
  634.  
  635. {$IFDEF Rplus} {$UNDEF RPlus} {$R+} {$ENDIF}
  636.  
  637.  
  638. FUNCTION TArrayBase.DeleteAll:LongInt;
  639. { - Resets array count and clears contents - always returns 0}
  640. VAR
  641.   Original : TDummyArray Absolute Self;
  642. BEGIN
  643.   FillChar(Original.Data, Limit*ItemSize, 0);
  644.   Count:=0;
  645.   DeleteAll:=0;
  646.   SetDirty;
  647. END; {PROC TArrayBase.DeleteAll}
  648.  
  649. FUNCTION TArrayBase.FreeCount:LongInt;
  650. { - Returns the number of free positions}
  651. BEGIN
  652.   FreeCount:=Count-Limit;
  653. END; {FUNC TArrayBase.FreeCount}
  654.  
  655. FUNCTION TArrayBase.IsEmpty:Boolean;
  656. BEGIN
  657.   IsEmpty:=Count=0;
  658. END; {FUNC TArrayBase.IsEmpty:Boolean}
  659.  
  660. FUNCTION TArrayBase.isFull:Boolean;
  661. { - Returns TRUE if the array is full}
  662. BEGIN
  663.   isFull:=FreeCount=0;
  664. END; {FUNC TArrayBase.isFull}
  665.  
  666. PROCEDURE TArrayBase.Inspect(VAR oFile:Text);
  667. BEGIN
  668.   Writeln(oFile, ' IS=', ItemSize, '  Max=',Limit,'  n=',Count);
  669. END; {PROC TArrayBase.Inspect}
  670.  
  671. {---------------------------------------------------------------- TByteArray ---}
  672.  
  673. FUNCTION TByteArray.Append(NewItem:Byte):LongInt;
  674. BEGIN
  675.   Append:=Inherited Append(NewItem);
  676. END; {FUNC TByteArray.Append}
  677.  
  678. FUNCTION TByteArray.Insert(Index:LongInt; NewItem:Byte):LongInt;
  679. BEGIN
  680.   Insert:=Inherited Insert(Index, NewItem);
  681. END; {FUNC TByteArray.Insert}
  682.  
  683. {---------------------------------------------------------------- TSmallIntArray ---}
  684.  
  685. FUNCTION TSmallIntArray.Append(NewItem:SmallInt):LongInt;
  686. BEGIN
  687.   Append:=Inherited Append(NewItem);
  688. END; {FUNC TSmallIntArray.Append}
  689.  
  690. FUNCTION TSmallIntArray.Insert(Index:LongInt; NewItem:SmallInt):LongInt;
  691. BEGIN
  692.   Insert:=Inherited Insert(Index, NewItem);
  693. END; {FUNC TSmallIntArray.Insert}
  694.  
  695. {---------------------------------------------------------------- TWordArray ---}
  696.  
  697. FUNCTION TWordArray.Append(NewItem:Word):LongInt;
  698. BEGIN
  699.   Append:=Inherited Append(NewItem);
  700. END; {FUNC TWordArray.Append}
  701.  
  702. FUNCTION TWordArray.Insert(Index:LongInt; NewItem:Word):LongInt;
  703. BEGIN
  704.   Insert:=Inherited Insert(Index, NewItem);
  705. END; {FUNC TWordArray.Insert}
  706.  
  707. {---------------------------------------------------------------- TLongIntArray ---}
  708.  
  709. FUNCTION TLongIntArray.Append(NewItem:LongInt):LongInt;
  710. BEGIN
  711.   Append:=Inherited Append(NewItem);
  712. END; {FUNC TLongIntArray.Append}
  713.  
  714. FUNCTION TLongIntArray.Insert(Index:LongInt; NewItem:LongInt):LongInt;
  715. BEGIN
  716.   Insert:=Inherited Insert(Index, NewItem);
  717. END; {FUNC TLongIntArray.Insert}
  718.  
  719. {---------------------------------------------------------------- TTimeArray ---}
  720.  
  721. FUNCTION TTimeArray.Append(NewItem:TTime):LongInt;
  722. BEGIN
  723.   Append:=Inherited Append(NewItem);
  724. END; {FUNC TTimeArray.Append}
  725.  
  726. FUNCTION TTimeArray.Insert(Index:LongInt; NewItem:TTime):LongInt;
  727. BEGIN
  728.   Insert:=Inherited Insert(Index, NewItem);
  729. END; {FUNC TTimeArray.Insert}
  730.  
  731. {---------------------------------------------------------------- TRealArray ---}
  732.  
  733. FUNCTION TRealArray.Append(NewItem:Real):LongInt;
  734. BEGIN
  735.   Append:=Inherited Append(NewItem);
  736. END; {FUNC TRealArray.Append}
  737.  
  738. FUNCTION TRealArray.Insert(Index:LongInt; NewItem:Real):LongInt;
  739. BEGIN
  740.   Insert:=Inherited Insert(Index, NewItem);
  741. END; {FUNC TRealArray.Insert}
  742.  
  743. FUNCTION TRealArray.PackToLFD:pRealArray;
  744. BEGIN
  745.   PackToLFD:=@Self; {/// Incomplete}
  746. END; {FUNC TRealArray.PackToLFD}
  747.  
  748. FUNCTION TRealArray.UnpackLFD:pRealArray;
  749. BEGIN
  750.   UnpackLFD:=@Self; {/// Incomplete}
  751. END; {FUNC TRealArray.UnpackLFD}
  752.  
  753.  
  754. {---------------------------------------------------------------- TDoubleArray ---}
  755.  
  756. FUNCTION TDoubleArray.Append(NewItem:Double):LongInt;
  757. BEGIN
  758.   Append:=Inherited Append(NewItem);
  759. END; {FUNC TDoubleArray.Append}
  760.  
  761. FUNCTION TDoubleArray.Insert(Index:LongInt; NewItem:Double):LongInt;
  762. BEGIN
  763.   Insert:=Inherited Insert(Index, NewItem);
  764. END; {FUNC TDoubleArray.Insert}
  765.  
  766. FUNCTION TDoubleArray.PackToLFD:pDoubleArray;
  767. VAR
  768.   LFDArray : pDummyArray;
  769.   LFDLimit,
  770.   iDouble,
  771.   iLFD     : LongInt;
  772.   iLen     : Integer;
  773. BEGIN
  774.   LFDArray:=Duplicate;
  775. (*  LFDLimit:=(Limit*ItemSize) - (11+SizeOf(Count)+SizeOf(Limit));
  776.   iDouble:=0;
  777.   iLFD:=0;
  778. {$IFOPT R+} {$DEFINE Rplus} {$R-} {$ENDIF}
  779.   Move(Count, LFDArray^.Data[iLFD], SizeOf(Count));   iLFD:=iLFD+SizeOf(Count);
  780.   Move(Limit, LFDArray^.Data[iLFD], SizeOf(Limit));   iLFD:=iLFD+SizeOf(Limit);
  781.   WHILE (iDouble<Count) and (iLFD<LFDLimit)
  782.   DO BEGIN
  783.     iLen:=DoubleToLFD(Item[iDouble], LFDArray^.Data[iLFD]);
  784.     iLFD:=iLFD+iLen;
  785.     Inc(iDouble);
  786.   END;
  787. {$IFDEF Rplus} {$R-} {$UNDEF Rplus} {$ENDIF}
  788.   IF iDouble<Count
  789.   THEN BEGIN
  790.     ArrayDispose(LFDArray);
  791.     LFDArray:=@Self;
  792.   END
  793.   ELSE BEGIN
  794.     iLen:=((iLFD+SizeOf(Count)+SizeOf(Limit)) DIV ItemSize)+1;
  795.     ArrayResize(LFDArray, iLen);
  796.     LFDArray^.Block.Format:=LFDArray^.Block.Format or icp_LFD;
  797.     LFDArray^.CompSize:=LFDArray^.TrueSize;
  798.   END;
  799. *)
  800.   PackToLFD:=pDoubleArray(LFDArray);
  801. END; {FUNC TDoubleArray.PackToLFD}
  802.  
  803. FUNCTION TDoubleArray.UnpackLFD:pDoubleArray;
  804. VAR
  805.   DoubleArray : pDoubleArray;
  806.   LFDArray    : TDummyArray Absolute Self;
  807.   LFDLimit,
  808.   iDouble,
  809.   iLFD     : LongInt;
  810.   iLen     : Integer;
  811.   nLimit,
  812.   nCount   : LongInt;
  813. BEGIN
  814.   iLFD:=0;
  815. {$IFOPT R+} {$DEFINE Rplus} {$R-} {$ENDIF}
  816.   Move(LFDArray.Data[iLFD], nCount, SizeOf(Count));   iLFD:=iLFD+SizeOf(Count);
  817.   Move(LFDArray.Data[iLFD], nLimit, SizeOf(Limit));   iLFD:=iLFD+SizeOf(Limit);
  818.   iDouble:=0;
  819.   LFDLimit:=Limit*ItemSize - (SizeOf(Count)+SizeOf(Limit));
  820.   ArrayNew(ItemSize, DoubleArray, nLimit);
  821. (*
  822.   WHILE (iDouble<nCount) and (iLFD<LFDLimit)
  823.   DO BEGIN
  824.     iLen:=LFDtoDouble(LFDArray.Data[iLFD], DoubleArray^.Item[iDouble]);
  825.     iLFD:=iLFD+iLen;
  826.     Inc(iDouble);
  827.   END;
  828.   DoubleArray^.Count:=iDouble;
  829. *)
  830. {$IFDEF Rplus} {$R-} {$UNDEF Rplus} {$ENDIF}
  831.   UnpackLFD:=DoubleArray; {/// Incomplete}
  832. END; {FUNC TDoubleArray.UnpackLFD}
  833.  
  834.  
  835. END.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement