Games::RailRoad::Node - a node object

  Jerome Quelin

# 
# This file is part of Games-RailRoad
# 
# This software is copyright (c) 2008 by Jerome Quelin.
# 
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# 
use 5.010;
use strict;
use warnings;

package Games::RailRoad::Node;
BEGIN {
  $Games::RailRoad::Node::VERSION = '1.101330';
}
# ABSTRACT: a node object

use Moose;
use MooseX::Has::Sugar;
use MooseX::SemiAffordanceAccessor;
use UNIVERSAL::require;


# -- attributes


has position => ( ro, isa=>'Games::RailRoad::Vector', required );


# -- constructor & initializers


# provided by moose


# -- public methods


sub connect {
    my ($self, $dir) = @_;

    # check if the node can be extended in the wanted $dir.
    my $map = $self->_transform_map;
    return unless exists $map->{$dir};

    # rebless the object in its new class.
    $map->{$dir}->require;
    bless $self, $map->{$dir};

    # initialize switch if needed.
    # FIXME: shouldn't it be it GRN:Switch:_init with an inconditional
    #        call to _init?
    if ( $self->isa('Games::RailRoad::Node::Switch')
        && not defined $self->_switch ) {
        $self->_switch(0);
    }
}



sub connectable {
    my ($self, $dir) = @_;
    my $map = $self->_transform_map;
    return exists $map->{$dir};
}



sub connections {
    my ($self) = @_;
    my $pkg = ref $self;
    return () if $pkg eq 'Games::RailRoad::Node';
    $pkg =~ s/^.*:://;
    return map { lc $_ } split /_/, $pkg;
}



sub delete {
    my ($self, $canvas) = @_;
    my $pos = $self->position;
    $canvas->delete("$pos");
}



sub draw {
    my ($self, $canvas, $tilelen) = @_;
    $self->delete($canvas);

    my $class = ref $self;
    $class =~ s/^.*:://;
    return if $class eq 'Node'; # naked node
    $self->_draw_segment(lc($_), $canvas, $tilelen)
        foreach split /_/, $class;
}



sub next_dir {
    my ($self, $from) = @_;
    # each node class is defining a _next_map() method that returns a
    # hashref of {from=>to}
    return $self->_next_map->{$from};
}



sub switch {}


# -- private methods

#
# $node->_draw_segment( $segment, $canvas, $tilelen )
#
# draw $segment of $node (at the correct col / row) on $canvas, assuming
# a square length of $tilelen. $segment can be one of nw, n, ne, w, e,
# sw, s, se.
#
sub _draw_segment {
    my ($self, $segment, $canvas, $tilelen) = @_;

    my $pos  = $self->position;
    my $col1 = $pos->posx;
    my $row1 = $pos->posy;
    my ($col2, $row2) = ($col1, $row1);

    # since each node is overlapping with the surrounding ones, we just
    # need to draw half of the segments.
    return unless $segment ~~ [ qw{ e sw s se } ];
    my $move = Games::RailRoad::Vector->new_dir($segment);
    my $end  = $pos + $move;

    # create the line.
    my $tags = [ "$pos", "$pos-$end" ];
    $canvas->createLine(
        $tilelen * $pos->posx, $tilelen * $pos->posy,
        $tilelen * $end->posx, $tilelen * $end->posy,
        -tags=>$tags
    );

    # add some fancy drawing
    my $div    = 3;
    my $radius = 1;
    foreach my $i ( 0 .. $div ) {
        my $x = $tilelen * ( $pos->posx + $move->posx * $i / $div );
        my $y = $tilelen * ( $pos->posy + $move->posy * $i / $div );
        $canvas->createOval(
            $x-$radius, $y-$radius,
            $x+$radius, $y+$radius,
            -fill => 'brown',
            -tags => $tags,
        );
    }

}


#
# my $map = $node->_transform_map;
#
# return a hashref, which keys are the directions where the node can be
# extended, and the values are the new class of the node after being
# extended.
#
sub _transform_map {
    my $prefix = 'Games::RailRoad::Node::';
    return {
        'e'  => $prefix . 'Half::E',
        'n'  => $prefix . 'Half::N',
        'ne' => $prefix . 'Half::NE',
        'nw' => $prefix . 'Half::NW',
        's'  => $prefix . 'Half::S',
        'se' => $prefix . 'Half::SE',
        'sw' => $prefix . 'Half::SW',
        'w'  => $prefix . 'Half::W',
    };
}



1;

__END__