File Coverage

blib/lib/Math/Logic.pm

Criterion	Covered	Total	%
statement	224	231	96.9
branch	153	168	91.0
condition	65	96	67.7
subroutine	56	59	94.9
pod	12	12	100.0
total	510	566	90.1

package Math::Logic ;    # Documented at the __END__.

# $Id: Logic.pm,v 1.16 2000/05/25 19:15:01 root Exp root $


require 5.004 ;

use strict ;
use integer ; # Forces us to quote all hash keys in 5.004.

use Carp qw( croak carp ) ;

use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ) ;
$VERSION     = '1.19' ;

use Exporter() ;

@ISA         = qw( Exporter ) ;

@EXPORT_OK   = qw( $TRUE $FALSE $UNDEF TRUE FALSE UNDEF
                   $STR_TRUE $STR_FALSE $STR_UNDEF STR_TRUE STR_FALSE STR_UNDEF ) ;
%EXPORT_TAGS = (
    ALL => [ @EXPORT_OK ],
    NUM => [ qw( $TRUE $FALSE $UNDEF TRUE FALSE UNDEF ) ],
    STR => [ qw( $STR_TRUE $STR_FALSE $STR_UNDEF STR_TRUE STR_FALSE STR_UNDEF ) ],
    ) ;


### Public class constants

use vars qw( $TRUE $FALSE $UNDEF $STR_TRUE $STR_FALSE $STR_UNDEF ) ;
*TRUE            =  \1 ;
*FALSE           =  \0 ;
*UNDEF           = \-1 ;

*STR_TRUE        = \'TRUE' ;
*STR_FALSE       = \'FALSE' ;
*STR_UNDEF       = \'UNDEF' ;

### Public class constants -- DEPRECATED

use constant TRUE      => $TRUE ;
use constant FALSE     => $FALSE ;
use constant UNDEF     => $UNDEF ;

use constant STR_TRUE  => $STR_TRUE ;
use constant STR_FALSE => $STR_FALSE ;
use constant STR_UNDEF => $STR_UNDEF ;


### Private class constants

my $DEF_VALUE       = $FALSE ;
my $DEF_DEGREE      = 3 ;
my $MIN_DEGREE      = 2 ;
my $DEF_PROPAGATE   = $FALSE ;


### Object keys (there are no class keys)
#
#   -value
#   -degree
#   -propagate


### Private data and methods
#
#   _set                    object
#   _get                    object
#   _cmp                    object
#

{
    sub _set { # Object method
        # Caller is responsible for ensuring the assigned value is valid
        my $self  = shift ;
#        my $class = ref( $self ) || $self ;
        my $field = shift ;

        $self->{$field} = shift ;
    }


    sub _get { # Object method
        my $self  = shift ;
#        my $class = ref( $self ) || $self ;

        $self->{shift()} ;
    }


    sub _cmp { # Object method
        my $self  = shift ;
#        my $class = ref( $self ) || $self ;
        my $comp  = shift ;

        $comp = $self->new( '-value' => $comp ) unless ref $comp ;
        { my $err ; croak $err if $err = $self->incompatible( $comp ) }

        $self->value <=> $comp->value ;
    }

}


### Public methods

sub new_from_string { # Class and object method
    my $self   = shift ;
    my $class  = ref( $self ) || $self ;
    my $string = shift ;

    my @arg = $string =~ /\(?\s*([^,\s\%]+)\%?,\s*([^,\s]+)(?:,\s*([^,\s]+))?\)?/o ;

    if( defined $arg[0] ) {
        # 1, 0 and -1 pass through unchanged; -1 will be silently converted to
        # 0 except for 3-degree logic in $class->new
        $arg[0] = $TRUE  if $arg[0] =~ /^-?[tT]/o ;
        $arg[0] = $FALSE if $arg[0] =~ /^-?[fF]/o ;
        $arg[0] = $UNDEF if $arg[0] =~ /^-?[uU]/o ;
    }
    $arg[2] = $arg[2] =~ /^-?[tTpP1]/o ?
                        $TRUE : $FALSE if defined $arg[2] ;

    # Ignores settings of calling object if called as an object method.
    $class->new(
        '-value'     => $arg[0] || $DEF_VALUE,
        '-degree'    => $arg[1] || $DEF_DEGREE,
        '-propagate' => $arg[2] || $DEF_PROPAGATE,
        ) ;
}


