My experiment on doing a binary tree based DB system instead of B-trees

damn.pas

{
Name            : DAMN! 1.00a
Purpose         : Dynamic Architectured data ManagemeNt
Date            : 25th May 94
Coder           : SSG

Update Info:
------------
25th May 94 - 02:00 - Starting at start...
}

{
notes:

each key has its own base-block specified in data header

data file structure
-------------------
header
key info
record data

index file structure
--------------------
header
blocks...
}

unit Damn;

interface

uses Dos,XTypes,Objects,Debris,XBuf,XIO;

const

{ file extensions }

  Ext_Data  : string[4] = '.DAM';
  Ext_Index : string[4] = '.DDX';

{ generic constants }

  DAMNId        = $4E4D4144;
  DAMNVersion   : word = $100;
  DAMNBlockSize : word = $800;

{ record flags }
  Rec_Deleted   = 1;
  Rec_Record    = $DE;

{ key types }

  Key_Binary    = 1;
  Key_String    = 2;

{ key flags }

  Key_Unique    = $100;
  Key_Reverse   = $200;

type

  PDataHeader = ^TDataHeader;
  TDataHeader = record
    case boolean of
      true  : (Data : array[0..255] of byte;);
      false : (Id        : longint;
               Version   : word;
               BlockSize : word;
               FirstFree : longint;
               RecSize   : word;
               KeyCount  : byte;);
  end;

  PIndexHeader = ^TIndexHeader;
  TIndexHeader = record
    FirstFree  : longint;
  end;

  PKeyInfo = ^TKeyInfo;
  TKeyInfo = object
    KeyType : word; {lo = keytype; hi = keyflags}
    Ofs     : word;
    Size    : word;
    BasePtr : longint;
  end;

  PKeyLink = ^TKeyLink;
  TKeyLink = object(TKeyInfo)
    Next   : PKeyLink;
  end;

  PKeyHeader = ^TKeyHeader;
  TKeyHeader = object
    DataPtr  : longint;
    RootPtr  : longint;
    Data     : record end;
  end;

  TRecordHeader = object
    Id          : byte;
    Flags       : byte;
  end;

  PBlock = ^TBlock;
  TBlock = object
    ItemCount : word;
  end;

  PDeletedBlock = ^TDeletedBlock;
  TDeletedBlock = object(TBlock)
    NextFree    : longint;
  end;

  PDamn = ^TDamn;
  TDamn = object(TObject)
    sData     : PDosStream;
    sIndex    : PDosStream;
    nData     : PString;
    nIndex    : PString;
    Status    : word;
    BufSize   : word;
    Buf       : pointer;
    RecSize   : word;
    KeyCount  : byte;
    KeyList   : PKeyLink;
    BlockSize : word;
    constructor Init(AName:FNameStr;ARecSize:word;Keys:PKeyLink);
    procedure   Write(RecPtr:Pointer);
    procedure   GetBlockSize;
    procedure   CalcKeyCount;
    function    GetFirstDataOffset:longint;
    function    Compare(var key1,key2; Info:PKeyInfo):integer;
    procedure   BuildData;
    procedure   ReadBlock(Ptr:longint; var Block:TBlock);
    function    CreateBlock:longint;
    function    GoTree(Ptr:longint; var Block:TBlock):longint;
    function    IsFree(items,size:word):boolean;
    procedure   PutKeyToBlock(var block:TBlock;var key;Info:PKeyInfo;
						        dataoffset:longint);
    procedure   WriteIndex(var rec; GivenKey:PKeyInfo; DataOffset:longint);
    procedure   BuildIndex;
    destructor  Done;virtual;
    procedure   AllocBuf(Size:word);
    procedure   DisposeBuf;
    procedure   Open;
    procedure   Close;
  end;

function NewKey(KeyType:word;KeySize,KeyOfs:word;Next:PKeyLink):PKeyLink;

implementation

procedure DisposeKeyLink(var P:PKeyLink);
begin
  if P^.Next <> NIL then DisposeKeyLink(P^.Next);
  Dispose(P);
  P := NIL;
end;

constructor TDamn.Init;
begin
  TObject.Init;
  nData   := NewStr(XAddExt(FExpand(AName),Ext_Data));
  nIndex  := NewStr(XAddExt(FExpand(AName),Ext_Index));
  RecSize := ARecSize;
  KeyList := Keys;
  CalcKeyCount;
  Open;
  GetBlockSize;
end;

procedure TDamn.Write(RecPtr:Pointer);
var
  DH:TDataHeader;
  RH:TRecordHeader;
  P:PKeyLink;
  Last:longint;
begin
  sData^.Seek(0);
  sData^.Read(DH,SizeOf(DH));
  Last := DH.FirstFree;
  if Last > 0 then Last := sData^.GetSize else begin
    sData^.Seek(DH.FirstFree+SizeOf(TRecordHeader));
    sData^.Read(DH.FirstFree,SizeOf(DH.FirstFree));
    sData^.Seek(0);
    sData^.Write(DH,SizeOf(DH));
  end;
  RH.Id    := Rec_Record;
  RH.Flags := 0;
  sData^.Seek(Last);
  sData^.Write(RH,SizeOf(RH));
  sData^.Write(RecPtr^,RecSize);
  P := KeyList;
  while P <> NIL do begin
    WriteIndex(RecPtr^,P,Last);
    P := P^.Next;
  end;
