first commit
This commit is contained in:
douboer
617
perl/Examples/all.pl
Normal file
617
perl/Examples/all.pl
Normal file
@@ -0,0 +1,617 @@
|
||||
|
||||
|
||||
###
|
||||
### rng-iterator.pl
|
||||
###
|
||||
|
||||
## Chapter 4 section 3.6
|
||||
|
||||
sub make_rand {
|
||||
my $seed = shift || (time & 0x7fff);
|
||||
return Iterator {
|
||||
$seed = (29*$seed+11111) & 0x7fff;
|
||||
return $seed;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
###
|
||||
### hamming.pl
|
||||
###
|
||||
|
||||
## Chapter 6 section 4
|
||||
|
||||
use Stream qw(transform promise merge node show);
|
||||
|
||||
sub scale {
|
||||
my ($s, $c) = @_;
|
||||
transform { $_[0]*$c } $s;
|
||||
}
|
||||
my $hamming;
|
||||
$hamming = node(1,
|
||||
promise {
|
||||
merge(scale($hamming, 2),
|
||||
merge(scale($hamming, 3),
|
||||
scale($hamming, 5),
|
||||
))
|
||||
}
|
||||
);
|
||||
|
||||
|
||||
show($hamming, 3000);
|
||||
|
||||
|
||||
###
|
||||
### dqp.pl
|
||||
###
|
||||
|
||||
## Chapter 8 section 7.1
|
||||
|
||||
use Lexer ':all';
|
||||
|
||||
sub lex_input {
|
||||
my @input = @_;
|
||||
my $input = sub { shift @input };
|
||||
|
||||
my $lexer = iterator_to_stream(
|
||||
make_lexer($input,
|
||||
['STRING', qr/' (?: \\. | [^'] )* '
|
||||
|" (?: \\. | [^"] )* " /sx,
|
||||
|
||||
sub { my $s = shift;
|
||||
$s =~ s/.//; $s =~ s/.$//;
|
||||
$s =~ s/\\(.)/$1/g;
|
||||
['STRING', $s] } ],
|
||||
|
||||
['FIELD', qr/[A-Z]+/ ],
|
||||
['AND', qr/&/ ],
|
||||
['OR', qr/\|/ ],
|
||||
|
||||
['OP', qr/[!<>=]=|[<>=]/,
|
||||
sub { $_[0] =~ s/^=$/==/;
|
||||
[ 'OP', $_[0] ] } ],
|
||||
|
||||
['LPAREN', qr/[(]/ ],
|
||||
['RPAREN', qr/[)]/ ],
|
||||
['NUMBER', qr/\d+ (?:\.\d*)? | \.\d+/x ],
|
||||
['SPACE', qr/\s+/, sub { "" } ],
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
## Chapter 8 section 7.2
|
||||
|
||||
use Parser ':all';
|
||||
use FlatDB_Composable qw(query_or query_and);
|
||||
|
||||
my ($cquery, $squery, $term);
|
||||
my $CQuery = parser { $cquery->(@_) };
|
||||
my $SQuery = parser { $squery->(@_) };
|
||||
my $Term = parser { $term->(@_) };
|
||||
|
||||
use FlatDB;
|
||||
|
||||
|
||||
## Chapter 8 section 7.2
|
||||
|
||||
$cquery = operator($Term, [lookfor('OR'), \&query_or]);
|
||||
$term = operator($SQuery, [lookfor('AND'), \&query_and]);
|
||||
|
||||
|
||||
## Chapter 8 section 7.2
|
||||
|
||||
# This needs to be up here so that the following $squery
|
||||
# definition can see $parser_dbh
|
||||
my $parser_dbh;
|
||||
sub set_parser_dbh { $parser_dbh = shift }
|
||||
sub parser_dbh { $parser_dbh }
|
||||
|
||||
|
||||
## Chapter 8 section 7.2
|
||||
|
||||
$squery = alternate(
|
||||
T(concatenate(lookfor('LPAREN'),
|
||||
$CQuery,
|
||||
lookfor('RPAREN'),
|
||||
),
|
||||
sub { $_[1] }),
|
||||
T(concatenate(lookfor('FIELD'),
|
||||
lookfor('OP'),
|
||||
lookfor('NUMBER')),
|
||||
sub {
|
||||
my ($field, $op, $val) = @_;
|
||||
my $cmp_code = 'sub { $_[0] OP $_[1] }';
|
||||
$cmp_code =~ s/OP/$op/;
|
||||
my $cmp = eval($cmp_code) or die;
|
||||
my $cb = sub { my %F = @_;
|
||||
$cmp->($F{$field}, $val)};
|
||||
$parser_dbh->callbackquery($cb);
|
||||
}),
|
||||
|
||||
|
||||
## Chapter 8 section 7.2
|
||||
|
||||
T(concatenate(lookfor('FIELD'),
|
||||
lookfor('OP'),
|
||||
lookfor('STRING')),
|
||||
sub {
|
||||
if ($_[1] eq '==') {
|
||||
$parser_dbh->query($_[0], $_[2]);
|
||||
} else {
|
||||
my ($field, $op, $val) = @_;
|
||||
my $cmp_code = 'sub { $_[0] OP $_[1] }';
|
||||
$cmp_code =~ s/OP/$string_version{$op}/;
|
||||
my $cmp = eval($cmp_code) or die;
|
||||
my $cb = sub { my %F = @_;
|
||||
$cmp->($F{$field}, $val)};
|
||||
$parser_dbh->callbackquery($cb);
|
||||
}
|
||||
}),
|
||||
);
|
||||
my %string_version = ('>' => 'gt', '>=', => 'ge', '==' => 'eq',
|
||||
'<' => 'lt', '<=', => 'le', '!=' => 'ne');
|
||||
package FlatDB::Parser;
|
||||
use base FlatDB_Composable;
|
||||
|
||||
sub parse_query {
|
||||
my $self = shift;
|
||||
my $query = shift;
|
||||
my $lexer = main::lex_input($query);
|
||||
my $old_parser_dbh = main::parser_dbh();
|
||||
main::set_parser_dbh($self);
|
||||
my ($result) = $cquery->($lexer);
|
||||
main::set_parser_dbh($old_parser_dbh);
|
||||
return $result;
|
||||
}
|
||||
|
||||
|
||||
###
|
||||
### simple-expr-parser-2.pl
|
||||
###
|
||||
|
||||
## Chapter 8 section 4
|
||||
|
||||
use Parser ':all';
|
||||
use Lexer ':all';
|
||||
|
||||
my ($expression, $term, $factor);
|
||||
my $Expression = parser { $expression->(@_) };
|
||||
my $Term = parser { $term ->(@_) };
|
||||
my $Factor = parser { $factor ->(@_) };
|
||||
$expression = alternate(concatenate($Term,
|
||||
lookfor(['OP', '+']),
|
||||
$Expression),
|
||||
$Term);
|
||||
|
||||
$term = alternate(concatenate($Factor,
|
||||
lookfor(['OP', '*']),
|
||||
$Term),
|
||||
$Factor);
|
||||
|
||||
$factor = alternate(lookfor('INT'),
|
||||
concatenate(lookfor(['OP', '(']),
|
||||
$Expression,
|
||||
lookfor(['OP', ')']))
|
||||
);
|
||||
|
||||
$entire_input = concatenate($Expression, \&End_of_Input);
|
||||
|
||||
|
||||
###
|
||||
### simple-expr-parser.pl
|
||||
###
|
||||
|
||||
## Chapter 8 section 4
|
||||
|
||||
use Parser ':all';
|
||||
use Lexer ':all';
|
||||
|
||||
my $expression;
|
||||
my $Expression = parser { $expression->(@_) };
|
||||
$expression = alternate(concatenate(lookfor('INT'),
|
||||
lookfor(['OP', '+']),
|
||||
$Expression),
|
||||
concatenate(lookfor('INT'),
|
||||
lookfor(['OP', '*']),
|
||||
$Expression),
|
||||
concatenate(lookfor(['OP', '(']),
|
||||
$Expression,
|
||||
lookfor(['OP', ')'])),
|
||||
lookfor('INT'));
|
||||
my $entire_input = concatenate($Expression, \&End_of_Input);
|
||||
my @input = q[2 * 3 + (4 * 5)];
|
||||
my $input = sub { return shift @input };
|
||||
my $lexer = iterator_to_stream(
|
||||
make_lexer($input,
|
||||
['TERMINATOR', qr/;\n*|\n+/ ],
|
||||
['INT, qr/\d+/ ],
|
||||
['PRINT', qr/\bprint\b/ ],
|
||||
['IDENTIFIER', qr|[A-Za-z_]\w*| ],
|
||||
['OP', qr#\*\*|[-=+*/()]# ],
|
||||
['WHITESPACE', qr/\s+/, sub { "" } ],
|
||||
)
|
||||
);
|
||||
if (my ($result, $remaining_input) = $entire_input->($lexer)) {
|
||||
use Data::Dumper;
|
||||
print Dumper($result), "\n";
|
||||
} else {
|
||||
warn "Parse error.\n";
|
||||
}
|
||||
|
||||
|
||||
###
|
||||
### iterator-to-stream.pl
|
||||
###
|
||||
|
||||
## Chapter 8 section 1.4
|
||||
|
||||
use Stream 'node';
|
||||
|
||||
sub iterator_to_stream {
|
||||
my $it = shift;
|
||||
my $v = $it->();
|
||||
return unless defined $v;
|
||||
node($v, sub { iterator_to_stream($it) });
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
###
|
||||
### 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