sub new { # Class and object method
    my $self   = shift ;
    my $class  = ref( $self ) || $self ;
    my $object = ref $self ? $self : undef ;
    my %arg    = @_ ;

    # Set defaults plus parameters
    $self = {
            '-value'     => $DEF_VALUE,
            '-degree'    => $DEF_DEGREE,
            '-propagate' => $DEF_PROPAGATE,
            %arg
        } ;

    # If called as an object method use the calling object's settings unless a
    # parameter has overridden
    if( defined $object ) {
        $self->{'-value'}     = $object->value
        unless exists $arg{'-value'} ;
        $self->{'-degree'}    = $object->degree
        unless exists $arg{'-degree'} ;
        $self->{'-propagate'} = $object->propagate
        unless exists $arg{'-propagate'} ;
    }

    # Ensure the settings are valid
    $self->{'-propagate'} = $self->{'-propagate'} ? $TRUE : $FALSE ;

    $self->{'-degree'}    = $DEF_DEGREE
    unless $self->{'-degree'} =~ /^\d+$/o ;
    $self->{'-degree'}    = $MIN_DEGREE
    if $self->{'-degree'} < $MIN_DEGREE ;

    $self->{'-value'} = $DEF_VALUE
    if not defined $self->{'-value'} or $self->{'-value'} !~ /^(?:\d+|-1)$/o ;

    if( $self->{'-degree'} == 2 ) {      # 2-degree logic
        $self->{'-value'} = ( $self->{'-value'} CORE::and
                              $self->{'-value'} != $UNDEF ) ?
                                    $TRUE : $FALSE ;
        delete $self->{'-propagate'} ;   # Don't store what we don't use
    }
    elsif( $self->{'-degree'} == 3 ) {   # 3-degree logic
        if( $self->{'-value'} != $UNDEF ) {
            $self->{'-value'} = $self->{'-value'} ? $TRUE : $FALSE ;
        }
    }
    else {                                      # Multi-degree logic
        $self->{'-value'} = $FALSE if $self->{'-value'} == $UNDEF ;
        $self->{'-value'} = $self->{'-degree'}
        if $self->{'-value'} > $self->{'-degree'} ;
        delete $self->{'-propagate'} ;   # Don't store what we don't use
    }

    bless $self, $class ;
}


use overload
        '""'       => \&as_string,
        '0+'       => \&value,
        'bool'     => \&value,
        '<=>'      => \&_cmp,
        '&'        => \&and,
        '|'        => \&or,
        '^'        => \&xor,
        '!'        => \¬,
        # Avoid surprises
        '='        => sub { croak "=() not overloaded" },
        '+'        => sub { croak "+() unsupported" },
        '-'        => sub { croak "-() unsupported" },
        '*'        => sub { croak "*() unsupported" },
        '/'        => sub { croak "/() unsupported" },
        '%'        => sub { croak "%() unsupported" },
        'x'        => sub { croak "x() unsupported" },
        '**'       => sub { croak "**() unsupported" },
        '<<'       => sub { croak "<<() unsupported" },
        '>>'       => sub { croak ">>() unsupported" },
        '+='       => sub { croak "+=() unsupported" },
        '-='       => sub { croak "-=() unsupported" },
        '*='       => sub { croak "*=() unsupported" },
        '/='       => sub { croak "/=() unsupported" },
        '%='       => sub { croak "%=() unsupported" },
        'x='       => sub { croak "x=() unsupported" },
        '++'       => sub { croak "++() unsupported" },
        '--'       => sub { croak "--() unsupported" },
        'lt'       => sub { croak "lt() unsupported" },
        'le'       => sub { croak "le() unsupported" },
        'gt'       => sub { croak "gt() unsupported" },
        'ge'       => sub { croak "ge() unsupported" },
        'eq'       => sub { croak "eq() unsupported; use == instead" },
        'ne'       => sub { croak "ne() unsupported; use != instead" },
        '**='      => sub { croak "**=() unsupported" },
        '<<='      => sub { croak "<<=() unsupported" },
        '>>='      => sub { croak ">>=() unsupported" },
        'cmp'      => sub { croak "cmp() unsupported; use <=> instead" },
        'neg'      => sub { croak "neg() unsupported" },
        'nomethod' => sub { croak @_ . "() unsupported" },
        ;


