unit tree_unit;
{  supply tree operations on elements with undo

   maxelement = number of elements
   maxaction  = number of undo steps saved

   element is record with mandatory fields:
   - parent
   - child
   - next
   - previous
   - elType   (eltFree = element not in use)
   - + customfields like x,y position, width, height, font, code.......

   operation   description        undo action  stack purge action
   ---------   --------------     -----------  ------------------
   insertA     insert after       destroy      none
   insertB     insert before      destroy      none
   addChild    insert child       destroy      none
   delete      but save           restore      destroy
   replace     but save old       reset        destroy
   pack        add to previous    unpack       none
                                  destroy old

   delete  : deactivate element, but do not destroy
            undo re-activetes
   destroy : permanently remove element
}

interface

uses windows;

type TElmntAction = (eaNone,eaInsertA,eaInsertB,eaDelete,eaReplace,
                     eaAddChild,eaPack);
     TTreemove    = (tmNone,tmParent,tmChild,tmNext,tmPrevious);
     TElementStatus = (esFree,esDeleted,esActive);

procedure initdata;
//--edit procedures
function getFreeElement(var el : dword) : boolean;
procedure insertElementA(el,new : dword);           //insert after
procedure insertElementB(el,new : dword);           //insert before
procedure replaceElement(el : dword; new : dword);  //replace by
procedure addChildElement(el,new : dword);
procedure packElement(el : dword);    //make child of previous
procedure deleteElement(el : dword);  //delete element e
procedure UndoElement;                //undo last action
procedure destroyElement(el : 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; tm : TTreeMove) : TTreeMove;
//--status
function getElementStatus(el : dword) : TElementStatus;
//--undo
procedure startLinking;
procedure stoplinking;
procedure registerAction(ea : TElmntAction; el : dword);
procedure purgeUndoStack;

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

type TElementtype = (elFree,elActive);
     TElement = record
                 eltype : TElementType;
                 marked : boolean;
                 x,y    : word;
                 parent : dword;
                 child  : dword;
                 next   : dword;
                 previous : dword
                end;
      TEditAction = record
                     elmnt  : dword;
                     action : TelmntAction;
                     bwlink : boolean;   //backward link
                    end;

var element : array[1..maxelement] of TElement;
    undolist : array[1..maxaction] of TEditAction;
    lastAction : word;
    freeElementcount : dword = 0;

implementation

var freeElementNr : dword;
    startflag,linkflag : boolean;

procedure clearElement(el : dword);
begin
 with element[el] do
  begin
   parent := 0;
   child := 0;
   next := 0;
   previous := 0;
   elType := elFree;
   marked := false;
   x := 0;
   y := 0;
  end;
end;
   
procedure initdata;
var i : dword;
begin
 for i := 1 to maxelement do clearElement(i);
 freeElementNr := 1;
 freeElementcount := maxelement;
 for i := 1 to maxAction do
  with undolist[i] do
   begin
    elmnt := 0;
    action := eaNone;
    bwlink := false;
   end;
 lastAction := 0;
 with element[1] do
  begin
   x := 1;
   y := 1;
  end;
 startflag := false;
 linkflag := false;
end;

function getFreeElement(var el : dword) : boolean;
//return free element number el
//return true if Ok, false if out of elements
//decrement freeElementcount
var n   : DWORD;
begin
 n := freeElementNr;
 repeat
  result := element[n].elType = elFree;
  if result then el := n
   else begin
         inc(n);
         if n > maxelement then n := 1;
        end;
 until result or (n = freeElementNr);
 if result then
  begin
   freeElementNr := n+1;
   if freeElementNr > maxElement then freeElementNr := 1;
   dec(freeElementcount);
   with element[n] do    //reset some element props
    begin
     child := 0;
     next := 0;
    end;
  end;
end;

