#
# This file is part of Language::Befunge::Debugger.
# Copyright (c) 2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#

package Language::Befunge::Debugger;

use strict;
use warnings;

use Language::Befunge;
use Language::Befunge::Debugger::Breakpoints;
use Language::Befunge::Vector;
use Readonly;
use Tk; # should come before POE
use Tk::Dialog;
use Tk::FBox;
use Tk::TableMatrix;
use Tk::ToolBar;
use POE;


our $VERSION = '0.3.6';

Readonly my $DECAY  => 8;
Readonly my $DELAY  => 0.1;
Readonly my @COLORS => ( [255,0,0], [0,0,255], [0,255,0], [255,255,0], [255,0,255], [0,255,255] );


#--
# constructor

#
# my $id = Language::Befunge::Debugger->spawn(%opts);
#
# create a new debugger gui for a befunge script. refer to the embedded
# pod for an explanation of the supported options.
#
sub spawn {
    my ($class, %opts) = @_;

    my $session = POE::Session->create(
        inline_states => {
            _start         => \&_on_start,
            # public events
            breakpoint_remove => \&_do_breakpoint_remove,
            # private events
            _breakpoint_add => \&_do_breakpoint_add,
            _open_file      => \&_do_open_file,
            # gui events
            _b_breakpoints => \&_on_b_breakpoints,
            _b_continue    => \&_on_b_continue,
            _b_forward     => \&_on_b_forward,
            _b_next        => \&_on_b_next,
            _b_open        => \&_on_b_open,
            _b_pause       => \&_on_b_pause,
            _b_quit        => \&_on_b_quit,
            _b_restart     => \&_on_b_restart,
            _tm_click      => \&_on_tm_click,
        },
        args => \%opts,
    );
    return $session->ID;
}


#--
# public events

#
# breakpoint_remove( $brkpt );
#
# remove $brkpt from the list of active breakpoints.
#
sub _do_breakpoint_remove {
    my ($k, $h, $brkpt) = @_[KERNEL, HEAP, ARG0];
    my ($type, $value) = split /: /, $brkpt;
    delete $h->{breakpoints}{$type}{$value}; # remove breakpoint
}


#--
# private events

#
# breakpoint_add( $brkpt );
#
# add $brkpt to the list of active breakpoints. request LDB::Breakpoints
# window to add it to its list.
#
sub _do_breakpoint_add {
    my ($k, $h, $args) = @_[KERNEL, HEAP, ARG0];
    my $brkpt = $args->[0];

    # store new breakpoint.
    my ($type, $value) = split /: /, $brkpt;
    $h->{breakpoints}{$type}{$value} = 1;

    # notify breakpoints window.
    if ( not exists $h->{w}{breakpoints} ) {
        my $id = Language::Befunge::Debugger::Breakpoints->spawn(
            parent     => $poe_main_window,
            breakpoint => $brkpt,
        );
        $h->{w}{breakpoints} = $id;
    } else {
        $k->post( $h->{w}{breakpoints}, 'breakpoint_add', $brkpt );
    }
}


#
# _open_file( $file );
#
# force reloading of $file, with everything that it implies - ie,
# reinitializes debugger state.
#
sub _do_open_file {
    my ($h, $file) = @_[HEAP, ARG0];

    # store filename
    $h->{file} = $file;

    # clean old ips
    foreach my $ip ( keys %{ $h->{ips} } ) {
        next unless defined $h->{ips}{$ip}{label};
        $h->{ips}{$ip}{label}->destroy;
        delete $h->{ips}{$ip}{label};
    }
    my $tm = $h->{w}{tm};
    $tm->tagDelete($_) for $tm->tagNames('decay-*');

    # load the new file
    my $bef = $h->{bef} = Language::Befunge->new({file=>$file});
    my $newip = Language::Befunge::IP->new($bef->get_dimensions);
    $bef->set_ips( [ $newip ] );
    $bef->set_retval(0);
    $h->{ips}      = {};
    $h->{tick}     = 0;
    $h->{continue} = 0;
    _create_ip_struct( $h, $newip );
    my $id = $newip->get_id;

    # force rescanning of the playfield
    $tm->configure(-command => sub { _get_cell_value($h->{bef}->get_storage,@_[1,2]) });
    $tm->tagCell("decay-$id-0", '0,0');
    _gui_set_pause($h);
}


