path: root/challenge-099/duncan-c-white/opt3-rewrite/PatternMatch.pm

package PatternMatch;

#
# This contains the complete code to pattern match a string against a
# pattern, integrating all the previous code from Translate and Interprete,
# no longer needing APIs, PosExprs or a hash of named variables, essentially
# we will now "parse a bit, match a bit" as we go along.  Captures were
# really confusing me, deep within the search, but I realised that all the
# search (pattern matching) routines could ignore them - leaving them to the
# end.  What you need at the end to construct the matched text snippets
# after a successful match is:
# - a list of all fixed-width Islands
# - 2 booleans: $firststar is true iff the pattern had a leading '*', and
#               $laststar is true iff the pattern had a trailing '*'.
# - a corresponding list of the starting point in the string of each island
# I suspect that I could have turned the pattern string into the list of
# islands and the 2 booleans rather earlier..
#

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(patternmatch extractmatchedtext); # Export on demand

use lib qw(.);
use Tuple qw(tuple);


my $debug = 0;

sub setdebug { my($d) = @_; $debug = $d; }


#
# my $ok = matchAt( $target, $strlit, $pos );
#	Return 1 iff $strlit matches $target starting at $pos.
#	Return 0 otherwise.
#
fun matchAt( $target, $strlit, $pos )
{
	return substr($target,$pos,length($strlit)) eq $strlit ? 1 : 0;
}