function getElementStatus(el : dword) : TElementStatus;
//esFree   : no parent or previous
//esActive : connected with parent or previous
//esDeleted: not connected to parent or previous
//element 1 always active
begin
 if el = 1 then
  begin
   result := esActive;
   exit;
  end;

 with element[el] do
  begin
   if (parent = 0) and (previous = 0) then
    begin
     result := esFree;
     exit;
    end;

   if parent > 0 then
    if element[parent].child = el then
     begin
      result := esActive;
      exit;
     end;

   if previous > 0 then
    if element[previous].next = el then
     begin
      result:= esActive;
      exit;
     end;
  end;
  result := esDeleted;
end;

function ParentEl(var nel : dword) : boolean;
var e : dword;
begin
 e := element[nel].parent;
 if e > 0 then
  begin
   nel := e;
   result := true;
  end else result := false;
end;

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

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

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

function ScanElement(var elmnt : dword; tm : TTreeMove) : TTreeMove;
//walk thru tree, children first then next (down)
//replace elmnt by next element
begin
 result := tmNone;
 if (tm = tmChild) or (tm = tmNext) then
  begin
   if childEl(elmnt) then result := tmChild
    else if nextEl(elmnt) then result := tmNext
          else if previousEl(elmnt) then result := tmPrevious
           else if parentEl(elmnt) then result := tmParent;
  end;
 if result <> tmNone then exit;

 if tm = tmPrevious then
  begin
   if previousEl(elmnt) then result := tmPrevious
    else if parentEl(elmnt) then result := tmParent;
  end;
 if result <> tmNone then exit;

 if tm = tmParent then
  begin
   if nextEl(elmnt) then result := tmNext
    else if previousEl(elmnt) then result := tmPrevious
     else if parentEl(elmnt) then result:= tmParent;
  end;
end;

//--- element procedures

procedure deleteElement(el : dword);
//delete element el
//do not delete children
var prv,nxt,par : DWORD;
begin
 with element[el] do
  begin
   nxt := next;
   prv := previous;
   par := parent;
   if prv > 0 then element[prv].next := nxt
    else
     if par > 0 then element[par].child := nxt;
   if nxt > 0 then element[nxt].previous := prv;
  end;
 registerAction(eaDelete,el); 
end;

procedure insertElementA(el : dword; new : dword);
//insert new element after el
var nxt,par : DWORD;
begin
 with element[el] do
  begin
   nxt := next;
   par := parent;
  end;
 element[el].next := new;
 with element[new] do
  begin
   previous := el;
   parent := par;
   next := nxt;
  end;
 if nxt > 0 then element[nxt].previous := new; 
 registerAction(eaInsertA,new);
end;

procedure insertElementB(el,new : dword);
//insert new element before e
var prv,par : DWORD;
begin
 with element[el] do
  begin
   prv := previous;
   par := parent;
  end;
 element[el].previous := new;
 with element[new] do
  begin
   previous := prv;
   if previous = 0 then element[par].child := new
    else element[prv].next := new;
   next := el;
   parent := par;
  end;
 registerAction(eaInsertB,new);
end;

procedure addChildElement(el,new : dword);
//add element[new] as child element to el
begin
 element[el].child := new;
 element[new].parent := el;
 registerAction(eaAddChild,new);
end;

procedure replaceElement(el,new : dword);
//replace element el by new
var nxt,prv,par,chd : dword;
begin
 with element[el] do
  begin
   par := parent;
   nxt := next;
   prv := previous;
   chd := child;
  end;
 with element[new] do
  begin
   parent := par;
   previous := prv;
   next := nxt;
   child := chd;
  end;
 if prv > 0 then element[prv].next := new
  else element[par].child := new;
 if nxt > 0 then element[nxt].previous := new;
 registerAction(eaReplace,el);
end;

procedure packElement(el : dword);  
//make el child of previous
var chd,nxt,prv : dword;
begin
 prv := element[el].previous;
 if prv = 0 then exit;              //must have previous
 nxt := element[el].next;
 chd := element[prv].child;
 if chd > 1 then                    //if children, skip
  begin
   repeat until nextEl(chd) = false;
   element[chd].next := el;
  end
 else                              //if previous has no children
  begin
   element[prv].child := el;
   element[el].previous := 0;
  end;
 element[el].next := 0;
 element[el].previous := chd;
 element[el].parent := prv;
 element[prv].next := nxt;
 element[nxt].previous := prv;
 registerAction(eaPack,el);