sub value { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;
    my $value = shift ;

    if( defined $value ) {
        my $result ;

        if( $self->degree == 2 ) {       # 2-degree logic
            $result = ( $value CORE::and $value != $UNDEF ) ? $TRUE : $FALSE ;
        }
        elsif( $self->degree == 3 ) {    # 3-degree logic
            $result = $value ? $TRUE : $FALSE ;
            $result = $UNDEF if $value == $UNDEF ;
        }
        else {                                  # Multi-degree logic
            $result = $value ;
            # $UNDEF is -1 which doesn't match the pattern, hence we can
            # abbreviate the following line
            # $result = $FALSE if $value == $UNDEF CORE::or $value !~ /^\d+$/o ;
            $result = $FALSE if $value !~ /^\d+$/o ;
            $result = $self->degree if $result > $self->degree ;
        }

        $self->_set( '-value' => $result ) ;
    }

    $self->_get( '-value' ) ;
}


sub degree { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    carp "degree is read-only" if @_ ;

    $self->_get( '-degree' ) ;
}


sub propagate { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    carp "propagate is read-only" if @_ ;

    $self->degree == 3 ? $self->_get( '-propagate' ) : $FALSE ;
}


sub incompatible { # Object method
    my $self  = shift ;
    my $class = ref( $self ) || $self ;
    my $comp  = shift ;

    croak "operator can only be applied to $class objects not " .
        ( ref( $comp ) || $comp )
    if ( CORE::not ref $comp )              CORE::or
       ( CORE::not $comp->can( 'degree' ) ) CORE::or
       ( CORE::not $comp->can( 'propagate' ) ) ;

    ( $self->degree    == $comp->degree CORE::and
      $self->propagate == $comp->propagate ) ? 0 :
      ref( $self ) . "(" . $self->degree . "," . $self->propagate . ")" .
      " and " .
      ref( $comp ) . "(" . $comp->degree . "," . $comp->propagate . ")" .
      " are incompatible" ;
}


sub compatible { # DEPRECATED Object method
    my $self  = shift ;
    my $class = ref( $self ) || $self ;
    my $comp  = shift ;

    croak "can only be applied to $class objects not " . ( ref( $comp ) || $comp )
    if ( CORE::not ref $comp )              CORE::or
       ( CORE::not $comp->can( 'degree' ) ) CORE::or
       ( CORE::not $comp->can( 'propagate' ) ) ;

    $self->degree    == $comp->degree CORE::and
    $self->propagate == $comp->propagate ;
}


sub as_string { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;
    my $full  = shift || 0 ;
    $full     = 0 unless $full eq '1' CORE::or $full eq '-full' ;

    my $result = '' ;

    if( $self->degree == 2 ) {       # 2-degree logic
        $result = $self->value ? $STR_TRUE : $STR_FALSE ;
    }
    elsif( $self->degree == 3 ) {    # 3-degree logic
        $result = $self->value ? $STR_TRUE : $STR_FALSE ;
        $result = $STR_UNDEF if $self->value == $UNDEF ;
    }
    else {                                  # Multi-degree logic
        if( $self->value == $FALSE ) {
            $result = $STR_FALSE ;
        }
        elsif( $self->value == $self->degree ) {
            $result = $STR_TRUE ;
        }
        else {
            $result = $self->value ;
            $result .= '%' if $self->degree == 100 CORE::and $full ;
        }
    }

    # e.g. $logic->as_string( -full ) ;
    $result = "($result," . $self->degree .
                ( $self->propagate ? "," . '-propagate' : '' ) . ")" if $full ;

    $result ;
}


sub and { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;
    my $comp  = shift ;

    $comp = $self->new( '-value' => $comp ) unless ref $comp ;
    { my $err ; croak $err if $err = $self->incompatible( $comp ) }

    my $value ;
    my $result = $self->new ;

    if( $self->degree == 2 ) {       # 2-degree logic
        $value = ( $self->value CORE::and $comp->value ) ? $TRUE : $FALSE ;
    }
    elsif( $self->degree == 3 ) {    # 3-degree logic
        if( $self->propagate ) {
            if( $self->value == $UNDEF CORE::or $comp->value == $UNDEF ) {
                # At least one is undefined which propagates.
                $value = $UNDEF ;
            }
            elsif( $self->value == $TRUE CORE::and $comp->value == $TRUE ) {
                # They're both defined and true.
                $value = $TRUE ;
            }
            else {
                # They're both defined and at least one is false.
                $value = $FALSE ;
            }
        }
        else {
            if( $self->value == $TRUE CORE::and $comp->value == $TRUE ) {
                # Both are defined and true.
                $value = $TRUE ;
            }
            elsif( $self->value == $FALSE CORE::or $comp->value == $FALSE ) {
                # At least one is defined and false.
                $value = $FALSE ;
            }
            else {
                # Either both are undefined or only one is defined and true.
                $value = $UNDEF ;
            }
        }
    }
    else {                                  # Multi-degree logic
        # and is the lowest value
        $value = $self->value < $comp->value ? $self->value : $comp->value ;
    }

    $result->value( $value ) ;

    $result ;
}


