unit tree_unit;
{  DavData software
   www.davdata.nl

   tree operations on elements with undo

   version 5, sept. 2013
   - separated element links (local) and properties (global)
     by using different units for links and data

   local array Links[1..maxElement] with fields:
   - parent
   - child
   - next
   - previous

   parent field bits 24,25,26,27
   hold element status:            0000 = free
                                   0001 = active
                                   0010 = deleted
                                   0011 = replaced
                                   0100 = unpacked

   operations      description
   ----------      --------------
   placeA          place after
   placeB          place before
   placeChildA     place as last child
   placeChildB     place as first child
   delete          de-activate
   replace         replace
   moveA           move element after
   moveB           move element before
   moveChildA      move element after last child
   moveChildB      move element as first children
   packEl          pack element (place as child)
   unpackEl        unpack element (remove parent)

   navigating
   ----------
   getFreeEl       get index of free element
   parentEL        get parent
   ChildEL         get child
   NextEL          get next
   PreviousEL      get previous
   scanElement     supply neighbour element in tree:
                   old relation      new direction search in priority order
                   -------------     --------------------------------------
                   next,child        child,next,previous,parent
                   previous          previous, parent
                   parent            next,previous,parent

   status and statistics
   ---------------------
   getELstatus     return status of element : stFree,stActive,stDeleted,
                                              stReplaced
   getTreeStats    return statistics

   undo
   ----
   undoAction      undo last operation
   purgeUndoStack  remove undostack, destroy deleted elements
   startlinking    next action is linked
   stoplinking     next action is not linked

   global constants
   ----------------
   maxelement      total number of elements 1..maxelement
   maxUndo         total number of undo steps remembered 1..maxUndo

   local (protected) variables
   ---------------------------
   Links[1..maxElement]
   undolist[1..maxUndo]     array of undo steps
}

interface

uses windows;

const maxelement = 50;
      maxundo    = 25;  //undo actions

type TLinkType      = (ltNone,ltParent,ltChild,ltNext,ltPrevious);
     TElementStatus = (esFree,esActive,esDeleted,esReplaced,esUnpacked);
     TELaction      = (eaPlaceA,eaPlaceB,eaPlaceChildA,eaPlaceChildB,eaReplace,
                       eaDelete,eaMoveA,eaMoveB,eaMoveChildA,eaMoveChildB,
                       eaPack,eaUnpack,eaUndo,eaNone);

     TLinks = record
               parent   : dword;   //bits 24,25,26 hold status of element
               child    : dword;
               next     : dword;
               previous : dword;
              end;

     TEditAction = record
                    action  : TELaction;
                    elmnt   : dword;     //element
                    linkEl  : dword;     //link element
                    linktype: TLinkType;
                    cc      : dword;     //child count for UnpackEl operation
                    bwlink  : boolean;   //backward link
                   end;
     TTreeStats = record
                   freeCount  : dword;  //# free elements
                   freeNr     : dword;  //free element
                   lastAction : word;
                  end;

//-- initialize

procedure initTree;

//--edit procedures

function getFreeEl(var el : dword) : boolean;//get free element number
procedure PlaceA(del,sel : dword);           //place element sel after del
procedure PlaceB(del,sel : dword);           //place element sel after del
procedure PlaceChildA(del,sel : dword);      //place elemnt sel after child
procedure PlaceChildB(del,sel : dword);      //place element sel before child
procedure ReplaceEL(del,sel : dword);        //replace element del by sel
procedure deleteEL(del : dword);             //delete element el
procedure moveElA(del,sel : dword);
procedure moveElB(del,sel : dword);
procedure moveELChildA(del,sel : dword);
procedure moveElChildB(del,sel : dword);
procedure packEl(del,sel : dword);
procedure unpackEl(sel : dword);

//--navigating

function ParentEl(var nel : dword) : boolean;
function ChildEl(var nel : dword) : boolean;
function NextEl(var nel : dword) : boolean;
function previousEl(var nel : dword) : boolean;
function ScanElement(var elmnt : dword; lt : TLinkType) : TLinktype;
function getChildCount(del : dword) : dword;
function getLastChild(del : dword) : dword;

//--status

function GetElLinks(n : dword) : TLinks;
function getELStatus(el : dword) : TElementStatus;
function getTreeStatistics : TTreestats;
function getstackdata(n : word) : TEditAction;
//-- undo stack
procedure startLinking;
procedure stoplinking;
procedure purgeUndoStack;                      //clear all undo information
procedure UndoAction;                          //undo last action

