#!/usr/bin/perl
#
# A demonstration of continuation passing style. Implements primitives
# for ambivalence and backtracking which are used to solve a logic
# problem.
#
use 5.008;
use strict;
use warnings;


# This package could be used as a standalone module offering CPS
# ambivalence utilities.
package Amb;

# This variable holds the current failure continuation, which is
# called when amb has no more values to return or Amb::assert fails.
# The default value of this variable signals an error, because it
# should really by initialized by Amb::find or Amb::collect.
our $Failure = sub {
    die 'Unexpected ambivalence failure'
};

# The universal backtracking ambivalence operator. Calling amb with an
# empty list of alternatives thus results in immediate invocation of
# the failure continuation while calling amb with several alternatives
# results in a CPS return value selected from that list as determined
# by the further flow of the program.
#
# This is achieved as follows: Given a success continuation and a list
# of alternatives, amb sets up the global failure continuation to
# shift a value off that list unless empty and to invoke the success
# continuation; iff the list is empty, though, the outer failure
# continuation is restored and invoked. amb then invokes the new
# failure continuation immediately.
#
# Params:
#   $Success      = The continuation invoked upon success.
#   @alternatives = The possible values that may be fed to $Success.
#
# Returns (CPS):
#   Any value from @alternatives.
sub some(&@) {
    my ($Success, @alternatives) = @_;
    my $OuterFailure = $Failure;

    $Failure = sub {
	if (@alternatives > 0) {
	    @_ = (shift @alternatives); goto &$Success;
	}
	else {
	    $Failure = $OuterFailure;
	    @_ = (); goto &$Failure;
	}
    };

    @_ = (); goto &$Failure;
}

# The ambivalence assertion operator. Given a success continuation and
# a condition, it invokes the success continuation iff the condition
# is true; otherwise the failure continuation is invoked.
#
# Params:
#   $Success   = The continuation invoked upon success.
#   $condition = The condition to check.
#
# Returns (CPS):
#   nothing.
sub assert(&$) {
    my ($Success, $condition) = @_;

    @_ = ();
    if ($condition) {
	goto &$Success;
    }
    else {
	goto &$Failure;
    }
}

# The single value ambivalence CPS entry point. Sets up initial
# success and failure continuations for use by the CPS method passed
# as the first argument and runs it, collecting its return value.
#
# Params:
#   &proc     = The CPS procedure to call.
#   @defaults = The default set of values to return if the CPS
#               procedure fails.
#
# Returns:
#   The values passed to the success continuation by the given CPS
#   procedure or the set of default values if the CPS procedure
#   invokes the initial failure continuation.
sub find(&@) {
    my ($proc, @defaults) = @_;

    my @results = ();
    local $Failure = sub {
	@results = @defaults;
    };

    my $Success = sub {
	@results = @_;
    };

    $proc->($Success);

    return @results;
}

# The collecting ambivalence CPS entry point. Sets up initial success
# and failure continuations for use by the CPS method passed as the
# argument and runs it, collecting all its possible return values.
#
# Params:
#    &proc = The CPS procedure to call.
#    $wrap = If true, return value sets from the CPS procedure are
#            wrapped into array references before they are
#            collected. If false, return value sets are simply
#            concatenated.
#
# Returns:
#    All possible return value sets from the CPS procedure as array
#    references.
sub collect(&$) {
    my ($proc, $wrap) = @_;

    my $done = 0;
    local $Failure = sub {
	$done = 1;
    };

    my @results = ();
    my $Success = sub {
	if ($wrap) {
	    push @results, [ @_ ];
	}
	else {
	    push @results, @_;
	}
    };

    $proc->($Success);
    $Failure->() while (!$done);

    return @results;
}

1;


# The following program uses the ambivalence operators and
# Amb::collect to find all possible solutions of the following puzzle:
#
#   The Kalotans are a tribe with a peculiar quirk. Their males always
#   tell the truth. Their females never make two consecutive true
#   statements, or two consecutive untrue statements.
#
#   An anthropologist (let's call him Worf) has begun to study
#   them. Worf does not yet know the Kalotan language. One day, he
#   meets a Kalotan (heterosexual) couple and their child Kibi. Worf
#   asks Kibi: "Are you a boy?" Kibi answers in Kalotan, which of
#   course Worf doesn't understand.
#
#   Worf turns to the parents (who know English) for explanation. One
#   of them says: "Kibi said: 'I am a boy.'" The other adds: "Kibi is
#   a girl. Kibi lied."
#
#   Solve for the sex of the parents and Kibi.
package main;

my @mf = qw/male female/;

my @solutions = Amb::collect {
    my ($Success) = @_;

    Amb::some {
	my ($parent1) = @_;
	Amb::some {
	    my ($parent2) = @_;
	    Amb::some {
		my ($kibi) = @_;
		Amb::some {
		    my ($kibi_self) = @_;
		    Amb::some {
			my ($kibi_lied) = @_;
			Amb::assert {
			    my $KibiSuccess = sub {
				my $Parent1Success = sub {
				    @_ = ({
					parent1 => $parent1,
					parent2 => $parent2,
					kibi => $kibi
				    });
				    goto &$Success;
				};

				if ($parent1 eq 'male') {
				    Amb::assert
					\&$Parent1Success,
					(($kibi_self eq 'male') &&
					 ((($kibi eq 'female') && !$kibi_lied) ^
					  (($kibi eq 'male') && $kibi_lied)))
				}
				else {
				    Amb::assert
					\&$Parent1Success,
					(($kibi eq 'female') && $kibi_lied)
				}
			    };

			    if ($kibi_lied) {
				Amb::assert
				    \&$KibiSuccess,
				    ((($kibi_self eq 'male') &&
				      ($kibi eq 'female')) ^
				     (($kibi_self eq 'female') &&
				      ($kibi eq 'male')))
			    }
			    else {
				Amb::assert
				    \&$KibiSuccess,
				    ((($kibi_self eq 'male') &&
				      ($kibi eq 'male')) ^
				     (($kibi_self eq 'female') &&
				      ($kibi eq 'female')))
			    }
			} ($parent1 ne $parent2);
		    } 1, 0;
		} @mf;
	    } @mf;
	} @mf;
    } @mf;
} 0;

print <<EOD foreach (0 .. $#solutions);
Solution $_:
  First parent is  $solutions[$_]->{parent1}
  Second parent is $solutions[$_]->{parent2}
  Kibi is          $solutions[$_]->{kibi}
EOD