#
# _on_start( \%opts );
#
# session initialization. %opts is received from spawn();
#
sub _on_start {
    my ($k, $h, $s, $opts) = @_[ KERNEL, HEAP, SESSION, ARG0 ];

    #-- load befunge file
    $k->yield( $opts->{file} ? ('_open_file', $opts->{file}) : '_b_open' );

    #-- create gui

    # prettyfying tk app.
    # see http://www.perltk.org/index.php?option=com_content&task=view&id=43&Itemid=37
    $poe_main_window->optionAdd('*BorderWidth' => 1);

    # menu
    $poe_main_window->optionAdd('*tearOff', 'false'); # no tear-off menus
    my $menuitems = [
        [ Cascade => '~File', -menuitems => [
            [ Button => '~Open',
                -command     => $s->postback('_b_open'),
                -accelerator => 'ctrl+o',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('fileopen16'),
                ],
            [ Separator => '' ],
            [ Button => '~Quit',
                -command     => $s->postback('_b_quit'),
                -accelerator => 'ctrl+q',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('actexit16'),
                ],
            ],
        ],
        [ Cascade => '~Run', -menuitems => [
            [ Button => '~Restart',
                -command     => $s->postback('_b_restart'),
                -accelerator => 'R',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('playstart16'),
                ],
            [ Button => '~Pause',
                -command     => $s->postback('_b_pause'),
                -accelerator => 'p',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('playpause16'),
                ],
            [ Button => '~Next',
                -command     => $s->postback('_b_next'),
                -accelerator => 'n',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('nav1rightarrow16'),
                ],
            [ Button => '~Continue',
                -command     => $s->postback('_b_continue'),
                -accelerator => 'c',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('nav2rightarrow16'),
                ],
            [ Button => 'Fast forward',
                -command     => $s->postback('_b_forward'),
                -accelerator => 'w',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('playend16'),
                ],
            [ Separator => '' ],
            [ Button => '~Breakpoints',
                -command     => $s->postback('_b_breakpoints'),
                #-accelerator => 'c',
                -compound    => 'left',
                -image       => $poe_main_window->Photo('calbell16'),
                ],
            ],
        ],
    ];
    my $menubar = $poe_main_window->Menu( -menuitems => $menuitems );
    $poe_main_window->configure( -menu => $menubar );
    $h->{w}{mnu_run} = $menubar->entrycget(1, '-menu');


    # toolbar
    my @tb = (
        [ 'Button', 'actexit16',        'quit',         '<Control-q>', '_b_quit'        ],
        [ 'Button', 'fileopen16',       'open',         '<Control-o>', '_b_open'        ],
        [ 'separator'                                                                   ],
        [ 'Button', 'calbell16',        'breakpoints',  '<F8>',        '_b_breakpoints' ],
        [ 'separator'                                                                   ],
        [ 'Button', 'playstart16',      'restart',      '<R>',         '_b_restart'     ],
        [ 'Button', 'playpause16',      'pause',        '<p>',         '_b_pause'       ],
        [ 'Button', 'nav1rightarrow16', 'next',         '<n>',         '_b_next'        ],
        [ 'Button', 'nav2rightarrow16', 'continue',     '<c>',         '_b_continue'    ],
        [ 'Button', 'playend16',        'fast forward', '<f>',         '_b_forward'     ],
    );
    my $tb = $poe_main_window->ToolBar(-movable=>0);
    foreach my $item ( @tb ) {
        my $type = shift @$item;
        $tb->separator( -movable => 0 ), next if $type eq 'separator';
        $h->{w}{$item->[3]} = $tb->$type(
            -image       => $item->[0],
            -tip         => $item->[1],
            -accelerator => $item->[2],
            -command     => $s->postback($item->[3]),
        );
    }
    $tb->separator(-movable => 0 );
    $h->{w}{ip} = $tb->LabEntry(-label=>'tick', -textvariable=>\$h->{tick},-justify=>'center',-state=>'readonly');

    # playfield
    my $fh1 = $poe_main_window->Frame->pack(-fill=>'both', -expand=>1);
    my $tm = $fh1->Scrolled( 'TableMatrix',
        -bg         => 'white',
        -scrollbars => 'osoe',
        -cols       => 200,
        -rows       => 999,
        -colwidth   => 3,
        -state      => 'disabled',
        -browsecmd  => $s->postback('_tm_click'),
    )->pack(-side=>'left', -fill=>'both', -expand=>1);
    $h->{w}{tm} = $tm;

    # frame with one summary label per running ip
    $h->{w}{f_ips} = $poe_main_window->Frame->pack(-fill=>'x');
}