//--set properties --- custom procedures

implementation

var Links : array[1..maxelement] of TLinks;
    startflag,linkflag : boolean;
    UndoStack : array[1..maxundo] of TEditAction;
    TreeStats : TTreeStats;

procedure destroyEL(del : dword);forward;

//--- initialisation

procedure clearElement(el : dword);
begin
 with Links[el] do
  begin
   parent := 0; //also free
   child := 0;
   next := 0;
   previous := 0;
  end;
end;

procedure clearUndoStack(nr : word);
//clear entry nr in undo stack
begin
 with UndoStack[nr] do
  begin
   action := eaNone;
   elmnt := 0;
   linkEl := 0;
   linkType := ltNone;
   cc := 0;
   bwlink := false;
  end;
end;

procedure setElStatus(elnr : dword; st : TElementStatus);
//set status of element elnr to st
var dw : dword;
begin
 dw := Links[elNr].parent and $ffffff;
 Links[elNr].parent := dw or (byte(st) shl 24);
end;

procedure clearEditAction(var ea : TEditAction);
//clear some fields of Edit Action record
begin
 with ea do
  begin
   linkEl := 0;
   linktype := ltNone;
   bwlink := false;
  end;
end;

procedure initTree;
//clear all elements
//set element 1 = active
//clear undostack
var i : dword;
begin
 for i := 1 to maxelement do clearElement(i);
 with treestats do
  begin
   freeNr := 2;
   freecount := maxelement-1;
   lastAction := 0;
  end;
 setELstatus(1,esActive);
 for i := 1 to maxUndo do clearUndoStack(i);
 startflag := false;
 linkflag := false;
end;

//--- status

function getELStatus(el : dword) : TElementStatus;
//element#1 always active
begin
 result:= TElementstatus(Links[el].parent shr 24);
end;

function getTreeStatistics : TTreestats;
//return tree statistics
begin
 result := treestats;
end;

function getstackdata(n : word) : TEditAction;
//return stack data
begin
 result := undoStack[n];
end;

function GetElLinks(n : dword) : TLinks;
//return element data
begin
 result := Links[n];
 result.parent := result.parent and $ffffff;
end;

//--- protected operations

procedure destroyEl(del : dword);
//destroy replaced,unpacked element del
//do not touch children
begin
 clearElement(del);
 inc(treestats.freeCount);
end;

procedure destroyELch(del : dword);
//destroy deleted element and it's children
//adjust freeElementcount
var mcode : TLinktype;
    oldEl : dword;
begin
 with Links[del] do
  begin
   parent := 0;       //isolate element, keep link to children
   next := 0;
   previous := 0;
  end;
 mcode := ltChild;
 repeat
  OldEl := del;
  mcode := ScanElement(del,mcode);
  if (mcode = ltPrevious) or (mcode = ltParent) or (mcode = ltNone) then
   begin
    clearElement(oldEl);
    inc(treestats.freecount);
   end;
 until mcode = ltNone;
end;

function getLink(el : dword) : TEditAction;
//set linkEl , linkType information
begin
 with Links[el] do
  if previous > 0 then
   begin
    result.linkEl := previous;
    result.linktype := ltPrevious;
   end
   else begin
         result.linkEl := parent and $ffffff;
         result.linktype := ltParent;
        end;
end;

function pickEL(pel : dword) : TEditAction;
//extract element pel from tree, repair tree
var par,chd,nxt,prv : dword;
begin
 with result do
  begin
   with Links[pel] do
    begin
     par := parent and $ffffff;
     chd := child;
     nxt := next;
     prv := previous;
    end;
   if prv > 0 then Links[prv].next := nxt
    else if par > 0 then
          begin
           Links[par].child := nxt;
           linkType := ltParent;
           linkEL := par;
          end;
   if nxt > 0 then Links[nxt].previous := prv;
  end;//with result
end;

procedure LinkIn(del : dword);
//element del has correct links but it's parent,children,next,previous
//must be adjusted to point to del
var par,chd,nxt,prv : dword;
begin
 with Links[del] do
  begin
   par := parent and $ffffff;
   chd := child;
   nxt := next;
   prv := previous;
  end;
 if nxt > 0 then Links[nxt].previous := del;
 if prv > 0 then Links[prv].next := del
  else Links[par].child := del;
 if chd > 0 then
  repeat
   Links[chd].parent := del or $1000000;//set active
  until nextEl(chd) = false;
end;

