package Machine; 
 
=head1 new (control:hashref, input:string) : Machine_ref

    Create a new object, give it a finite control and a tape, 
    and set it ready to run. 
 
    [1] Set the machine's finite control.   There's more 
    information about the process in the POD for method 
    use_control(). 
 
    [2] Set the contents of the tape.   Again, there's more 
    information in the POD for use_tape(). 
 
    [3] Start the machine in 'quiet' state.   This is explained 
    more fully in the POD for method cycle(). 
 
    [4] Position the read/write head over the endmarker. 
 
    [5] Put the machine in the 'start' state. 

=cut

sub new { 
    my $O = bless {}, shift; 
     
    $O->use_control (shift);            #[1] 
    $O->use_tape (shift);               #[2] 
    $O->set_quiet ();                   #[3] 
     
    $O->{'rw_head'} = 0;                #[4] 
    $O->{'state'}   = 'START';          #[5] 
     
    return ($O); 
} 
 
=head1 use_control (control:hashref) : nil 

    Set the machine's finite control. 

    We do this as a separate method so you can set the control 
    explicitly from client code. 

    [1] If the client doesn't supply a control, make a trivial 
    one that halts in the ACCEPT state immediately. 

    [2] the 'description' key doesn't actually map to a state  
    transition, it maps to a human-readable description of the  
    state.   It makes calling print_description() more fun,  
    and provides a nice way of commenting states while you  
    build the control. 

=cut

sub use_control { 
    my $O = shift; 
     
    $O->{'control'} = shift || {                            #[1] 
        'START' => {  
            'description' => "the machine's initial state", #[2] 
            '>>' => 'ACCEPT,,R' 
        } 
    }; 
    return; 
} 
 
=head1 use_tape (input:string) : nil 

    Set the machine's tape. 

    We break the input string into a list of characters, then 
    prepend the left-end-of-tape symbol.   All the machine's  
    'special' symbols are two-character glyphs, which means  
    you can't accidentally write one to the tape as part of  
    the input string.   You *can* write special symbols as  
    output, but that's something you define in your finite  
    control. 

=cut

sub use_tape { 
    my $O = shift; 
    $O->{'tape'}    = [ '>>', split ('', shift) ];    #[2] 
    return; 
} 
 
 
=head1 cycle (nil) : nil 

    Run the machine through one cycle of operation. 

    For all its size, this routine is little more that a table 
    lookup.   Most of the code is just print() statements that 
    execute if the 'verbose' flag is set, and the rest provides 
    convenience features that make it easier to build a finite  
    control. 

    [1] Copy some values into temp variables to make the code  
    that follows easier to read.   $R is just a prefix that  
    appears at the head of each print() statement triggered by 
    the 'verbose' flag. 

    [2] Read the current cell.   If no value exists, use the 
    right-end-of-tape special symbol.   This symbol only marks 
    the end of input, not the end of the tape per se.   You can 
    write another symbol cell, pushing the endmarker one more 
    cell right. 

    [3] Choose a transition for the current input.   There are 
    three options: 

        * if a transition is defined in the control, use it.

        * if no transition is defined for this symbol, check for a
        default transition, represented by the special symbol '**'.
        This is a utility feature, because without a default
        transition, we'd have to define transitions for every legal
        input, which would be a nuisance if we wanted to match the
        regular expression '.*'.

        * if no default transition exists, go to the 'REJECT' state.
        Again, this is a utility feature, because defining every
        possible *invalid* input is a bitch.

    [4] Split the transition string into pieces that we can use. 

    [5] If no output character is defined, write the input 
    character back to the tape.   Another boy-would-this-be-a- 
    bitch-to-define-by-hand feature. 

    [6] Translate 'L' and 'R' into numeric offsets, using an 
    anonymous hash.   If $move doesn't match 'L' or 'R', default 
    to zero, and leave the head where it is. 

    [7] The remaining operations are pretty much documented by 
    the corresponding 'verbose' output. 

=cut

sub cycle { 
    my $O = shift; 
     
    my $c = $O->{'control'};                            # 
    my $s = $O->{'state'};                              # 
    my $p = $O->{'rw_head'};                            #[1] 
    my $v = $O->{'verbose'};                            # 
    my $R = 'RUNNING -';                                # 
 
    my $in = (defined $O->{'tape'}->[ $p ] )    ?       #[2] 
        $O->{'tape'}->[ $p ]                    : 
        '<<' 
    ; 
print qq($R read input symbol "$in"\n) if ($v); 
     
    my $trans = $c->{ $s }->{ $in };                    #[3] 
    $trans  ||= $c->{ $s }->{'**'}; 
    $trans  ||= 'REJECT,,'; 
print qq($R found transition "$trans"\n) if ($v); 
 
    my ($new, $out, $move) = split (/,/, $trans);       #[4] 
    $out  = ('' eq $out) ? $in : $out;                  #[5] 
    $move = ${{'L'=>-1,'R'=>1}}{$move} || 0;            #[6] 
     
    $O->{'state'} = $new; 
print qq($R moving to state "$new"\n) if ($v); 
 
    $O->{'tape'}->[ $O->{'rw_head'} ] = $out; 
print qq($R writing symbol "$out" back to the tape.\n) if ($v); 
 
    $O->{'rw_head'} += $move; 
print "$R ", ${[ 
    "leaving the read/write head where it is.",         #[7] 
    "moving the read/write head right.", 
    "moving the read/write head left." 
]}[$move], "\n\n\n" if ($v); 
 
    return; 
} 
 
 
=head1 print_description (nil) : nil 

    Dump the machine's current configuration in human-readable  
    terms. 

=cut

sub print_description { 
    my $O = shift; 
     
    my $s = $O->{'state'}; 
    print qq(in state "$s"); 
    my $d = $O->{'control'}->{$s}->{'description'}; 
    print qq( - $d) if ($d); 
    print "\n"; 
     
    print "|"; 
 
    for $s (@{ $O->{'tape'} }, '<<') { 
        printf " %2s |", $s; 
    last if ('<<' eq $s); 
    } 
    print "\n"; 
 
    print  
        " ",  
        '     ' x $O->{'rw_head'},  
        "####\n\n\n", 
    ; 
    return; 
} 
 
 
=head1 is_running (nil) : boolean 

    A utility routine that says whether the machine has halted 
    yet.   It makes a nice control statement for a while() loop. 

=cut

sub is_running { 
    my $O = shift; 
    my $r = ( 
        ('ACCEPT' eq $O->{'state'}) ||  
        ('REJECT' eq $O->{'state'}) 
    ) ? 0 : 1; 
    return ($r); 
} 


=head1 set_verbose (nil) : nil 

    Set the flag that generates runtime commentary. 

=cut

sub set_verbose { 
    my $O = shift; 
    $O->{'verbose'} = 1; 
    return; 
} 
 
 
=head1 set_quiet (nil) : nil 

    Clear the flag that generates runtime commentary. 

=cut

sub set_quiet { 
    my $O = shift; 
    $O->{'verbose'} = 0; 
    return; 
} 
 
 
package main; 
 
$m = new Machine (); 
$m->use_control ({ 
    'START' => { 
        'description' => "where the machine starts", 
        '>>' => 'S1,,R', 
    }, 
    'S1' => { 
        'description' => "clear any non-empty cell", 
        '<<' => 'ACCEPT,,', 
        '**' => 'S1,--,R', 
    }, 
}); 
$m->use_tape ("accept .*"); 
$m->set_verbose(); 
 
while ($m->is_running()) { 
    $m->print_description(); 
    $m->cycle(); 
} 
 
$m->print_description();