first commit
This commit is contained in:
douboer
42
perl/Examples/Chap9/Constraint.pm
Normal file
42
perl/Examples/Chap9/Constraint.pm
Normal file
@@ -0,0 +1,42 @@
|
||||
|
||||
|
||||
###
|
||||
### Constraint.pm
|
||||
###
|
||||
|
||||
## Chapter 9 section 4.1.3
|
||||
|
||||
package Constraint;
|
||||
use Equation;
|
||||
@Constraint::ISA = qw(Equation);
|
||||
sub qualify {
|
||||
my ($self, $prefix) = @_;
|
||||
my %result = ("" => $self->constant);
|
||||
for my $var ($self->varlist) {
|
||||
$result{"$prefix.$var"} = $self->coefficient($var);
|
||||
}
|
||||
$self->new(%result);
|
||||
}
|
||||
sub new_constant {
|
||||
my ($base, $val) = @_;
|
||||
my $class = ref $base || $base;
|
||||
$class->new("" => $val);
|
||||
}
|
||||
sub add_constant {
|
||||
my ($self, $v) = @_;
|
||||
$self->add_equations($self->new_constant($v));
|
||||
}
|
||||
|
||||
sub mul_constant {
|
||||
my ($self, $v) = @_;
|
||||
$self->scale_equation($v);
|
||||
}
|
||||
package Constraint_Set;
|
||||
@Constraint_Set::ISA = 'Equation::System';
|
||||
|
||||
sub constraints {
|
||||
my $self = shift;
|
||||
$self->equations;
|
||||
}
|
||||
|
||||
1;
|
||||
19
perl/Examples/Chap9/Environment.pm
Normal file
19
perl/Examples/Chap9/Environment.pm
Normal file
@@ -0,0 +1,19 @@
|
||||
|
||||
|
||||
###
|
||||
### Environment.pm
|
||||
###
|
||||
|
||||
## Chapter 9 section 4.3.2
|
||||
|
||||
sub subset {
|
||||
my ($self, $name) = @_;
|
||||
my %result;
|
||||
for my $k (keys %$self) {
|
||||
my $kk = $k;
|
||||
if ($kk =~ s/^\Q$name.//) {
|
||||
$result{$kk} = $self->{$k};
|
||||
}
|
||||
}
|
||||
$self->new(%result);
|
||||
}
|
||||
46
perl/Examples/Chap9/Node.pm
Normal file
46
perl/Examples/Chap9/Node.pm
Normal file
@@ -0,0 +1,46 @@
|
||||
|
||||
|
||||
###
|
||||
### Node.pm
|
||||
###
|
||||
|
||||
## Chapter 9 section 2.1
|
||||
|
||||
package Node;
|
||||
my %NAMES;
|
||||
sub new {
|
||||
my ($class, $base_name, $behavior, $wiring) = @_;
|
||||
my $self = {N => $base_name . ++$NAMES{$base_name},
|
||||
B => $behavior,
|
||||
W => $wiring,
|
||||
};
|
||||
for my $wire (values %$wiring) {
|
||||
$wire->attach($self);
|
||||
}
|
||||
bless $self => $class;
|
||||
}
|
||||
sub notify {
|
||||
my $self = shift;
|
||||
my %vals;
|
||||
while (my ($name, $wire) = each %{$self->{W}}) {
|
||||
$vals{$name} = $wire->value($self);
|
||||
}
|
||||
$self->{B}->($self, %vals);
|
||||
}
|
||||
sub name {
|
||||
my $self = shift;
|
||||
$self->{N}|| "$self";
|
||||
}
|
||||
|
||||
sub wire { $_[0]{W}{$_[1]} }
|
||||
sub set_wire {
|
||||
my ($self, $wire, $value) = @_;
|
||||
my $wire = $self->wire($wire);
|
||||
$wire->set($self, $value);
|
||||
}
|
||||
|
||||
sub revoke_wire {
|
||||
my ($self, $wire) = @_;
|
||||
my $wire = $self->wire($wire);
|
||||
$wire->revoke($self);
|
||||
}
|
||||
291
perl/Examples/Chap9/Value.pm
Normal file
291
perl/Examples/Chap9/Value.pm
Normal file
@@ -0,0 +1,291 @@
|
||||
|
||||
|
||||
###
|
||||
### Value.pm
|
||||
###
|
||||
|
||||
## Chapter 9 section 4.2
|
||||
|
||||
package Value;
|
||||
|
||||
my %op = ("add" =>
|
||||
{
|
||||
"FEATURE,FEATURE" => 'add_features',
|
||||
"FEATURE,CONSTANT" => 'add_feature_con',
|
||||
"FEATURE,TUPLE" => 'add_feature_tuple',
|
||||
"TUPLE,TUPLE" => 'add_tuples',
|
||||
"TUPLE,CONSTANT" => undef,
|
||||
"CONSTANT,CONSTANT" => 'add_constants',
|
||||
NAME => "Addition",
|
||||
},
|
||||
"mul" =>
|
||||
{
|
||||
NAME => "Multiplication",
|
||||
"FEATURE,CONSTANT" => 'mul_feature_con',
|
||||
"TUPLE,CONSTANT" => 'mul_tuple_con',
|
||||
"CONSTANT,CONSTANT" => 'mul_constants',
|
||||
},
|
||||
);
|
||||
sub op {
|
||||
my ($self, $op, $operand) = @_;
|
||||
my ($k1, $k2) = ($self->kindof, $operand->kindof);
|
||||
my $method;
|
||||
if ($method = $op{$op}{"$k1,$k2"}) {
|
||||
$self->$method($operand);
|
||||
} elsif ($method = $op{$op}{"$k2,$k1"}) {
|
||||
$operand->$method($self);
|
||||
} else {
|
||||
my $name = $op{$op}{NAME} || "'$op'";
|
||||
die "$name of '$k1' and '$k2' not defined";
|
||||
}
|
||||
}
|
||||
sub negate { $_[0]->scale(-1) }
|
||||
sub reciprocal { die "Nonlinear division" }
|
||||
package Value::Constant;
|
||||
@Value::Constant::ISA = 'Value';
|
||||
|
||||
sub new {
|
||||
my ($base, $con) = @_;
|
||||
my $class = ref $base || $base;
|
||||
bless { WHAT => $base->kindof,
|
||||
VALUE => $con,
|
||||
} => $class;
|
||||
}
|
||||
|
||||
sub kindof { "CONSTANT" }
|
||||
|
||||
sub value { $_[0]{VALUE} }
|
||||
sub scale {
|
||||
my ($self, $coeff) = @_;
|
||||
$self->new($coeff * $self->value);
|
||||
}
|
||||
sub reciprocal {
|
||||
my ($self, $coeff) = @_;
|
||||
my $v = $self->value;
|
||||
if ($v == 0) {
|
||||
die "Division by zero";
|
||||
}
|
||||
$self->new(1/$v);
|
||||
}
|
||||
sub add_constants {
|
||||
my ($c1, $c2) = @_;
|
||||
$c1->new($c1->value + $c2->value);
|
||||
}
|
||||
|
||||
sub mul_constants {
|
||||
my ($c1, $c2) = @_;
|
||||
$c1->new($c1->value * $c2->value);
|
||||
}
|
||||
package Value::Tuple;
|
||||
@Value::Tuple::ISA = 'Value';
|
||||
|
||||
sub kindof { "TUPLE" }
|
||||
|
||||
sub new {
|
||||
my ($base, %tuple) = @_;
|
||||
my $class = ref $base || $base;
|
||||
bless { WHAT => $base->kindof,
|
||||
TUPLE => \%tuple,
|
||||
} => $class;
|
||||
}
|
||||
sub components { keys %{$_[0]{TUPLE}} }
|
||||
sub has_component { exists $_[0]{TUPLE}{$_[1]} }
|
||||
sub component { $_[0]{TUPLE}{$_[1]} }
|
||||
sub to_hash { $_[0]{TUPLE} }
|
||||
sub scale {
|
||||
my ($self, $coeff) = @_;
|
||||
my %new_tuple;
|
||||
for my $k ($self->components) {
|
||||
$new_tuple{$k} = $self->component($k)->scale($coeff);
|
||||
}
|
||||
$self->new(%new_tuple);
|
||||
}
|
||||
sub has_same_components_as {
|
||||
my ($t1, $t2) = @_;
|
||||
my %t1c;
|
||||
for my $c ($t1->components) {
|
||||
return unless $t2->has_component($c);
|
||||
$t1c{$c} = 1;
|
||||
}
|
||||
for my $c ($t2->components) {
|
||||
return unless $t1c{$c};
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
sub add_tuples {
|
||||
my ($t1, $t2) = @_;
|
||||
croak("Nonconformable tuples") unless $t1->has_same_components_as($t2);
|
||||
|
||||
my %result ;
|
||||
for my $c ($t1->components) {
|
||||
$result{$c} = $t1->component($c) + $t2->component($c);
|
||||
}
|
||||
$t1->new(%result);
|
||||
}
|
||||
sub mul_tuple_con {
|
||||
my ($t, $c) = @_;
|
||||
|
||||
$t->scale($c->value);
|
||||
}
|
||||
package Intrinsic_Constraint_Set;
|
||||
|
||||
sub new {
|
||||
my ($base, @constraints) = @_;
|
||||
my $class = ref $base || $base;
|
||||
bless \@constraints => $class;
|
||||
}
|
||||
|
||||
sub constraints { @{$_[0]} }
|
||||
sub apply {
|
||||
my ($self, $func) = @_;
|
||||
my @c = map $func->($_), $self->constraints;
|
||||
$self->new(@c);
|
||||
}
|
||||
sub qualify {
|
||||
my ($self, $prefix) = @_;
|
||||
$self->apply(sub { $_[0]->qualify($prefix) });
|
||||
}
|
||||
sub union {
|
||||
my ($self, @more) = @_;
|
||||
$self->new($self->constraints, map {$_->constraints} @more);
|
||||
}
|
||||
package Synthetic_Constraint_Set;
|
||||
|
||||
sub new {
|
||||
my $base = shift;
|
||||
my $class = ref $base || $base;
|
||||
|
||||
my $constraints;
|
||||
if (@_ == 1) {
|
||||
$constraints = shift;
|
||||
} elsif (@_ % 2 == 0) {
|
||||
my %constraints = @_;
|
||||
$constraints = \%constraints;
|
||||
} else {
|
||||
my $n = @_;
|
||||
require Carp;
|
||||
Carp::croak("$n arguments to Synthetic_Constraint_Set::new");
|
||||
}
|
||||
|
||||
bless $constraints => $class;
|
||||
}
|
||||
sub constraints { values %{$_[0]} }
|
||||
sub constraint { $_[0]->{$_[1]} }
|
||||
sub labels { keys %{$_[0]} }
|
||||
sub has_label { exists $_[0]->{$_[1]} }
|
||||
sub add_labeled_constraint {
|
||||
my ($self, $label, $constraint) = @_;
|
||||
$self->{$label} = $constraint;
|
||||
}
|
||||
sub apply {
|
||||
my ($self, $func) = @_;
|
||||
my %result;
|
||||
for my $k ($self->labels) {
|
||||
$result{$k} = $func->($self->constraint($k));
|
||||
}
|
||||
$self->new(\%result);
|
||||
}
|
||||
sub qualify {
|
||||
my ($self, $prefix) = @_;
|
||||
$self->apply(sub { $_[0]->qualify($prefix) });
|
||||
}
|
||||
sub scale {
|
||||
my ($self, $coeff) = @_;
|
||||
$self->apply(sub { $_[0]->scale_equation($coeff) });
|
||||
}
|
||||
sub apply2 {
|
||||
my ($self, $arg, $func) = @_;
|
||||
my %result;
|
||||
for my $k ($self->labels) {
|
||||
next unless $arg->has_label($k);
|
||||
$result{$k} = $func->($self->constraint($k),
|
||||
$arg->constraint($k));
|
||||
}
|
||||
$self->new(\%result);
|
||||
}
|
||||
|
||||
|
||||
## Chapter 9 section 4.2.5
|
||||
|
||||
sub apply_hash {
|
||||
my ($self, $hash, $func) = @_;
|
||||
my %result;
|
||||
for my $c (keys %$hash) {
|
||||
my $dotc = ".$c";
|
||||
for my $k ($self->labels) {
|
||||
next unless $k eq $c || substr($k, -length($dotc)) eq $dotc;
|
||||
$result{$k} = $func->($self->constraint($k), $hash->{$c});
|
||||
}
|
||||
}
|
||||
$self->new(\%result);
|
||||
}
|
||||
package Value::Feature;
|
||||
@Value::Feature::ISA = 'Value';
|
||||
|
||||
sub kindof { "FEATURE" }
|
||||
|
||||
sub new {
|
||||
my ($base, $intrinsic, $synthetic) = @_;
|
||||
my $class = ref $base || $base;
|
||||
my $self = {WHAT => $base->kindof,
|
||||
SYNTHETIC => $synthetic,
|
||||
INTRINSIC => $intrinsic,
|
||||
};
|
||||
bless $self => $class;
|
||||
}
|
||||
sub new_from_var {
|
||||
my ($base, $name, $type) = @_;
|
||||
my $class = ref $base || $base;
|
||||
$base->new($type->qualified_intrinsic_constraints($name),
|
||||
$type->qualified_synthetic_constraints($name),
|
||||
);
|
||||
}
|
||||
sub intrinsic { $_[0]->{INTRINSIC} }
|
||||
sub synthetic { $_[0]->{SYNTHETIC} }
|
||||
sub scale {
|
||||
my ($self, $coeff) = @_;
|
||||
return
|
||||
$self->new($self->intrinsic,
|
||||
$self->synthetic->scale($coeff),
|
||||
);
|
||||
}
|
||||
sub add_features {
|
||||
my ($o1, $o2) = @_;
|
||||
my $intrinsic = $o1->intrinsic->union($o2->intrinsic);
|
||||
my $synthetic = $o1->synthetic->apply2($o2->synthetic,
|
||||
sub { $_[0]->add_equations($_[1]) },
|
||||
);
|
||||
$o1->new($intrinsic, $synthetic);
|
||||
}
|
||||
sub mul_feature_con {
|
||||
my ($o, $c) = @_;
|
||||
$o->scale($c->value);
|
||||
}
|
||||
sub add_feature_con {
|
||||
my ($o, $c) = @_;
|
||||
my $v = $c->value;
|
||||
my $synthetic = $o->synthetic->apply(sub { $_[0]->add_constant($v) });
|
||||
$o->new($o->intrinsic, $synthetic);
|
||||
}
|
||||
sub add_feature_tuple {
|
||||
my ($o, $t) = @_;
|
||||
my $synthetic =
|
||||
$o->synthetic->apply_hash($t->to_hash,
|
||||
sub {
|
||||
my ($constr, $comp) = @_;
|
||||
my $kind = $comp->kindof;
|
||||
if ($kind eq "CONSTANT") {
|
||||
$constr->add_constant($comp->value);
|
||||
} elsif ($kind eq "FEATURE") {
|
||||
$constr->add_equations($comp->synthetic->constraint(""));
|
||||
} elsif ($kind eq "TUPLE") {
|
||||
die "Tuple with subtuple component";
|
||||
} else {
|
||||
die "Unknown tuple component type '$kind'";
|
||||
}
|
||||
},
|
||||
);
|
||||
$o->new($o->intrinsic, $synthetic);
|
||||
}
|
||||
|
||||
1;
|
||||
76
perl/Examples/Chap9/Wire.pm
Normal file
76
perl/Examples/Chap9/Wire.pm
Normal file
@@ -0,0 +1,76 @@
|
||||
|
||||
|
||||
###
|
||||
### Wire.pm
|
||||
###
|
||||
|
||||
## Chapter 9 section 2.1
|
||||
|
||||
package Wire;
|
||||
|
||||
my $N = 0;
|
||||
sub new {
|
||||
my ($class, $name) = @_;
|
||||
$name ||= "wire" . ++$N;
|
||||
bless { N => $name, S => undef, V => undef, A => [] } => $class;
|
||||
}
|
||||
sub make {
|
||||
my $class = shift;
|
||||
my $N = shift;
|
||||
my @wires;
|
||||
push @wires, $class->new while $N--;
|
||||
@wires;
|
||||
}
|
||||
sub set {
|
||||
my ($self, $settor, $value) = @_;
|
||||
if (! $self->has_settor || $self->settor_is($settor)) {
|
||||
$self->{V} = $value;
|
||||
$self->{S} = $settor;
|
||||
$self->notify_all_but($settor, $value);
|
||||
} elsif ($self->has_settor) {
|
||||
unless ($value == $self->value) {
|
||||
my $v = $self->value;
|
||||
my $N = $self->name;
|
||||
warn "Wire $N inconsistent value ($value != $v)\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
sub notify_all_but {
|
||||
my ($self, $exception, $value) = @_;
|
||||
for my $node ($self->attachments) {
|
||||
next if $node == $exception;
|
||||
$node->notify;
|
||||
}
|
||||
}
|
||||
sub attach {
|
||||
my ($self, @nodes) = @_;
|
||||
push @{$self->{A}}, @nodes;
|
||||
}
|
||||
|
||||
sub attachments { @{$_[0]->{A}} }
|
||||
sub name {
|
||||
$_[0]{N} || "$_[0]";
|
||||
}
|
||||
|
||||
sub settor { $_[0]{S} }
|
||||
sub has_settor { defined $_[0]{S} }
|
||||
sub settor_is { $_[0]{S} == $_[1] }
|
||||
sub revoke {
|
||||
my ($self, $revoker) = @_;
|
||||
return unless $self->has_value;
|
||||
return unless $self->settor_is($revoker);
|
||||
undef $self->{V};
|
||||
$self->notify_all_but($revoker, undef);
|
||||
undef $self->{S};
|
||||
}
|
||||
|
||||
1;
|
||||
sub value { my ($self, $querent) = @_;
|
||||
return if $self->settor_is($querent);
|
||||
$self->{V};
|
||||
}
|
||||
|
||||
sub has_value { my ($self, $querent) = @_;
|
||||
return if $self->settor_is($querent);
|
||||
defined $_[0]{V};
|
||||
}
|
||||
359
perl/Examples/Chap9/linogram.pl
Normal file
359
perl/Examples/Chap9/linogram.pl
Normal file
@@ -0,0 +1,359 @@
|
||||
|
||||
|
||||
###
|
||||
### linogram.pl
|
||||
###
|
||||
|
||||
## Chapter 9 section 4.4
|
||||
|
||||
use Parser ':all';
|
||||
use Lexer ':all';
|
||||
|
||||
my $input = sub { read INPUT, my($buf), 8192 or return; $buf };
|
||||
|
||||
my @keywords = map [uc($_), qr/\b$_\b/],
|
||||
qw(constraints define extends draw);
|
||||
|
||||
my $tokens = iterator_to_stream(
|
||||
make_lexer($input,
|
||||
@keywords,
|
||||
['ENDMARKER', qr/__END__.*/s,
|
||||
sub {
|
||||
my $s = shift;
|
||||
$s =~ s/^__END__\s*//;
|
||||
['ENDMARKER', $s]
|
||||
} ],
|
||||
['IDENTIFIER', qr/[a-zA-Z_]\w*/],
|
||||
['NUMBER', qr/(?: \d+ (?: \.\d*)?
|
||||
| \.\d+)
|
||||
(?: [eE] \d+)? /x ],
|
||||
['FUNCTION', qr/&/],
|
||||
['DOT', qr/\./],
|
||||
['COMMA', qr/,/],
|
||||
['OP', qr|[-+*/]|],
|
||||
['EQUALS', qr/=/],
|
||||
['LPAREN', qr/[(]/],
|
||||
['RPAREN', qr/[)]/],
|
||||
['LBRACE', qr/[{]/],
|
||||
['RBRACE', qr/[}]\n*/],
|
||||
['TERMINATOR', qr/;\n*/],
|
||||
['WHITESPACE', qr/\s+/, sub { "" }],
|
||||
));
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.2
|
||||
|
||||
my $ROOT_TYPE = Type->new('ROOT');
|
||||
my %TYPES = ('number' => Type::Scalar->new('number'),
|
||||
'ROOT' => $ROOT_TYPE,
|
||||
);
|
||||
$program = star($Definition
|
||||
| $Declaration
|
||||
> sub { add_declarations($ROOT_TYPE, $_[0]) }
|
||||
)
|
||||
- option($Perl_code) - $End_of_Input
|
||||
>> sub {
|
||||
$ROOT_TYPE->draw();
|
||||
};
|
||||
$perl_code = _("ENDMARKER") > sub { eval $_[0];
|
||||
die if $@;
|
||||
};
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.4
|
||||
|
||||
$defheader = _("DEFINE") - _("IDENTIFIER") - $Extends
|
||||
>> sub { ["DEFINITION", @_[1,2] ]};
|
||||
|
||||
$extends = option(_("EXTENDS") - _("IDENTIFIER") >> sub { $_[1] }) ;
|
||||
$definition = labeledblock($Defheader, $Declaration)
|
||||
>> sub {
|
||||
my ($defheader, @declarations) = @_;
|
||||
my ($name, $extends) = @$defheader[1,2];
|
||||
my $parent_type = (defined $extends) ? $TYPES{$extends} : undef;
|
||||
my $new_type;
|
||||
|
||||
if (exists $TYPES{$name}) {
|
||||
lino_error("Type '$name' redefined");
|
||||
}
|
||||
if (defined $extends && ! defined $parent_type) {
|
||||
lino_error("Type '$name' extended from unknown type '$extends'");
|
||||
}
|
||||
|
||||
$new_type = Type->new($name, $parent_type);
|
||||
|
||||
add_declarations($new_type, @declarations);
|
||||
|
||||
$TYPES{$name} = $new_type;
|
||||
};
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
$type = lookfor("IDENTIFIER",
|
||||
sub {
|
||||
exists($TYPES{$_[0][1]}) || lino_error("Unrecognized type '$_[0][1]'");
|
||||
$_[0][1];
|
||||
}
|
||||
);
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
$declarator = _("IDENTIFIER")
|
||||
- option(_("LPAREN") - commalist($Param_Spec) - _("RPAREN")
|
||||
>> sub { $_[1] }
|
||||
)
|
||||
>> sub {
|
||||
{ WHAT => 'DECLARATOR',
|
||||
NAME => $_[0],
|
||||
PARAM_SPECS => $_[1],
|
||||
};
|
||||
};
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
$param_spec = _("IDENTIFIER") - _("EQUALS") - $Expression
|
||||
>> sub {
|
||||
{ WHAT => "PARAM_SPEC",
|
||||
NAME => $_[0],
|
||||
VALUE => $_[2],
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
$declaration = $Type - commalist($Declarator) - _("TERMINATOR")
|
||||
>> sub { my ($type, $decl_list) = @_;
|
||||
unless (exists $TYPES{$type}) {
|
||||
lino_error("Unknown type name '$type' in declaration '@_'\n");
|
||||
}
|
||||
for (@$decl_list) {
|
||||
$_->{TYPE} = $type;
|
||||
check_declarator($TYPES{$type}, $_);
|
||||
}
|
||||
{WHAT => 'DECLARATION',
|
||||
DECLARATORS => $decl_list };
|
||||
}
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
| $Constraint_section
|
||||
| $Draw_section
|
||||
;
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
sub check_declarator {
|
||||
my ($type, $declarator) = @_;
|
||||
for my $pspec (@{$declarator->{PARAM_SPECS}}) {
|
||||
my $name = $pspec->{NAME};
|
||||
unless ($type->has_subfeature($name)) {
|
||||
lino_error("Declaration of '$declarator->{NAME}' "
|
||||
. "specifies unknown subfeature '$name' "
|
||||
. "for type '$type->{N}'\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
$constraint_section = labeledblock(_("CONSTRAINTS"), $Constraint)
|
||||
>> sub { shift;
|
||||
{ WHAT => 'CONSTRAINTS', CONSTRAINTS => [@_] }
|
||||
};
|
||||
$constraint = $Expression - _("EQUALS") - $Expression - _("TERMINATOR")
|
||||
>> sub { Expression->new('-', $_[0], $_[2]) } ;
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
$draw_section = labeledblock(_("DRAW"), $Drawable)
|
||||
>> sub { shift; { WHAT => 'DRAWABLES', DRAWABLES => [@_] } };
|
||||
$drawable = $Name - _("TERMINATOR")
|
||||
>> sub { { WHAT => 'NAMED_DRAWABLE',
|
||||
NAME => $_[1],
|
||||
}
|
||||
}
|
||||
| _("FUNCTION") - _("IDENTIFIER") - _("TERMINATOR")
|
||||
>> sub { my $ref = \&{$_[1]};
|
||||
{ WHAT => 'FUNCTIONAL_DRAWABLE',
|
||||
REF => $ref,
|
||||
NAME => $_[1],
|
||||
};
|
||||
};
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.5
|
||||
|
||||
my %add_decl = ('DECLARATION' => \&add_subfeature_declaration,
|
||||
'CONSTRAINTS' => \&add_constraint_declaration,
|
||||
'DRAWABLES' => \&add_draw_declaration,
|
||||
'DEFAULT' => sub {
|
||||
lino_error("Unknown declaration kind '$[1]{WHAT}'");
|
||||
},
|
||||
);
|
||||
|
||||
sub add_declarations {
|
||||
my ($type, @declarations) = @_;
|
||||
|
||||
for my $declaration (@declarations) {
|
||||
my $decl_kind = $declaration->{WHAT};
|
||||
my $func = $add_decl{$decl_kind} || $add_decl{DEFAULT};
|
||||
$func->($type, $declaration);
|
||||
}
|
||||
}
|
||||
sub add_subobj_declaration {
|
||||
my ($type, $declaration) = @_;
|
||||
my $declarators = $declaration->{DECLARATORS};
|
||||
for my $decl (@$declarators) {
|
||||
my $name = $decl->{NAME};
|
||||
my $decl_type = $decl->{TYPE};
|
||||
my $decl_type_obj = $TYPES{$decl_type};
|
||||
$type->add_subfeature($name, $decl_type_obj);
|
||||
for my $pspec (@{$decl->{PARAM_SPECS}}) {
|
||||
my $pspec_name = $pspec->{NAME};
|
||||
my $constraints = convert_param_specs($type, $name, $pspec);
|
||||
$type->add_constraints($constraints);
|
||||
}
|
||||
}
|
||||
}
|
||||
sub add_constraint_declaration {
|
||||
my ($type, $declaration) = @_;
|
||||
my $constraint_expressions = $declaration->{CONSTRAINTS};
|
||||
my @constraints
|
||||
= map expression_to_constraints($type, $_),
|
||||
@$constraint_expressions;
|
||||
$type->add_constraints(@constraints);
|
||||
}
|
||||
sub add_draw_declaration {
|
||||
my ($type, $declaration) = @_;
|
||||
my $drawables = $declaration->{DRAWABLES};
|
||||
|
||||
for my $d (@$drawables) {
|
||||
my $drawable_type = $d->{WHAT};
|
||||
if ($drawable_type eq "NAMED_DRAWABLE") {
|
||||
unless ($type->has_subfeature($d->{NAME})) {
|
||||
lino_error("Unknown drawable feature '$d->{NAME}'");
|
||||
}
|
||||
$type->add_drawable($d->{NAME});
|
||||
} elsif ($drawable_type eq "FUNCTIONAL_DRAWABLE") {
|
||||
$type->add_drawable($d->{REF});
|
||||
} else {
|
||||
lino_error("Unknown drawable type '$type'");
|
||||
}
|
||||
}
|
||||
}
|
||||
$expression = operator($Term,
|
||||
[_('OP', '+'), sub { Expression->new('+', @_) } ],
|
||||
[_('OP', '-'), sub { Expression->new('-', @_) } ],
|
||||
);
|
||||
|
||||
$term = operator($Atom,
|
||||
[_('OP', '*'), sub { Expression->new('*', @_) } ],
|
||||
[_('OP', '/'), sub { Expression->new('/', @_) } ],
|
||||
);
|
||||
package Expression;
|
||||
|
||||
sub new {
|
||||
my ($base, $op, @args) = @_;
|
||||
my $class = ref $base || $base;
|
||||
unless (exists $eval_op{$op}) {
|
||||
die "Unknown operator '$op' in expression '$op @args'\n";
|
||||
}
|
||||
bless [ $op, @args ] => $class;
|
||||
}
|
||||
package main;
|
||||
|
||||
$atom = $Name
|
||||
| $Tuple
|
||||
| lookfor("NUMBER", sub { Expression->new('CON', $_[0][1]) })
|
||||
| _('OP', '-') - $Expression
|
||||
>> sub { Expression->new('-', Expression->new('CON', 0), $_[1]) }
|
||||
| _("LPAREN") - $Expression - _("RPAREN") >> sub {$_[1]};
|
||||
$name = $Base_name
|
||||
- star(_("DOT") - _("IDENTIFIER") >> sub { $_[1] })
|
||||
> sub { Expression->new('VAR', join(".", $_[0], @{$_[1]})) }
|
||||
;
|
||||
|
||||
$base_name = _"IDENTIFIER";
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.6
|
||||
|
||||
$tuple = _("LPAREN")
|
||||
- commalist($Expression) / sub { @{$_[0]} > 1 }
|
||||
- _("RPAREN")
|
||||
>> sub {
|
||||
my ($explist) = $_[1];
|
||||
my $N = @$explist;
|
||||
my @axis = qw(x y z);
|
||||
if ($N == 2 || $N == 3) {
|
||||
return [ 'TUPLE',
|
||||
{ map { $axis[$_] => $explist->[$_] } (0 .. $N-1) }
|
||||
];
|
||||
} else {
|
||||
lino_error("$N-tuples are not supported\n");
|
||||
}
|
||||
} ;
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.6
|
||||
|
||||
sub expression_to_constraints {
|
||||
my ($context, $expr) = @_;
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.6
|
||||
|
||||
unless (defined $expr) {
|
||||
Carp::croak("Missing expression in 'expression_to_constraints'");
|
||||
}
|
||||
my ($op, @s) = @$expr;
|
||||
if ($op eq 'VAR') {
|
||||
my $name = $s[0];
|
||||
return Value::Feature->new_from_var($name, $context->subfeature($name));
|
||||
} elsif ($op eq 'CON') {
|
||||
return Value::Constant->new($s[0]);
|
||||
} elsif ($op eq 'TUPLE') {
|
||||
my %components;
|
||||
for my $k (keys %{$s[0]}) {
|
||||
$components{$k} = expression_to_constraints($context, $s[0]{$k});
|
||||
}
|
||||
return Value::Tuple->new(%components);
|
||||
}
|
||||
my $e1 = expression_to_constraints($context, $s[0]);
|
||||
my $e2 = expression_to_constraints($context, $s[1]);
|
||||
my %opmeth = ('+' => 'add',
|
||||
'-' => 'sub',
|
||||
'*' => 'mul',
|
||||
'/' => 'div',
|
||||
);
|
||||
|
||||
my $meth = $opmeth{$op};
|
||||
if (defined $meth) {
|
||||
return $e1->$meth($e2);
|
||||
} else {
|
||||
lino_error("Unknown operator '$op' in AST");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## Chapter 9 section 4.4.6
|
||||
|
||||
sub convert_param_specs {
|
||||
my ($context, $subobj, $pspec) = @_;
|
||||
my @constraints;
|
||||
my $left = Value::Feature->new_from_var("$subobj." . $pspec->{NAME},
|
||||
$context->subfeature($subobj)
|
||||
->subfeature($pspec->{NAME})
|
||||
);
|
||||
my $right = expression_to_constraints($context, $pspec->{VALUE});
|
||||
return $left->sub($right);
|
||||
}
|
||||
Reference in New Issue
Block a user