procedure copyLinks(var del,sel : dword);
begin
 with Links[del] do
  begin
   parent   := Links[sel].parent and $ffffff;
   child    := Links[sel].child;
   next     := lInks[sel].next;
   previous := Links[sel].previous;
  end;
end;

procedure UN_delete(const ea : TEditAction);
//un delete element
var elmnt : dword;
begin
 elmnt := ea.elmnt;
 LinkIn(elmnt);
 setElStatus(elmnt,esActive);
end;

procedure UN_replace(const ea : TEditAction);
//re-replace element el
//var actel,par,nxt,prv : dword;
begin
 with ea do
  begin
   LinkIn(elmnt);
   setElStatus(elmnt,esActive);
   destroyEl(linkEl);
  end;
end;

procedure UN_Pack(const ea : TEditAction);
//undo a Pack operation
var par,chd : dword;
begin
 par := ea.elmnt;
 chd := Links[par].child;
 Links[chd].parent := Links[par].parent;
 Links[chd].previous := Links[par].previous;
 Links[chd].next := Links[par].next;
 LinkIn(chd);
 destroyEL(par);
end;

procedure UN_Unpack(const ea: TEditAction);
//undo an UnPack operation = RePack
var chd,par,nxt,count : dword;
begin
 par := ea.elmnt;
 LinkIn(par);
 setElStatus(par,esActive);
 chd := Links[par].child;
 Links[chd].previous := 0;
 for count := 1 to ea.cc-1 do nextEl(chd);
 nxt := chd;
 if nextEL(nxt) then Links[nxt].previous := par;
 Links[chd].next := 0;
end;

procedure UN_MoveEl(const ea : TEditAction);
//undo moveA,moveB,moveChildA,moveChildB
begin
 pickEL(ea.elmnt);
 with Links[ea.elmnt] do
  case ea.linktype of
   ltParent   : begin
                 parent := ea.linkEl;
                 previous := 0;
                 next := Links[parent].child;
                end;
   ltprevious : begin
                 parent := Links[ea.linkEL].parent;
                 previous := ea.linkEl;
                 next := Links[previous].next;
              end;
  end;//case
 LinkIn(ea.elmnt);
 setELstatus(ea.elmnt,esActive);
end;

procedure ShiftStack;
//shift stack up 1 place or more if linked
var link : boolean;
    i : word;
begin
 if treestats.lastAction = 0 then exit;
 repeat
  with undoStack[1] do
   case action of
    eaReplace,
    eaUnpack  : destroyEl(elmnt);   //element only
    eaDelete  : destroyElch(elmnt); //children as well
   end;//case
  if treestats.lastaction > 1 then link := undoStack[2].bwlink;
  for i := 1 to treestats.lastAction - 1 do undoStack[i] := undoStack[i+1];
  clearUndoStack(treestats.lastaction);
  dec(treestats.lastaction);
 until link = false;
end;

procedure purgeUndoStack;
//undo all actions
begin
 while treestats.lastaction > 0 do ShiftStack;
end;

procedure registerAction(act : TEditAction);
//add link flag to action, register in undo list
begin
 if treestats.lastAction = maxUndo then ShiftStack;
 inc(treestats.lastAction);
 act.bwlink := linkflag;
 undoStack[treestats.lastaction] := act;
 linkflag := startflag;
end;

//--- navigation

function ParentEl(var nel : dword) : boolean;
var e : dword;
begin
 e := links[nel].parent and $ffffff;
 result := e > 0;
 if result then nel := e;
end;

function ChildEl(var nel : dword) : boolean;
var e : dword;
begin
 e := Links[nel].child;
 result := e > 0;
 if result then  nel := e;
end;

function NextEl(var nel : dword) : boolean;
var e : dword;
begin
 e := Links[nel].next;
 result := e > 0;
 if result then nel := e;
end;

function previousEl(var nel : dword) : boolean;
var e : dword;
begin
 e := Links[nel].previous;
 result := e > 0;
 if result then nel := e;
end;

function getChildCount(del : dword) : dword;
//return number of children
begin
 result := 0;
 if childEl(del) then
  begin
   inc(result);
   while nextEl(del) do inc(result);
  end; 
end;

function getLastChild(del : dword) : dword;
//return 0 if no child
begin
 result := 0;
 if childEl(del) then
  begin
   repeat until nextEl(del) = false;
   result := del;
  end;
end;

//--- undo operations

procedure startLinking;
//start new edit commands
//clear linkflag, set startflag
begin
 linkflag := false;
 startFlag := true;