end;

procedure TDamn.GetBlockSize;
var
  H:TDataHeader;
begin
  sData^.Seek(0);
  sData^.Read(H,SizeOf(H));
  BlockSize := H.BlockSize;
end;

procedure TDamn.CalcKeyCount;
var
  P:PKeyLink;
begin
  KeyCount := 0;
  P        := KeyList;
  while P <> NIL do begin
    inc(KeyCount);
    P := P^.Next;
  end;
end;

function TDamn.GetFirstDataOffset:longint;
begin
  GetFirstDataOffset := SizeOf(TDataHeader)+SizeOf(TKeyInfo)*KeyCount;
end;

function TDamn.Compare(var key1,key2; Info:PKeyInfo):integer;
begin
  case Lo(Info^.KeyType) of
    Key_Binary : Compare := BinaryComp(key1,key2,Info^.Size);
    Key_String : Compare := StrComp(String(key1),String(key2));
    else Compare := 0;
  end; {case}
end;

procedure TDamn.BuildData;
var
  P:PKeyLink;
begin
  AllocBuf(SizeOf(TDataHeader));
  ClearBuf(Buf^,BufSize);
  sData^.Seek(0);
  sData^.Truncate;
  with PDataHeader(Buf)^ do begin
    Id        := DAMNId;
    Version   := DAMNVersion;
    BlockSize := DAMNBlockSize;
    PDataHeader(Buf)^.KeyCount  := Self.KeyCount;
  end;
  sData^.Write(Buf^,SizeOf(TDataHeader));
end;

procedure TDamn.ReadBlock(Ptr:longint; var Block:TBlock);
begin
  sIndex^.Seek(Ptr);
  sIndex^.Read(Block,BlockSize);
end;

function TDamn.CreateBlock;
var
  IH:TIndexHeader;
  BH:TDeletedBlock;
  Last:longint;
begin
  sIndex^.Seek(0);
  sIndex^.Read(IH,SizeOf(IH));
  Last := Ofs(PIndexHeader(NIL)^.FirstFree);
  if Last <> -1 then begin
    sIndex^.Seek(Last);
    sIndex^.Read(BH,SizeOf(BH));
    IH.FirstFree := BH.NextFree;
    sIndex^.Seek(0);
    sIndex^.Write(IH,SizeOf(IH));
  end;
  if Last < 1 then Last := sIndex^.GetSize;
  sIndex^.Seek(Last);
  BH.ItemCount := 0;
  sIndex^.Write(BH,SizeOf(TBlock));
  CreateBlock := Last;
end;

function TDamn.GoTree(Ptr:longint; var Block:TBlock):longint;
begin
  if Ptr = 0 then Ptr := CreateBlock;
  ReadBlock(Ptr,Block);
  GoTree := Ptr;
end;

function TDamn.IsFree(items,size:word):boolean;
begin
  IsFree := ((items*(size+SizeOf(TKeyHeader))+SizeOf(TBlock)) > size);
end;

procedure TDamn.PutKeyToBlock(var block:TBlock;var key;Info:PKeyInfo;
						    dataoffset:longint);
var
  P:Pointer;
  P2:Pointer;
  n:integer;
  comp:integer;
  remaining:word;
  totsize:word;
  PK:PKeyHeader;
begin
  P := @Block;
  inc(word(P),SizeOf(TBlock));
  totsize   := SizeOf(TKeyHeader)+Info^.Size;
  remaining := totsize*Block.ItemCount;
  GetMem(PK,totsize);
  with PK^ do begin
    DataPtr := DataOffset;
    RootPtr := 0;
    Move(Key,Data,Info^.Size);
  end;
  for n:=1 to Block.ItemCount do begin
    comp :=  Compare(key,PKeyHeader(P)^.Data,Info);
    if (comp < 0) or ((comp = 0) and (Info^.KeyType and Key_Unique = 0)) then break;
    dec(Remaining,totsize);
    inc(word(P),Info^.Size+SizeOf(TKeyHeader));
  end;
  if remaining > 0 then begin
    P2 := P;
    inc(word(P2),totsize);
    Move(P^,P2^,remaining);
  end;
  Move(PK^,P^,totsize);
end;

procedure TDamn.WriteIndex(var rec; GivenKey:PKeyInfo; DataOffset:longint);
var
  PrevItem,Item  : PKeyHeader;
  Block : PBlock;
  P	   : Pointer;
  LastComp : integer;
  Comp	 : integer;
  LastPos	 : longint;
  n		 : integer;
  Temp	: Pointer;
  OldDataPtr : longint;
  totsize	: word;
