package rel;
use strict;
use warnings;

use Data::Dumper;
use YAML;
use Data::Alias;
use Lib;
use L;
use dict;

use Exporter;
use base 'Exporter';
our @EXPORT = qw(rel det multi option declare $graph solve solve_all graph stop keep);

our $options;
our $graph = {};
our ($stop, $keep);  # TODO check this, keep

sub import {
	my ($pkg) = @_;
	my $caller = caller;
	strict->import; warnings->import;
	eval "package $caller; use Data::Dumper; use YAML; use Data::Alias; use Lib; use L; use dict;";
	goto \&Exporter::import;
}

use constant { MAKE => 0 };

sub rel (&) {
	my ($sub) = @_;
	my $rel = bless [$sub], __PACKAGE__;
	return $rel;
}

sub det (&) {
	my ($sub) = @_;
	my $wrap = sub { return [$sub]; };
	return bless $wrap, 'det';
}

sub multi (&) {
	my ($sub) = @_;
	my $wrap = sub {
		local $options = [];
		$sub->();
		return $options;
	};
	return bless $wrap, 'multi';
}

sub option (&) {
	my ($sub) = @_;
	push @$options, $sub;
}

sub declare (&) {
	my ($sub) = @_;
	no strict 'refs';
	my $caller = caller;
	my $dict = dict \&$sub;
#	my $graph = $graph;
	dict::for {
		my ($name, $make) = @_;
		*{"${caller}::$name"} = sub {
			rship($graph, $name, $make, \@_);
		};
	} $dict;
}

sub rship {
	my ($graph, $name, $rel, $args) = @_;
	my $rship = bless { $rel->[MAKE]->(@$args), args => [\(@$args)] }, $name;
	push @{$graph->{nodes}}, \(@$args);
	push @{$graph->{rships}}, $rship;
	for my $node (\(@$args)) {
		push @{$graph->{node_rels}{0+$node}}, $rship;   # TODO use set
	}
	$rship;
}

sub graph (&) {
	my ($sub) = @_;
	local $graph = {};
	$sub->();
	return $graph;
}

sub solve (&@) {
	my $sub = shift;
	my @target_nodes = \(@_);
#	solve_ref_fake($sub, \@target_nodes);
	solve_ref($sub, \@target_nodes);
}

sub solve_all (&) {
	my ($sub) = @_;
	my @target_nodes = grep {!defined $$_} @{$graph->{nodes}};
	solve_ref($sub, \@target_nodes);
}

sub solve_ref_fake {
	my ($sub, $targets) = @_;
	my $rship = $graph->{rships}[0];
	apply($rship, 'io');
	$sub->();
	revert($rship, 'io');
}

