state_monad.pl

BEGIN{ 
	$INC{'Util.pm'} = '-';

	package Util;
	use strict;
	use warnings;
	use Exporter qw/import/;
	our @EXPORT = qw/comp nt_nt T_nt nt_T/;

	sub comp($$){
		my ($arrow1, $arrow2) = @_;
		return sub {
			return $arrow1->( $arrow2->(@_) );
		}
	}

	sub nt_nt{
		my ($nt1, $nt2) = @_;
		# 各対象に対するコンポーネントを合成(今回は全部同じコンポーネント)
		comp $nt1, $nt2;
	}

	sub T_nt{
		my ($T, $nt) = @_;
		return $T->($nt);
	}

	sub nt_T{
		my ($nt, $T) = @_;
		# 対象TAによる$ntのコンポーネントだが、
		# 任意の対象について同じコンポーネントとしているので何もしなくていい
		return $nt;
	}
}

package Monad;
use Any::Moose;
use Util;

# 自己関手 (射の写像)
has T_arrow => (
	isa      => 'CodeRef',
	is       => 'ro',
	required => 1,
);

# モナドの単位元となる自然変換 (ID -> T)
has eta => (
	isa      => 'CodeRef',
	is       => 'ro',
	required => 1,
);

# モナドの乗法となる自然変換 (TT -> T)
has mu => (
	isa      => 'CodeRef',
	is       => 'ro',
	required => 1,
);

sub flat {
	my $self = shift;
	return sub {
		my $arrow = shift;  # A -> TB
		# TA -> TB
		return comp $self->mu, $self->T_arrow->( $arrow );
	};
}

no Any::Moose;
1;


package main;
use strict;
use warnings;
use Util;

my $state_monad = Monad->new(
	T_arrow => sub {
		my $arrow = shift;  #  A ->  B
		return sub {        # TA -> TB
			my $tx = shift; # TA
			return sub {    # TB
				my $env = shift;
				my ($value, $new_env) = $tx->($env);
				return $arrow->($value), $new_env;
			};
		};
	},
	eta => sub {
		my $value = shift; #  A
		return sub {       # TA
			my $env = shift;
			return $value, $env;
		};
	},
	mu => sub {
		my $ttx = shift; # TTA
		return sub {     #  TA
			my $env = shift;
			my ($tx, $new_env) = $ttx->($env);
			return $tx->($new_env);
		};
	},
);

sub get {
	sub {
		my $env = shift;
		return $env, $env
	};
}

sub set {
	my $new_env = shift;
	sub {
		my $env = shift;
		return undef, $new_env
	};
}


use Coro::Generator;
use Devel::Caller qw/caller_cv/;

sub do_monad(&$){
	my ($code, $monad_class) = @_;

	return sub {
		my @args = @_;

		my $result_as_monad;
		my $instruction_iter = generator {
			$result_as_monad = $code->(@args);
			yield undef while 1;
		};

		my $next_kleisli = sub {
			my @val = @_;
			my $monad = $instruction_iter->(@val);
			if($monad){
				return $monad_class->flat->(caller_cv 0)->($monad);
			}else{
				return $result_as_monad;
			}
		};

		return $next_kleisli->();
	};
}

sub retrieve($){
	my $monad = shift;
	return yield $monad;
}

my $countup = do_monad {
	my $up = shift;
	my $cnt = retrieve get;
	retrieve set($cnt + $up);
	$state_monad->eta->($cnt + $up);
} $state_monad;

print "RET: ", ( $countup->(2)->(1) )[0], "\n";

my $count5 = do_monad {
	retrieve $countup->(2);
	return $countup->(3);
} $state_monad;

print "RET: ", ( $count5->()->(0) )[0], "\n";