lib/Language/Befunge/Debugger.pm

   1 #
   2 # This file is part of Language::Befunge.
   3 # Copyright (c) 2007 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8
   9 package Language::Befunge::Debugger;
  10
  11 use strict;
  12 use warnings;
  13
  14 use Language::Befunge;
  15 use Language::Befunge::Vector;
  16 use Tk; # should come before POE
  17 use Tk::Dialog;
  18 use Tk::TableMatrix;
  19 use POE;
  20
  21
  22 #--
  23 # constructor
  24
  25 sub spawn {
  26     POE::Session->create(
  27         inline_states => {
  28             _start     => \&_on_start,
  29             # gui
  30             _b_quit     => \&_on_b_quit,
  31             _tm_click   => \&_on_tm_click,
  32         },
  33         args => \@ARGV,
  34     );
  35 }
  36
  37 #--
  38 # private events
  39
  40 sub _on_start {
  41     my ($k, $h, $s, $file) = @_[ KERNEL, HEAP, SESSION, ARG0 ];
  42
  43     #-- load befunge file
  44     # FIXME: barf unless file exists
  45     $h->{bef} = Language::Befunge->new( $file );
  46
  47
  48     #-- create gui
  49
  50     my $fh1 = $poe_main_window->Frame->pack(-fill=>'both', -expand=>1);
  51     my $tm = $fh1->Scrolled( 'TableMatrix',
  52         -scrollbars => 'osoe',
  53         -cols       => 80,
  54         -rows       => 25,
  55         -colwidth   => 3,
  56         -state      => 'disabled',
  57         -command    => sub { _get_cell_value($h->{bef}->get_torus,@_[1,2]) },
  58         -browsecmd  => $s->postback('_tm_click'),
  59     )->pack(-side=>'left', -fill=>'both', -expand=>1);
  60     $h->{w}{tm} = $tm;
  61
  62     # buttons
  63     my $fv = $fh1-> Frame->pack(-fill=>'x');
  64     my $fh11 = $fv->Frame->pack;
  65     my $b_quit = $fh11->Button(
  66         -text    => 'Quit',
  67         -command => $s->postback('_b_quit'),
  68     )->pack(-side=>'left');
  69     my $b_restart = $fh11->Button(
  70         -text    => 'Restart',
  71         -command => $s->postback('_b_restart'),
  72     )->pack(-side=>'left');
  73     my $fh12 = $fv->Frame->pack;
  74     my $b_pause = $fh12->Button(
  75         -text    => '||',
  76         -command => $s->postback('_b_pause'),
  77     )->pack(-side=>'left');
  78     my $b_next = $fh12->Button(
  79         -text    => '>',
  80         -command => $s->postback('_b_next'),
  81     )->pack(-side=>'left');
  82     my $b_continue = $fh12->Button(
  83         -text    => '>>',
  84         -command => $s->postback('_b_continue'),
  85     )->pack(-side=>'left');
  86
  87     # current position
  88     my $fh2 = $poe_main_window->Frame->pack(-fill=>'x', -expand=>1);
  89     $fh2->Label(-text=>'Current pos:')->pack(-side=>'left');
  90     my $vec = Language::Befunge::Vector->new_zeroes(2);
  91     my $val = $h->{bef}->get_torus->get_value($vec);
  92     my $chr = chr $val;
  93     my $l_curpos = $fh2->Label(-text=>"(0,0) $chr (ord=$val)")->pack(-side=>'left');
  94     $h->{w}{l_curcpos} = $l_curpos;
  95
  96     # stack
  97     my $fh3 = $poe_main_window->Frame->pack(-fill=>'x', -expand=>1);
  98     $fh3->Label(-text=>'Stack:')->pack(-side=>'left');
  99     my $l_stack = $fh3->Label(-text=>'[ ]')->pack(-side=>'left');
 100     $h->{w}{l_stack} = $l_stack;
 101
 102     #-- various initializations
 103     my $curx = $h->{curx} = 0;
 104     my $cury = $h->{cury} = 0;
 105     $tm->tagCell( 'current', "$cury,$curx" );
 106     $tm->tagConfigure( 'current', -bg => 'red' );
 107 }
 108
 109 #--
 110 # gui events
 111
 112 sub _on_b_quit {
 113     $poe_main_window->destroy;
 114     #exit;
 115 }
 116
 117 sub _on_tm_click {
 118     my ($h, $arg) = @_[HEAP, ARG1];
 119     my ($old, $new) = @$arg;
 120     my ($x,$y) = split /,/, $new;
 121     my $vec = Language::Befunge::Vector->new(2, $y, $x);
 122     my $val = $h->{bef}->get_torus->get_value($vec);
 123     my $chr = chr $val;
 124     $poe_main_window->Dialog( -text => "($x,$y) = $val = '$chr'" )->Show;
 125 }
 126
 127
 128 #--
 129 # private subs
 130
 131 sub _get_cell_value {
 132     my ($torus, $row, $col) = @_;
 133     my $v = Language::Befunge::Vector->new(2, $col, $row);
 134     return chr( $torus->get_value($v) );
 135 }
 136
 137
 138 1;
 139
 140 __END__