# solve_ref: does most of the work for solving, finding paths for solutions
# TODO simplify this if possible, reduce nesting, use recursion
sub solve_ref {
	my ($sub, $targets) = @_;
	my %nodes_found = map {$_=>$_} grep {defined $$_} @{$graph->{nodes}};  # TODO use set
	my %nodes_not_found = map {$_=>$_} grep { !defined $$_ } @$targets;
	my %nodes_active = %nodes_found;
#	warn "- [$$_]\n" for values %nodes_active;
	my %node_calc_rship_mode;
	my $nodes_new_n;
	while (%nodes_not_found) {
		$nodes_new_n = 0;
		for my $node (values %nodes_active) {
#			warn "checking active node: $node $$node\n";
			my $node_keep_active = 0;
			for my $rship (@{$graph->{node_rels}{0+$node}}) {
#				warn "  rel ".ref($rship)."\n";
				my $args = $rship->{args};
#				warn D $rship;
				for my $mode (keys %$rship) {
					next if $mode !~ /^[io]*$/;
					my @arg_modes = split //, $mode;
					my $have_all_ins = 1;
					my $might_need_some_outs = 0;
					for2 {
						if ($b eq 'i' && !$nodes_active{$a}) {
							$have_all_ins = 0;
							Last;
						} elsif ($b eq 'o' && !$nodes_found{$a}) {
							$might_need_some_outs = 1;
						}
					} @$args, @arg_modes;
					if ($have_all_ins && $might_need_some_outs) {
						for2 {
							if ($b eq 'o' && !$nodes_found{$a}) {
#								warn "found node: ".D($a);
#								warn "  ".ref($rship)." $mode\n";
								++$nodes_new_n;
								$nodes_found{$a} = $a;
								$nodes_active{$a} = $a;
								delete $nodes_not_found{$a};
								$node_calc_rship_mode{$a} = [$rship, $mode];
#								%nodes_not_found or last SEARCH;
							}
						} @$args, @arg_modes;
					}
					if ($might_need_some_outs) {
						$node_keep_active = 1;
					}
				}
			}
			if (!$node_keep_active) {
				delete $nodes_active{$node};
			}
		}
		last if !$nodes_new_n;
	}
	# TODO cache %node_calc_rship_mode info (and more) at the rel level for this graph ...

	if (%nodes_not_found) {
		return;
	}

	# work out the path, going backwards from the targets to defined nodes
	my %nodes_target = map {$_=>$_} grep { !defined $$_ } @$targets;
	my %node_fire_rships;
	while (%nodes_target) {
		for my $node (values %nodes_target) {
			my ($rship, $mode) = @{$node_calc_rship_mode{$node}};
			my $args = $rship->{args};
			my @arg_modes = split //, $mode;
			for2 {
				if ($b eq "i") {
					push @{$node_fire_rships{$a}}, [$rship, $mode];
					$nodes_target{$a} = $a unless defined $$a;
				}
			} @$args, @arg_modes;
			delete $nodes_target{$node};
		}
	}

	# serialise the path, going forward from defined nodes to targets
	my @path;
	%nodes_found = map {$_=>$_} grep {defined $$_} @{$graph->{nodes}};
	%nodes_not_found = map {$_=>$_} grep { !defined $$_ } @$targets;
	%nodes_active = %nodes_found;

	while (%nodes_not_found) {
		for my $node (values %nodes_active) {
			my $fire = $node_fire_rships{$node};
			for my $rship_mode (@$fire) {
				my ($rship, $mode) = @$rship_mode;
#				warn "trying to fire $rship $mode\n";
				my $args = $rship->{args};
				my @arg_modes = split //, $mode;
				my $can_fire = 1;
				for2 {
					if ($b eq "i" && !$nodes_found{$a}
					    or $b eq "o" && $nodes_found{$a}) {
						$can_fire = 0;
						Last;
					}
				} @$args, @arg_modes;
				if ($can_fire) {
#					warn "  can fire\n";
					for2 {
						if ($b eq "o") {
							push @path, $rship_mode;
							$nodes_found{$a} = $a;
							$nodes_active{$a} = $a;
							delete $nodes_not_found{$a};
						}
					} @$args, @arg_modes;
				}
			}
			delete $nodes_active{$node};
		}
	}

	# follow the path, applying each op to get options, and calling $sub for each possible solution, with backtracking
	# it's easier to do this recursively
	local ($stop, $keep) = (0, 0);
	solve_path($sub, \@path);
}

sub solve_path {
	my ($sub, $path, $i) = @_;
	$i ||= 0;
	return if $stop;
	if ($i == @$path) {
		$sub->();
		return;
	}
	my ($rship, $mode) = @{$path->[$i]};
	my $op = $rship->{$mode};
#	warn "applying ".ref($rship)." $mode\n";
	my $options = $op->();
	for my $option (@$options) {
		$option->();
		solve_path($sub, $path, $i+1);
		last if $stop;
	}
	revert($rship, $mode) unless $keep;
}

sub apply {
	my ($rship, $mode) = @_;
	$rship->{$mode}()[0]();
}

sub revert {
	my ($rship, $mode) = @_;
#	warn "reverting ".ref($rship)." $mode\n";
	my @arg_modes = split //, $mode;
	for2 { undef $$a if $b eq 'o' } @{$rship->{args}}, @arg_modes;
}

sub stop {
	$stop = 1;
}

sub keep {
	$stop = 1;
	$keep = 1;
}

1