end;

procedure unpackelement(el : dword);
//place last child as next of parent
var par,nxt,prv : dword;
begin
 if element[el].next <> 0 then exit; //el must be last child
 with element[el] do
  begin
   par := parent;
   nxt := element[par].next;
   prv := previous;
  end;
 if prv = 0 then element[par].child := 0
  else element[prv].next := 0;
 element[par].next := el;
 element[el].previous := par;
 if nxt > 0 then
  begin
   element[el].next := nxt;
   element[nxt].previous := el;
  end;
 par := element[par].parent;
 element[el].parent := par;
end;

procedure restoreElement(el : dword);
//un-delete
var prv,nxt,par : dword;
begin
 with element[el] do
  begin
   prv := previous;
   nxt := next;
   par := parent;
  end;
 if (prv = 0) and (par = 0) then exit; //already destroyed or element 1

 if prv > 0 then element[prv].next := el
  else element[par].child := el;
 if nxt > 0 then element[nxt].previous := el;
end;

procedure resetElement(el : dword);
//un-replace
//destroy replaced element
var des,nxt,prv,par : dword;
begin
 with element[el] do
  begin
   prv := previous;
   nxt := next;
   par := parent;
   if prv = 0 then des := element[par].child
    else des := element[prv].next;
  end;
 if prv = 0 then element[par].child := el
  else element[prv].next := el;
 if nxt > 0 then element[nxt].previous := el;
 clearElement(des);
 inc(freeElementCount);
end;

procedure destroyElement(el : dword);
//destroy element and it's children
//adjust freeElementcount
var mcode : TTreeMove;
    oldEl,prv,nxt,par : dword;
begin
 with element[el] do
  begin
   if getElementStatus(el) = esActive then  //delete first if active
    begin
     nxt := next;
     prv := previous;
     par := parent;
     if prv > 0 then element[prv].next := nxt
      else if par > 0 then element[par].child := nxt;
     if nxt > 0 then element[nxt].previous := prv;
    end;//if
   parent := 0;       //isolate element, keep link to children
   next := 0;
   previous := 0;
  end;
 mcode := tmChild;
 repeat
  OldEl := el;
  mcode := ScanElement(el,mcode);
  if (mcode = tmPrevious) or (mcode = tmParent) or (mcode = tmNone) then
   begin
    clearElement(oldEl);
    inc(freeElementcount);
   end;
 until mcode = tmNone;
end;

//--- undo ---

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 purgeUndoStack;
//remove bottom of undo stack to make space
var link : boolean;
    i : word;
begin
 if lastAction = 0 then exit;
 repeat
  with undolist[1] do
   case action of
    eaInsertA,
    eaInsertB  : ; //no action
    eaReplace,
    eaDelete   : destroyElement(elmnt);
   end;//case
   if lastaction > 1 then link := undolist[2].bwlink
    else link := false;
  for i := 1 to lastAction - 1 do undolist[i] := undolist[i+1];
  with undolist[lastaction] do
   begin
    elmnt := 0;
    action := eaNone;
    bwlink := false;
   end;
  dec(lastaction);
 until link = false;
end;

procedure registerAction(ea : TElmntAction; el : dword);
begin
 if lastAction = maxAction then purgeUndoStack;
 inc(lastAction);
 with undolist[lastaction] do
  begin
   elmnt := el;
   action := ea;
   bwlink := linkflag;
  end;
 linkflag := startflag; 
end;

procedure UndoElement;
//reverse last operation
var link : boolean;
begin
 if lastAction = 0 then exit;
 repeat
  with undolist[lastaction] do
   begin
    case action of
     eaInsertA,
     eaInsertB,
     eaAddChild : destroyElement(elmnt);
     eaReplace  : resetElement(elmnt);
     eaDelete   : restoreElement(elmnt);
     eaPack     : unpackElement(elmnt);
    end;//case
    link := bwlink;
   end;//with
  dec(lastaction);
 until link = false;
end;

end.