#!/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