File Coverage

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

Criterion	Covered	Total	%
statement	184	184	100.0
branch	71	72	98.6
condition	15	15	100.0
subroutine	63	63	100.0
pod	31	31	100.0
total	364	365	99.7

# 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::Trit;

use 5.008;
use strict;
use warnings;
use Carp qw(croak);
use Scalar::Util qw(blessed);
use Role::Basic qw(with);
with qw(Math::Logic::Ternary::Object);

our $VERSION  = '0.004';
our @CARP_NOT = qw(Math::Logic::Ternary Math::Logic::Ternary::Word);

# ----- auxiliary constants -----

use constant TRIT_PREFIX => '$';

use constant _UINT     => 0;
use constant _INT      => 1;
use constant _NAME     => 2;
use constant _PNAME    => 3;
use constant _IS_NIL   => 4;
use constant _IS_TRUE  => 5;
use constant _IS_FALSE => 6;
use constant _BOOL     => 7;
use constant _MODINT   => 8;

use constant _MAX_MEMOIZED_OPS => 364;

# class backing data type for logical values: singleton arrayref

my @trits =
my ($nil, $true, $false) = map { bless $_ } (
    [0,  0, 'nil'  ],
    [1,  1, 'true' ],
    [2, -1, 'false'],
);
foreach my $trit ($nil, $true, $false) {
    $trit->[_PNAME]    = TRIT_PREFIX . $trit->[_NAME];
    $trit->[_IS_NIL]   = $trit->[_UINT] == $nil->[_UINT];
    $trit->[_IS_TRUE]  = $trit->[_UINT] == $true->[_UINT];
    $trit->[_IS_FALSE] = $trit->[_UINT] == $false->[_UINT];
    $trit->[_BOOL]     = $trit->[_IS_NIL]? undef: $trit->[_IS_TRUE];
}

# return values for trit conversions
my %by_name =
    map {
        ($_->[_NAME] => $_, $_->[_PNAME] => $_)
    } @trits;

# tables for parameter to index mappings
my @arg3s = (
    [[0, 1, 2], [1, 3, 4], [2, 4, 5]],
    [[1, 3, 4], [3, 6, 7], [4, 7, 8]],
    [[2, 4, 5], [4, 7, 8], [5, 8, 9]],
);
my @arg4s = (
    \@arg3s,
    [
        [[1, 3, 4], [3,  6,  7], [4,  7,  8]],
        [[3, 6, 7], [6, 10, 11], [7, 11, 12]],
        [[4, 7, 8], [7, 11, 12], [8, 12, 13]],
    ],
    [
        [[2, 4, 5], [4,  7,  8], [5,  8,  9]],
        [[4, 7, 8], [7, 11, 12], [8, 12, 13]],
        [[5, 8, 9], [8, 12, 13], [9, 13, 14]],
    ],
);

# generic op prefixes
my %arity = (
    c => 0,
    u => 1,
    b => 2,
    s => 3,
    t => 3,
    q => 4,
    Q => 4,
);

