Skip to content

Commit

Permalink
initial draft of boolean context
Browse files Browse the repository at this point in the history
  • Loading branch information
@drdrew42
drdrew42 committed Mar 13, 2024
1 parent a9d9280 commit cfad030
Showing 1 changed file with 253 additions and 0 deletions.
253 changes: 253 additions & 0 deletions macros/contexts/contextBoolean.pl
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,253 @@
## contextBoolean.pl

sub _contextBoolean_init { context::Boolean::Init() }

package context::Boolean;

sub Init {
my $context = $main::context{Boolean} = Parser::Context->getCopy('Numeric');
$context->{name} = 'Boolean';
$context->{parser}{Formula} = 'context::Boolean::Formula';
$context->{value}{Formula} = 'context::Boolean::Formula';
$context->{parser}{Number} = 'context::Boolean::Boolean';
$context->{value}{Boolean} = 'context::Boolean::Value';
$context->{value}{Real} = 'context::Boolean::Value';

$context->{pattern}{number} = '^[01TtFf]$';
$context->{pattern}{signedNumber} = '^[01TtFf]$';
$context->flags->set(
NumberCheck => sub {
my $self = shift;
$self->{value} = ($self->{value_string} =~ /[t1]/i) ? 1 : 0;
$self->{isOne} = ($self->{value} == 1);
$self->{isZero} = ($self->{value} == 0);
}
);
$context->update;

my $orPrec = $context->operators->get('+')->{precedence};
my $andPrec = $context->operators->get('*')->{precedence};
my $notPrec = $context->operators->get('u-')->{precedence};

## Disable unnecessary context stuff
$context->functions->clear();
$context->strings->clear();
$context->lists->clear();

## Define constants for 'True' and 'False'
$context->constants->are(
'T' =>
{ value => context::Boolean::Value->new(1), isConstant => 0, string => 'T', TeX => '\top', perl => 1 },
'F' =>
{ value => context::Boolean::Value->new(0), isConstant => 0, string => 'F', TeX => '\bot', perl => 0 },
# 0 and 1 are not recognized unless added as constants
# it might not be a bad idea anyhow?
'1' => { alias => 'T' },
'0' => { alias => 'F' },
'True' => { alias => 'T' },
'False' => { alias => 'F' },
);

## Define our logic operators
$context->operators->are(
'or' => {
class => 'context::Boolean::BOP::or',
precedence => $orPrec,
associativity => 'left',
type => 'bin',
string => ' or ',
TeX => '\vee ',
perl => '||',
alteratives => ['\x{2228}'],
},
'and' => {
class => 'context::Boolean::BOP::and',
precedence => $andPrec,
associativity => 'left',
type => 'bin',
string => ' and ',
TeX => '\wedge ',
perl => '&&',
alteratives => ['\x{2229}'],
},
'xor' => {
class => 'context::Boolean::BOP::xor',
precedence => $andPrec,
associativity => 'left',
type => 'bin',
string => ' xor ',
perl => '!=',
TeX => '\oplus ',
alteratives => [ '\x{22BB}', '\x{2295}' ],
},
# unary negation is only allowed if the '-' token is recognized, so make it BOP::undef
'-' => {
class => 'Parser::BOP::undefined',
precedence => $notPrec - 1,
associativity => 'left',
type => 'both',
string => '-',
},
'not' => {
class => 'context::Boolean::UOP::not',
precedence => $notPrec,
associativity => 'left',
type => 'unary',
string => ' not ',
TeX => '\mathord{\sim}',
perl => '!',
alteratives => [ '\x{172}', '\x{732}' ],
nofractionparens => 1,
},
' ' => { alias => 'and' },
'*' => { alias => 'and' },
'+' => { alias => 'or' },
'!' => { alias => 'not' },
'u-' => { alias => 'not' },
'><' => { alias => 'xor' },
);

## Set default variables 'p' and 'q'
$context->variables->are(
p => { isValue => 1, type => Value::Type('Boolean') },
q => { isValue => 1, type => Value::Type('Boolean') },
);
}