begin
  totsize := SizeOf(TKeyHeader)+GivenKey^.Size;
  GetMem(Item,totsize);
  GetMem(Block,BlockSize);
  LastPos  := GoTree(GivenKey^.BasePtr,Block^);
  Temp := @rec;
  Inc(word(Temp),GivenKey^.Ofs);
  GetMem(P,GivenKey^.Size);
  Move(Temp^,P^,GivenKey^.Size);
  repeat
    if IsFree(Block^.ItemCount,GivenKey^.Size) then begin
	 PutKeyToBlock(Block^,P^,GivenKey,DataOffset);
	 sIndex^.Seek(LastPos);
	 sIndex^.Write(Block^,BlockSize);
	 break;
    end;
    n := 0;
    Item := PKeyHeader(Block);
    inc(word(Item),SizeOf(TBlock));
    PrevItem := NIL;
    LastComp := -2;
    while n < Block^.ItemCount do begin
	 Comp := Compare(Item^.Data,rec,GivenKey);
	 if (Comp < 0) and (LastComp=1) then begin
	   if PrevItem = NIL then begin
		GetMem(Temp,GivenKey^.Size);
		Move(Item^.Data,Temp^,GivenKey^.Size);
		Move(P^,Item^.Data,GivenKey^.Size);
		PutKeyToBlock(Block^,Item^,GivenKey,DataOffset);
		OldDataPtr    := Item^.DataPtr;
		Item^.DataPtr := DataOffset;
		sIndex^.Seek(LastPos);
		sIndex^.Write(Block^,BlockSize);
		LastPos := GoTree(Item^.RootPtr,Block^);
		Move(Temp^,P^,GivenKey^.Size);
		FreeMem(temp,givenkey^.size);
		DataOffset := Item^.DataPtr;
		break; {while}
	   end else begin
		LastPos := GoTree(Item^.RootPtr,Block^);
		break;
	   end;
	 end; {if comp < 0}
	 if (Comp=0) and (GivenKey^.KeyType and Key_Unique = 0) then begin
	   Move(P^,Item^.Data,GivenKey^.Size);
	   sIndex^.Seek(LastPos);
	   sIndex^.Write(Block^,BlockSize);
	   FreeMem(P,GivenKey^.Size);
	   exit; {proc}
	 end;
	 LastComp := Comp;
	 PrevItem	:= Item;
	 inc(word(Item),totsize);
	 inc(n);
    end; {while}
    if PrevItem = Item then
	 if LastComp = 1 then LastPos := GoTree(PrevItem^.RootPtr,Block^);
  until false;
end;

procedure TDamn.BuildIndex;
var
  P:PKeyLink;
  H:TIndexHeader;
  RH:TRecordHeader;
  DataPos:longint;
begin
  P := KeyList;
  H.FirstFree := -1;
  sIndex^.Seek(0);
  sIndex^.Truncate;
  sIndex^.Write(H,SizeOf(H));
  while P <> NIL do begin
    P^.BasePtr := CreateBlock;
    sIndex^.Write(P^,SizeOf(TKeyInfo));
    P := P^.Next;
  end;
  sData^.Seek(SizeOf(TDataHeader));
  AllocBuf(RecSize);
  P := KeyList;
  while P <> NIL do begin
    WriteIndex(Buf^,P,DataPos);
    P := P^.Next;
  end;
  sData^.Reset;
end;

destructor TDamn.Done;
begin
  Close;
  DisposeBuf;
  DisposeKeyLink(KeyList);
  DisposeStr(nData);
  DisposeStr(nIndex);
  TObject.Done;
end;

procedure TDamn.AllocBuf(Size:word);
begin
  if BufSize = Size then exit;
  DisposeBuf;
  GetMem(Buf,Size);
  BufSize := Size;
end;

procedure TDamn.DisposeBuf;
begin
  if Buf <> NIL then begin
    FreeMem(Buf,BufSize);
    Buf     := NIL;
    BufSize := 0;
  end;
end;

procedure TDamn.Open;
begin
  New(sData,Init(nData^,stOpen));
  if sData^.Status <> stOK then begin
    Dispose(sData,Done);
    New(sData,Init(nData^,stCreate));
    BuildData;
    New(sIndex,Init(nIndex^,stCreate));
    BuildIndex;
    exit;
  end;
  New(sIndex,Init(nIndex^,stOpen));
  if sIndex^.Status <> stOK then begin
    Dispose(sIndex,Done);
    New(sIndex,Init(nIndex^,stCreate));
    BuildIndex;
  end;
end;

procedure TDamn.Close;
begin
  if XInit(sData) then Dispose(sData,Done);
  if XInit(sIndex) then Dispose(sIndex,Done);
end;

function NewKey(KeyType:word;KeySize,KeyOfs:word;Next:PKeyLink):PKeyLink;
var
  P:PKeyLink;
begin
  New(P);
  with P^ do begin
    P^.KeyType := KeyType;
    P^.Size    := KeySize;
    P^.Ofs     := KeyOfs;
    P^.Next    := Next;
  end; {with}
  NewKey := P;
end;

end.