unit uTreeNode;

interface

uses
{$IFDEF VCL}
  ComCtrls,
{$ELSE}
  QComCtrls,
{$ENDIF}
  Rubies;

var
  cTreeNode, cTreeNodes: Tvalue;

//function GetNode(obj: Tvalue): TTreeNode;
function ap_cTreeNode: Tvalue;
function ap_iTreeNode(real: TTreeNode; owner: Tvalue): Tvalue;
function ap_cTreeNodes: Tvalue;
function ap_iTreeNodes(real: TTreeNodes; owner: Tvalue): Tvalue;
function dl_TreeNode(obj: Tvalue): TTreeNode;
function ap_TreeNode(node: TTreeNode): Tvalue;
procedure Init_TreeNode;

implementation

uses
  SysUtils, Classes,
  uConv, uDefUtils, uHandle, uIntern, uAlloc, uProp, uPhi, uError,
  uSizeConstraints,
  uPersistent, uComponent, uControl;

type
  PNode = ^TNode;
  TNode = record
    real: TTreeNode;
    dead: Boolean;
    data: Tvalue;
  end;

procedure TreeNode_free(p: PNode); cdecl;
begin
  dispose(p);
end;

procedure TreeNode_mark(p: PNode); cdecl;
begin
  rb_gc_mark(Pointer(p^.data));
end;

function TreeNode_alloc1(klass: Tvalue; real: TTreeNode): Tvalue;
var
  p: PNode;
  parent: Tvalue;
begin
  if real = nil then begin result := Qnil; exit; end;
  new(p);
  p^.real := real;
  p^.dead := False;
  p^.data := Qnil;
  result := rb_data_object_alloc(klass, p, @TreeNode_mark, @TreeNode_free);
  rb_iv_set(result, '@events', rb_hash_new);
  real.Data := Pointer(result);
  if real.Parent = nil then
    parent := Qnil
  else
    parent := Tvalue(real.Parent.Data);
  rb_iv_set(result, '@parent', parent);
end;

function GetP(obj: Tvalue): PNode;
begin
  if rb_obj_is_kind_of(obj, cTreeNode) = 0 then
    ap_raise(ap_eArgError, sWrong_arg_type);
  result := ap_data_get_struct(obj);
end;

function GetNode(obj: Tvalue): TTreeNode;
var
  p: PNode;
begin
  p := GetP(obj);
  if p^.dead then
    ap_raise(eDelphiError, 'dead node');
  result := p^.real;
end;

function dl_TreeNode(obj: Tvalue): TTreeNode;
begin
  result := GetNode(obj);
end;

function ap_TreeNode(node: TTreeNode): Tvalue;
begin
  result := Tvalue(node.data);
end;

function ap_cTreeNode: Tvalue;
begin
  result := cTreeNode;
end;

function TreeNode_alloc(This: Tvalue; real: TTreeNode): Tvalue; forward;

procedure TreeNode_setup(obj: Tvalue; real: TTreeNode);
var
  i: Integer;
begin
  rb_iv_set(obj, '@text', rb_str_new2(PChar(real.Text)));
  rb_iv_set(obj, '@index', INT2FIX(real.Index));
  rb_iv_set(obj, '@level', INT2FIX(real.Level));
  for i := 0 to real.Count-1 do
    TreeNode_alloc(cTreeNode, real[i]);
end;

function TreeNode_alloc;
begin
  result := TreeNode_alloc1(This, real);
  TreeNode_setup(result, real);
end;

function ap_iTreeNode(real: TTreeNode; owner: Tvalue): Tvalue;
begin
  result := TreeNode_alloc(cTreeNode, real);
  ap_owner(result, owner);
end;

