Skip to content

Commit

Permalink
incorporate code from @dpvc
Browse files Browse the repository at this point in the history
  • Loading branch information
@drdrew42
drdrew42 committed Mar 18, 2024
1 parent 7633a66 commit fedc1fe
Showing 1 changed file with 137 additions and 56 deletions.
193 changes: 137 additions & 56 deletions macros/contexts/contextBoolean.pl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@ sub Init {
my $context = $main::context{Boolean} = Parser::Context->getCopy('Numeric');
$context->{name} = 'Boolean';

$context->{parser}{Number} = 'context::Boolean::Number';
$context->{parser}{Formula} = 'context::Boolean::Formula';
$context->{value}{Formula} = 'context::Boolean::Formula';
$context->{value}{Boolean} = 'context::Boolean::Boolean';
Expand All @@ -26,7 +27,7 @@ sub Init {
$context->operators->are(
'or' => {
class => 'context::Boolean::BOP::or',
precedence => 1,
precedence => 3,
associativity => 'left',
type => 'bin',
rightparens => 'same',
Expand All @@ -37,7 +38,7 @@ sub Init {
},
'and' => {
class => 'context::Boolean::BOP::and',
precedence => 1,
precedence => 3,
associativity => 'left',
type => 'bin',
rightparens => 'same',
Expand All @@ -48,7 +49,7 @@ sub Init {
},
'xor' => {
class => 'context::Boolean::BOP::xor',
precedence => 1,
precedence => 3,
associativity => 'left',
type => 'bin',
rightparens => 'same',
Expand All @@ -68,19 +69,21 @@ sub Init {
alternatives => ["\x{00AC}"],
},
' ' => {
class => 1,
class => 3,
precedence => 1,
associativity => 'left',
type => 'bin',
string => 'and',
hidden => 1
},
'*' => { alias => 'and' },
'+' => { alias => 'or' },
'-' => { alias => 'not' },
'!' => { alias => 'not' },
'~' => { alias => 'not', alternatives => ["\x{223C}"] },
'><' => { alias => 'xor' },
'*' => { alias => 'and' },
'/\\' => { alias => 'and' },
'+' => { alias => 'or' },
'\\/' => { alias => 'or' },
'-' => { alias => 'not' },
'!' => { alias => 'not' },
'~' => { alias => 'not', alternatives => ["\x{223C}"] },
'><' => { alias => 'xor' },
);

## redefine, but disable some usual context tokens for 'clearer' error messages
Expand All @@ -100,22 +103,103 @@ sub Init {
## Set up new reduction rules:
$context->reductions->set('x||1' => 1, 'x||0' => 1, 'x&&1' => 1, 'x&&0' => 1, '!!x' => 1);

## Value::inContext does not recognize our $context as second argument -- using inContext method instead
our $T = context::Boolean::Boolean->new(1)->inContext($context);
our $F = context::Boolean::Boolean->new(0)->inContext($context);

## Define constants for 'True' and 'False'
$context->constants->{namePattern} = qr/(?:\w|[\x{22A4}\x{22A5}])+/;
$context->constants->are(
'T' => { value => $T, TeX => '\top ', perl => '$context::Boolean::T' }, #, alternatives => ["\x{22A4}"] },
'F' => { value => $F, TeX => '\bot ', perl => '$context::Boolean::F' }, #, alternatives => ["\x{22A5}"] },
T => {
value => context::Boolean::Boolean->new($context, 1),
string => 'T',
TeX => '\top',
perl => 'context::Boolean->T',
isConstant => 1,
alternatives => ["\x{22A4}"]
},
F => {
value => context::Boolean::Boolean->new($context, 0),
string => 'F',
TeX => '\bot',
perl => 'context::Boolean->F',
isConstant => 1,
alternatives => ["\x{22A5}"]
},
'True' => { alias => 'T' },
'False' => { alias => 'F' },
);

## add our methods to this context
bless $context, 'context::Boolean::Context';

## allow authors to create Boolean values
main::PG_restricted_eval('sub Boolean { Value->Package("Boolean()")->new(@_) }');
}

## top-level access to context-specific T and T
sub T {
my $context = main::Context();
Value::Error("Context must be a Boolean context") unless $context->can('T');
return $context->T;
}

sub F {
my $context = main::Context();
Value::Error("Context must be a Boolean context") unless $context->can('F');
return $context->F;
}

## Subclass the Parser::Context to override copy() and add T and F functions
package context::Boolean::Context;
our @ISA = ('Parser::Context');

sub copy {
my $self = shift->SUPER::copy(@_);
## update the T and F constants to refer to this context
$self->constants->set(
T => { value => context::Boolean::Boolean->new($self, 1) },
F => { value => context::Boolean::Boolean->new($self, 0) }
);
return $self;
}

## Access to the constant T and F values
sub F { shift->constants->get('F')->{value} }
sub T { shift->constants->get('T')->{value} }

## Easy setting of precedence to different types
sub setPrecedence {
my ($self, $order) = @_;
if ($order eq 'equal') {
$self->operators->set(
or => { precedence => 3 },
xor => { precedence => 3 },
and => { precedence => 3 },
not => { precedence => 3 },
);
} elsif ($order eq 'oxan') {
$self->operators->set(
or => { precedence => 1 },
xor => { precedence => 2 },
and => { precedence => 3 },
not => { precedence => 6 },
);
} else {
Value::Error("Unknown precedence class '%s'", $order);
}
}

## Subclass Parser::Number to return the constant T or F
package context::Boolean::Number;
our @ISA = ('Parser::Number');

sub eval {
my $self = shift;
return $self->context->constants->get(('F', 'T')[ $self->{value} ])->{value};
}

sub perl {
my $self = shift;
return $self->context->constants->get(('F', 'T')[ $self->{value} ])->{perl};
}

## Subclass Value::Formula for boolean formulas
package context::Boolean::Formula;
our @ISA = ('Value::Formula');
Expand All @@ -128,8 +212,8 @@ sub createRandomPoints {
my @points;
my @values;

my $T = $context::Boolean::T->inContext($context);
my $F = $context::Boolean::F->inContext($context);
my $T = $context->T;
my $F = $context->F;

my $f = $self->{f};
$f = $self->{f} = $self->perlFunction(undef, \@variables) unless $f;
Expand Down Expand Up @@ -163,63 +247,62 @@ sub perl {
my $lPerl = $self->{lop}->perl(1) . '->value';
my $rPerl = $self->{rop}->perl(2) . '->value';
my $result = "$lPerl $bop $rPerl";
return "($result ? \$context::Boolean::T : \$context::Boolean::F)";
return "($result ? context::Boolean->T : context::Boolean->F)";
}

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

sub _eval { ($_[1]->value || $_[2]->value ? $context::Boolean::T : $context::Boolean::F) }
sub _eval {
my ($self, $l, $r) = @_;
return ($l->value || $r->value ? $self->context->T : $self->context->F);
}

sub _reduce {
my $self = shift;
my $context = $self->{equation}{context};
my $reduce = $context->{reduction};
my $l = $self->{lop};
my $r = $self->{rop};
my $self = shift;
my $reduce = $self->context->{reduction};
my $l = $self->{lop};
my $r = $self->{rop};

return $self unless ($l->{isConstant} || $r->{isConstant});

# make sure we are comparing to an updated 'true'
my $T = $context::Boolean::T->inContext($context);

# using string since Parser::Number::eval is unblessed, while Parser::Constant::eval is a (truthy) MathObject
if ($l->{isConstant}) {
return $l->string eq "$T" ? ($reduce->{'x||1'} ? $l : $self) : ($reduce->{'x||0'} ? $r : $self);
return $l->eval->value ? ($reduce->{'x||1'} ? $l : $self) : ($reduce->{'x||0'} ? $r : $self);
} else {
return $r->string eq "$T" ? ($reduce->{'x||1'} ? $r : $self) : ($reduce->{'x||0'} ? $l : $self);
return $r->eval->value ? ($reduce->{'x||1'} ? $r : $self) : ($reduce->{'x||0'} ? $l : $self);
}
}

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

sub _eval { ($_[1]->value && $_[2]->value ? $context::Boolean::T : $context::Boolean::F) }
sub _eval {
my ($self, $l, $r) = @_;
return ($l->value && $r->value ? $self->context->T : $self->context->F);
}

sub _reduce {
my $self = shift;
my $context = $self->{equation}{context};
my $reduce = $context->{reduction};
my $l = $self->{lop};
my $r = $self->{rop};
my $self = shift;
my $reduce = $self->context->{reduction};
my $l = $self->{lop};
my $r = $self->{rop};

return $self unless ($l->{isConstant} || $r->{isConstant});

# make sure we are comparing to an updated 'true'
my $T = $context::Boolean::T->inContext($context);

# using string since Parser::Number::eval is unblessed, while Parser::Constant::eval is a (truthy) MathObject
if ($l->{isConstant}) {
return $l->string eq "$T" ? ($reduce->{'x&&1'} ? $r : $self) : ($reduce->{'x&&0'} ? $l : $self);
return $l->eval->value ? ($reduce->{'x&&1'} ? $r : $self) : ($reduce->{'x&&0'} ? $l : $self);
} else {
return $r->string eq "$T" ? ($reduce->{'x&&1'} ? $l : $self) : ($reduce->{'x&&0'} ? $r : $self);
return $r->eval->value ? ($reduce->{'x&&1'} ? $l : $self) : ($reduce->{'x&&0'} ? $r : $self);
}
}

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

sub _eval { ($_[1]->value != $_[2]->value ? $context::Boolean::T : $context::Boolean::F) }
sub _eval {
my ($self, $l, $r) = @_;
return ($l->value != $r->value ? $self->context->T : $self->context->F);
}

package context::Boolean::UOP::not;
our @ISA = qw(Parser::UOP);
Expand All @@ -231,35 +314,34 @@ sub _check {
}

sub _reduce {
my $self = shift;
my $context = $self->{equation}{context};
my $reduce = $context->{reduction};
my $op = $self->{op};
my $self = shift;
my $reduce = $self->context->{reduction};
my $op = $self->{op};

if ($op->isNeg && $reduce->{'!!x'}) {
delete $op->{op}{noParens};
return $op->{op};
}

if ($op->{isConstant} && $context->flag('reduceConstants')) {
# same issue with Parser::Number::eval being unblessed, check string instead
my $T = $context::Boolean::T->inContext($context);
my $new = $op->string eq "$T" ? 0 : 1;
return $self->Item('Value')->new($self->{equation}, [$new]);
return $self->Item('Value')->new($self->{equation}, [ 1 - $op->value ]);
}
return $self;
}

sub isNeg {1}

sub _eval { (!($_[1]->value) ? $context::Boolean::T : $context::Boolean::F) }
sub _eval {
my ($self, $op) = @_;
return (!($op->value) ? $self->context->T : $self->context->F);
}

sub perl {
my $self = shift;
my $op = $self->{def}{perl} || $self->{def}{string};
my $perl = $self->{op}->perl(1) . '->value';
my $result = "$op $perl";
return "($result ? \$context::Boolean::T : \$context::Boolean::F)";
return "($result ? context::Boolean->T : context::Boolean->F)";
}

package context::Boolean::Boolean;
Expand All @@ -286,7 +368,6 @@ sub checkBoolean {
}

sub compare {
# copypasta from other compare methods -- is this necessary?
my ($self, $l, $r) = Value::checkOpOrderWithPromote(@_);
return $l->value <=> $r->value;
}
Expand All @@ -311,7 +392,7 @@ sub TeX {

sub perl {
my $self = shift;
return $self->value ? '$context::Boolean::T' : '$context::Boolean::F';
return $self->value ? 'context::Boolean->T' : 'context::Boolean->F';
}

sub cmp_defaults { shift->SUPER::cmp_defaults(@_) }
Expand Down

0 comments on commit fedc1fe

Please sign in to comment.