#--
# gui events

#
# _b_breakpoints();
#
# called when the user wants to show/hide breakpoints.
#
sub _on_b_breakpoints {
    my ($k, $h) = @_[KERNEL, HEAP];

    return $k->post($h->{w}{breakpoints}, 'visibility_toggle')
        if exists $h->{w}{breakpoints};

    my $id = Language::Befunge::Debugger::Breakpoints->spawn(parent=>$poe_main_window);
    $h->{w}{breakpoints} = $id;
}


#
# _b_continue();
#
# called when the user wants the paused script to be ran.
#
sub _on_b_continue {
    my ($k, $h) = @_[KERNEL, HEAP];
    $h->{continue} = 1;
    _gui_set_continue($h);
    $k->yield('_b_next');
}


#
# _b_forward();
#
# called when the user wants the paused script to be ran as close as
# real time as possible.
#
sub _on_b_forward {
    my ($k, $h) = @_[KERNEL, HEAP];
    $h->{continue} = 2;
    _gui_set_continue($h);
    $k->yield('_b_next');
}

#
# _b_next();
#
# called when the user wants to advance the script one step further.
#
sub _on_b_next {
    my ($k,$h) = @_[KERNEL, HEAP];

    my $w   = $h->{w};
    my $bef = $h->{bef};
    my $ips = $h->{ips};
    my $tm  = $h->{w}{tm};

    if ( scalar @{ $bef->get_ips } == 0 ) {
        # no more ip - end of program
        return;
    }

    # get next ip
    my $ip = shift @{ $bef->get_ips };
    my $id = $ip->get_id;

    _create_ip_struct($h, $ip) unless exists $ips->{$ip};

    # show color of ip being currently processed
    $w->{ip}->configure(-bg=>$ips->{$ip}{bgcolor});

    # do some color decay.
    my $oldpos = $ips->{$ip}{oldpos};
    unshift @$oldpos, _vec_to_tablematrix_index($ip->get_position);
    pop     @$oldpos if scalar @$oldpos > $DECAY;
    foreach my $i ( reverse 0 .. $DECAY-1 ) {
        next unless exists $oldpos->[$i];
        $tm->tagCell("decay-$id-$i", $oldpos->[$i]);
    }


    # update gui

    # advance next ip
    $bef->set_curip($ip);
    $bef->process_ip;

    if ( $ip->get_end ) {
        # ip should be terminated - remove summary label.
        $ips->{$ip}{label}->destroy;
        delete $ips->{$ip}{label};
    } else {
        # update gui
        my $tmindex = _vec_to_tablematrix_index($ip->get_position);
        $tm->see($tmindex);
        $tm->tagCell( "decay-$id-0", $tmindex );
        $ips->{$ip}{label}->configure( -text => _ip_to_label($ip,$bef) );
    }


    # end of tick: no more ips to process
    if ( scalar @{ $bef->get_ips } == 0 ) {
        $h->{tick}++;
        $bef->set_ips( $bef->get_newips );
        $bef->set_newips( [] );

        # color decay on terminated ips
        my @ips    = map { $ips->{$_}{object} } keys %$ips;
        my @oldips = grep { $_->get_end } @ips;
        foreach my $oldip ( @oldips ) {
            my $oldid = $oldip->get_id;
            my $oldpos = $ips->{$oldip}{oldpos};
            pop @$oldpos;
            foreach my $i ( 0 .. $DECAY-1 ) {
                last unless exists $oldpos->[$i];
                my $decay = $i + $DECAY - scalar(@$oldpos);
                $tm->tagCell("decay-$oldid-$decay", $oldpos->[$i]);
            }
            delete $ips->{$oldip} unless scalar(@$oldpos);
        }
    }

    # fire again if user asked for continue.
    my $vec = $ip->get_position;
    my ($x, $y) = $vec->get_all_components;
    my $brkpts = $h->{breakpoints};
    my $is_breakpoint = exists $brkpts->{row}{$y}
        || exists $brkpts->{col}{$x}
        || exists $brkpts->{pos}{"$x,$y"};
    if ( $is_breakpoint ) {
        $k->yield('_b_pause');
    } else {
        $k->yield( '_b_next' ) if $h->{continue} == 2;
        $k->delay_set( '_b_next', $DELAY ) if $h->{continue} == 1;
    }
}