function TreeNode_aref(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
  n: Integer;
begin
  real := GetNode(This);
  n := NUM2INT(v);
  if (n < 0) or (real.Count <= n) then
    ap_raise(ap_eIndexError, sOut_of_range);
  if real[n].Data = nil then
    result := Qnil
  else
    result := Tvalue(real[n].Data);
end;

function TreeNode_get_data(This: Tvalue): Tvalue; cdecl;
var
  p: PNode;
begin
  p := GetP(This);
  result := p^.data;
end;

function TreeNode_set_data(This, v: Tvalue): Tvalue; cdecl;
var
  p: PNode;
begin
  p := GetP(This);
  p^.data := v;
  result := v;
end;

function TreeNode_get_count(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  result := INT2FIX(real.Count);
end;

function TreeNode_set_text(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
  str: Tvalue;
begin
  real := GetNode(This);
  real.Text := dl_String(v);
  str := rb_iv_get(This, '@text');
  rb_str_resize(str, 0);
  rb_str_concat(str, v);
  result := v;
end;

{$IFDEF VCL}
function SortProc(a, b, This: Longint): Integer; stdcall;
var
  ret, anode, bnode: Tvalue;
begin
  anode := Tvalue(TTreeNode(a).Data);
  bnode := Tvalue(TTreeNode(b).Data);
  ret := rb_yield(rb_assoc_new(anode, bnode));
  if RTYPE(ret) = T_FIXNUM then
    result := FIX2INT(ret)
  else
    result := 0;
end;
{$ENDIF}

function TreeNode_sort(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
{$IFDEF VCL}
  if rb_block_given_p <> 0 then
    result := ap_bool(real.CustomSort(SortProc, This))
  else
    result := ap_bool(real.AlphaSort);
{$ELSE}
    result := ap_bool(real.AlphaSort(True));
{$ENDIF}
end;

function TreeNode_assign(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
  source: TPersistent;
begin
  real := GetNode(This);
  ap_data_get_object(v, TPersistent, source);
  real.Assign(source);
  result := v;
end;

function TreeNode_expand(This, recurse: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  real.Expand(RTEST(recurse));
  result := This;
end;

function TreeNode_collapse(This, recurse: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  real.Collapse(RTEST(recurse));
  result := This;
end;

function TreeNode_get_expanded(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  result := ap_bool(real.Expanded);
end;

function TreeNode_set_expanded(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  real.Expanded := RTEST(v);
  result := This;
end;

function TreeNode_get_first_child(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetFirstChild = nil then
    result := Qnil
  else if real.GetFirstChild.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.getFirstChild.Data);
end;

function TreeNode_get_last_child(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetLastChild = nil then
    result := Qnil
  else if real.GetLastChild.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetLastChild.Data);
end;

function TreeNode_get_next(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetNext = nil then
    result := Qnil
  else if real.GetNext.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetNext.Data);
end;

function TreeNode_get_next_child(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
  child: TTreeNode;
begin
  real := GetNode(This);
  child := GetNode(v);

  if child = nil then
    result := Qnil
  else if real.GetNextChild(child) = nil then
    result := Qnil
  else if real.GetNextChild(child).Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetNextChild(child).Data);
end;

function TreeNode_get_next_sibling(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetNextSibling = nil then
    result := Qnil
  else if real.GetNextSibling.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetNextSibling.Data);
end;

function TreeNode_get_next_visible(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetNextVisible = nil then
    result := Qnil
  else if real.GetNextVisible.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetNextVisible.Data);
end;

function TreeNode_get_prev(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetPrev = nil then
    result := Qnil
  else if real.GetPrev.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetPrev.Data);
end;

function TreeNode_get_prev_child(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
  child: TTreeNode;
begin
  real := GetNode(This);
  child := GetNode(v);

  if child = nil then
    result := Qnil
  else if real.GetPrevChild(child) = nil then
    result := Qnil
  else if real.GetPrevChild(child).Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetPrevChild(child).Data);
end;

function TreeNode_get_prev_sibling(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetPrevSibling = nil then
    result := Qnil
  else if real.GetPrevSibling.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetPrevSibling.Data);
end;

function TreeNode_get_prev_visible(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  if real.GetPrevVisible = nil then
    result := Qnil
  else if real.GetPrevVisible.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetPrevVisible.Data);
end;

function ap_cTreeNodes: Tvalue;
begin
  result := cTreeNodes;
end;

procedure TreeNodes_setup(obj: Tvalue; real: TTreeNodes);
var
  i: Integer;
begin
  rb_iv_set(obj, '@items', rb_ary_new);
  for i := 0 to real.Count-1 do
    TreeNode_alloc(cTreeNode, real[i]);
end;

function TreeNodes_alloc(This: Tvalue; real: TTreeNodes): Tvalue;
begin
  result := TmpAlloc(This, real);
  TreeNodes_setup(result, real);
end;

function ap_iTreeNodes(real: TTreeNodes; owner: Tvalue): Tvalue;
begin
  result := TreeNodes_alloc(cTreeNodes, real);
  ap_owner(result, owner);
end;

function TreeNodes_aref(This, v: Tvalue): Tvalue; cdecl;
var
  n: Integer;
  real: TTreeNodes;
begin
  real := ap_data_get_struct(This);
  n := NUM2INT(v);
  if (n < 0) or (real.Count <= n) then
    ap_raise(ap_eIndexError, sOut_of_range);
  if real[n].Data = nil then
    result := Qnil
  else
  begin
    result := Tvalue(real[n].Data);
    GetNode(result);
  end;
end;

function TreeNodes_get_count(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.Count);
end;

function TreeNodes_get_first_node(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
begin
  real := ap_data_get_struct(This);
  if real.GetFirstNode.Data = nil then
    result := Qnil
  else
    result := Tvalue(real.GetFirstNode.Data);
end;

function TreeNodes_get_owner(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
begin
  real := ap_data_get_struct(This);
  if real.Owner = nil then
    result := Qnil
  else
    result := real.Owner.tag
  ;
end;

function TreeNodes_add(This, vnode, str: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  node, ret: TTreeNode;
begin
  real := ap_data_get_struct(This);
  if vnode = Qnil then node := nil else node := GetNode(vnode);
  ret := real.Add(node, dl_String(str));
  result := ap_iTreeNode(ret, This);
  if rb_block_given_p <> 0 then rb_obj_instance_eval(0, nil, result);
  rb_ary_push(rb_iv_get(This, '@items'), result);
end;

function TreeNodes_add_first(This, vnode, str: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  node, ret: TTreeNode;
begin
  real := ap_data_get_struct(This);
  if vnode = Qnil then node := nil else node := GetNode(vnode);
  ret := real.Add(node, dl_String(str));
  result := ap_iTreeNode(ret, This);
  rb_ary_push(rb_iv_get(This, '@items'), result);
end;

function TreeNodes_add_child(This, vnode, str: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  node, ret: TTreeNode;
begin
  real := ap_data_get_struct(This);
  node := GetNode(vnode);
  ret := real.AddChild(node, dl_String(str));
  result := ap_iTreeNode(ret, This);
  rb_ary_push(rb_iv_get(This, '@items'), result);
end;

function TreeNodes_add_child_first(This, vnode, str: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  node, ret: TTreeNode;
begin
  real := ap_data_get_struct(This);
  node := GetNode(vnode);
  ret := real.AddChildFirst(node, dl_String(str));
  result := ap_iTreeNode(ret, This);
  rb_ary_push(rb_iv_get(This, '@items'), result);
end;

function TreeNodes_insert(This, vnode, str: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  node, ret: TTreeNode;
begin
  real := ap_data_get_struct(This);
  if vnode = Qnil then node := nil else node := GetNode(vnode);
  ret := real.Insert(node, dl_String(str));
  result := ap_iTreeNode(ret, This);
  rb_ary_push(rb_iv_get(This, '@items'), result);
end;

procedure Node_delete(This, vnode: Tvalue);
var
  p: PNode;
  node: TTreeNode;
  n: Integer;
begin
  rb_iv_set(vnode, '@owner', Qnil);
  rb_ary_delete(rb_iv_get(This, '@items'), vnode);
  p := GetP(vnode);
  p^.dead := True;
  node := p^.real;
  for n := 0 to node.Count-1 do
    Node_delete(This, Tvalue(node[n].Data));
end;

function TreeNodes_delete(This, vnode: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  p: PNode;
  node: TTreeNode;
begin
  Node_delete(This, vnode);
  
  p := GetP(vnode);
  p^.dead := True;
  node := p^.real;
  
  real := ap_data_get_struct(This);
  real.Delete(node);
  result := This;
end;

function TreeNodes_clear(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  ary: Tvalue;
  ptr: Pvalue;
  len: Integer;
  vnode: Tvalue;
  p: PNode;
begin
  ary := rb_iv_get(This, '@items');
  ptr := ap_ary_ptr(ary);
  len := ap_ary_len(ary);
  while len > 0 do
  begin
    vnode := ptr^;
    p := GetP(vnode);
    p^.dead := True;
    Inc(ptr);
    Dec(len);
  end;
  rb_ary_clear(ary);
  real := ap_data_get_struct(This);
  real.Clear;
  result := This;
end;

function TreeNodes_assign(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
  source: TPersistent;
  ary, dup: Tvalue;
  ptr: Pvalue;
  len: Integer;
begin
  real := ap_data_get_struct(This);
  ap_data_get_object(v, TPersistent, source);
  real.Assign(source);
  ary := rb_iv_get(v, '@items');
  if RTYPE(ary) = T_ARRAY then
  begin
    ptr := ap_ary_ptr(ary);
    len := ap_ary_len(ary);
    dup := rb_iv_get(This, '@items');
    rb_ary_clear(dup);
    while len > 0 do
    begin
      rb_ary_push(dup, ptr^);
      Inc(ptr);
      Dec(len);
    end;
  end;
  result := v;
end;

function TreeNodes_update(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNodes;
begin
  real := ap_data_get_struct(This);
  real.BeginUpdate;
  try
    result := rb_yield(Qnil);
  finally
    real.EndUpdate;
  end;
end;

function TreeNode_get_image_index(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  result := INT2FIX(real.ImageIndex);
end;

function TreeNode_set_image_index(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  real.ImageIndex := FIX2INT(v);
  result := This;
end;

function TreeNode_get_selected_index(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  result := INT2FIX(real.SelectedIndex);
end;

function TreeNode_set_selected_index(This, v: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  real.SelectedIndex := FIX2INT(v);
  result := This;
end;

function TreeNode_get_absolute_index(This: Tvalue): Tvalue; cdecl;
var
  real: TTreeNode;
begin
  real := GetNode(This);
  result := INT2FIX(real.AbsoluteIndex);
end;

procedure Init_TreeNode;
begin
  cTreeNode := rb_define_class_under(mPhi, 'TreeNode', cPersistent);
  OutputProp(cTreeNode, TTreeNode);

  rb_undef_method(CLASS_OF(cTreeNode), 'new');

  rb_define_method(cTreeNode, '[]', @TreeNode_aref, 1);
  DefineAttrGet(cTreeNode, 'data', TreeNode_get_data);
  DefineAttrSet(cTreeNode, 'data', TreeNode_set_data);
  DefineAttrGet(cTreeNode, 'count', TreeNode_get_count);
  DefineAttrSet(cTreeNode, 'text', TreeNode_set_text);
  rb_define_method(cTreeNode, 'sort', @TreeNode_sort, 0);
  rb_define_method(cTreeNode, 'assign', @TreeNode_assign, 1);
  rb_define_method(cTreeNode, 'expand', @TreeNode_expand, 1);
  rb_define_method(cTreeNode, 'collapse', @TreeNode_collapse, 1);
  DefineAttrGet(cTreeNode, 'expanded', TreeNode_get_expanded);
  DefineAttrSet(cTreeNode, 'expanded', TreeNode_set_expanded);
  rb_define_alias(cTreeNode, 'expanded?', 'expanded');
  rb_define_method(cTreeNode, 'first_child', @TreeNode_get_first_child, 0);
  rb_define_method(cTreeNode, 'last_child', @TreeNode_get_last_child, 0);
  rb_define_method(cTreeNode, 'next', @TreeNode_get_next, 0);
  rb_define_method(cTreeNode, 'next_child', @TreeNode_get_next_child, 0);
  rb_define_method(cTreeNode, 'next_sibling', @TreeNode_get_next_sibling, 0);
  rb_define_method(cTreeNode, 'next_visible', @TreeNode_get_next_visible, 0);
  rb_define_method(cTreeNode, 'prev', @TreeNode_get_prev, 0);
  rb_define_method(cTreeNode, 'prev_child', @TreeNode_get_prev_child, 0);
  rb_define_method(cTreeNode, 'prev_sibling', @TreeNode_get_prev_sibling, 0);
  rb_define_method(cTreeNode, 'prev_visible', @TreeNode_get_prev_visible, 0);

  rb_define_attr(cTreeNode, 'text', 1, 0);
  rb_define_attr(cTreeNode, 'index', 1, 0);
  rb_define_attr(cTreeNode, 'level', 1, 0);
  rb_define_attr(cTreeNode, 'parent', 1, 0);
  rb_define_attr(cTreeNode, 'owner', 1, 0);

  cTreeNodes := rb_define_class_under(mPhi, 'TreeNodes', cPersistent);
  OutputProp(cTreeNodes, TTreeNodes);

  rb_undef_method(CLASS_OF(cTreeNodes), 'new');

  rb_define_method(cTreeNodes, '[]', @TreeNodes_aref, 1);
  DefineAttrGet(cTreeNodes, 'count', TreeNodes_get_count);
  DefineAttrGet(cTreeNodes, 'first_node', TreeNodes_get_first_node);
  rb_define_method(cTreeNodes, 'add', @TreeNodes_add, 2);
  rb_define_method(cTreeNodes, 'add_first', @TreeNodes_add_first, 2);
  rb_define_method(cTreeNodes, 'add_child', @TreeNodes_add_child, 2);
  rb_define_method(cTreeNodes, 'add_child_first', @TreeNodes_add_child_first, 2);
  rb_define_method(cTreeNodes, 'insert', @TreeNodes_insert, 2);
  rb_define_method(cTreeNodes, 'clear', @TreeNodes_clear, 0);
  rb_define_method(cTreeNodes, 'delete', @TreeNodes_delete, 1);
  rb_define_method(cTreeNodes, 'assign', @TreeNodes_assign, 1);
  rb_define_method(cTreeNodes, 'update', @TreeNodes_update, 0);
  DefineAttrGet(cTreeNodes, 'owner', TreeNodes_get_owner);

  DefineAttrGet(cTreeNode, 'image_index', TreeNode_get_image_index);
  DefineAttrSet(cTreeNode, 'image_index', TreeNode_set_image_index);
  DefineAttrGet(cTreeNode, 'selected_index', TreeNode_get_selected_index);
  DefineAttrSet(cTreeNode, 'selected_index', TreeNode_set_selected_index);
  DefineAttrGet(cTreeNode, 'absolute_index', TreeNode_get_absolute_index);
end;

end.
