{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit DynaData;

///////////////////////////////////////////////////////////////////////////////
//
//  TclDbTbl.pas
//	Copyright(c) 1995-1997 William Byrne
//		WilliamB@ByrneLitho.com
//		76262.13@CompuServe.com
//
//	All rights reserved.
//  	William Byrne makes no representations about the suitability of this
//    	software for any purpose.  It is provided "as is" without express or
//    	implied warranty.
//
//	Usage
//      I hereby grant to the legal purchasors of the source code contained
//      herein a non-exclusive license for the use of said source code in
//      developing compiled, executable software, and for the distribution of
//      said source code as part of said developed, compiled, executable software.
//
//  Purpose:
//		This file provides for Bde Table Manipulation using the
//		Tcl Scripting Language Components.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self

{$Z+}
{$D-,L-,Y-,R-,H+}
{$O+}

interface
uses SysUtils;

type
	EDynaDataError	= class(Exception);
	pTDynaData	= ^TDynaData;
	TDynaData	= class(TObject)
		private
			pData		: pointer;
			iNext		: word;
			iUnits	: word;
			iDelta	: word;
			wSize		: word;
			function ValidRange(idx : word): boolean;
			procedure CheckIndex(idx : word);
			procedure Resize(size : word);
		protected
			procedure Deleting(FirstItem, Count : word); virtual;
			procedure Expand(items : word);
			procedure Shrink(items : word);
		public
			constructor create(size : word; delta : word);
			destructor destroy; override;
			procedure Embed(p : pointer; idx, offset, len : word);
			procedure SetMem(idx, offset, len : word; C : Char);
			procedure SetItem(idx : word; C : Char);
			procedure EmbedItem(p : pointer; idx : word);
		 	function EmbedNew(p : pointer) : pointer;
			function Add(p : pointer; count : word) : pointer;
			function GetNew(n : word) : pointer;
			function GetNewIdx(n : word)	: word;
			function DupeIdx(id : word):word;
			function Get(id : word):pointer;
			function FindIdx(pData : pointer; offset, len : word; bCaseSens : boolean):longInt;
			function ItemAddress(idx, offset : word):pointer;
			function ItemOffset(idx, offset : word):word;
			function Assigned : word;
			function Allocated : word;
            procedure Choke(n: word);
			procedure Clear;
			procedure Reset;
            procedure Shift(idxHead, idxTail, offset: integer);
            procedure Swap(idx1, idx2: word);
			property Count : word read iNext;
			property Size : word read wSize;
		end;

procedure DynaDataError(const msg : string);

implementation

const
	MaxWord	= 65535;
	seInvalidInit			= 'Invalid Initialization!';
	seIndexOutOfRange		= 'Index Out Of Range!';
	seEmbedBeyondAssigned 	= 'Cannot embed beyond unassigned memory!';
	seValueOutOfRange		= 'Value out of range!';
	seIndexValueZero		= 'Value cannot be zero!';
	seMemoryAlloc			= 'Memory Allocation Failure!';

procedure DynaDataError(const msg : string);
begin
	raise EDynaDataError.Create(msg);
end;

constructor TDynaData.create(size : word; delta : word);
begin
	inherited create;
	if (Size < 1) or (Delta < 1) then DynaDataError(seInvalidInit);
	iUnits 			:= 0;
	iNext  			:= 0;
	pData 			:= nil;
	wSize 			:= size;
	iDelta 			:= delta;
end;

destructor TDynaData.destroy;
begin
	Reset;
	inherited destroy;
end;

procedure TDynaData.Deleting(FirstItem, Count : word);
begin
end;

procedure TDynaData.Shrink( items : word);
begin
	if items > iUnits then DynaDataError(seValueOutOfRange);
	Deleting(iUnits - items, items);
	Resize(iUnits - items);
end;

procedure TDynaData.Resize(size : word);
var
	newData : pointer;
	copyLen : word;
begin
	try
		if size = 0 then
		begin
			if iUnits = 0 then exit;
			freeMem(pData, iUnits * wSize);
		end
		else
		begin
			GetMem(newData, size * wSize);
      		if iUnits > 0 then
     		begin
      			if size > iUnits then copyLen := iUnits * wSize
        		else copyLen := size * wSize;
				Move(pData^, newData^, copyLen);
				freeMem(pData, iUnits * wSize);
            end;
			pData := newData;
		end;
		iUnits := size;
		if iNext > iUnits then iNext := iUnits;
	except
		on Exception do
        	DynaDataError(seMemoryAlloc);
	end;
end;

procedure TDynaData.Choke(n: word);
begin
	if ( n < 0 ) or ( n > iNext ) then
    	DynaDataError(seValueOutOfRange);
    dec(iNext, n);
end;

procedure TDynaData.Clear;
begin
	iNext := 0;
end;

procedure TDynaData.Reset;
begin
	Shrink( iUnits );
end;

function TDynaData.Assigned : word;
begin
	Result := iNext * wSize;
end;

function TDynaData.Allocated : word;
begin
	Result := iUnits * wSize;
end;

procedure TDynaData.Expand(items : word);
var
	deltaCount : word;
begin
	deltaCount := items div iDelta;
	if items mod iDelta <> 0 then inc(deltaCount);
	Resize( (deltaCount * iDelta) + iUnits );
end;

procedure TDynaData.SetMem(idx, offset, len : word; C : Char);
begin
	if ItemOffset(idx, offset) + len > Assigned then DynaDataError(seEmbedBeyondAssigned);
	FillChar(ItemAddress(idx, offset)^, len, C);
end;

procedure TDynaData.SetItem(idx : word; C : Char);
begin
	SetMem(idx, 0, wSize, C);
end;

function TDynaData.Add(p : pointer; count : word) : pointer;
var
	idx : word;
begin
	if count <= 0 then DynaDataError(seIndexValueZero);
	if longInt(count) * wSize > MaxWord then DynaDataError(seValueOutOfRange);
	idx := GetNewIdx(count);
	Result := Get(idx);
	Embed(p, idx, 0, count * wSize);
end;

procedure TDynaData.Embed(p : pointer; idx, offset, len : word);
begin
	if ItemOffset(idx, offset) + len > Assigned then DynaDataError(seEmbedBeyondAssigned);
	if p <> nil then
    	Move(p^, ItemAddress(idx, offset)^, len)
	else
    	FillChar(ItemAddress(idx, offset)^, len, #0);
end;

procedure TDynaData.EmbedItem(p : pointer; idx : word);
begin
	Embed(p, idx, 0, wSize);
end;

function TDynaData.ValidRange(idx : word):boolean;
begin
	Result := (idx >= 0) and (idx < iNext);
end;

procedure TDynaData.CheckIndex(idx : word);
begin
	if not ValidRange(idx) then DynaDataError(seIndexOutOfRange);
end;

function TDynaData.ItemAddress(idx, offset : word):pointer;
begin
	Result := pointer(pChar(Get(idx)) + offset);
end;

function TDynaData.ItemOffset(idx, offset : word):word;
begin
	Result := (idx * wSize) + offset;
end;

function MemComp(P1, P2: Pointer; Len: Cardinal): Integer; assembler;
asm
        PUSH    EDI
        PUSH    ESI
        MOV     EDI,EDX
        MOV     ESI,EAX
        XOR 	EAX,EAX
        OR		ECX,ECX
        JE      @@1
        XOR     EDX,EDX
        REPE    CMPSB
        MOV     AL,[ESI-1]
        MOV     DL,[EDI-1]
        SUB     EAX,EDX
@@1:    POP     ESI
        POP     EDI
end;

function MemIComp(P1, P2: Pointer; Len: Cardinal): Integer; assembler;
asm
        PUSH    EDI
        PUSH    ESI
        MOV     EDI,EDX
        MOV     ESI,EAX
        XOR     EAX,EAX
        OR      ECX,ECX
        JE      @@4
        XOR     EDX,EDX
@@1:    REPE    CMPSB
        JE      @@4
        MOV     AL,[ESI-1]
        CMP     AL,'a'
        JB      @@2
        CMP     AL,'z'
        JA      @@2
        SUB     AL,20H
@@2:    MOV     DL,[EDI-1]
        CMP     DL,'a'
        JB      @@3
        CMP     DL,'z'
        JA      @@3
        SUB     DL,20H
@@3:    SUB     EAX,EDX
        JE      @@1
@@4:    POP     ESI
        POP     EDI
end;

function TDynaData.FindIdx(pData : pointer; offset, len : word; bCaseSens : boolean):longInt;
var
	x: integer;
begin
	x := 0;
	if bCaseSens then
    begin
		while x < iNext do
			if MemComp(pData, ItemAddress(x, offset), len) = 0 then break;
	end else
		while x < iNext do
			if MemIComp(pData, ItemAddress(x, offset), len) = 0 then break;
	if x < iNext then
    	Result := x
    else
		Result := -1;
end;

function TDynaData.GetNewIdx(n : word) : word;
begin
	if n <= 0 then DynaDataError(seValueOutOfRange);
	if n > iUnits - iNext then Expand( n - (iUnits - iNext));
	Result := iNext;
    FillChar((pChar(pData)+(Result * wSize))^, n * wSize, #0);
	inc(iNext, n);
end;

function TDynaData.GetNew(n : word) : pointer;
begin
	Result := Get(GetNewIdx(n));
end;

function TDynaData.EmbedNew(p : pointer) : pointer;
var
	idx : word;
begin
	 idx := GetNewIdx(1);
	 EmbedItem(p, idx);
	 Result := Get(idx);
end;

function TDynaData.Get(id : word):pointer;
begin
	CheckIndex(id);
	Result := pointer(longInt(pData) + (id * wSize));
end;

function TDynaData.DupeIdx(id : word):word;
var
	src, dest : pointer;
begin
	result := GetNewIdx(1);
	src := Get(id);
	dest := Get(Result);
    Move(src^, dest^, wSize);
end;

procedure TDynaData.Shift(idxHead, idxTail, offset: integer);
var
	p1, p2: pointer;
    items: integer;
begin
	if (offset = 0) or (idxHead > idxTail) then
    	exit;
	CheckIndex(idxHead + offset);
    CheckIndex(idxTail + offset);
	p1 := Get(idxHead);
    items := idxTail - idxHead + 1;
    GetMem(p2, items * wSize);
    try
		Move(p1^, p2^, items * wSize);
        inc(longint(p1), offset * wSize);
        Move(p2^, p1^, items * wSize);
        if offset > 0 then
        	p1 := Get(idxHead)
        else
        begin
        	p1 := Get(idxTail);
            inc(longint(p1), (offset + 1) * wSize);
        end;
		FillChar(p1^, abs(offset) * wSize, 0);
    finally
    	FreeMem(p2, items * wSize);
    end;
end;


procedure TDynaData.Swap(idx1, idx2: word);
var
	buf: array[0..255] of byte;
    p1, p2, p3: pointer;
begin
	CheckIndex(idx1);
    CheckIndex(idx2);
    p1 := Get(idx1);
    p2 := Get(idx2);
    if sizeof(buf) >= wSize then
    begin
		Move(p2^, buf, wSize);
        Move(p1^, p2^, wSize);
        Move(buf, p1^, wSize);
    end else
    begin
    	GetMem(p3, wSize);
        try
        	Move(p2^, p3^, wSize);
            Move(p1^, p2^, wSize);
            Move(p3^, p1^, wSize);
        finally
        	FreeMem(p3, wSize);
        end;
    end;
end;

end.
