unit FStarC;
//*******************************************************
// Tree class stored in forward star format.
//*******************************************************
// Copyright (C) 1998 John Wiley & Sons, Inc.
// All rights reserved. See additional copyright
// information in Readme.txt.
//*******************************************************

// Real node indices run from 1 to NumNodes - 1. The
// FirstLink array's sentinel is at position NumNodes.
//
// Links run from 1 to NumLinks. Each has an entry in
// ToNode. No sentinel is needed for the ToNode array.
//
// Note that the Parent information assumes this is a tree.

interface

uses
    Windows, Graphics, Math, Classes,
    SysUtils, Dialogs;

type
    String10 = String[10];

    // Array of node information.
    TNodeInfo = record
        Id        : String10;
        FirstLink : Integer;
        Position  : TPoint;
        Parent    : Integer;
    end;
    TNodeInfoArray = array [1..10000000] of TNodeInfo;
    PNodeInfoArray = ^TNodeInfoArray;

    // Array of ToNode information.
    TIntArray = array [1..100000000] of Integer;
    PIntArray = ^TIntArray;

    TFStarTree = class(TObject)
        private
            NumNodes    : Integer;        // Num nodes.
            Node      : Array of TNodeInfo;

            NumLinks    : Integer;        // Num links.
            ToNode      : PIntArray;      // Link info.
            

        public
            Selected    : Integer;        // Selected node.

            constructor Create;
            destructor Destroy; override;
            procedure SetPosition(index : Integer; var xmin : Integer; ymin : Integer);
            procedure DrawNode(cvs : TCanvas; index : Integer);
            procedure DrawSubtree(cvs : TCanvas; index : Integer);
            procedure SelectNode(X, Y, index : Integer);
            function MakeNode(new_id : String) : Integer;
            procedure MakeLink(fr_node, to_node : Integer);
            procedure RemoveSelected;
            function SelectedHasChildren : Boolean;
            procedure ShowArrays;
    end;

implementation

const
    WID = 40;
    HGT = 16;
    HGAP = 2;
    VGAP = 6;

// Create memory to free later.
constructor TFStarTree.Create;
begin
    // Create the root and node sentinel.
    NumNodes := 2;

    (*
    GetMem(Node, NumNodes * SizeOf(TNodeInfo));
    *)
    SetLength(Node, NumNodes);


    Node[1-1].Id := 'Root';
    Node[1-1].FirstLink := 1;
    Node[1-1].Parent := 0;
    Node[2-1].Id := 'Sentinel';
    Node[2-1].FirstLink := 1;
    Node[2-1].Parent := 0;

    // Allocate some memory to free later.
    NumLinks := 0;

    GetMem(ToNode, SizeOf(Integer));

    // Perform inherited initialization.
    inherited Create;
end;

// Free the dynamically allocated arrays.
destructor TFStarTree.Destroy;
begin
    // Free ToLink array.

    FreeMem(ToNode);

    // Free node information array.
    (*
    FreeMem(Node);
    *)
    Node := NIL;

    inherited Destroy;
end;

// Set the position for the node and its descendants.
// Update xmin so it indicates the rightmost position
// used by the node and its descendants.
procedure TFStarTree.SetPosition(index : Integer; var xmin : Integer; ymin : Integer);
var
    i, first_link, last_link, to_node : Integer;
begin
    with (Node[index-1]) do
    begin
        Position.Y := ymin;
        first_link := FirstLink;
        last_link := Node[index + 1-1].FirstLink - 1;

        if (last_link - first_link < 0) then begin
            // No children. Place the node at (xmin, ymin).
            Position.X := xmin;
            xmin := xmin + WID;
        end else begin
            // Position the children.
            for i := first_link to last_link do
            begin
                to_node := ToNode[i];
                SetPosition(to_node, xmin, ymin + HGT + VGAP);
                if (i < last_link) then xmin := xmin + HGAP;
            end;

            // Center the node over its children.
            Position.X := (
                Node[ToNode[first_link]-1].Position.X +
                Node[ToNode[last_link]-1].Position.X) div 2;
        end; // End if (no children) ... else ...
    end; // End with (Node^[index]) do ...