end;

procedure stopLinking;
begin
 startflag := false;
 linkflag := false;
end;

procedure UndoAction;
var par,prv,nxt : dword;
    bwl : boolean;
    ea : TEditAction;
begin
 repeat
  ea := UndoStack[treestats.lastAction];
  begin
    bwl := ea.bwLink;
    case ea.action of
     eaPlaceA,
     eaPlaceB,
     eaPlaceChildA,
     eaPlaceChildB   : begin
                        pickEl(ea.elmnt);
                        destroyEl(ea.elmnt);
                       end;
     eaDelete        : UN_delete(ea);
     eaReplace       : UN_replace(ea);
     eaPack          : UN_Pack(ea);
     eaUnPack        : UN_Unpack(ea);
     eaMoveA,
     eaMoveB,
     eaMoveChildA,
     eaMoveChildB    : UN_moveEL(ea);
    end;
   end;//with undolist
  dec(treestats.lastaction);
 until bwl = false;
end;

//--- element actions ---

function getFreeEl(var el : dword) : boolean;
//return free element number elnr
//return true if Ok, false if out of elements
var n : DWORD;
begin
 n := treestats.freeNr;
 repeat
  result := (Links[n].parent and $f000000) = 0;
  if result then el := n
   else begin
         inc(n);
         if n > maxelement then n := 1;
        end;
 until result or (n = treestats.freeNr);
 if result then treestats.freeNr := n;
end;

procedure PlaceA(del,sel : dword);
//place free element sel after del
var nxt,par : DWORD;
    ea      : TEditAction;
begin
 clearEditAction(ea);
 ea.action := eaPlaceA;
 ea.elmnt := sel;
 with Links[del] do
  begin
   nxt := next;
   par := parent;
  end;
 with Links[sel] do
  begin
   previous := del;
   parent := par;
   next := nxt;
  end;
 LinkIn(sel);
 registerAction(ea);
 dec(treeStats.freecount);
 setElStatus(sel,esActive);
end;

procedure PlaceB(del,sel : dword);
//place free element sel before del
var prv,par : DWORD;
    ea      : TEditAction;
begin
 clearEditAction(ea);
 ea.action := eaPlaceB;
 ea.elmnt := sel;
 with Links[del] do
  begin
   prv := previous;
   par := parent;
  end;
 with Links[sel] do
  begin
   previous := prv;
   next := del;
   parent := par;
  end;
 LinkIn(sel);
 registerAction(ea);
 dec(treeStats.freecount);
 setElStatus(sel,esActive);
end;

procedure PlaceChildA(del,sel : dword);
//place free element sel as last child of del
var ea  : TEditAction;
    chd : dword;
begin
 clearEditAction(ea);
 ea.action := eaPlaceChildA;
 ea.elmnt := sel;
 chd := Links[del].child;
 if chd > 0 then
  repeat until nextEL(chd) = false; //position on last child
 with Links[sel] do
  begin
   parent := del;
   next := 0;
   previous := chd;
  end;
 LinkIn(sel);
 registeraction(ea);
 dec(treeStats.freecount);
 setElStatus(sel,esActive);
end;

procedure PlaceChildB(del,sel : dword);
//place free element sel as first child of del
var ea  : TEditAction;
    chd : dword;
begin
 clearEditAction(ea);
 ea.action := eaPlaceChildB;
 ea.elmnt := sel;
 chd := Links[del].child;
 with Links[sel] do
  begin
   parent := del;
   previous := 0;
   next := chd;
  end;
 LinkIn(sel);
 registerAction(ea);
 dec(treeStats.freecount);
 setElStatus(sel,esActive);
end;

procedure ReplaceEL(del,sel : dword);
//replace element del by sel
//sel must be free element
//del is part of tree
var nxt,prv,par,chd : dword;
    ea : TeditAction;
begin
 with ea do
  begin
   elmnt := del;            //replaced element
   action := eaReplace;
   ea.linkEl := sel;        //new element
  end;
 copyLinks(sel,del);
 LinkIn(sel);
 registerAction(ea);
 dec(treeStats.freecount);
 setElStatus(sel,esActive);
 setElStatus(del,esReplaced);
end;

procedure deleteEL(del : dword);
//delete element del
//do not delete children
var ea : TEditAction;
begin
 ea.action := eaDelete;
 ea.elmnt := del;
 pickEl(del);
 registerAction(ea);
 setElStatus(del,esDeleted);
end;