# named operators
my @named_ops = (
    [sn    => 'u000'],          # Set to Nil
    [st    => 'u111'],          # Set to True
    [sf    => 'u222'],          # Set to False
    [id    => 'u012'],          # IDentity
    [not   => 'u021'],          # NOT
    [up    => 'u120'],          # increment modulo 3, UP one
    [nup   => 'u210'],          # swap nil/false, Not(UP(x))
    [dn    => 'u201'],          # decrement modulo 3, DowN one
    [ndn   => 'u102'],          # swap nil/true, Not(DowN(x))
    [eqn   => 'u122'],          # EQual to Nil
    [eqt   => 'u212'],          # EQual to True
    [eqf   => 'u221'],          # EQual to False
    [nen   => 'u211'],          # Not Equal to Nil
    [net   => 'u121'],          # Not Equal to True
    [nef   => 'u112'],          # Not Equal to False
    [hm    => 'u011'],          # HaMlet (x or not x)
    [uhm   => 'u110'],          # Up & HaMlet
    [dhm   => 'u101'],          # Down & HaMlet
    [orn   => 'u010'],          # OR Nil
    [uorn  => 'u100'],          # Up & OR Nil
    [dorn  => 'u001'],          # Down & OR Nil
    [qt    => 'u022'],          # QuanTum (x and not x)
    [uqt   => 'u220'],          # Up & QuanTum
    [dqt   => 'u202'],          # Down & QuanTum
    [ann   => 'u002'],          # ANd Nil
    [uann  => 'u020'],          # Up & ANd Nil
    [dann  => 'u200'],          # Down & ANd Nil
    [and   => 'b002012222'],    # AND
    [or    => 'b010111012'],    # OR
    [xor   => 'b000021012'],    # eXclusive OR
    [eqv   => 'b000012021'],    # EQuiValent
    [imp   => 'b010012111'],    # IMPlication (x ==> y)
    [rep   => 'b001111021'],    # REPlication (x <== y)
    [nand  => 'b001021111'],    # Not AND
    [nor   => 'b020222021'],    # Not OR
    [cmp   => 'b021101220'],    # CoMPare,              false < nil < true
    [asc   => 'b012202110'],    # ASCending
    [tlr   => 'b002012222'],    # The LesseR
    [tgr   => 'b010111012'],    # The GreateR
    [eq    => 'b122212221'],    # EQual to
    [ne    => 'b211121112'],    # Not Equal to
    [lt    => 'b212222112'],    # Less Than
    [ge    => 'b121111221'],    # Greater or Equal
    [gt    => 'b221121222'],    # Greater Than
    [le    => 'b112212111'],    # Less or Equal
    [cmpu  => 'b022102110'],    # CoMPare (Unbalanced), nil < true < false
    [ascu  => 'b011201220'],    # ASCending (Unbalanced)
    [tlru  => 'b000011012'],    # The LesseR (Unbalanced)
    [tgru  => 'b012112222'],    # The GreateR (Unbalanced)
    [ltu   => 'b211221222'],    # Less Than (Unbalanced)
    [geu   => 'b122112111'],    # Greater or Equal (Unbalanced)
    [gtu   => 'b222122112'],    # Greater Than (Unbalanced)
    [leu   => 'b111211221'],    # Less or Equal (Unbalanced)
    [incr  => 'b012120201'],    # INCRement
    [incc  => 'b000010002'],    # INCrement Carry
    [inccu => 'b000001011'],    # INCrement Carry (Unbalanced)
    [inccv => 'b001000020'],    # INCrement Carry (negatiVe base)
    [decr  => 'b021102210'],    # DECRement
    [decc  => 'b000002010'],    # DECrement Carry
    [deccu => 'b011001000'],    # DECrement Carry (Unbalanced)
    [deccv => 'b020000001'],    # DECrement Carry (negatiVe base)
    [pty   => 'b021210102'],    # PariTY
    [dpl   => 'b012201120'],    # DuPLicate
    [dplc  => 'b000110202'],    # DuPLication Carry
    [dplcu => 'b000011112'],    # DuPLication Carry (Unbalanced)
    [dplcv => 'b001020222'],    # DuPLication Carry (negatiVe base)
#   [hlv   => 'b011022211'],    # HaLVe
#   [hlvc  => 'b011100100'],    # HaLVing Carry
#   [hlvs  => 'b002010002'],    # HaLVing Second carry
#   [hlvu  => 'b000000000'],    # HaLVe (Unbalanced)
#   [hlvcu => 'b000000000'],    # HaLVing Carry (Unbalanced)
#   [hlvsu => 'b000000000'],    # HaLVing Second carry (Unbalanced)
    [negcv => 'b000100110'],    # NEGation Carry (negatiVe base)
    [mulcu => 'b000000001'],    # MULtiplication Carry (Unbalanced)
    [add   => 's0122010120'],   # ADDition
    [addc  => 's0001021002'],   # ADDition Carry
    [addcu => 's0000111112'],   # ADDition Carry (Unbalanced)
    [addcv => 't001000020000020220020220222'], # ADDition Carry (negatiVe base)
    [addcx => 't001000101000020001020220000'], # ADDition Carry (miXed base)
    [subt  => 't021210102102021210210102021'], # SUBTraction
    [subc  => 't000010002002000202010110000'], # SUBTraction Carry
    [subcu => 't011111112001011111000001011'], # SUBTraction Carry (Unbal.)
    [subcv => 't020220222000020220001000020'], # SUBTraction Carry (nV.b.)
#   [amn   => 't000000000000000000000000000'], # Arithmetic MeaN
#   [amnc  => 't000000000000000000000000000'], # Arithmetic MeaN Carry
#   [amncu => 't000000000000000000000000000'], # Arithmetic MeaN Carry (Unbal.)
    [ipqc  => 's0211020210'],   # InterPolation Quadratic Coeff
    [cmin  => 't000221000121121121000220000'], # ternary Comparison to MINimum
    [cmed  => 't121102121010212010121001121'], # ternary Comparison to MEDian
    [cmax  => 't212010212202000202212112212'], # ternary Comparison to MAXimum
    [cvld  => 't100010001001111021010012111'], # ternary Comparison VaLiDation
    [min   => 's0020221222'],   # MINimum of three
    [med   => 's0001021122'],   # MEDian of three
    [max   => 's0101101112'],   # MAXimum of three
    [minu  => 's0000001112'],   # MINimum of three (Unbalanced)
    [medu  => 's0001121122'],   # MEDian of three (Unbalanced)
    [maxu  => 's0121221222'],   # MAXimum of three (Unbalanced)
    [sum   => 'q012201012012012'], # SUMmation
    [sumc  => 'q000102100211022'], # SUMmation Carry
    [sumcu => 'q000011111211222'], # SUMmation Carry (Unbalanced)
);
# names of arithmetic operators with mode-dependent variants
my %is_ar = map {($_ => 0, $_ . 'u' => 1, $_ . 'v' => 2)} qw(
    asc cmp ge gt le lt max med min tgr tlr
    addc decc dplc incc negc subc sumc
);