## Subclass Value::Formula for boolean formulas
package context::Boolean::Formula;
our @ISA = ('Value::Formula');

sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);

my @variables = $self->{context}->variables->names;
my @points;
my @values;

my $f = $self->{f} = $self->perlFunction(undef, \@variables);

foreach my $combination (0 .. 2**@variables - 1) {
my @point = map { $combination & 2**$_ ? 1 : 0 } (0 .. $#variables);
my $value = &$f(@point) ? 1 : 0;
push @points, \@point;
push @values, $value;
}

$self->{test_points} = \@points;
$self->{test_values} = \@values;

return $self;
}

sub typeRef { return Value::Type('Boolean') }

package context::Boolean::BOP;
our @ISA = qw(Parser::BOP);

sub _check {
my $self = shift;
# constants don't have type methods
# TODO: should that be "fixed"?
my $lType = $self->{lop}->type || $self->{lop}{type};
my $rType = $self->{rop}->type || $self->{lop}{type};

$self->{type} = Value::Type('Boolean');
}

sub perl {
my $self = shift;
my $result = $self->SUPER::perl(@_);
my $pkg = $self->Package('Real');
return "$pkg->new($result ? 1 : 0)";
}

package context::Boolean::BOP::or;
our @ISA = qw(context::Boolean::BOP);

sub _eval { return $_[1] || $_[2] ? 1 : 0 }

package context::Boolean::BOP::and;
our @ISA = qw(context::Boolean::BOP);

sub _eval { return $_[1] && $_[2] ? 1 : 0 }

package context::Boolean::UOP::not;
our @ISA = qw(Parser::UOP);

sub _check {
my $self = shift;
my $lType = $self->{op}->type || $self->{op}{type};

$self->{type} = Value::Type('Boolean');
}

sub _eval { !($_[1]) ? 1 : 0 }

sub perl {
my $self = shift;
my $result = $self->SUPER::perl(@_);
my $pkg = $self->Package('Real');
return "$pkg->new($result ? 1 : 0)";
}

package context::Boolean::BOP::xor;
our @ISA = qw(context::Boolean::BOP);

sub _eval { return !($_[1]) != !($_[2]) ? 1 : 0 }

package context::Boolean::Value;
our @ISA = qw(Value::Real);

# subclass is necessary because Parser::Constant::getValueType attempts
# to dereference the incoming value as an ARRAY -- unclear why that is
sub getValueType {
# note value & equation are reversed from Value::getValueType when subclassed
my $value = shift;
my $equation = shift;
return ($value, $value->typeRef) if ref($value) eq 'context::Boolean::Value';
return (context::Boolean::Value->new($value), Value::Type('Boolean'));
}

sub isBoolean {1}
sub getType {'Boolean'}
sub typeRef { Value::Type('Boolean') }
sub class {'Value'}
sub type {'Boolean'}

## WIP!
package context::Boolean::Boolean;
our @ISA = qw(Parser::Number);

sub new {
my $self = shift;
warn "NUMBER PARSER";
warn "self: $self received " . scalar @_ . " arguments";
warn 'arg1 (parser): {' . join(',', keys %{ $_[0] }) . '}';
warn "arg2 (token): '$_[1]'";
warn "arg3 (tokenRef): $_[2] = ['" . join('\', \'', @{ $_[2] }) . '\']';
my $class = ref($self) || $self;
my ($equation, $value, $ref) = @_;
# $value = $value->value while Value::isReal($value);
$value = $value->value while Value::isValue($value);
my $num = bless {
value => $value ? 1 : 0,
value_string => $value ? 'T' : 'F',
type => Value::Type('Boolean'),
isConstant => 1,
ref => $ref,
equation => $equation,
}, $class;
$num->weaken;
$num->{isOne} = 1 if $value;
$num->{isZero} = 1 unless $value;
return $num;
}

#sub class { 'Boolean' }
sub typeRef { Value::Type('Boolean') }
sub getType {'Boolean'}
sub type {'Boolean'}

1;

0 comments on commit cfad030

Please sign in to comment.