File Coverage

blib/lib/Math/Logic/Ternary/Expression.pm

Criterion	Covered	Total	%
statement	84	84	100.0
branch	48	48	100.0
condition	12	12	100.0
subroutine	15	15	100.0
pod	7	7	100.0
total	166	166	100.0

# Copyright (c) 2012-2017 Martin Becker, Blaubeuren.  All rights reserved.
# This package is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

package Math::Logic::Ternary::Expression;

use strict;
use warnings;

require Exporter;

our @ISA         = qw(Exporter);
our @EXPORT_OK   = qw(not3 and3 or3 xor3 eqv3 bool3 val3);
our %EXPORT_TAGS = ('all' => \@EXPORT_OK);
our $VERSION     = '0.004';

# ----- object definition -----

# Math::Logic::Ternary::Expression=ARRAY(...)

# M::L::T::Expression          ARRAY
# +----------+---------+       +----------+----------+
# | VALUEREF |    o----------->| VALUE    | anything |
# +----------+---------+       +----------+----------+
# | NEGATED  | boolean |       | DEFERRED | boolean  |
# +----------+---------+       +----------+----------+

# .......... index ..........   # .............. value ..............
use constant VALUEREF => 0;     # ref of lazily accessible value
use constant NEGATED  => 1;     # boolean

# lazily accessible value: ARRAY(...)

# .......... index ..........   # .............. value ..............
use constant VALUE    => 0;     # coderef while deferred, then value
use constant DEFERRED => 1;     # boolean

my $undef = bless [[undef, ''], ''];

# turn any value into an MLTE object
sub _object {
    my ($this) = @_;
    return $undef if !defined $this;
    return $this  if __PACKAGE__ eq ref $this;
    return bless [[$this, 'CODE' eq ref $this], ''];
}

# get the actual value from an MLTE object
sub _evaluate {
    my ($this) = @_;
    my $vr = $this->[VALUEREF];
    my $v  = $vr->[VALUE];
    my $n  = $this->[NEGATED];
    if ($vr->[DEFERRED]) {
        $vr->[DEFERRED] = '';
        $v = $vr->[VALUE] = $v->();
        if (!defined $v) {
            $n = $this->[NEGATED] = '';
        }
    }
    # die "assertion failed" unless defined($v) || !$n;
    return $n? !$v: $v;
}

# get the actual value from anything
sub val3 {
    my ($this) = @_;
    return $this if !defined($this) || __PACKAGE__ ne ref $this;
    return _evaluate($this);
}

# replace actual value by a truth value
sub bool3 {
    my ($this) = @_;
    my $val = _evaluate(_object($this));
    return $undef if !defined $val;
    return bless [[!!$val, ''], ''];
}

# negate without evaluating
sub not3 {
    my ($this) = @_;
    return $undef if !defined $this;
    if (__PACKAGE__ eq ref $this) {
        my $vr = $this->[VALUEREF];
        return $undef if !($vr->[DEFERRED] || defined $vr->[VALUE]);
        return bless [$vr, !$this->[NEGATED]];
    }
    return bless [[$this, 'CODE' eq ref $this], 1];
}

# a && b:    tt => b, tf => b, ft => a, ff => a
sub and3 {
    my ($this, $that) = @_;
    my $obj = _object($this);
    my $val = _evaluate($obj);
    return $obj if defined($val) && !$val;      # false, * => LHS
    $obj = _object($that);
    return $obj if $val;                        # true, * => RHS
    $val = _evaluate($obj);
    return $obj if defined($val) && !$val;      # undef, false => RHS
    return $undef;                              # else => undef
}

# a || b:    tt => a, tf => a, ft => b, ff => b
sub or3 {
    my ($this, $that) = @_;
    my $obj = _object($this);
    my $val = _evaluate($obj);
    return $obj if $val;                        # true, * => LHS
    $obj = _object($that);
    return $obj if defined $val;                # false, * => RHS
    $val = _evaluate($obj);
    return $obj if $val;                        # undef, true => RHS
    return $undef;                              # else => undef
}

# a? !b: b                 tt => !b, tf => !b, ft => b, ff => b
# !a && b || !b && a       tt => !b, tf => a,  ft => b, ff => a
# !b && a || !a && b       tt => !a, tf => a,  ft => b, ff => b
# !(a && b) && (a || b)    tt => !b, tf => a,  ft => b, ff => b   (implemented)

sub xor3 {
    my ($this, $that) = @_;
    my $obj1 = _object($this);
    my $val = _evaluate($obj1);
    return $undef if !defined $val;             # undef, * => undef
    my $obj2 = _object($that);
    return $obj2 if !$val;                      # false, * => RHS
    $val = _evaluate($obj2);
    return $undef if !defined $val;             # true, undef => undef
    return $obj1 if !$val;                      # true, false => LHS
    return not3($obj2);                         # true, true => not RHS
}

# !(a || b) || (a && b)         tt => b, tf => b, ft => a, ff => !b

sub eqv3 {
    my ($this, $that) = @_;
    my $obj1 = _object($this);
    my $val = _evaluate($obj1);
    return $undef if !defined $val;             # undef, * => undef
    my $obj2 = _object($that);
    return $obj2 if $val;                       # true, * => RHS
    $val = _evaluate($obj2);
    return $undef if !defined $val;             # false, undef => undef
    return $obj1 if $val;                       # false, true => LHS
    return not3($obj2);                         # false, false => not RHS
}

1;
__END__