# ----- private variables -----

# operator memoizer
# initialized with some special cases
# maps name to [argc, sub]
my %OP = (
    'c0'   => [0, sub { 0 }],
    'c1'   => [0, sub { 1 }],
    'c2'   => [0, sub { 2 }],
    'u012' => [1, sub { $_[0] }],
);

# ----- other initializations -----

_load_generated_methods();

# ----- private subroutines -----

# raw unary op factory, takes 3 values
sub _unary {
    my @val = @_;
    return sub { $val[$_[0]] };
}

# argument shifter, takes 1 operator, yields 1 operator
sub _shiftarg {
    my $op = $_[0];
    return sub { shift; $op->(@_) };
}

# argument chooser, takes 3 operators, yields 1 operator with extra parameter
sub _mpx {
    my @op = @_;
    return sub { my $i = shift; $op[$i]->(@_) };
}

# symmetric ternary op factory, takes 10 values
sub _symmetric_3adic {
    my @val = @_;
    return sub { $val[$arg3s[$_[0]]->[$_[1]]->[$_[2]]] };
}

# symmetric quaternary op factory, takes 15 values
sub _symmetric_4adic {
    my @val = @_;
    return sub { $val[$arg4s[$_[0]]->[$_[1]]->[$_[2]]->[$_[3]]] };
}