end;

// Draw this node.
procedure TFStarTree.DrawNode(cvs : TCanvas; index : Integer);
var
    rect      : TRect;
    text_size : TSize;
begin
    // Select appropriate colors.
    if (index = Selected) then
    begin
        cvs.Font.Color := clWhite;
        cvs.Brush.Color := clBlack;
    end else begin
        cvs.Font.Color := clBlack;
        cvs.Brush.Color := clWhite;
    end;

    with (Node[index-1]) do
    begin
        // Erase the spot and draw a box around it.
        rect.Left   := Position.X;
        rect.Right  := Position.X + WID;
        rect.Top    := Position.Y;
        rect.Bottom := Position.Y + HGT;
        cvs.FillRect(rect);
        cvs.Rectangle(rect.Left, rect.Top, rect.Right, rect.Bottom);

        // Draw the label.
        text_size := cvs.TextExtent(Id);
        cvs.TextOut(
            (rect.Left + rect.Right - text_size.cx) div 2,
            (rect.Top + rect.Bottom - text_size.cy) div 2,
            Id);
    end; // End with (Node^[index]) do...
end;

// Draw the subtree rooted at this node.
procedure TFStarTree.DrawSubtree(cvs : TCanvas; index : Integer);
var
    i, first_link, last_link, to_node : Integer;
begin
    // Draw this node.
    DrawNode(cvs, index);

    // Draw the children.
    with (Node[index-1]) do
    begin
        first_link := FirstLink;
        last_link := Node[index + 1-1].FirstLink - 1;
        for i := first_link to last_link do
        begin
            to_node := ToNode[i];
            DrawSubtree(cvs, to_node);
            cvs.MoveTo(
                Position.X + WID div 2,
                Position.Y + HGT);
            cvs.LineTo(
                Node[ToNode[i]-1].Position.X + WID div 2,
                Node[ToNode[i]-1].Position.Y);
        end; // End drawing children.
    end; // End with (Node^[index]) do ...
end;

// Select the descendant node containing this point.
// Return true if the node is found.
// Note that this is not a very sophisticated method.
// A quadtree would be much faster.
procedure TFStarTree.SelectNode(X, Y, index : Integer);
var
    i, first_link, last_link, to_node : Integer;
begin
    Selected := 0;

    // Check this node.
    with (Node[index-1]) do
    begin
        if ((Position.X <= X) and (X <= Position.X + WID) and
            (Position.Y <= Y) and (Y <= Position.Y + HGT)) then
        begin
            Selected := index;
        end else begin
            // Check the children.
            first_link := FirstLink;
            last_link := Node[index + 1-1].FirstLink - 1;
            for i := first_link to last_link do
            begin
                to_node := ToNode[i];
                SelectNode(X, Y, to_node);
                if (Selected > 0) then break;
            end;
        end;
    end; // End with (Node^[index]) do...
end;

// Create a new node and return its index.
function TFStarTree.MakeNode(new_id : String) : Integer;
begin
    // Make room for the new node info.
    // Create the new array.
    (*
    GetMem(new_node, (NumNodes + 1) * SizeOf(TNodeInfo));

    // Copy the node info into the new array.
    for i := 1 to NumNodes - 1 do
        new_node^[i] := Node^[i];

    // Copy the sentinel.
    new_node^[NumNodes + 1] := Node^[NumNodes];

    // Free the previously allocated memory.
    FreeMem(Node);
    Node := new_node;
    *)
    SetLength(Node,NumNodes + 1);
    // kopiuj wartownika
    Node[NumNodes + 1-1] := Node[NumNodes-1];


    // Create the new node.
    with (Node[NumNodes-1]) do
    begin
        Id := new_id;
        FirstLink := Node[NumNodes + 1-1].FirstLink;
        Parent := 0;
    end;
    NumNodes := NumNodes + 1;

    Result := NumNodes - 1;