#
# _b_pause();
#
# called when the user wants the running script to be paused.
#
sub _on_b_pause {
    my ($k, $h) = @_[KERNEL, HEAP];
    $h->{continue} = 0;
    _gui_set_pause($h);
}


#
# _b_open();
#
# called when the user wants to load another befunge script.
#
sub _on_b_open {
    my @types = (
       [ 'Befunge scripts', '.bef' ],
       [ 'All files',       '*'    ]
    );
    # i know, this prevent poe from running
    my $file = $poe_main_window->getOpenFile(-filetypes => \@types);
    $_[KERNEL]->yield( '_open_file', $file )
        if defined($file) && $file ne '';
}


#
# _b_quit();
#
# called when the user wants to quit the application.
#
sub _on_b_quit {
    $poe_main_window->destroy;
}


#
# _b_restart();
#
# reload current file.
#
sub _on_b_restart {
    my ($k,$h) = @_[KERNEL, HEAP];
    $k->yield('_open_file', $h->{file});
}


#
# _tm_click();
#
# called when the user clicks on the field. used to add breakpoints.
#
sub _on_tm_click {
    my ($h, $s, $arg) = @_[HEAP, SESSION, ARG1];

    my ($old, $new) = @$arg;
    my ($x,$y) = split /,/, $new;

    #my $vec = Language::Befunge::Vector->new($y, $x);
    #my $val = $h->{bef}->get_torus->get_value($vec);
    #my $chr = chr $val;


    my $menuitems = [ [ Cascade => '~Add breakpoint', -menuitems => [
        [ Button=>"on ~row $x",      -command=>$s->postback('_breakpoint_add', "row: $x") ],
        [ Button=>"on ~col $y",      -command=>$s->postback('_breakpoint_add', "col: $y") ],
        [ Button=>"at ~pos ($y,$x)", -command=>$s->postback('_breakpoint_add', "pos: $y,$x") ],
    ] ] ];

    my $m = $poe_main_window->Menu( -menuitems => $menuitems );
    $m->Popup( -popover => 'cursor', -popanchor => 'nw' );
}


#--
# private subs


#
# _create_ip_struct( $heap, $ip );
#
# L::B::Debugger maintains some data associated to the running ips. this
# sub initialize the $heap data associated to a new $ip so it can be
# used later on.
#
# note: a new ip can be created either during befunge script loading, or
# when encountering the 't' command (thread) since L::B supports
# threaded befunge.
#
sub _create_ip_struct {
    my ($h, $ip) = @_;

    my $bef = $h->{bef};
    my $ips = $h->{ips};
    my $id  = $ip->get_id;
    my $w   = $h->{w};
    my $tm  = $w->{tm};

    # newly created ip - initializing data structure.
    $ips->{$ip}{object} = $ip;

    # - decay colors
    my ($r,$g,$b) = exists $COLORS[$id]
        ?  @{$COLORS[$id]}
        : (rand(255), rand(255), rand(255));

    foreach my $i ( 0 .. $DECAY-1 ) {
        my $ri = sprintf "%02x", $r + (255-$r) / $DECAY * ($i+1);
        my $gi = sprintf "%02x", $g + (255-$g) / $DECAY * ($i+1);
        my $bi = sprintf "%02x", $b + (255-$b) / $DECAY * ($i+1);
        $tm->tagConfigure( "decay-$id-$i", -bg => "#$ri$gi$bi" );
        $ips->{$ip}{bgcolor} = "#$ri$gi$bi" if $i == 0;
    }
    $w->{ip}->configure( -bg => $ips->{$ip}{bgcolor} );

    # - summary label
    $ips->{$ip}{label} = $w->{f_ips}->Label(
        -text    => _ip_to_label($ip,$bef),
        -justify => 'left',
        -anchor  => 'w',
        -bg      => $ips->{$ip}{bgcolor},
    )->pack(-fill=>'x', -expand=>1);

    # - old positions
    $ips->{$ip}{oldpos} = [];
}


#
# my $value = _get_cell_value( $storage, $row, $col );
#
# return the $value of $storage at the position ($row, $col). this
# function is used by Tk::TableMatrix to fill in the values of the
# cells.
#
sub _get_cell_value {
    my ($storage, $row, $col) = @_;
    my $v = Language::Befunge::Vector->new($col, $row);
    return $storage->get_char($v);
}


