use strict;
use warnings;
use Parse::RecDescent;
$RD_HINT=1;

# todo:
#    add   word := expr
#    figure out how to write the left associative grammar
#    add multiparam L

# this is the base grammar, no left associativity
my $base_grammar= q{
expr: identifier { $return=$item[1] }
    | lambda     { $return=$item[1] }
    | apply      { $return=$item[1] }
    | <error>
apply: '(' expr expr ')'  
    { $return=bless { operator=>$item[2], applicant=>$item[3] }, 'apply'; }
lambda: '(' 'L' identifier '.' expr ')'
    { $return=bless { identifier=>$item[3], expression=>$item[5] }, 'lambda'; }
identifier: /[A-Za-z_][A-Za-z0-9_]*/
    { $return=bless { name=>$item[1] }, 'identifier'; }
};

# this is the left associative grammar.
my $assoc_grammar= q{
expr: identifier { $return=$item[1] }
    | lambda     { $return=$item[1] }
    | apply  { $return=$item[1] }
    | '(' expr ')' { $return=$item[2] }
    | <error>
apply:  expr expr
    { $return=bless { operator=>$item[1], applicant=>$item[2] }, 'apply'; }
lambda: 'L' identifier '.' expr
    { $return=bless { identifier=>$item[2], expression=>$item[4] }, 'lambda'; }
identifier: ...!'L' /[A-Za-z_][A-Za-z0-9_]*/
    { $return=bless { name=>$item[1] }, 'identifier'; }
};
my $L_parser= new Parse::RecDescent $base_grammar;
use Data::Dumper;

while (<DATA>) {
    s/\s+$//;
    my $lexpr= $_;
    my $tree= $L_parser->expr($lexpr);

    printf("\n---- free{%s} bound{%s} %s\n", $tree->get_free->as_string, $tree->get_bound->as_string, $lexpr);
    #print Dumper($tree);
    printf("%s;\n", $tree->to_perl);
}
package lambda;

use Set::Object qw(set);

sub alpha_convert {
    my ($self, $old, $new)= @_;
    if (($self->get_free() + $self->get_bound())->contains($new)) {
        return undef;
    }
    return bless { 
        expression=>$self->{expression}->alpha_convert($old, $new),
        identifier=>$new,
    }, ref $self;
}
sub beta_reduce {
    my ($self)= @_;
    return $self;
}
sub eta_convert {
}
sub get_free {
    my ($self)= @_;

    my $freeset= $self->{expression}->get_free();
    $freeset->remove($self->{identifier}{name});
    return $freeset;
}
sub to_perl {
    my ($self)= @_;
    return sprintf("sub { my %s=shift; %s }",
        $self->{identifier}->to_perl,
        $self->{expression}->to_perl);
}
sub get_bound {
    my ($self)= @_;

    return set($self->{identifier}{name});
}
package apply;

sub alpha_convert {
    my ($self, $old, $new)= @_;
    if (($self->get_free() + $self->get_bound())->contains($new)) {
        return undef;
    }
    return bless { 
        applicant=>$self->{applicant}->alpha_convert($old, $new),
        operator=>$self->{operator}->alpha_convert($old, $new),
    }, ref $self;
}
sub beta_reduce {
    my ($self)= @_;
    return $self;
}
sub eta_convert {
}
sub to_perl {
    my ($self)= @_;
    return sprintf("%s->(%s)", $self->{operator}->to_perl, $self->{applicant}->to_perl);
}
sub get_free {
    my ($self)= @_;

    return $self->{operator}->get_free() + $self->{applicant}->get_free();
}
sub get_bound {
    my ($self)= @_;

    return $self->{operator}->get_bound() + $self->{applicant}->get_bound();
}
package identifier;
use Set::Object qw(set);
sub alpha_convert {
    my ($self, $old, $new)= @_;
    if (($self->get_free() + $self->get_bound())->contains($new)) {
        return undef;
    }
    return bless { 
        name=>($self->{name} eq $old) ? $new : $old,
    }, ref $self;
}
sub beta_reduce {
    my ($self)= @_;
    return $self;
}
sub eta_convert {
}
sub to_perl {
    my ($self)= @_;
    return '$'.$self->{name};
}
sub get_free {
    my ($self)= @_;

    return set($self->{name});
}
sub get_bound {
    my ($self)= @_;

    return set();
}
package main;
# omega combinator
# 1
# SUCC
# Y combinator
__DATA__
(L x. (x x))
(L f. (L x. (f x)))
(L n.(L f.(L x. (f ((n f) x)))))
(L g. ((L x. (g (x x))) (L x. (g (x x)))))
((L x. (x x)) (L y. y))
((L x. ((L y. y) z)) q)