#!/usr/bin/perl -w

use strict;

use Tk;

my $top = MainWindow->new;
my $canvas = $top->Canvas(-background => 'blue')->pack(-expand=>'y', -fill=>'both');

my $page = Page->new;
Node->new( id => "#1", parent => $page, name => 'Sam', position => [50, 50] );
Node->new( id => "#2", parent => $page, name => 'Sophie', position => [150, 75] );
$page->attach_to_canvas($canvas);

MainLoop();

=pod

A Page contains Nodes, which are indexed by name.  It has a certain width and height.

=cut

package Page;

sub new {
    my ($class) = @_;
    return bless { nodes => {},
		   width => 100,
		   height => 100,
		   canvas => undef
		 }, $class;
}

sub add_node {
    my ($self, $node) = @_;
    $self->{nodes}{$node->{id}} = $node; # NOTE: violates Node's encapsulation of 'id'
    if (my $canvas = $self->{canvas}) {
	$node->attach_to_canvas($canvas);
    }
}

sub get_canvas_tags {
    return ();
}

sub abs_position {
    return (0,0);
}

sub attach_to_canvas {
    my ($self, $canvas) = @_;
    $self->{canvas} = $canvas;
    for my $node (values %{$self->{nodes}}) {
	$node->attach_to_canvas($canvas);
    }
}

=pod

A Node has a name, a type and a value.  The name is a string, which
uniquely identifies this node ; the type is a string for the moment,
but may become a reference to another node somewhere, and the value
may be any Perl scalar, including a reference, etc, or undef which
means that no value is bound.

A node knows its appearence and position, and can maintain a set of
canvas items on a canvas.  It will automatically handle drag events,
etc. on these items.

The node knows its parent / container, and will check any motion
requests with that parent - so that the parent can constrain the
node's motion.  The parent of a node may be a page, or another node.

A simple Node has a list of arcs that are attached to it, and looks
like a small dot.  It displays its name, if it has been given a
meaningful name, and also displays its type when the mouse is over it.

A generic Struct node looks like a circle, and has a fixed number of
child nodes that may be moved freely around its border.

There are other subclasses of Node, such as List, Bag, Set, Lambda,
etc. which have different appearance and behaviour.

=cut

package Node;
use Carp;
use Tk;

# knowledge: name, type, value ; appearence, position, canvas, canvas
# items ; parent ; arcs

sub new {
    my ($class, %args) = @_;
    my ($parent, $id, $name, $type, $position) = delete @args{qw(parent id name type position)};

#    croak 'bad args' unless defined $parent && defined $id;
#    $position = $parent->alloc_position unless $position;

    my $self =  bless { id => $id, #TODO: use the object id itself as an id? it's preserved when dumping & unique!
			parent => $parent,
			name => $name,
			type => $type,
			value => undef,
			position => $position,
		      }, $class;

    $parent->add_node($self);

    return $self;
}

sub attach_to_canvas {
    my ($self, $canvas) = @_;
    $self->{canvas} = $canvas; #is this necessary, or do the events automatically pass the canvas?
    my ($id, $parent) = @$self{qw(id parent)};
    my ($x, $y) = $self->abs_position;
    my $r = 5;
    my $body = $canvas->create('oval', $x-$r, $y-$r, $x+$r, $y+$r, -fill => 'yellow',
			       -tags => ["${id}_body", $self->get_canvas_tags]);
    my $body_text = $canvas->create('text', $x, $y, text => $self->{name}, -fill => 'white', -font => "Helvetica 12",
				    -tags => ["${id}_body", $self->get_canvas_tags]);
    $canvas->bind("${id}_body", '<1>' => [\&_press_body, $self, Ev('x'), Ev('y')]);
    $canvas->bind("${id}_body", '<B1-Motion>' => [\&_drag_body, $self, Ev('x'), Ev('y')]);
}


sub abs_position {
    my ($self) = @_;
    my ($pos, $parent) = @$self{qw(position parent)};
    my ($parent_x, $parent_y) = $parent->abs_position;
    return ($pos->[0] + $parent_x, $pos->[1] + $parent_y);
}

sub get_canvas_tags {
    my ($self) = @_;
    return ($self->{id}, $self->{parent}->get_canvas_tags);
}

#TODO: put dragging functions in a separate package? or inherit them?
sub _press_body {
    my ($ev, $self, $x, $y) = @_;
    my $id = $self->{id};
    my $canvas = $self->{canvas}; # get from event?
    $canvas->raise($id, 'all');
    @$self{qw(pressed_x pressed_y)} = ($x, $y);
    @$self{qw(dragged_x dragged_y)} = (0, 0);
}

sub _drag_body {
    my ($ev, $self, $x, $y) = @_;
    my $id = $self->{id};

    my ($pressed_x, $pressed_y) = @$self{qw(pressed_x pressed_y)};
    my ($dragged_x, $dragged_y) = @$self{qw(dragged_x dragged_y)};
    my ($dx, $dy) = ($x - ($pressed_x + $dragged_x), $y - ($pressed_y + $dragged_y));
    @$self{qw(dragged_x dragged_y)} = ($dragged_x + $dx, $dragged_y + $dy);
    my $canvas = $self->{canvas};
    $canvas->move($id, $dx, $dy);
#    @$self{qw(x y)} = ($x, $y);
}