#
# _gui_set_continue( $heap );
#
# update the gui to enable/disable the buttons in order to match the
# state 'running'. it will use the $heap->{w} structure to find the
# wanted gui elements.
#
sub _gui_set_continue {
    my ($h) = @_;
    $h->{w}{_b_pause}   ->configure( -state => 'normal'   );
    $h->{w}{_b_next}    ->configure( -state => 'disabled' );
    $h->{w}{_b_continue}->configure( -state => 'disabled' );
    $h->{w}{_b_forward} ->configure( -state => 'disabled' );
    $h->{w}{mnu_run}->entryconfigure( 1, -state => 'normal'   );
    $h->{w}{mnu_run}->entryconfigure( 2, -state => 'disabled' );
    $h->{w}{mnu_run}->entryconfigure( 3, -state => 'disabled' );
}


#
# _gui_set_pause( $heap );
#
# update the gui to enable/disable the buttons in order to match the
# state 'paused'. it will use the $heap->{w} structure to find the
# wanted gui elements.
#
sub _gui_set_pause {
    my ($h) = @_;
    $h->{w}{_b_pause}   ->configure( -state => 'disabled' );
    $h->{w}{_b_next}    ->configure( -state => 'normal'   );
    $h->{w}{_b_continue}->configure( -state => 'normal'   );
    $h->{w}{_b_forward} ->configure( -state => 'normal'   );
    $h->{w}{mnu_run}->entryconfigure( 1, -state => 'disabled' );
    $h->{w}{mnu_run}->entryconfigure( 2, -state => 'normal'   );
    $h->{w}{mnu_run}->entryconfigure( 3, -state => 'normal'   );
}


#
# my $str = _ip_to_label( $ip, $bef );
#
# return a stringified value of the Language::Befunge::IP to be
# displayed in the label. it needs the Language::Befunge::Interpreter to
# fetch some values in the torus.
#
# the stringified value will be sthg like:
#   IP#2 @4,6 0 (ord=48) [ 32 111 52 32 ]
#
sub _ip_to_label {
    my ($ip,$bef) = @_;
    my $id     = $ip->get_id;
    my $vec    = $ip->get_position;
    my ($x,$y) = $vec->get_all_components;
    my $stack  = $ip->get_toss;
    my $val    = $bef->get_storage->get_value($vec);
    my $chr    = chr $val;
    return "IP#$id \@$x,$y $chr (ord=$val) [@$stack]";
}


#
# my $str = _vec_to_tablematrix_index( $vector );
#
# given a Language::Befunge::Vector object, return its stringified value
# as Tk::TableMatrix understand it: "x,y".
#
sub _vec_to_tablematrix_index {
    my ($vec) = @_;
    my ($x, $y) = $vec->get_all_components;
    return "$y,$x";
}


1;

__END__


=head1 NAME

Language::Befunge::Debugger - a graphical debugger for Language::Befunge



=head1 SYNOPSYS

    $ jqbefdb



=head1 DESCRIPTION

Language::Befunge::Debugger provides you with a graphical debugger for
Language::Befunge. This allow to follow graphically your befunge program
while it gets executed, update the stack and the playfield, add
breakpoints, etc.



=head1 CLASS METHODS

=head2 my $id = Language::Befunge::Debugger->spawn( %opts );

Create a graphical debugger, and return the associated POE session ID.
One can pass the following options:

=over 4

=item file => $file

A befunge program to be loaded for debug purposes.


=back



=head1 PUBLIC EVENTS

The POE session accepts the following events:


=over 4

=item breakpoint_remove( $brkpt )

Remove a breakpoint from the list of active breakpoints.


=back



=head1 BUGS

Please report any bugs or feature requests to C<< <
language-befunge-debugger at rt.cpan.org> >>, or through the web
interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Language-Befunge-Debugger>.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.



=head1 SEE ALSO

L<Language::Befunge>, L<POE>, L<Tk>.


Development is discussed on E<lt>language-befunge@mongueurs.netE<gt> -
feel free to join us.


You can also look for information on this module at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Language-Befunge-Debugger>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Language-Befunge-Debugger>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Language-Befunge-Debugger>

=back



=head1 AUTHOR

Jerome Quelin, C<< <jquelin at cpan.org> >>



=head1 COPYRIGHT & LICENSE

Copyright (c) 2007 Jerome Quelin, all rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.


=cut