sub or { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;
    my $comp  = shift ;

    $comp = $self->new( '-value' => $comp ) unless ref $comp ;
    { my $err ; croak $err if $err = $self->incompatible( $comp ) }

    my $value ;
    my $result = $self->new ;

    if( $self->degree == 2 ) {       # 2-degree logic
        $value = ( $self->value CORE::or $comp->value ) ? $TRUE : $FALSE ;
    }
    elsif( $self->degree == 3 ) {    # 3-degree logic
        if( $self->propagate ) {
            if( $self->value == $UNDEF CORE::or $comp->value == $UNDEF ) {
                # At least one is undefined which propagates.
                $value = $UNDEF ;
            }
            elsif( $self->value == $TRUE CORE::or $comp->value == $TRUE ) {
                # They're both defined and at least one is true.
                $value = $TRUE ;
            }
            else {
                # They're both defined and both are false.
                $value = $FALSE ;
            }
        }
        else {
            if( $self->value == $TRUE CORE::or $comp->value == $TRUE ) {
                # At least one is defined and true.
                $value = $TRUE ;
            }
            elsif( $self->value == $FALSE CORE::and $comp->value == $FALSE ) {
                # They're both defined and false.
                $value = $FALSE ;
            }
            else {
                # Either both are undefined or one is defined and false.
                $value = $UNDEF ;
            }
        }
    }
    else {                                  # Multi-degree logic
        # or is the greatest value
        $value = $self->value > $comp->value ? $self->value : $comp->value ;
    }

    $result->value( $value ) ;

    $result ;
}


sub xor { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;
    my $comp  = shift ;

    $comp = $self->new( '-value' => $comp ) unless ref $comp ;
    { my $err ; croak $err if $err = $self->incompatible( $comp ) }

    my $value ;
    my $result = $self->new ;

    if( $self->degree == 2 ) {       # 2-degree logic
        $value = ( $self->value CORE::xor $comp->value ) ? $TRUE : $FALSE ;
    }
    elsif( $self->degree == 3 ) {    # 3-degree logic
        # Same truth table whether propagating or not.
        if( $self->value == $UNDEF CORE::or $comp->value == $UNDEF ) {
            # At least one is undefined which propagates.
            $value = $UNDEF ;
        }
        elsif( $self->value == $comp->value ) {
            # Both are defined and they're both the same.
            $value = $FALSE ;
        }
        else {
            # Both are defined and they're different.
            $value = $TRUE ;
        }
    }
    else {                                  # Multi-degree logic
        # By truth table xor(a,b) == and(or(a,b),not(and(a,b)))
        # We could write it thus, but prefer not to use overloading within the
        # module itself:
        #   my $temp = ( $self | $comp ) & ( ! ( $self & $comp ) ) ;
        #   $value   = $temp->value ;
        $value = $self->or( $comp )->and( $self->and( $comp )->not )->value ;
    }

    $result->value( $value ) ;

    $result ;
}


sub not { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my $value ;
    my $result = $self->new ;

    if( $self->degree == 2 ) {       # 2-degree logic
        $value = ( $self->value ? $FALSE : $TRUE ) ;
    }
    elsif( $self->degree == 3 ) {    # 3-degree logic
        # Same truth table whether propagating or not.
        if( $self->value == $UNDEF ) {
            # It's undefined which propogates.
            $value = $UNDEF ;
        }
        elsif( $self->value == $TRUE ) {
            # It's defined and true so return false.
            $value = $FALSE ;
        }
        else {
            # It's defined and false so return true.
            $value = $TRUE ;
        }
    }
    else {                                  # Multi-degree logic
        $value = $self->degree - $self->value ;
    }

    $result->value( $value ) ;

    $result ;
}


DESTROY { # Object method
    ; # Noop
}


1 ;


__END__