end;

// Create a link between the nodes.
procedure TFStarTree.MakeLink(fr_node, to_node : Integer);
var
    new_link     : PIntArray;
    i, last_link : Integer;
begin

    // Make room for the new link.
    // Create the new array.
    GetMem(new_link, (NumLinks + 1) * SizeOf(Integer));

    // Copy the link info into the new array, inserting
    // the new ToNode entry for this link.
    last_link := Node[fr_node + 1-1].FirstLink - 1;
    for i := 1 to last_link do
        new_link^[i] := ToNode^[i];



    new_link^[last_link + 1] := to_node;


    for i := last_link + 2 to NumLinks + 1 do
        new_link^[i] := ToNode^[i - 1];

    // Free the previously allocated memory.
    FreeMem(ToNode);
    ToNode := new_link;


    // Save the to_node's parent information.
    Node[to_node-1].Parent := fr_node;

    // Update the FirstLink entries.
    for i := fr_node + 1 to NumNodes do
        Node[i-1].FirstLink := Node[i-1].FirstLink + 1;

    NumLinks := NumLinks + 1;
end;

// Usuń wybrany węzeł z drzewa. Węzeł nie może mieć potomków
procedure TFStarTree.RemoveSelected;
var
    i, first_link, last_link : Integer;
    parent_node, parent_link : Integer;
begin
    // Znajdź gałąź prowadzącą z węzła rodzicielskiego
    parent_node := Node[Selected-1].Parent;
    first_link := Node[parent_node-1].FirstLink;
    last_link := Node[parent_node + 1-1].FirstLink - 1;
    for parent_link := first_link to last_link do
        if (ToNode^[parent_link] = Selected) then break;

    // Jeżeli znaleziono gałąź, usuń ją
    if (parent_link <= last_link) then
    begin
        // Wypełnij dziurę w ToNode
        for i := parent_link to NumLinks - 1 do
            ToNode^[i] := ToNode^[i + 1];
        NumLinks := NumLinks - 1;


        // uaktualnij tablicę FirstLink
        for i := 1 to NumNodes do
            if (Node[i-1].FirstLink > parent_link) then
                Node[i-1].FirstLink := Node[i-1].FirstLink - 1;
    end;

    // usuń węzeł, zsuwając pozycje tablicy Node
    for i := Selected to NumNodes - 1 do
        Node[i-1] := Node[i + 1-1];
    NumNodes := NumNodes - 1;

    // Uaktualnij tablicę ToNode
    for i := 1 to NumLinks do
        if (ToNode^[i] > Selected) then
            ToNode^[i] := ToNode^[i] - 1;

    // Uaktualnij numery gałęzi
    for i:= 1 to NumNodes do
        if (Node[i-1].Parent >= Selected) then
            Node[i-1].Parent := Node[i-1].Parent - 1;

    Selected := 0;
end;

// Return true if the selected node has children.
function TFStarTree.SelectedHasChildren : Boolean;
begin
    Result := (Node[Selected + 1-1].FirstLink >
               Node[Selected-1].FirstLink);
end;

procedure TFStarTree.ShowArrays;
const
    CRCR = #13#10#13#10;
var
    txt : String;
    i   : Integer;
begin
    txt := 'Name:';
    for i := 1 to NumNodes do
        txt := txt + ' ' + Node[i-1].ID;

    txt := txt + CRCR + 'Parent:';
    for i := 1 to NumNodes do
        txt := txt + ' ' + IntToStr(Node[i-1].Parent);

    txt := txt + CRCR + 'FirstLink:';
    for i := 1 to NumNodes do
        txt := txt + ' ' + IntToStr(Node[i-1].FirstLink);

    txt := txt + CRCR + 'ToNode:';
    for i := 1 to NumLinks do
        txt := txt + ' ' + IntToStr(ToNode^[i]);

    ShowMessage(txt);
end;

end.