procedure packEl(del,sel : dword);
//free element sel becomes parent of del
var ea : TEditAction;
begin
 with ea do
  begin
   action := eaPack;
   elmnt := sel;
  end;
 copylinks(sel,del);
 Links[sel].child := del;
 LinkIn(sel);
 with Links[del] do
  begin
   previous := 0;
   next := 0;
  end;
 registerAction(ea);
 dec(treeStats.freeCount);
 setElStatus(sel,esActive);
end;

procedure unpackEl(sel : dword);
//remove active element sel, children not deleted
//if no children : NOP
var par,chd,nxt,prv : dword;
    ea : TEditAction;
begin
 if Links[sel].child = 0 then exit;
 with ea do
  begin
   action := eaUnPack;
   elmnt := sel;
   cc := getChildCount(sel);
  end;
 with Links[sel] do
  begin
   par := parent and $ffffff;
   chd := child;
   nxt := next;
   prv := previous;
  end;
 if prv > 0 then Links[prv].next := chd
  else if par > 0 then Links[par].child := chd;
 Links[chd].previous := prv;
 repeat
  Links[chd].parent := par or $1000000;//set active
 until nextEl(chd) = false;
 Links[chd].next := nxt;
 if nxt > 0 then Links[nxt].previous := chd;
 setElStatus(sel,esUnpacked);
 registerAction(ea);
end;

procedure moveElA(del,sel : dword);
//move active element sel after del
var ea : TEditAction;
    par,nxt : dword;
begin
 ea := getLink(sel);
 with ea do
  begin
   action := eaMoveA;
   elmnt := sel;
  end;
 pickEl(sel);
 with Links[del] do
  begin
   par := parent and $ffffff;
   nxt := next;
  end;
 with Links[sel] do
  begin
   previous := del;
   next := nxt;
   parent := par;
  end;
 setELstatus(sel,esActive);
 LinkIn(sel);
 registerAction(ea);
end;

procedure moveElB(del,sel : dword);
//move active element sel after del
var ea : TEditAction;
    par, prv : dword;
begin
 ea := getLink(sel);
 with ea do
  begin
   action := eaMoveB;
   elmnt := sel;
  end;
 pickEL(sel);
 with Links[del] do
  begin
   par := parent and $ffffff;
   prv := previous;
  end;
 with Links[sel] do
  begin
   parent := par;
   next := del;
   previous := prv;
  end;
 setELstatus(sel,esActive);
 LinkIn(sel);
 registerAction(ea);
end;

procedure moveELChildA(del,sel : dword);
//move active element sel after last child of del
var ea : TEditAction;
    chd : dword;
begin
 ea := getLink(sel);
 with ea do
  begin
   action := eaMoveChildA;
   elmnt := sel;
  end;
 pickEL(sel);
 chd := Links[del].child;
 if chd > 0 then repeat until nextEL(chd) = false;
 with Links[sel] do
  begin
   parent := del;
   next := 0;
   previous := chd;
  end;
 setELstatus(sel,esActive); 
 LinkIn(sel);
 registerAction(ea);
end;

procedure moveElChildB(del,sel : dword);
//move active element sel to first child of del
var ea : TEditAction;
    chd : dword;
begin
 ea := getLink(sel);
 with ea do
  begin
   action := eaMoveChildA;
   elmnt := sel;
  end;
 pickEL(sel);
 chd := Links[del].child;
 with Links[sel] do
  begin
   parent := del;
   next := chd;
   previous := 0;
  end;
 setELstatus(sel,esActive); 
 LinkIn(sel);
 registerAction(ea);
end;

function ScanElement(var elmnt : dword; lt : TLinktype) : TLinktype;
//walk thru tree, children first then next (down)
//replace elmnt by next element
begin
 result := ltNone;
 if (lt = ltChild) or (lt = ltNext) then
  begin
   if childEl(elmnt) then result := ltChild
    else if nextEl(elmnt) then result := ltNext
          else if previousEl(elmnt) then result := ltPrevious
           else if parentEl(elmnt) then result := ltParent;
  end;
 if result <> ltNone then exit;

 if lt = ltPrevious then
  begin
   if previousEl(elmnt) then result := ltPrevious
    else if parentEl(elmnt) then result := ltParent;
  end;
 if result <> ltNone then exit;

 if lt = ltParent then
  begin
   if nextEl(elmnt) then result := ltNext
    else if previousEl(elmnt) then result := ltPrevious
     else if parentEl(elmnt) then result:= ltParent;
  end;
end;

end.