Ternary_logic

#!/usr/bin/env perl
#u# http://rosettacode.org/wiki/Ternary_logic
#c# 2018-08-11 <RC, 2023-03-21 >RC, 2023-03-22 >RC
#p# OK
#n# using modern Perl required cleaning up some dodgy practices, results in cleaner code
#n# factored out the logic values into %E hash table, all refs go through it now

my $result;

use v5.36.0;

package Trit;
use List::Util qw(min max);

our @ISA = qw(Exporter);
our @EXPORT = qw(%E);

my %E = (true => 1, false => -1, maybe => 0); # codes for logic values

use overload
'<=>' => sub ($a,$b)       { $a->cmp($b)   },
'cmp' => sub ($a,$b)       { $a->cmp($b)   },
'=='  => sub ($a,$b,$)     { $$a == $$b    },
'eq'  => sub ($a,$b,$)     { $a->equiv($b) },
'>'   => sub ($a,$b,$)     { $$a >  $E{$b} }, 
'<'   => sub ($a,$b,$)     { $$a <  $E{$b} },
'>='  => sub ($a,$b,$)     { $$a >= $$b    }, 
'<='  => sub ($a,$b,$)     { $$a <= $$b    },
'|'   => sub ($a,$b,$,$,$) { $a->or($b)    },
'&'   => sub ($a,$b,$,$,$) { $a->and($b)   },
'!'   => sub ($a,$,$)      { $a->not()     },
'~'   => sub ($a,$,$,$,$)  { $a->not()     }, # why is this different from '!' ?
'neg' => sub ($a,$,$)      { -$$a          },
'""'  => sub ($a,$,$)      { $a->tostr()   },
'0+'  => sub ($a,$,$)      { $a->tonum()   },
;

# $a = ref(Trit), $b = string
sub eqv ($a,$b) { 
    $$a == $E{maybe} || $E{$b} == $E{maybe} ? $E{maybe} :       # either arg 'maybe', return 'maybe'
    $$a == $E{false} && $E{$b} == $E{false} ? $E{true}  :       #  both args 'false', return 'true'
                                              min $$a, $E{$b}   # either arg 'false', return 'false', otherwise 'true'
}

# get in trouble here because the tests follow the overloading rules, resulting in unwanted ref(Trit) vs scalar comparisons
# so use tests that avoid the overloaded operations, even if ends up seeming a bit silly
sub new ($class, $v) {
    my $value =
        ! defined $v    ? $E{maybe} :
       #$v eq 'true'    ? $E{true}  :
       #$v eq 'false'   ? $E{false} :
       #$v eq 'maybe'   ? $E{maybe} :
        $v =~ /true/    ? $E{true}  :
        $v =~ /false/   ? $E{false} :
        $v =~ /maybe/   ? $E{maybe} :
       #$v > $E{maybe}  ? $E{true}  :
       #$v < $E{maybe}  ? $E{false} :
        $v gt $E{maybe} ? $E{true}  :
        $v lt $E{maybe} ? $E{false} :
                          $E{maybe} ;
    bless \$value, $class;
}

sub tostr ($a) { $$a > $E{maybe} ? 'true' : $$a < $E{maybe} ? 'false' : 'maybe' }
sub tonum ($a) { $$a }

sub not   ($a)    { Trit->new( -$a        ) } # added overloaded operation 'neg' for this
sub cmp   ($a,$b) { Trit->new( $a <=> $b  ) }
sub and   ($a,$b) { Trit->new( min $a, $b ) }
sub or    ($a,$b) { Trit->new( max $a, $b ) }
sub equiv ($a,$b) { Trit->new( eqv $a, $b ) }

package main;
Trit->import;

my @a = ( Trit->new($E{true}), Trit->new($E{maybe}), Trit->new($E{false}) );
$result = sprintf "Codes for logic values: %6s = %d %6s = %d %6s = %d\n", @a[0, 0, 1, 1, 2, 2]; # easier than List::Util::mesh

# prefix ! (not) ['~' also can be used]
$result .= "\na\tNOT a" . "\n";
$result .= "$_\t" . (!$_) ."\n" for @a;

# infix & (and)
$result .= "\nAND\t" . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a & $_)  for @a; $result .= "\n" }

# infix | (or)
$result .= "\nOR\t"  . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a | $_)  for @a; $result .= "\n" }

# infix eq (equivalence)
$result .= "\nEQV\t" . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a eq $_) for @a; $result .= "\n" }

# infix == (equality)
$result .= "\n==\t"  . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a == $_) for @a; $result .= "\n" }

# infix >
$result .= "\n>\t"  . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a > $_)  for @a; $result .= "\n" }

# infix >=
$result .= "\n>=\t" . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a >= $_) for @a; $result .= "\n" }

# infix <
$result .= "\n<\t"  . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a < $_)  for @a; $result .= "\n" }

# infix <=
$result .= "\n<=\t" . join("\t",@a) . "\n";
for my $a (@a) { $result .= $a; $result .= "\t" . ($a <= $_) for @a; $result .= "\n" }

say $result;

my $ref = <<'EOD';
Codes for logic values:   true = 1  maybe = 0  false = -1

a	NOT a
true	false
maybe	maybe
false	true

AND	true	maybe	false
true	true	maybe	false
maybe	maybe	maybe	false
false	false	false	false

OR	true	maybe	false
true	true	true	true
maybe	true	maybe	maybe
false	true	maybe	false

EQV	true	maybe	false
true	true	maybe	false
maybe	maybe	maybe	maybe
false	false	maybe	true

==	true	maybe	false
true	1		
maybe		1	
false			1

>	true	maybe	false
true		1	1
maybe			1
false			

>=	true	maybe	false
true	1	1	1
maybe		1	1
false			1

<	true	maybe	false
true			
maybe	1		
false	1	1	

<=	true	maybe	false
true	1		
maybe	1	1	
false	1	1	1
EOD

use Test::More;
is ($result, $ref);
done_testing;