From b0656542a4136149c91ef8ed1ca7beef70d68616 Mon Sep 17 00:00:00 2001 From: dcw Date: Sun, 21 Feb 2021 21:42:58 +0000 Subject: imported my solutions to ch#100, and also some more work on ch#99s pattern matching - ch#99's README is basically now a blog --- challenge-099/duncan-c-white/README | 59 ++- challenge-099/duncan-c-white/opt1-noFL/API.pm | 255 ++++++++++++ .../duncan-c-white/opt1-noFL/Interpreter.pm | 123 ++++++ challenge-099/duncan-c-white/opt1-noFL/PosExpr.pm | 253 ++++++++++++ challenge-099/duncan-c-white/opt1-noFL/README | 5 + .../duncan-c-white/opt1-noFL/TestMatch.pm | 75 ++++ .../duncan-c-white/opt1-noFL/TestMatch2.pm | 102 +++++ challenge-099/duncan-c-white/opt1-noFL/TestPE.pm | 79 ++++ .../duncan-c-white/opt1-noFL/TestPat2Api.pm | 64 +++ .../duncan-c-white/opt1-noFL/Translate.pm | 302 +++++++++++++++ challenge-099/duncan-c-white/opt1-noFL/ch-1a.pl | 127 ++++++ challenge-099/duncan-c-white/opt1-noFL/ch-1b.pl | 137 +++++++ challenge-099/duncan-c-white/opt1-noFL/mkTypes | 250 ++++++++++++ .../duncan-c-white/opt2-separateRunX/API.pm | 255 ++++++++++++ .../opt2-separateRunX/Interpreter.pm | 176 +++++++++ .../duncan-c-white/opt2-separateRunX/PosExpr.pm | 254 ++++++++++++ .../duncan-c-white/opt2-separateRunX/README | 11 + .../duncan-c-white/opt2-separateRunX/TestMatch.pm | 75 ++++ .../duncan-c-white/opt2-separateRunX/TestMatch2.pm | 102 +++++ .../duncan-c-white/opt2-separateRunX/TestPE.pm | 79 ++++ .../opt2-separateRunX/TestPat2Api.pm | 64 +++ .../duncan-c-white/opt2-separateRunX/Translate.pm | 301 +++++++++++++++ .../duncan-c-white/opt2-separateRunX/ch-1a.pl | 127 ++++++ .../duncan-c-white/opt2-separateRunX/ch-1b.pl | 137 +++++++ .../duncan-c-white/opt2-separateRunX/mkTypes | 250 ++++++++++++ .../duncan-c-white/opt3-rewrite/PatternMatch.pm | 428 +++++++++++++++++++++ challenge-099/duncan-c-white/opt3-rewrite/README | 11 + .../opt3-rewrite/TestPatternMatch.pm | 111 ++++++ challenge-099/duncan-c-white/opt3-rewrite/Tuple.pm | 85 ++++ challenge-099/duncan-c-white/opt3-rewrite/ch-1b.pl | 103 +++++ .../duncan-c-white/opt3-rewrite/testextract.pl | 138 +++++++ challenge-099/duncan-c-white/perl/API.pm | 92 +++-- challenge-099/duncan-c-white/perl/Interpreter.pm | 138 +++++++ challenge-099/duncan-c-white/perl/PosExpr.pm | 57 ++- challenge-099/duncan-c-white/perl/TestMatch.pm | 75 ++++ challenge-099/duncan-c-white/perl/TestMatch2.pm | 102 +++++ challenge-099/duncan-c-white/perl/TestPE.pm | 79 ++++ challenge-099/duncan-c-white/perl/TestPat2Api.pm | 64 +++ challenge-099/duncan-c-white/perl/Translate.pm | 318 +++++++++++++++ challenge-099/duncan-c-white/perl/ch-1.pl | 7 +- challenge-099/duncan-c-white/perl/ch-1a.pl | 148 +------ challenge-099/duncan-c-white/perl/ch-1b.pl | 137 +++++++ challenge-099/duncan-c-white/perl/mkTypes | 109 +++++- challenge-100/duncan-c-white/README | 110 +++--- challenge-100/duncan-c-white/perl/ch-1.sh | 29 ++ challenge-100/duncan-c-white/perl/ch-2.pl | 162 ++++++++ challenge-100/duncan-c-white/perl/mkTypes | 200 ---------- 47 files changed, 5914 insertions(+), 451 deletions(-) create mode 100644 challenge-099/duncan-c-white/opt1-noFL/API.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/Interpreter.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/PosExpr.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/README create mode 100644 challenge-099/duncan-c-white/opt1-noFL/TestMatch.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/TestMatch2.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/TestPE.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/TestPat2Api.pm create mode 100644 challenge-099/duncan-c-white/opt1-noFL/Translate.pm create mode 100755 challenge-099/duncan-c-white/opt1-noFL/ch-1a.pl create mode 100755 challenge-099/duncan-c-white/opt1-noFL/ch-1b.pl create mode 100755 challenge-099/duncan-c-white/opt1-noFL/mkTypes create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/API.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/Interpreter.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/PosExpr.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/README create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/TestMatch.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/TestMatch2.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/TestPE.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/TestPat2Api.pm create mode 100644 challenge-099/duncan-c-white/opt2-separateRunX/Translate.pm create mode 100755 challenge-099/duncan-c-white/opt2-separateRunX/ch-1a.pl create mode 100755 challenge-099/duncan-c-white/opt2-separateRunX/ch-1b.pl create mode 100755 challenge-099/duncan-c-white/opt2-separateRunX/mkTypes create mode 100644 challenge-099/duncan-c-white/opt3-rewrite/PatternMatch.pm create mode 100644 challenge-099/duncan-c-white/opt3-rewrite/README create mode 100644 challenge-099/duncan-c-white/opt3-rewrite/TestPatternMatch.pm create mode 100644 challenge-099/duncan-c-white/opt3-rewrite/Tuple.pm create mode 100755 challenge-099/duncan-c-white/opt3-rewrite/ch-1b.pl create mode 100755 challenge-099/duncan-c-white/opt3-rewrite/testextract.pl create mode 100644 challenge-099/duncan-c-white/perl/Interpreter.pm create mode 100644 challenge-099/duncan-c-white/perl/TestMatch.pm create mode 100644 challenge-099/duncan-c-white/perl/TestMatch2.pm create mode 100644 challenge-099/duncan-c-white/perl/TestPE.pm create mode 100644 challenge-099/duncan-c-white/perl/TestPat2Api.pm create mode 100644 challenge-099/duncan-c-white/perl/Translate.pm create mode 100755 challenge-099/duncan-c-white/perl/ch-1b.pl create mode 100755 challenge-100/duncan-c-white/perl/ch-1.sh create mode 100755 challenge-100/duncan-c-white/perl/ch-2.pl delete mode 100755 challenge-100/duncan-c-white/perl/mkTypes diff --git a/challenge-099/duncan-c-white/README b/challenge-099/duncan-c-white/README index 1b476ca4de..a184ac1e54 100644 --- a/challenge-099/duncan-c-white/README +++ b/challenge-099/duncan-c-white/README @@ -47,15 +47,15 @@ in $s into a variable called l". Another API might be "T l>2", meaning pos 1 to char pos l-1". Then I wrote an API-interpreter for them. Of course, this has to handle -the general match API (see API.pm and ch-1a.pl for details) which can match -in multiple places - requiring us to try each possible place, and backtrack. +the general match API (see Interpreter.pm, API.pm and ch-1a.pl for details) +which can match in multiple places - requiring us to try each possible place +recursively. The API-interpreter successfully does pattern matching, as shown by "./ch-1a.pl -t" passing all tests. So this is a successful proof of concept. -But as yet I have not attempted to translate our patterns such as 'a*c?e' -into lists of API calls. - +Up to the submission deadline, this was all I managed to achieve. See the +bottom of this README for an update.. Task 2: "Unique Subsequence @@ -91,3 +91,52 @@ into a Task-1-style pattern, so lit becomes *l*i*t* and figuring out how many different ways that pattern can apply. But as $T has no meta-chars, an easy approach may be possible (locate all positions in $S where head($T) appears, for each of them recursively match subtr($S,pos+1) against tail($T)) + + +Return to Task 1 after the deadline + +After the deadline had passed, I spent quite a long time working out +how to translate our patterns such as 'a*c?e' into lists of API calls. +See Translate.pm and ch-1b.pl for the details of what I did. This half +of the problem was much harder than the Interpreter. + +I then invested some more time optimising the Interpreter+Translator: + +opt1-noFL: + Here I realised that "First" (match @ 0) and "Last" (match @ end of + the string) were special cases, and removed them, thus removing over + 100 lines of Perl without any harm. + +opt2-separateRunX: + I started thinking about merging the Translator and Interpreter, + here I split out the Interpreter operations for At, Match, Test and + Capture into separate functions thinking this might make it easier + to move bits of the Interpreter into the Translator. It might have + helped with At, Test and Capture, but Match has to try matching at + several different places, backtracking, and the structure of this + would be entirely different in a merged T+I. So this was a dead end. + +opt3-rewrite: + Here I bit the bullet, and started working out from scratch (reusing + snippets of code from both Translator and Interpreter) how to do an + integrated Pattern Match. I got very bogged down in captures and + backtracking, before eventually realising that working out which + substrings to capture should be completely postponed until after the + match was complete. All that it needed was to know how many fixed width + islands (sequences of string literals and '?'s) there were, and + for each island, the starting position in the string we were matching + against where that island had matched. All the captures could be + worked out from there. It took two solid evenings work, but eventually + it worked fine. See PatternMatch.pm, Tuple.pm (reused ADT) and so on. + This approach completely abandons the API instructions, the PosExpr + module and the concept of an interpreter for them. + + It's considerably shorter, and most likely faster (although I haven't + benchmarked them). + +Is it more elegant? I'm not sure. There was a great elegance about the +concept of an Abstract Pattern Instruction, with a front end compiling a +pattern into a list of APIs, and a back end interpreting them to perform +the pattern match. On the other hand, there was a certain elegance about +the concept of fixed width islands, either matched at a fixed location, +or matched floating about, and the startpos array. diff --git a/challenge-099/duncan-c-white/opt1-noFL/API.pm b/challenge-099/duncan-c-white/opt1-noFL/API.pm new file mode 100644 index 0000000000..2d8d23f0bd --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/API.pm @@ -0,0 +1,255 @@ +package API; + +# automatically generated implementation of recursive data type +# API = A(string lit,posexpr at,string name) +# or M(string lit,posexpr atorafter,string name) +# or T(posexpr pe1,string op,posexpr pe2) +# or C(posexpr pe1,posexpr pe2) + + +use strict; +use warnings; +use feature 'say'; + +use overload '""' => \&as_string; +use overload 'eq' => \&streq; + + + +# API->A: Constructor or get method, use: +# my $obj = API->A($lit, $at, $name) OR +# my ($lit, $at, $name) = $obj->A +sub A ($;$$$) +{ + my( $thing, $lit, $at, $name ) = @_; + if( @_ == 4 ) # constructor + { + die "API->A: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["A", $lit, $at, $name], "API"; + } else # get method + { + die "API->A: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->A: malformed object $thing\n" + unless @x == 3 && $t eq "A"; + return @x; + } +} + + +# API->M: Constructor or get method, use: +# my $obj = API->M($lit, $atorafter, $name) OR +# my ($lit, $atorafter, $name) = $obj->M +sub M ($;$$$) +{ + my( $thing, $lit, $atorafter, $name ) = @_; + if( @_ == 4 ) # constructor + { + die "API->M: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["M", $lit, $atorafter, $name], "API"; + } else # get method + { + die "API->M: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->M: malformed object $thing\n" + unless @x == 3 && $t eq "M"; + return @x; + } +} + + +# API->T: Constructor or get method, use: +# my $obj = API->T($pe1, $op, $pe2) OR +# my ($pe1, $op, $pe2) = $obj->T +sub T ($;$$$) +{ + my( $thing, $pe1, $op, $pe2 ) = @_; + if( @_ == 4 ) # constructor + { + die "API->T: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["T", $pe1, $op, $pe2], "API"; + } else # get method + { + die "API->T: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->T: malformed object $thing\n" + unless @x == 3 && $t eq "T"; + return @x; + } +} + + +# API->C: Constructor or get method, use: +# my $obj = API->C($pe1, $pe2) OR +# my ($pe1, $pe2) = $obj->C +sub C ($;$$) +{ + my( $thing, $pe1, $pe2 ) = @_; + if( @_ == 3 ) # constructor + { + die "API->C: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["C", $pe1, $pe2], "API"; + } else # get method + { + die "API->C: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->C: malformed object $thing\n" + unless @x == 2 && $t eq "C"; + return @x; + } +} + + +sub kind ($) +{ + my( $self ) = @_; + die "API->kind: $self is not a API\n" + unless ref($self) eq "API"; + return $self->[0]; +} + + +sub as_string ($) +{ + my( $self ) = @_; + die "API->as_string: $self is not a API\n" + unless ref($self) eq "API"; + my @x = @$self; + my $t = shift @x; + + # stringify all params + @x = map { "$_" } @x; + + # specific printing rules + return "A'$x[0]' $x[1]->$x[2]" if $t eq 'A'; + return "C $x[0] $x[1]" if $t eq 'C'; + return "M'$x[0]' $x[1]->$x[2]" if $t eq 'M'; + return "T$x[0]$x[1]$x[2]" if $t eq 'T'; + + # general case + my $args = join( ',', @x ); + return $args ne "" ? "$t($args)" : "$t"; +} + + + +sub streq ($$) +{ + my( $a, $b ) = @_; + #print "API->streq called with a=$a, b=$b\n"; + return "$a" eq "$b" ? 1 : 0; # the sneaky way +} + + + + +my $debug = 0; +sub setdebug { my($d) = @_; $debug = $d; } + +# +# my @api = parse( $input ); +# Parse $input, a string containing a comma-separated sequence +# of Abstract Pattern Instructions, return the list of apis. +# Die screaming if parsing fails. +# For example, the pattern a*e is represented by the +# following api string: +# A'a' 0->a,A'e' slen-1->e,Te>a-1,C a+1 e-1 +# (where slen is a runtime variable representing the length of +# the target string these APIs would eventually operate on). +# +# The individual api forms are: +# M'str' posexpr->name +# A'str' posexpr->name +# Tposexpr ('>'|'='|'>=') posexpr +# C posexpr [posexpr] +# where posexpr = \d+ or name or name '+'|'-' \d+ (see module PosExpr) +# +sub parse ($) +{ + my( $input ) = @_; + my @result; + while( $input ) + { + # M'str' posexpr->name + if( $input =~ s/^M\s*// ) + { + $input =~ s/^'([^']+)'\s+// || + die "bad input $input in M..\n"; + my $str = $1; + (my $pe,$input) = PosExpr::parse($input); + die "bad input $input in M$str $pe...\n" + unless $input =~ s/^\s*->\s*(\w+)//; + my $pname = $1; + my $api = API->M($str, $pe, $pname); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # A'str' posexpr->name + elsif( $input =~ s/^A\s*// ) + { + $input =~ s/^'([^']+)'\s+// || + die "bad input $input in A..\n"; + my $str = $1; + (my $pe,$input) = PosExpr::parse($input); + die "bad input $input in A$str $pe...\n" + unless $input =~ s/^\s*->\s*(\w+)//; + my $pname = $1; + my $api = API->A($str, $pe, $pname); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # Tposexpr ('>'|'='|'>=') posexpr + elsif( $input =~ s/^T\s*// ) + { + (my $pe,$input) = PosExpr::parse($input); + $input =~ s/^(>=|>|=)// || + die "bad input $input in T$pe, ". + "'>','=' or '>=' expected\n"; + my $op = $1; + (my $pe2,$input) = PosExpr::parse($input); + my $api = API->T($pe, $op, $pe2); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # C posexpr [posexpr] + elsif( $input =~ s/^C\s*// ) + { + (my $pe,$input) = PosExpr::parse($input); + $input =~ s/^\s*//; + + # second posexpr is optional: + # present if next ch is not ',' + my $pe2 = $pe; + if( $input ne '' && $input !~ /^,/ ) + { + ($pe2,$input) = PosExpr::parse($input); + } + my $api = API->C($pe, $pe2); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + $input =~ s/^\s*,\s*//; + } + die "bad input $input, non empty but not M|T|C..\n" if $input; + return @result; +} + + +1; + diff --git a/challenge-099/duncan-c-white/opt1-noFL/Interpreter.pm b/challenge-099/duncan-c-white/opt1-noFL/Interpreter.pm new file mode 100644 index 0000000000..4e2e29fb1a --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/Interpreter.pm @@ -0,0 +1,123 @@ +package Interpreter; + +# Here's the interpreter for a list of APIs. This is the guts of +# pattern matching. + +use strict; +use warnings; +use feature 'say'; +use Function::Parameters; +use Data::Dumper; +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(interprete); # Export on demand + +use lib qw(.); +use API; +use PosExpr; + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; } + + +# +# my @litpos = findliteral( $lit, $p, $s ); +# Find all instances of $lit atorafter position $p in $s, +# build and return a list of possible starting positions. +# +fun findliteral( $lit, $p, $s ) +{ + my $slen = length($s); + my $llen = length($lit); + my @result = grep { substr($s,$_,$llen) eq $lit; } $p..$slen-1; + #die "findliteral: lit=$lit, s=$s, results=".Dumper(\@result); + return @result; +} + + +# +# my $match = interprete( $s, $apilist, $poshash, $mtlist ); +# Interprete @$apilist against the string $s, using (and modifying) +# %$poshash which maps names to their positions. +# Return 1 for a match (filling in @$mtlist) or 0 for no match. +# +fun interprete( $s, $apilist, $poshash, $mtlist ) +{ + my $slen = length($s); + my $n = 0; + foreach my $api (@$apilist) + { + my $kind = $api->kind; + if( $kind eq 'A' ) # Match at pos + { + my( $lit, $at, $name ) = $api->A; + my $pos = $at->eval($poshash); + return 0 unless substr($s,$pos,length($lit)) eq $lit; + $poshash->{$name} = $pos; + say "debug: A: set pos[$name] = $pos" if $debug; + } + elsif( $kind eq 'M' ) # Match at or after - tricky + { + my( $lit, $atorafterpos, $name ) = $api->M; + my $atorafter = $atorafterpos->eval($poshash); + my @litpos = findliteral( $lit, $atorafter, $s ); + return 0 if @litpos==0; + + # must try each possible position in @litpos in turn + if( @litpos == 1 ) + { + $poshash->{$name} = $litpos[0]; + say "debug: M: set pos[$name] = $litpos[0]" if $debug; + } else + { + say "debug: M: try each pos ".join(',',@litpos) if $debug; + # Try the rest of the api list.. + my @restapi = @$apilist[$n+1..$#$apilist]; + + # for each possible pos of the match + foreach my $pos (@litpos) + { + $poshash->{$name} = $pos; + say "debug: try pos[$name] = $pos" if $debug; + my $match = interprete( + $s, \@restapi, $poshash, $mtlist ); + say "debug: matchrest = $match" if $debug; + return 1 if $match; + undef $poshash->{$name}; + } + return 0; + } + } + elsif( $kind eq 'T' ) + { + my( $pe1, $op, $pe2 ) = $api->T; + my $pv1 = $pe1->eval($poshash); + my $pv2 = $pe2->eval($poshash); + return 0 if $op eq '>' && $pv1 <= $pv2; + return 0 if $op eq '>=' && $pv1 < $pv2; + return 0 if $op eq '=' && $pv1 != $pv2; + say "debug: test $api succeeded" if $debug; + } + elsif( $kind eq 'C' ) + { + my ($pe1, $pe2) = $api->C; + my $from = $pe1->eval($poshash); + my $to = $pe2->eval($poshash); + my $cap = substr($s,$from,$to-$from+1) // ''; + my $mn = @$mtlist; + push @$mtlist, $cap; + say "debug: C: set mt[$mn] to $cap" if $debug; + } + else + { + die "interprete: not yet implemented $kind\n"; + } + $n++; + } + return 1; +} + + +1; diff --git a/challenge-099/duncan-c-white/opt1-noFL/PosExpr.pm b/challenge-099/duncan-c-white/opt1-noFL/PosExpr.pm new file mode 100644 index 0000000000..dbeef03ff4 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/PosExpr.pm @@ -0,0 +1,253 @@ +package PosExpr; + +# automatically generated implementation of recursive data type +# PosExpr = I(int n) +# or N(string name) +# or NO(string name,char op,int n) + + +use strict; +use warnings; +use feature 'say'; + +use overload '""' => \&as_string; +use overload 'eq' => \&streq; + + + +# PosExpr->I: Constructor or get method, use: +# my $obj = PosExpr->I($n) OR +# my $n = $obj->I +sub I ($;$) +{ + my( $thing, $n ) = @_; + if( @_ == 2 ) # constructor + { + die "PosExpr->I: classname $thing is not 'PosExpr'\n" + unless $thing eq "PosExpr"; + return bless ["I", $n], "PosExpr"; + } else # get method + { + die "PosExpr->I: $thing is not a PosExpr\n" + unless ref($thing) eq "PosExpr"; + my @x = @$thing; + my $t = shift @x; + die "PosExpr->I: malformed object $thing\n" + unless @x == 1 && $t eq "I"; + return $x[0]; + } +} + + +# PosExpr->N: Constructor or get method, use: +# my $obj = PosExpr->N($name) OR +# my $name = $obj->N +sub N ($;$) +{ + my( $thing, $name ) = @_; + if( @_ == 2 ) # constructor + { + die "PosExpr->N: classname $thing is not 'PosExpr'\n" + unless $thing eq "PosExpr"; + return bless ["N", $name], "PosExpr"; + } else # get method + { + die "PosExpr->N: $thing is not a PosExpr\n" + unless ref($thing) eq "PosExpr"; + my @x = @$thing; + my $t = shift @x; + die "PosExpr->N: malformed object $thing\n" + unless @x == 1 && $t eq "N"; + return $x[0]; + } +} + + +# PosExpr->NO: Constructor or get method, use: +# my $obj = PosExpr->NO($name, $op, $n) OR +# my ($name, $op, $n) = $obj->NO +sub NO ($;$$$) +{ + my( $thing, $name, $op, $n ) = @_; + if( @_ == 4 ) # constructor + { + die "PosExpr->NO: classname $thing is not 'PosExpr'\n" + unless $thing eq "PosExpr"; + return bless ["NO", $name, $op, $n], "PosExpr"; + } else # get method + { + die "PosExpr->NO: $thing is not a PosExpr\n" + unless ref($thing) eq "PosExpr"; + my @x = @$thing; + my $t = shift @x; + die "PosExpr->NO: malformed object $thing\n" + unless @x == 3 && $t eq "NO"; + return @x; + } +} + + +sub kind ($) +{ + my( $self ) = @_; + die "PosExpr->kind: $self is not a PosExpr\n" + unless ref($self) eq "PosExpr"; + return $self->[0]; +} + + +sub as_string ($) +{ + my( $self ) = @_; + die "PosExpr->as_string: $self is not a PosExpr\n" + unless ref($self) eq "PosExpr"; + my @x = @$self; + my $t = shift @x; + + # stringify all params + @x = map { "$_" } @x; + + # specific printing rules + return "$x[0]" if $t eq 'I'; + return "$x[0]" if $t eq 'N'; + return "$x[0]$x[1]$x[2]" if $t eq 'NO'; + + # general case + my $args = join( ',', @x ); + return $args ne "" ? "$t($args)" : "$t"; +} + + + +sub streq ($$) +{ + my( $a, $b ) = @_; + #print "PosExpr->streq called with a=$a, b=$b\n"; + return "$a" eq "$b" ? 1 : 0; # the sneaky way +} + + + + +my $debug = 0; +sub setdebug { my($d) = @_; $debug = $d; } + +# +# my($pe,$leftover) = parse($input); +# Parse $input, a string starting with a position expression, +# delivering the position expression in $pe and the leftover +# input in $leftover. Die screaming if no well formed pos expr +# can be found at the start of $input. +# A position expression is either \d+ or name or name '+'|'-' \d+ +# The internal form of a posexpr is ['I', int const] or ['N', name] +# or ['NO', name, +-, offset] +# +sub parse ($) +{ + my( $input ) = @_; + if( $input =~ s/^(\d+)\s*// ) + { + return ( PosExpr->I($1), $input ); + } + $input =~ s/^(\w+)\s*// || + die "bad input in pos expr $input, name expected\n"; + my $name = $1; + if( $input =~ s/^([\+-])\s*(\d+)\s*// ) + { + if( $2 == 0 ) + { + return ( PosExpr->N($name), $input ); + } else + { + return ( PosExpr->NO($name,$1,$2), $input ); + } + } + return ( PosExpr->N($name), $input ); +} + +# +# my $pe = simpleparse($str); +# Parse a position expression out of $str. Fail if there's +# anything left over. +# +sub simpleparse ($) +{ + my( $str ) = @_; + my($pe,$leftover) = parse($str); + die "PosExpr->simpleparse($str): left over $leftover after pe $pe\n" + if $leftover; + return $pe; +} + + +# +# my $newpe = $pe->add($n); +# Arithmetic on PosExprs: add $n (an integer) +# to $pe, giving $newpe. +# +sub add +{ + my( $self, $n ) = @_; + return $self if $n==0; + if( $self->kind eq 'I' ) + { + my $x = $self->I; + return PosExpr->I( $x+$n ); + } elsif( $self->kind eq "N" ) + { + my $name = $self->N; + my $op = $n>0?'+':'-'; + $n = abs($n); + return PosExpr->NO( $name, $op, $n ); + } else + { + # .. NO( string name, char op, int n ) + my( $name, $op, $x ) = $self->NO; + $x = -$x if $op eq '-'; + $op = '+'; + $x += $n; + return PosExpr->N( $name ) if $x==0; + $op = '-' if $x<0; + $x = abs($x); + return PosExpr->NO( $name, $op, $x ); + } +} + + +# +# my $pos = $pe->eval($poshash); +# Evaluate the given PosExpr $pe, using %$poshash +# for name lookup. Returns the actual position (a number). +# +sub eval ($$) +{ + my( $self, $poshash ) = @_; + if( $self->kind eq 'I' ) + { + return $self->I; + } elsif( $self->kind eq 'N' ) + { + my $name = $self->N; + die "error in PosExpr::eval($self): ". + "no such name $name in poshash ". Dumper($poshash) + unless exists $poshash->{$name}; + return $poshash->{$name}; + } else # if( $self->kind eq 'NO' ) + { + my ($name, $op, $n) = $self->NO; + die "error in PosExpr::eval($self): ". + "no such name $name in poshash ". Dumper($poshash) + unless exists $poshash->{$name}; + die "error in PosExpr::eval($self): bad op $op\n" unless + $op eq '+' || $op eq '-'; + $n = - $n if $op eq '-'; + return $poshash->{$name} + $n; + } +} + + + + + +1; + diff --git a/challenge-099/duncan-c-white/opt1-noFL/README b/challenge-099/duncan-c-white/opt1-noFL/README new file mode 100644 index 0000000000..29e7be5d6f --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/README @@ -0,0 +1,5 @@ +In this version, I've remove F'str'->name and L'str'->name APIs, +because after all F and L are just special cases of A'str' pos->name, +(pos=0 for F, and pos=slen-length(str) for L). + +This saves about 100 lines overall.. diff --git a/challenge-099/duncan-c-white/opt1-noFL/TestMatch.pm b/challenge-099/duncan-c-white/opt1-noFL/TestMatch.pm new file mode 100644 index 0000000000..9cfac08f40 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/TestMatch.pm @@ -0,0 +1,75 @@ +package TestMatch; + +use strict; +use warnings; +use feature 'say'; +use Data::Dumper; +use Function::Parameters; +use Test::More; + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(match_tests); # Export on demand + +use lib qw(.); +use API; + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; } + + +# +# match_tests( $patmatch ); +# Do a load of match tests using the $patmatch->() function, using the +# pattern only for info: we are really matching the string against +# the api list. +# +fun match_tests( $patmatch ) +{ + # format of each match test: S:P:API(p):expmatch:expmt + my @matchtests = ( + "abcde:abcde:Tslen=5,A'abcde' 0->a:1:", + "abcdef:abcde:Tslen=5,A'abcde' 0->a:0:", + "abcde:abcdef:Tslen=6,A'abcdef' 0->a:0:", + "abcde:*:C 0 slen-1:1:abcde", + "abcde:a*e:A'a' 0->a,A'e' slen-1->e,Te>a,C a+1 e-1:1:bcd", + "abcde:abc*de:A'abc' 0->a,A'de' slen-2->d,Td>a+2,C a+3 d-1:1:__empty__", + "abcde:a*d:A'a' 0->a,A'd' slen-1->d,Td>a-1,C a+1 d-1:0:", + "abcde:?b*d:A'd' slen-1->d,A'b' 1->b,C 0,C b+1 d-1:0:", + "abcde:?b*e:A'e' slen-1->e,A'b' 1->b,C 0,C b+1 e-1:1:a,cd", + "abcde:a*c?e:A'a' 0->a,A'e' slen-1->e,A'c' e-2->c,". + "C a+1 c-1,C c+1:1:b,d", + "hellotherehowareyou:*ll*u:A'u' slen-1->u,M'll' 0->l,Tu>=l,". + "C 0 l-1,C l+2 u-1:1:he,otherehowareyo", # my example.. + ); + + #say "matchtests=". Dumper(\@matchtests); + foreach my $test (@matchtests) + { + #say "test $test"; + my( $s, $p, $api, $expmatch, $expmts ) = split( /:/, $test ); + $expmatch //= '0'; + my @expectedmt = map { /^__empty__$/ ? '' : $_ } + split(/,/,$expmts); + my @api = API::parse( $api ); + my( $match, @mt ) = $patmatch->( $s, @api ); + #say "p=$p, s=$s, match=$match, mt=".Dumper(\@mt); + is( $match, $expmatch, "match($s,$p)=$expmatch" ); + if( $match ) + { + my $nmatch = @expectedmt; + is( scalar(@mt), $nmatch, + "match($s,$p).#mt==$nmatch" ); + foreach my $i (0..$#mt) + { + is( $mt[$i], $expectedmt[$i], + "match($s,$p).mt[$i]==$expectedmt[$i]" ); + } + } + } +} + + +1; diff --git a/challenge-099/duncan-c-white/opt1-noFL/TestMatch2.pm b/challenge-099/duncan-c-white/opt1-noFL/TestMatch2.pm new file mode 100644 index 0000000000..484019e186 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/TestMatch2.pm @@ -0,0 +1,102 @@ +package TestMatch2; + +use strict; +use warnings; +use feature 'say'; +use Data::Dumper; +use Function::Parameters; +use Test::More; + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(match_tests); # Export on demand + +use lib qw(.); +use Translate qw(pat2apis); + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; Translate::setdebug($d); } + + +# +# match_tests( $patmatch ); +# Do a load of match tests, using the $patmatch->() function, +# really using the pattern this time. we compile each pattern into +# a api list, then string match the string against the api list. +# +fun match_tests( $patmatch ) +{ + # format of each match test: S:P:expmatch:expmt + my @matchtests = ( + "abcde:abcde:1:", + "abcdef:abcde:0:", + "abcde:abcdef:0:", + "abcde:*:1:abcde", + "abcde:a*e:1:bcd", + "abcde:abc*de:1:__empty__", + "abcde:a*d:0:", + "abcde:?b*d:0:", + "abcde:?b*e:1:a,cd", + "abcde:a*c?e:1:b,d", + + # and here some of my own examples.. + "hellotherehowareyou:*ll*u:1:he,otherehowareyo", + "hellu:*ll*u:1:he,__empty__", + "hellou:*ll*u:1:he,o", + "helloyu:*ll*u:1:he,oy", + "helloyou:*ll*u:1:he,oyo", + "hellohellohelloyou:*ll*u:1:he,ohellohelloyo", + + "hlo:h*?l*:0:", + "hel:h*?l*:1:__empty__,e,__empty__", + "helo:h*?l*:1:__empty__,e,o", + "hello:h*?l*:1:__empty__,e,lo", + "heello:h*?l*:1:e,e,lo", + "heauellooo:h*?l*:1:eau,e,looo", + + "mississippi:*s*:1:mi,sissippi", + "mississippi:*ss*:1:mi,issippi", + "mississippi:*ss*s*:1:mi,i,sippi", + "mississippi:*ss*ss*:1:mi,i,ippi", + "mississippi:*ss*ss*p*:1:mi,i,i,pi", + "mississippi:*ss*ss*pp*:1:mi,i,i,i", + "mississippi:*ss*ss*p?*:1:mi,i,i,p,i", + "mississippi:*ss*ss*?p?*:1:mi,i,,i,p,i", + "mississippi:*is*:1:m,sissippi", + "mississippi:*mis*:1:,sissippi", + "mississippi:*mi?*:1:,s,sissippi", + ); + + #say "matchtests=". Dumper(\@matchtests); + foreach my $test (@matchtests) + { + #say "test $test"; + my( $s, $p, $expmatch, $expmts ) = split( /:/, $test ); + $expmatch //= '0'; + my @expectedmt = map { /^__empty__$/ ? '' : $_ } + split(/,/,$expmts); + my @api = pat2apis( $p ); + say "apis:" if $debug; + say join("\n", map { " $_" } @api ) if $debug; + + my( $match, @mt ) = $patmatch->( $s, @api ); + #say "p=$p, s=$s, match=$match, mt=".Dumper(\@mt); + is( $match, $expmatch, "match($s,$p)=$expmatch" ); + if( $match ) + { + my $nmatch = @expectedmt; + is( scalar(@mt), $nmatch, + "match($s,$p).#mt==$nmatch" ); + foreach my $i (0..$#mt) + { + is( $mt[$i], $expectedmt[$i], + "match($s,$p).mt[$i]==$expectedmt[$i]" ); + } + } + } +} + + +1; diff --git a/challenge-099/duncan-c-white/opt1-noFL/TestPE.pm b/challenge-099/duncan-c-white/opt1-noFL/TestPE.pm new file mode 100644 index 0000000000..17837f2410 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/TestPE.pm @@ -0,0 +1,79 @@ +package TestPE; + +use strict; +use warnings; +use feature 'say'; +use Data::Dumper; +use Function::Parameters; +use Test::More; + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(pe_tests); # Export on demand + +use lib qw(.); +use PosExpr; + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; } + + +# +# pe_tests(); +# Do a load of PosExpr tests. +# +sub pe_tests +{ + # format of each PosExpr test: pe:op:arg:result + my @petests = ( + "10:parse::10", + "x:parse::x", + "x,y:parse:,y:x", + "x,y+7:parse:,y+7:x", + "x+1,z:parse:,z:x+1", + "x+17:parse::x+17", + "x-17:parse::x-17", + "10:add:10:20", + "10:add:-10:0", + "x:add:10:x+10", + "x+10:add:10:x+20", + "x+10:add:-10:x", + "x-1:add:1:x", + "x-1:add:2:x+1", + "x-1:add:-1:x-2", + "1:eval:3:1", + "x:eval:3:3", + "x-1:eval:3:2", + "x+7:eval:3:10", + ); + + #say "petests=". Dumper(\@petests); + foreach my $test (@petests) + { + #say "test $test"; + my( $pstr, $op, $arg, $expresult ) = split( /:/, $test ); + my($pe,$leftover) = PosExpr::parse($pstr); + if( $op eq "parse" ) + { + is( "$pe", $expresult, "parse($pstr)==$expresult" ); + is( $leftover, $arg, "parse($pstr).leftover==$arg" ); + } elsif( $op eq "add" ) + { + $pe = $pe->add( $arg ); + is( "$pe", $expresult, "add($pstr,$arg)==$expresult" ); + } elsif( $op eq "eval" ) + { + my $result = $pe->eval( { 'x' => $arg } ); + is( $result, $expresult, + "eval($pstr w x=$arg)==$expresult" ); + } else + { + die "bad test $test\n"; + } + } +} + + +1; diff --git a/challenge-099/duncan-c-white/opt1-noFL/TestPat2Api.pm b/challenge-099/duncan-c-white/opt1-noFL/TestPat2Api.pm new file mode 100644 index 0000000000..5c9074aae7 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/TestPat2Api.pm @@ -0,0 +1,64 @@ +package TestPat2Api; + +# +# Tests +# + +use strict; +use warnings; +use feature 'say'; +use Data::Dumper; +use Function::Parameters; +use Test::More; + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(pat2api_tests); # Export on demand + +use lib qw(.); +use PosExpr; +use API; +use Translate qw(pat2apis); + + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; } + + +# +# pat2api_tests(); +# Do a load of pat2api tests. +# +sub pat2api_tests +{ + # format of each pat2api test: P:API(p) + our @pat2apitests = ( + "*:C 0 slen-1", + "abcde:Tslen=5,A'abcde' 0->a", + "abcdef:Tslen=6,A'abcdef' 0->a", + "abc?e?:Tslen=6,A'abc' 0->a,A'e' a+4->e,C a+3 a+3,C e+1 e+1", + "a*e:Tslen>=2,A'a' 0->a,A'e' slen-1->e,Te>=a+1,C a+1 e-1", + "ab*e:Tslen>=3,A'ab' 0->a,A'e' slen-1->e,Te>=a+2,C a+2 e-1", + "ab*de:Tslen>=4,A'ab' 0->a,A'de' slen-2->d,Td>=a+2,C a+2 d-1", + "abc*de:Tslen>=5,A'abc' 0->a,A'de' slen-2->d,Td>=a+3,C a+3 d-1", + "?b*d:Tslen>=3,A'b' 1->b,A'd' slen-1->d,Td>=b+1,C 0 0,C b+1 d-1", + "?bc*e:Tslen>=4,A'bc' 1->b,A'e' slen-1->e,Te>=b+2,C 0 0,C b+2 e-1", + # optimal for "a*c?e is Tslen>=4,A'a' 0->a,A'e' slen-1->e,A'c' e-2->c,C a+1 c-1,C c+1", + "a*c?e:Tslen>=4,A'a' 0->a,A'c' slen-3->c,A'e' c+2->e,Te-2>=a+1,C a+1 e-3,C c+1 c+1", + "*ll*u:Tslen>=3,A'u' slen-1->u,M'll' 0->l,Tu>=l+2,C 0 l-1,C l+2 u-1", # my example.. + ); + + say "pat2apitests=". Dumper(\@pat2apitests) if $debug; + foreach my $test (@pat2apitests) + { + say "test $test" if $debug; + my( $pat, $expectedapi ) = split( /:/, $test ); + my @api = pat2apis( $pat ); + my $apistr = join( ',', map { "$_" } @api ); + is( $apistr, $expectedapi, "pat2apis($pat)=$expectedapi" ); + } +} + +1; diff --git a/challenge-099/duncan-c-white/opt1-noFL/Translate.pm b/challenge-099/duncan-c-white/opt1-noFL/Translate.pm new file mode 100644 index 0000000000..a9f2c4cadd --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/Translate.pm @@ -0,0 +1,302 @@ +package Translate; + +# +# Contains the code to Translate a pattern to a list of APIs. +# + +use strict; +use warnings; +use Getopt::Long; +use feature 'say'; +use Function::Parameters; +use Data::Dumper; + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(pat2apis); # Export on demand + +use lib qw(.); +use API; +use PosExpr; + + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; } + + +# +# my $name = str2name($str); +# Given a string literal $str, determine a unique pos +# name $name. Usually this is the first letter of $str +# followed by a disambiguating number. +# +my %knownstr2name; +fun str2name( $str ) +{ + die "str2name: empty str $str!\n" unless $str; + $str =~ /^(.)/; + my $first = $1; + $first = 'p' unless $first =~ /^[0-9a-z]/; # if not alphanumeric.. + if( exists $knownstr2name{$first} ) + { + my $i; + for( $i=1; exists $knownstr2name{"$first$i"}; $i++ ) + { + } + $knownstr2name{"$first$i"}++; + return "$first$i"; + } + $knownstr2name{$first}++; + return $first; +} + + +# +# my $api = mkapi( $str ); +# Wrapper: Turns a string into an API element or dies trying. +# +fun mkapi( $str ) +{ + my @api = API::parse($str); + if( $debug ) + { + $str =~ /^(.)/; # grab first char + my $msg = $1 eq 'C' ? 'capture' : '+'; + say "$msg $str"; + } + return $api[0]; +} + +# +# my $pe = sp( $str ); +# Wrapper: Turns a string into a PosExpr or dies trying. +# +fun sp( $str ) { return PosExpr::simpleparse($str); } + + +# +# my( $newlpos, @api ) = fixedisland( $island, $lpos, $captures ); +# We have a fixed-width island (a pattern with no '*'s) called $island, +# which must start at posexpr $lpos (so it can be symbolic). +# Translate the island into a list of APIs, and return that list along +# with the new lpos after matching it. +# Store any associated text captures (also APIs) in @$captures in left +# to right order (one capture per '?') - they will be added to the final +# list of apis at the end of the whole pattern match (NOT HERE). +# +fun fixedisland( $island, $lpos, $captures ) +{ + say "island $island @ $lpos" if $debug; + if( $island !~ /\?/ ) # string literal? + { + my $name = str2name($island); + my $l = length($island); + my $api = mkapi("A'$island' $lpos->$name"); + $lpos = sp("$name+$l"); + return ( $lpos, $api ); + } + + # ok, the island has at least one '?', maybe more + # build captures as we go along, from left to right + my @api; + while( $island ) + { + if( $island =~ s/^([^?]+)// ) + { + my $str = $1; # strlit at lpos + my $l = length($str); + my $name = str2name($str); + say "str=$str, name=$name, remaining island=$island"; + my $api = mkapi("A'$str' $lpos->$name"); + push @api, $api; + my $advance = length($str); + $lpos = sp("$name+$advance"); + } else + { + $island =~ s/^\?//; + # found a '?' + push @$captures, mkapi("C $lpos"); + $lpos = $lpos->add(1); + } + say "debug: island now $island, lpos now $lpos" if $debug; + } + return ( $lpos, @api ); +} + + +# +# my( $newlpos, @api ) = floatingisland( $island, $lpos, $rpos, $captures ); +# Look for a "floating island" $island at or after position $lpos, +# and allowed to extend up to position $rpos. Return the new lpos "after +# the island" and the list of generated API instructions, and append any +# captures (in left to right order) onto @$captures. +# +fun floatingisland( $island, $lpos, $rpos, $captures ) +{ + my @api; + if( $island !~ /\?/ ) # if the island is a literal... + { + my $name = str2name($island); + my $l = length($island); + push @api, mkapi("M'$island' $lpos->$name"); + + my $pos = $rpos->add(1); + push @api, mkapi("T$pos>=$name+$l"); + + push @$captures, mkapi("C $lpos $name-1"); + + $lpos = sp("$name+$l"); + return( $lpos, @api ); + } + + # otherwise island contains at least one '?' + # find first strlit in $island, counting how many '?'s + # come before it. + my $nq = 0; + while( $island =~ s/^\?// ) + { + $nq++; + } + say "debug: floatisland: found nq=$nq '?'s before first strlit" + if $debug; + + $island =~ s/^([^?]+)//; # find and remove first strlit + my $str = $1; + my $l = length($str); + my $name = str2name($str); + my $p = $lpos->add($nq); # form lpos+nq: the first poss + # position that could match + # the first strlit $str + push @api, mkapi("M'$str' $p->$name" ); + + # generate a capture for the '*' before this island starts + $p = sp("$name-". ($nq+1) ); + push @$captures, mkapi("C $lpos $p"); + + # now generate captures for each of $nq '?'s before the $str + for( my $i=0; $i<$nq; $i++ ) + { + $p = $p->add(1); + push @$captures, mkapi("C $p"); + } + + # now deal with the rest of the floating island, starting at: + $lpos = sp("$name+$l"); + + # could be empty + return ( $lpos, @api ) unless $island; + + # the rest of it is by definition a fixed island starting @ $name+$l + ( $lpos, my @newapi ) = + fixedisland( $island, $lpos, $captures ); + push @api, @newapi; + return ( $lpos, @api ); +} + + +# +# my $nfix = countfixed( $pat ); +# Count the number of fixed-width elements in $pat, ie. +# literal characters and '?' - anything but '*' in fact. +# +fun countfixed( $pat ) +{ + my $result = grep { $_ ne '*' } split(//,$pat); + return $result; +} + + +# +# my @api = pat2apis( $pat ); +# Translate pattern $pat into a list of API objects. +# +fun pat2apis( $pat ) +{ + my $lpos = sp('0'); + my $rpos = sp('slen-1'); + return mkapi( "C $lpos $rpos" ) if $pat eq '*'; # special case + + %knownstr2name = (); # empty str2name cache + + my @api; + my @captures; + + my $nfix = countfixed( $pat ); + my $len = length($pat); + + if( $nfix == $len ) # if the whole pattern is fixed - no '*' + { + push @api, mkapi("Tslen=$len"); # Test length + ($lpos, my @islandapi ) = + fixedisland( $pat, $lpos, \@captures ); + push @api, @islandapi, @captures; + return @api; + } + + # ok, there's at least 1 '*'.. test the string is long enough, $nfix + # (the number of fixed elements in the pattern) is the minimum length + if( $nfix > 0 ) + { + push @api, mkapi("Tslen>=$nfix"); + } + + $pat =~ s/^([^*]*)//; # find first island (if any) + my $island = $1; + if( $island ) + { + ($lpos, my @islandapi ) = + fixedisland( $island, $lpos, \@captures ); + push @api, @islandapi; + } + + $pat =~ s/([^*]*)$//; # find trailing island (if any) + $island = $1; + my @finalcaptures; + if( $island ) + { + my $l = length($island); + my $p = sp("slen-$l"); + my( $lastislandlpos, @islandapi ) = + fixedisland( $island, $p, \@finalcaptures ); + push @api, @islandapi; + $rpos = $lastislandlpos->add(-($l+1)); + # NB: need to append @finalcaptures to @captures at the end, + # before appending @captures to @api. + } + + # now, pattern comprises * or *island* or *island*island...* + say "middle part ($pat), rpos=$rpos, lpos=$lpos" + if $debug; + if( $pat eq '*' ) + { + my $p = $rpos->add(1); + push @api, mkapi("T$p>=$lpos"); + + push @captures, mkapi("C $lpos $rpos"); + } else + { + $pat =~ s/^\*//; # remove leading '*' + while( $pat && $pat =~ s/^([^*]+)\*// ) + { + my $float = $1; + say "found * floatingisland '$float' *, lpos=$lpos, ". + "rpos=$rpos" if $debug; + ( $lpos, my @fapi ) = + floatingisland( $float, $lpos, $rpos, \@captures ); + push @api, @fapi; + } + + die "pat2apis: logic error, $pat should be empty\n" if $pat; + + # add the capture for the final '*' + push @captures, mkapi("C $lpos $rpos"); + } + + push @api, @captures, @finalcaptures; + return @api; +} + + +1; diff --git a/challenge-099/duncan-c-white/opt1-noFL/ch-1a.pl b/challenge-099/duncan-c-white/opt1-noFL/ch-1a.pl new file mode 100755 index 0000000000..18dae25be4 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/ch-1a.pl @@ -0,0 +1,127 @@ +#!/usr/bin/perl +# +# Task 1: "Pattern Match +# +# You are given a string $S and a pattern $P. +# +# Write a script to check if given pattern validate the entire string. Print +# 1 if pass otherwise 0. +# +# The patterns can also have the following characters: +# ? - Match any single character. +# * - Match any sequence of characters. +# +# Example 1: +# Input: $S = "abcde" $P = "a*e" +# Output: 1 +# +# Example 2: +# Input: $S = "abcde" $P = "a*d" +# Output: 0 +# +# Example 3: +# Input: $S = "abcde" $P = "?b*d" +# Output: 0 +# +# Example 4: +# Input: $S = "abcde" $P = "a*c?e" +# Output: 1 +# " +# +# My notes: oh, cool, simpler than regexes, but nice. Two basic ways of +# doing this: 1). translate it into a regex and use Perl's regex matching, +# 2). figure out a from-scratch mechanism to solve this problem. +# In this version (having already got (1) working in ch-1.pl), let's do (2). +# I've invented "Abstract Pattern Instructions (APIs)", and am writing an +# interpreter for them in order to do the matching. To make life interesting, +# let's also capture the matching text for each '?' and '*'. I've got this +# working; see API.pm and PosExpr.pm too.. +# +# Of course, for a full solution, I also need to work out how to translate +# our patterns into a list of APIs. But I haven't done that yet. So, +# this is an incomplete proof-of-concept, that "interpreting a list of APIs" +# will do pattern matching, even if I don't yet know how to build the api list +# from a pattern. +# +# Note: I also added a test suite (the above examples) with --test. +# + +use strict; +use warnings; +use Getopt::Long; +use feature 'say'; +use Function::Parameters; +use Data::Dumper; + +use lib qw(.); +use API; +use PosExpr; +use Interpreter qw(interprete); + +my $debug=0; +my $test=0; + +die "Usage: pattern-match [--test] [--debug]\n". + "Or... pattern-match [--debug] S csvlist(API)\n" + unless GetOptions( "debug" => \$debug, "test" => \$test ) + && ($test && @ARGV==0 || !$test && @ARGV>=2); +API::setdebug( $debug ); +PosExpr::setdebug( $debug ); +Interpreter::setdebug( $debug ); + +if( $test ) +{ + dotests(); + exit 0; +} + +my( $s, @apistr ) = @ARGV; +my @api = API::parse( join(',',@apistr) ); +say "apis:"; +say join("\n", map { " $_" } @api ); +my( $matched, @matchtext ) = patmatch( $s, @api ); +say "Output: $matched"; +if( $matched ) +{ + foreach my $i (0..$#matchtext) + { + say " match text $i: $matchtext[$i]"; + } +} + + +# +# my( $matched, @matchtext ) = patmatch( $s, @api ); +# Pattern match @api against $s, returning ( 1, @matchtext ) iff it +# matches the whole of $s, ( 0 ) otherwise. Basically this is an +# Interpreter for the list @api. +# +sub patmatch +{ + my( $s, @api ) = @_; + say "patmatch: matching api rules against $s" if $debug; + my %pos; + $pos{"slen"} = length($s); + my @mt; + my $match = interprete( $s, \@api, \%pos, \@mt ); + return ( $match, @mt ); +} + + +# +# dotests(); +# Do a load of tests. +# +sub dotests +{ + eval "use Test::More"; die $@ if $@; + eval "use TestPE qw(pe_tests)"; die $@ if $@; + eval "use TestMatch qw(match_tests)"; die $@ if $@; + + TestMatch::setdebug($debug); + + pe_tests(); + match_tests( \&patmatch ); + + done_testing(); +} diff --git a/challenge-099/duncan-c-white/opt1-noFL/ch-1b.pl b/challenge-099/duncan-c-white/opt1-noFL/ch-1b.pl new file mode 100755 index 0000000000..2a157d2028 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/ch-1b.pl @@ -0,0 +1,137 @@ +#!/usr/bin/perl +# +# Task 1: "Pattern Match +# +# You are given a string $S and a pattern $P. +# +# Write a script to check if given pattern validate the entire string. Print +# 1 if pass otherwise 0. +# +# The patterns can also have the following characters: +# ? - Match any single character. +# * - Match any sequence of characters. +# +# Example 1: +# Input: $S = "abcde" $P = "a*e" +# Output: 1 +# +# Example 2: +# Input: $S = "abcde" $P = "a*d" +# Output: 0 +# +# Example 3: +# Input: $S = "abcde" $P = "?b*d" +# Output: 0 +# +# Example 4: +# Input: $S = "abcde" $P = "a*c?e" +# Output: 1 +# " +# +# My notes: oh, cool, simpler than regexes, but nice. Two basic ways of +# doing this: 1). translate it into a regex and use Perl's regex matching, +# 2). figure out a from-scratch mechanism to solve this problem. +# In this version (having already got (1) working in ch-1.pl), let's do (2). +# I've invented "Abstract Pattern Instructions (APIs)", and am writing an +# interpreter for them in order to do the matching. To make life interesting, +# let's also capture the matching text for each '?' and '*'. I've got this +# working; see API.pm and PosExpr.pm too.. This proves that "interpreting a +# list of APIs" will do pattern matching. +# +# Next, I need to work out how to translate our patterns into a list of APIs. +# I have some ideas, and notes, but not a full method worked out. +# I think the first concept is: divide the pattern up into "fixed size islands" +# containing string literals and adjacent '?'s, i.e. anything but a '*'A, +# separated by patches of sea: each seapatch is a single '*' +# [NB: '**' and '*(?)+*' have already been ruled out, detected and trapped] +# +# Note: I also added a test suite (the above examples) with --test. +# + +use strict; +use warnings; +use Getopt::Long; +use feature 'say'; +use Function::Parameters; +use Data::Dumper; + +our $debug=0; +our $test=0; + +use lib qw(.); +use API; +use PosExpr; +use Interpreter qw(interprete); +use Translate qw(pat2apis); + +die "Usage: pattern-match [--test] [--debug]\n". + "Or... pattern-match [--debug] S P\n" + unless GetOptions( "debug" => \$debug, "test" => \$test ) + && ($test && @ARGV==0 || !$test && @ARGV==2); +API::setdebug( $debug ); +PosExpr::setdebug( $debug ); +Interpreter::setdebug( $debug ); +Translate::setdebug( $debug ); + +if( $test ) +{ + dotests(); + exit 0; +} + +my( $s, $pat ) = @ARGV; + +my @api = pat2apis( $pat ); +say "apis:"; +say join("\n", map { " $_" } @api ); +#exit 0; + +my( $matched, @matchtext ) = patmatch( $s, @api ); +say "Output: $matched"; +if( $matched ) +{ + foreach my $i (0..$#matchtext) + { + say " match text $i: $matchtext[$i]"; + } +} + + +# +# my( $matched, @matchtext ) = patmatch( $s, @api ); +# Pattern match @api against $s, returning ( 1, @matchtext ) iff it +# matches the whole of $s, ( 0 ) otherwise. Basically this is an +# Interpreter for the list @api. +# +sub patmatch +{ + my( $s, @api ) = @_; + say "patmatch: matching api rules against $s" if $debug; + my %pos; + $pos{"slen"} = length($s); + my @mt; + my $match = interprete( $s, \@api, \%pos, \@mt ); + return ( $match, @mt ); +} + + +# +# dotests(); +# Do a load of tests. +# +sub dotests +{ + eval "use Test::More"; die $@ if $@; + #eval "use TestPE"; die $@ if $@; + eval "use TestPat2Api qw(pat2api_tests)"; die $@ if $@; + eval "use TestMatch2 qw(match_tests)"; die $@ if $@; + + TestPat2Api::setdebug( $debug ); + TestMatch2::setdebug( $debug ); + + #pe_tests(); + pat2api_tests(); + match_tests( \&patmatch ); + + done_testing(); +} diff --git a/challenge-099/duncan-c-white/opt1-noFL/mkTypes b/challenge-099/duncan-c-white/opt1-noFL/mkTypes new file mode 100755 index 0000000000..1831538577 --- /dev/null +++ b/challenge-099/duncan-c-white/opt1-noFL/mkTypes @@ -0,0 +1,250 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use lib qw(/homes/dcw/lib/perl5/DCW); +use Datadec; + +my $posexpr = q( +PosExpr = I( int n ) "$1" + or N( string name ) "$1" + or NO( string name, char op, int n ) "$1$2$3" +); + +my $extra = q! +use Data::Dumper; + +my $debug = 0; +sub setdebug { my($d) = @_; $debug = $d; } + +# +# my($pe,$leftover) = parse($input); +# Parse $input, a string starting with a position expression, +# delivering the position expression in $pe and the leftover +# input in $leftover. Die screaming if no well formed pos expr +# can be found at the start of $input. +# A position expression is either \d+ or name or name '+'|'-' \d+ +# The internal form of a posexpr is ['I', int const] or ['N', name] +# or ['NO', name, +-, offset] +# +sub parse ($) +{ + my( $input ) = @_; + if( $input =~ s/^(\d+)\s*// ) + { + return ( PosExpr->I($1), $input ); + } + $input =~ s/^(\w+)\s*// || + die "bad input in pos expr $input, name expected\n"; + my $name = $1; + if( $input =~ s/^([\+-])\s*(\d+)\s*// ) + { + if( $2 == 0 ) + { + return ( PosExpr->N($name), $input ); + } else + { + return ( PosExpr->NO($name,$1,$2), $input ); + } + } + return ( PosExpr->N($name), $input ); +} + +# +# my $pe = simpleparse($str); +# Parse a position expression out of $str. Fail if there's +# anything left over. +# +sub simpleparse ($) +{ + my( $str ) = @_; + my($pe,$leftover) = parse($str); + die "PosExpr->simpleparse($str): left over $leftover after pe $pe\n" + if $leftover; + return $pe; +} + + +# +# my $newpe = $pe->add($n); +# Arithmetic on PosExprs: add $n (an integer) +# to $pe, giving $newpe. +# +sub add +{ + my( $self, $n ) = @_; + return $self if $n==0; + if( $self->kind eq 'I' ) + { + my $x = $self->I; + return PosExpr->I( $x+$n ); + } elsif( $self->kind eq "N" ) + { + my $name = $self->N; + my $op = $n>0?'+':'-'; + $n = abs($n); + return PosExpr->NO( $name, $op, $n ); + } else + { + # .. NO( string name, char op, int n ) + my( $name, $op, $x ) = $self->NO; + $x = -$x if $op eq '-'; + $op = '+'; + $x += $n; + return PosExpr->N( $name ) if $x==0; + $op = '-' if $x<0; + $x = abs($x); + return PosExpr->NO( $name, $op, $x ); + } +} + + +# +# my $pos = $pe->eval($poshash); +# Evaluate the given PosExpr $pe, using %$poshash +# for name lookup. Returns the actual position (a number). +# +sub eval ($$) +{ + my( $self, $poshash ) = @_; + if( $self->kind eq 'I' ) + { + return $self->I; + } elsif( $self->kind eq 'N' ) + { + my $name = $self->N; + die "error in PosExpr::eval($self): ". + "no such name $name in poshash ". Dumper($poshash) + unless exists $poshash->{$name}; + return $poshash->{$name}; + } else # if( $self->kind eq 'NO' ) + { + my ($name, $op, $n) = $self->NO; + die "error in PosExpr::eval($self): ". + "no such name $name in poshash ". Dumper($poshash) + unless exists $poshash->{$name}; + die "error in PosExpr::eval($self): bad op $op\n" unless + $op eq '+' || $op eq '-'; + $n = - $n if $op eq '-'; + return $poshash->{$name} + $n; + } +} + + + +!; + +open( my $fh, '>', "PosExpr.pm" ) || die; +say $fh gen_datatype( $posexpr, $extra ); + +close($fh); + +my $api = q( +API = A( string lit, posexpr at, string name ) "A'$1' $2->$3" + or M( string lit, posexpr atorafter, string name ) "M'$1' $2->$3" + or T( posexpr pe1, string op, posexpr pe2 ) "T$1$2$3" + or C( posexpr pe1, posexpr pe2) "C $1 $2" +); + +$extra = q% + +my $debug = 0; +sub setdebug { my($d) = @_; $debug = $d; } + +# +# my @api = parse( $input ); +# Parse $input, a string containing a comma-separated sequence +# of Abstract Pattern Instructions, return the list of apis. +# Die screaming if parsing fails. +# For example, the pattern a*e is represented by the +# following api string: +# A'a' 0->a,A'e' slen-1->e,Te>a-1,C a+1 e-1 +# (where slen is a runtime variable representing the length of +# the target string these APIs would eventually operate on). +# +# The individual api forms are: +# M'str' posexpr->name +# A'str' posexpr->name +# Tposexpr ('>'|'='|'>=') posexpr +# C posexpr [posexpr] +# where posexpr = \d+ or name or name '+'|'-' \d+ (see module PosExpr) +# +sub parse ($) +{ + my( $input ) = @_; + my @result; + while( $input ) + { + # M'str' posexpr->name + if( $input =~ s/^M\s*// ) + { + $input =~ s/^'([^']+)'\s+// || + die "bad input $input in M..\n"; + my $str = $1; + (my $pe,$input) = PosExpr::parse($input); + die "bad input $input in M$str $pe...\n" + unless $input =~ s/^\s*->\s*(\w+)//; + my $pname = $1; + my $api = API->M($str, $pe, $pname); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # A'str' posexpr->name + elsif( $input =~ s/^A\s*// ) + { + $input =~ s/^'([^']+)'\s+// || + die "bad input $input in A..\n"; + my $str = $1; + (my $pe,$input) = PosExpr::parse($input); + die "bad input $input in A$str $pe...\n" + unless $input =~ s/^\s*->\s*(\w+)//; + my $pname = $1; + my $api = API->A($str, $pe, $pname); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # Tposexpr ('>'|'='|'>=') posexpr + elsif( $input =~ s/^T\s*// ) + { + (my $pe,$input) = PosExpr::parse($input); + $input =~ s/^(>=|>|=)// || + die "bad input $input in T$pe, ". + "'>','=' or '>=' expected\n"; + my $op = $1; + (my $pe2,$input) = PosExpr::parse($input); + my $api = API->T($pe, $op, $pe2); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # C posexpr [posexpr] + elsif( $input =~ s/^C\s*// ) + { + (my $pe,$input) = PosExpr::parse($input); + $input =~ s/^\s*//; + + # second posexpr is optional: + # present if next ch is not ',' + my $pe2 = $pe; + if( $input ne '' && $input !~ /^,/ ) + { + ($pe2,$input) = PosExpr::parse($input); + } + my $api = API->C($pe, $pe2); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + $input =~ s/^\s*,\s*//; + } + die "bad input $input, non empty but not M|T|C..\n" if $input; + return @result; +} +%; + + +open( $fh, '>', "API.pm" ) || die; +say $fh gen_datatype( $api, $extra ); +close($fh); diff --git a/challenge-099/duncan-c-white/opt2-separateRunX/API.pm b/challenge-099/duncan-c-white/opt2-separateRunX/API.pm new file mode 100644 index 0000000000..2d8d23f0bd --- /dev/null +++ b/challenge-099/duncan-c-white/opt2-separateRunX/API.pm @@ -0,0 +1,255 @@ +package API; + +# automatically generated implementation of recursive data type +# API = A(string lit,posexpr at,string name) +# or M(string lit,posexpr atorafter,string name) +# or T(posexpr pe1,string op,posexpr pe2) +# or C(posexpr pe1,posexpr pe2) + + +use strict; +use warnings; +use feature 'say'; + +use overload '""' => \&as_string; +use overload 'eq' => \&streq; + + + +# API->A: Constructor or get method, use: +# my $obj = API->A($lit, $at, $name) OR +# my ($lit, $at, $name) = $obj->A +sub A ($;$$$) +{ + my( $thing, $lit, $at, $name ) = @_; + if( @_ == 4 ) # constructor + { + die "API->A: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["A", $lit, $at, $name], "API"; + } else # get method + { + die "API->A: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->A: malformed object $thing\n" + unless @x == 3 && $t eq "A"; + return @x; + } +} + + +# API->M: Constructor or get method, use: +# my $obj = API->M($lit, $atorafter, $name) OR +# my ($lit, $atorafter, $name) = $obj->M +sub M ($;$$$) +{ + my( $thing, $lit, $atorafter, $name ) = @_; + if( @_ == 4 ) # constructor + { + die "API->M: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["M", $lit, $atorafter, $name], "API"; + } else # get method + { + die "API->M: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->M: malformed object $thing\n" + unless @x == 3 && $t eq "M"; + return @x; + } +} + + +# API->T: Constructor or get method, use: +# my $obj = API->T($pe1, $op, $pe2) OR +# my ($pe1, $op, $pe2) = $obj->T +sub T ($;$$$) +{ + my( $thing, $pe1, $op, $pe2 ) = @_; + if( @_ == 4 ) # constructor + { + die "API->T: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["T", $pe1, $op, $pe2], "API"; + } else # get method + { + die "API->T: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->T: malformed object $thing\n" + unless @x == 3 && $t eq "T"; + return @x; + } +} + + +# API->C: Constructor or get method, use: +# my $obj = API->C($pe1, $pe2) OR +# my ($pe1, $pe2) = $obj->C +sub C ($;$$) +{ + my( $thing, $pe1, $pe2 ) = @_; + if( @_ == 3 ) # constructor + { + die "API->C: classname $thing is not 'API'\n" + unless $thing eq "API"; + return bless ["C", $pe1, $pe2], "API"; + } else # get method + { + die "API->C: $thing is not a API\n" + unless ref($thing) eq "API"; + my @x = @$thing; + my $t = shift @x; + die "API->C: malformed object $thing\n" + unless @x == 2 && $t eq "C"; + return @x; + } +} + + +sub kind ($) +{ + my( $self ) = @_; + die "API->kind: $self is not a API\n" + unless ref($self) eq "API"; + return $self->[0]; +} + + +sub as_string ($) +{ + my( $self ) = @_; + die "API->as_string: $self is not a API\n" + unless ref($self) eq "API"; + my @x = @$self; + my $t = shift @x; + + # stringify all params + @x = map { "$_" } @x; + + # specific printing rules + return "A'$x[0]' $x[1]->$x[2]" if $t eq 'A'; + return "C $x[0] $x[1]" if $t eq 'C'; + return "M'$x[0]' $x[1]->$x[2]" if $t eq 'M'; + return "T$x[0]$x[1]$x[2]" if $t eq 'T'; + + # general case + my $args = join( ',', @x ); + return $args ne "" ? "$t($args)" : "$t"; +} + + + +sub streq ($$) +{ + my( $a, $b ) = @_; + #print "API->streq called with a=$a, b=$b\n"; + return "$a" eq "$b" ? 1 : 0; # the sneaky way +} + + + + +my $debug = 0; +sub setdebug { my($d) = @_; $debug = $d; } + +# +# my @api = parse( $input ); +# Parse $input, a string containing a comma-separated sequence +# of Abstract Pattern Instructions, return the list of apis. +# Die screaming if parsing fails. +# For example, the pattern a*e is represented by the +# following api string: +# A'a' 0->a,A'e' slen-1->e,Te>a-1,C a+1 e-1 +# (where slen is a runtime variable representing the length of +# the target string these APIs would eventually operate on). +# +# The individual api forms are: +# M'str' posexpr->name +# A'str' posexpr->name +# Tposexpr ('>'|'='|'>=') posexpr +# C posexpr [posexpr] +# where posexpr = \d+ or name or name '+'|'-' \d+ (see module PosExpr) +# +sub parse ($) +{ + my( $input ) = @_; + my @result; + while( $input ) + { + # M'str' posexpr->name + if( $input =~ s/^M\s*// ) + { + $input =~ s/^'([^']+)'\s+// || + die "bad input $input in M..\n"; + my $str = $1; + (my $pe,$input) = PosExpr::parse($input); + die "bad input $input in M$str $pe...\n" + unless $input =~ s/^\s*->\s*(\w+)//; + my $pname = $1; + my $api = API->M($str, $pe, $pname); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # A'str' posexpr->name + elsif( $input =~ s/^A\s*// ) + { + $input =~ s/^'([^']+)'\s+// || + die "bad input $input in A..\n"; + my $str = $1; + (my $pe,$input) = PosExpr::parse($input); + die "bad input $input in A$str $pe...\n" + unless $input =~ s/^\s*->\s*(\w+)//; + my $pname = $1; + my $api = API->A($str, $pe, $pname); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # Tposexpr ('>'|'='|'>=') posexpr + elsif( $input =~ s/^T\s*// ) + { + (my $pe,$input) = PosExpr::parse($input); + $input =~ s/^(>=|>|=)// || + die "bad input $input in T$pe, ". + "'>','=' or '>=' expected\n"; + my $op = $1; + (my $pe2,$input) = PosExpr::parse($input); + my $api = API->T($pe, $op, $pe2); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + # C posexpr [posexpr] + elsif( $input =~ s/^C\s*// ) + { + (my $pe,$input) = PosExpr::parse($input); + $input =~ s/^\s*//; + + # second posexpr is optional: + # present if next ch is not ',' + my $pe2 = $pe; + if( $input ne '' && $input !~ /^,/ ) + { + ($pe2,$input) = PosExpr::parse($input); + } + my $api = API->C($pe, $pe2); + say "debug: parsed api $api, rest input $input" + if $debug; + push @result, $api; + } + $input =~ s/^\s*,\s*//; + } + die "bad input $input, non empty but not M|T|C..\n" if $input; + return @result; +} + + +1; + diff --git a/challenge-099/duncan-c-white/opt2-separateRunX/Interpreter.pm b/challenge-099/duncan-c-white/opt2-separateRunX/Interpreter.pm new file mode 100644 index 0000000000..ae5af02fd9 --- /dev/null +++ b/challenge-099/duncan-c-white/opt2-separateRunX/Interpreter.pm @@ -0,0 +1,176 @@ +package Interpreter; + +# Here's the interpreter for a list of APIs. This is the guts of +# pattern matching. + +use strict; +use warnings; +use feature 'say'; +use Function::Parameters; +use Data::Dumper; +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw(interprete); # Export on demand + +use lib qw(.); +use API; +use PosExpr; + +my $debug = 0; + +sub setdebug { my($d) = @_; $debug = $d; } + + +# +# my $ok = runAt( $s, $lit, $at, $poshash, $name ); +# Try to match $lit in $s at $at. Return 0 if we can't +# find that literal. 1 otherwise (and store name==pos in the poshash) +# +fun runAt( $s, $lit, $at, $poshash, $name ) +{ + my $pos = $at->eval($poshash); + return 0 unless substr($s,$pos,length($lit)) eq $lit; + $poshash->{$name} = $pos; + say "debug: A: set pos[$name] = $pos" if $debug; + return 1; +} + + +# +# my @litpos = findliteral( $lit, $p, $s ); +# Find all instances of $lit atorafter position $p in $s, +# build and return a list of possible starting positions. +# +fun findliteral( $lit, $p, $s ) +{ + my $slen = length($s); + my $llen = length($lit); + my @result = grep { substr($s,$_,$llen) eq $lit; } $p..$slen-1; + #die "findliteral: lit=$lit, s=$s, results=".Dumper(\@result); + return @result; +} + + +# +# my $ok = runMatch( $s, $lit, $atorafter, $poshash, $name, $restapi, $mtlist ); +# Try to find $lit in $s at-or-after position $atorafter. Return 0 if we +# can't find that literal anywhere.