# raw operator factory, takes a name
sub _OP {
    my ($name) = @_;
    return $OP{$name} if exists $OP{$name};
    my $op;
    if ($name =~ /^u([012])([012])([012])\z/) {
        if ($1 eq $2 && $1 eq $3) {
            return $OP{"c$1"};
        }
        $op = [1, _unary($1, $2, $3)];
    }
    elsif ($name =~ /^b([012]{3})([012]{3})([012]{3})\z/) {
        if ($1 eq $2 && $1 eq $3) {
            return $OP{$name} = [2, _shiftarg(_unary(split //, $1))];
        }
        $op = [2, _mpx(map {_OP($_)->[1]} "u$1", "u$2", "u$3")];
    }
    elsif ($name =~ /^s([012]{10})\z/) {
        $op = [3, _symmetric_3adic(split //, $1)];
    }
    elsif ($name =~ /^t([012]{9})([012]{9})([012]{9})\z/) {
        $op = [3, _mpx(map {_OP($_)->[1]} "b$1", "b$2", "b$3")];
    }
    elsif ($name =~ /^q([012]{15})\z/) {
        $op = [4, _symmetric_4adic(split //, $1)];
    }
    elsif ($name =~ /^Q([012]{27})([012]{27})([012]{27})\z/) {
        $op = [4, _mpx(map {_OP($_)->[1]} "t$1", "t$2", "t$3")];
    }
    else {
        croak qq{unknown operator name "$name"};
    }
    if (keys(%OP) < _MAX_MEMOIZED_OPS) {
        $OP{$name} = $op;
    }
    return $op;
}

sub _generic {
    my ($argc, $op) = @{_OP($_[0])};
    return sub {
        if (@_ < $argc) {
            my $missing = $argc - @_;
            croak "too few arguments, expected $missing more";
        }
        my @args = map { $_->res_mod3 } @_[0..$argc-1];
        return $trits[ $op->(@args) ];
    };
}

sub _load_generated_methods {
    foreach my $arec (@named_ops) {
        my ($method, $gen_method) = @{$arec};
        # use fully qualified method names to avoid clashes with builtins
        my $tm = __PACKAGE__ . '::' . $method;
        no strict 'refs';
        *$tm = _generic($gen_method);
    }
}

# ----- class methods -----

sub nil   { $nil   }
sub true  { $true  }
sub false { $false }

sub from_bool {
    my $bool = $_[1];
    return $true  if $bool;
    return $false if defined $bool;
    return $nil;
}

sub from_sign      { $trits[$_[1] <=> 0] }
sub from_remainder { $trits[$_[1]  %  3] }

sub from_int {
    my $int = $_[1];
    croak qq{integer "$int" out of range -1..1} if $int < -1 || 1 < $int;
    return $trits[$int];
}

sub from_int_u {
    my $int = $_[1];
    croak qq{integer "$int" out of range 0..2} if $int < 0 || 2 < $int;
    return $trits[$int];
}

sub from_string {
    my $name = lc $_[1];
    croak qq{unknown trit name "$_[1]"} if !exists $by_name{$name};
    return $by_name{$name};
}

sub from_modint {
    my $mi = $_[1];
    my ($mod, $res) = eval { $mi->modulus, $mi->residue };
    croak qq{modular integer with modulus 3 expected} if !$mod || 3 != $mod;
    return $trits[$res];
}

sub from_various {
    my ($class, $item) = @_;
    my $type = blessed $item;
    if ($type) {
        if (eval { $item->DOES('Math::Logic::Ternary::Object') }) {
            return $class->from_int($item->as_int);
        }
        if (eval { $item->isa('Math::BigInt') }) {
            my $is_two = 2 == $item;            # for Devel::Cover
            return $is_two? $false: $class->from_int($item);
        }
        if (eval { $item->isa('Math::ModInt') }) {
            return $class->from_modint($item);
        }
        croak qq{cannot convert "$type" object to a trit};
    }
    $type = ref $item;
    if ($type) {
        croak qq{cannot convert $type reference to a trit};
    }
    if (!defined $item) {
        return $nil;
    }
    if ($item =~ /^[\+\-]?\d+\z/) {
        return 2 == $item? $false: $class->from_int($item);
    }
    return $class->from_string($item);
}

sub make_generic { _generic($_[1]) }

sub trit_operators {
    return (
        [nil   => 0, 0, 1],
        [true  => 0, 0, 1],
        [false => 0, 0, 1],
        (
            map {
                my ($name, $gname) = @{$_};
                [
                    $name,
                    $arity{substr $gname, 0, 1},
                    0,
                    1,
                    exists($is_ar{$name})? $is_ar{$name}: ()
                ]
            }
            @named_ops
        ),
        [mpx   => 4, 0, 1],
    );
}

# ----- object methods -----

sub Mpx {
    if (@_ < 4) {
        my $missing = 4 - @_;
        croak "too few arguments, expected $missing more";
    }
    my ($this, $case_n, $case_t, $case_f) = @_;
    return ($case_n, $case_t, $case_f)[$this->res_mod3];
}

sub mpx { $trits[shift->Mpx(@_)->res_mod3] }

sub generic {
    my ($this, $method, @params) = @_;
    return _generic($method)->($this, @params);
}

sub is_nil    { $_[0]->[_IS_NIL]    }
sub is_true   { $_[0]->[_IS_TRUE]   }
sub is_false  { $_[0]->[_IS_FALSE]  }
sub as_bool   { $_[0]->[_BOOL]      }

sub as_modint {
    my ($this) = @_;
    my $mi = $this->[_MODINT];
    if (!defined $mi) {
        eval { require Math::ModInt }
            or croak 'perl extension Math::ModInt is not available';
        $mi = $this->[_MODINT] = Math::ModInt->new($this->[_UINT], 3);
    }
    return $mi;
}

# role: ternary object

sub is_equal  { $_[1]->Rtrits <= 1 && $_[0]->as_int == $_[1]->Trit(0)->as_int }
sub Rtrits    { $_[0]->[_IS_NIL]? (wantarray? (): 0): (wantarray? $_[0]: 1) }

sub Sign      { $_[0]                  }
sub Trit      { ($_[0])[$_[1]] || $nil }
sub Trits     { wantarray? $_[0]: 1    }
sub as_int    { $_[0]->[_INT]          }
sub as_int_u  { $_[0]->[_UINT]         }
sub as_int_v  { $_[0]->[_UINT]         }
sub res_mod3  { $_[0]->[_UINT]         }
sub as_string { $_[0]->[_PNAME]        }

1;

__END__