public
Created

  • Download Gist
regexer-golfed.pl
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
use feature':5.12';
sub S(&){pop}
$,=S{goto pop};
sub p{push@{+shift},@_}
sub c{my$l=$,;for my$r(@_){my$L=$l;
$l=S{my($i,$c)=@_;&$L($i,S{&$r(shift,$c)})}}$l}
sub a{my@A=@_;S{my($i,$c,$o)=@_;$o=&$_($i,$c)and return$o for@A;0}}
sub A{$#_?a(map c(@$_),@_):c(@{+pop})}
sub k{my($I,$k)=@_;$k=a c($I,S{&$k}),$,}
$_=shift;$P=do{@a=$r=[];for(/./g){when('('){p\@p,[@a];@a=$r=[]}
when(')'){$p=A@a;@a=@{pop@p};p$r=$a[-1],$p}
p\@a,$r=[]when'|';p$r,k pop@$r when'*';
p$r,c $$r[-1],k pop@$r when'+';p$r,a pop@$r,$,when '?';
my$s=$_;p$r,S{my($_,$c)=@_;s/^\Q$s//&&$_->$c}}A@a};
say&$P($_,S{!length pop})?"true":"false"for@ARGV
regexer.pl
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
use feature ':5.10';
 
sub nil { # $, in golf
my ($input, $cont) = @_;
$cont->($input);
}
 
sub EOI { # inlined in the parser call in golf
my ($input) = @_;
length($input) == 0;
}
 
sub literal { # inlined in the builder in golf
my ($match) = @_;
sub {
my ($input, $cont) = @_;
if ($input =~ s/^\Q$match//) {
$cont->($input);
}
}
}
 
sub concat_2 { # not in golf
my ($left, $right) = @_;
sub {
my ($input, $cont) = @_;
my $matchright = sub {
my ($input) = @_;
$right->($input, $cont); # $cont from outer
};
$left->($input, $matchright);
}
}
 
sub concat { # sub c
my $left = \&nil;
for my $right (@_) {
$left = concat_2($left, $right);
}
$left;
}
 
sub alternate { # sub a
my @alternatives = @_;
sub {
my ($input, $cont) = @_;
for my $alt (@alternatives) {
if (my $result = $alt->($input, $cont)) {
return $result;
}
}
return; # all failed
}
}
 
sub star { # sub k
my ($inner) = @_;
my $star;
$star = alternate(
concat_2( $inner, sub { $star->(@_) } ),
\&nil
);
$star;
}
 
sub plus { # not in golfed
my ($inner) = @_;
return concat_2($inner, star($inner)),
}
 
sub maybe { # not in golfed
my ($inner) = @_;
 
return alternate($inner, \&nil);
}
 
# Takes a list of alternatives, each one of which is an arrayref holding
# a list of concatenated atoms. Calls concatenate() and alternate() on them
# in turn to build up a matcher. This is how we finalize either a paren group
# or the whole regex.
sub flatten {
my @alternates = @_;
if (@alternates > 1) {
return alternate(
map { concat(@$_) } @alternates
);
} else {
return concat(@{ $alternates[0] });
}
}
 
sub build_regex {
my ($regex) = @_;
 
my @alternatives =
$concat = [];
 
my @paren_groups;
 
for (split //, $regex) {
when ('(') {
push @paren_groups, [ @alternatives ]; # Save on the stack
@alternatives = $concat = []; # Clear the working space
}
when (')') {
# Turn the current workspace into a real matcher
my $current_group = flatten( @alternatives );
# Pop back to where we were before we entered this paren
@alternatives = @{ pop @paren_groups };
$concat = @alternatives[-1];
# And add the matcher for this paren group to the outer scope
push @$concat, $current_group;
}
when ('|') {
# Start a new empty concat list and push it on the alternatives
$concat = [];
push @alternatives, $concat;
}
when ('*') { # Replace last atom with a starred version of itself
$concat->[-1] = star( $concat->[-1] );
}
when ('+') { # Replace last atom with a plussed version of itself
$concat->[-1] = plus( $concat->[-1] );
}
when ('?') { # Replace last atom with a maybe'd version of itself
$concat->[-1] = maybe( $concat->[-1] );
}
default { # Generate a literal char matcher
push @$concat, literal($_); # inline in golf
}
}
# Build the top-level matcher
return flatten(@alternatives);
}
 
my $regex = shift(@ARGV);
my $parser = build_regex($regex);
for my $str (@ARGV) {
if ($parser->($str, \&EOI)) { # EOI is inline in golf
say "true";
} else {
say "false";
}
}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.