#
# 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 @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 $found = fixedisland( $s, $island, $lpos );
#	Pattern match a fixed-width island (a pattern with no '*'s,
#	which can contain strliterals and '?'s) called $island, against
#	$s at exactly $lpos.  If we fail to pattern match, return 0.
#	If we do pattern match successfully, return 1.
#
fun fixedisland( $s, $island, $lpos )
{
	say "fixedisland: island $island @ $lpos, string $s" if $debug;
	if( $island !~ /\?/ )			# string literal?
	{
		my $l = length($island);
		return 0 unless matchAt($s, $island, $lpos);
		return 1;
	}

	# ok, the island has at least one '?', maybe more
	# match each string literal, skip '?'s
	while( $island )
	{
		if( $island =~ s/^([^?]+)// )
		{
			my $strlit = $1;	# strlit at lpos
			my $l = length($strlit);
			say "debug: fixedisland: strlit=$strlit, ".
			    "remaining island=$island" if $debug;
			return 0 unless matchAt( $s, $strlit, $lpos );
			$lpos += $l;
		} else
		{				# '?' at lpos
			$island =~ s/^\?//;
			# found a '?', skip it
			$lpos++;
		}
		say "debug: fixedisland: island now $island, lpos now $lpos" if $debug;
	}
	return 1;
}


#
# my $substr = ft( $s, $from, $to );
#	From-to: extract the substring of $s from pos $from
#	to pos $to.
#
fun ft( $s, $from, $to )
{
	my $sub = substr($s,$from,$to-$from+1) // '';
	return $sub;
}


#
# my @mt = extractmatchedtext( $s, $firststar, $laststar, @is );
#	Given a string $s, a boolean $firststar saying whether there's
#	a '*' before the first island, and a similar boolean $laststar,
#	and an array @is of (fixed-width island, it's start pos in $s) pairs,
#	generate the array of matched text capture fragments.
#
fun extractmatchedtext( $s, $firststar, $laststar, @is )
{
	#say "emt: debug=$debug";
	say "emt: s=$s, is=".Dumper(\@is) if $debug;

	my $slen = length($s);
	my $freel = 0;				# first free pos in string
	my @mt;
	foreach my $oneis (@is)
	{
		my( $island, $startpos ) = $oneis->detuple;

		# there is usually a capture, i.e. a * before the island
		push @mt, ft($s,$freel,$startpos-1)
			unless $freel==0 && ! $firststar;

		# process any '?'s
		my $p = $startpos;
		foreach my $ch (split(//,$island))
		{
			push @mt, substr($s,$p,1) if $ch eq '?';
			$p++;
		}

		# advance freel to first available pos in $s AFTER $island
		$freel = $p;
	}

	if( $laststar )
	{
		push @mt, ft($s,$freel,$slen-1) // '';
	}
	say "emt: mt=".Dumper(\@mt) if $debug;
	return @mt;
}


#
# my( $match, @matchedtext ) = patternmatch( $s, $pat );
#	Pattern match $pat against the whole of $s.
#	If it matches, return (1, the array of captured text fragments)
#		[nb: one text fragment for every ? and * in $pat]
#	If the pattern doesn't match the string, return (0).
#
fun patternmatch( $s, $pat )
{
	die "bad pattern $pat\n" if $pat =~ /\*\?*\*/;

	# capture whole string if the pattern is '*'
	return (1, $s) if $pat eq '*';

	my $firststar = ($pat =~ /^\*/) ? 1 : 0;
	my $laststar = ($pat =~ /\*$/) ? 1 : 0;

	my @is;	# array of [island,startpos] pairs, ie. 2-tuples.
	my $match = patternmatchSP( $s, $pat, \@is );
	return 0 unless $match;

	# now we have a match, turn the @is data into matched texts
	my @mt = extractmatchedtext( $s, $firststar, $laststar, @is );
	return (1, @mt);
}


#
# my $match = patternmatchSP( $s, $pat, $is );
#	Pattern match $pat against the whole of $s, storing all the
#	fixed-width islands in $pat, and their corresponding
#	starting positions in $s, into @$is.
#
#	Return 0 if the whole match fails.
#	If the match succeeds, return 1
#
fun patternmatchSP( $s, $pat, $is )
{
	say "debug: patternmatchSP( $s, $pat )" if $debug;

	my $slen = length($s);
	my $nfix = countfixed( $pat );
	my $len = length($pat);

	if( $nfix == $len )  	# if the whole pattern is fixed - no '*'
	{
		return 0 unless $slen==$len;		# Test length
		return 0 unless fixedisland( $s, $pat, 0 );
		@$is = ( tuple($pat,0) );
		return 1;
	}

	# 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 )
	{
		say "debug: $pat has at least one '*', checking length slen=$slen vs nfix=$nfix" if $debug;
		return 0 if $slen<$nfix;
	}

	my $lpos = 0;
	my $rpos = $slen-1;

	if( $pat =~ s/^([^*]+)// )	# find first island (if present)
	{
		my $island = $1;
		return 0 unless fixedisland( $s, $island, $lpos );
		push @$is, tuple( $island, $lpos );
		$lpos = length($island);
	}

	my $lastis;
	if( $pat =~ s/([^*]+)$// )	 # find trailing island (if present)
	{
		my $island = $1;
		my $l = length($island);
		my $lastsp = $slen-$l;
		return (0) unless fixedisland( $s, $island, $lastsp );

		$lastis = tuple( $island, $lastsp );
		$rpos -= $l;
		# NB: need to add $lastis to @is at the end (if it's >0)
	}

	my $match = matchfloatingislands( $s, $pat, $lpos, $rpos, $is );
	return 0 unless $match;

	push @$is, $lastis if $lastis;
	return 1;
}


#
# my $match = matchfloatingislands( $s, $pat, $lpos, $rpos, $is );
#	Recursive pattern matcher for $pat that comprises * or *island*
#	or *island*island...*, ie. a list of zero or more floating islands.
#	Try to pattern match $s against each island in the $pat, all between
#	positions $lpos and $rpos in $s.
#
#	Return 0 if the match fails.  If the match succeeds, return 1 (also
#	having added each ( island, start pos ) pair to @$is.
#
fun matchfloatingislands( $s, $pat, $lpos, $rpos, $is )
{
	say "matchfloatingislands: pattern $pat, string $s, lpos $lpos, rpos $rpos"
		if $debug;

	# what if no islands?
	if( $pat eq '*' )
	{
		return 0 unless $rpos+1 >= $lpos;
		return 1;
	}

	# each island is free floating, and has to be tried
	# everywhere it could possibly match: Try the first..

	# break off the first "*island"
	die "matchfloatingislands: logic error: no island in $pat\n"
		unless $pat =~ s/^\*([^*]+)//;

	my $island <