steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

regexp.disambiguate: Make it cleaner imo, but still can't make heads of tails of the algorithm being used.

locals-and-roots
Doug Coleman 2016-04-12 14:19:18 -07:00
parent 9ee109ae50
commit c5f7ae9d74
1 changed files with 9 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
basis/regexp/disambiguate/disambiguate.factor
View File

@ -15,8 +15,7 @@ TUPLE: parts in out ;
: partition>class ( parts -- class ) : partition>class ( parts -- class )
[ out>> [ <not-class> ] map ] [ out>> [ <not-class> ] map ]
[ in>> <and-class> ] bi [ in>> <and-class> ] bi prefix <and-class> ;
prefix <and-class> ;
: singleton-partition ( integer non-integers -- {class,partition} ) : singleton-partition ( integer non-integers -- {class,partition} )
dupd dupd
@ -25,9 +24,9 @@ TUPLE: parts in out ;
2array ; 2array ;
: add-out ( seq partition -- partition' ) : add-out ( seq partition -- partition' )
[ out>> append ] [ in>> ] bi swap parts boa ; [ nip in>> ] [ out>> append ] 2bi parts boa ;
: intersection ( seq -- elts ) : intersection ( seq -- elts/f )
[ f ] [ unclip [ intersect ] reduce ] if-empty ; [ f ] [ unclip [ intersect ] reduce ] if-empty ;
: meaningful-integers ( partition table -- integers ) : meaningful-integers ( partition table -- integers )
@ -39,34 +38,30 @@ TUPLE: parts in out ;
: add-integers ( partitions classes integers -- partitions ) : add-integers ( partitions classes integers -- partitions )
class-integers '[ class-integers '[
[ _ meaningful-integers ] keep add-out [ _ meaningful-integers ] [ ] bi add-out
] map ; ] map ;
:: class-partitions ( classes -- assoc ) :: class-partitions ( classes -- assoc )
classes [ integer? ] partition :> ( integers classes ) classes [ integer? ] partition :> ( integers classes )
classes powerset-partition classes integers add-integers classes powerset-partition classes integers add-integers
[ [ partition>class ] keep 2array ] map [ first ] filter [ [ partition>class ] [ ] bi 2array ] map sift-keys
integers [ classes singleton-partition ] map append ; integers [ classes singleton-partition ] map append ;
: new-transitions ( transitions -- assoc ) ! assoc is class, partition : new-transitions ( transitions -- assoc ) ! assoc is class, partition
values [ keys ] gather values [ keys ] gather [ tagged-epsilon? ] reject class-partitions ;
[ tagged-epsilon? ] reject
class-partitions ;
: get-transitions ( partition state-transitions -- next-states ) : get-transitions ( partition state-transitions -- next-states )
[ in>> ] dip '[ _ at ] gather sift ; [ in>> ] dip '[ _ at ] gather sift ;
: preserving-epsilon ( state-transitions quot -- new-state-transitions )
[ [ drop tagged-epsilon? ] assoc-filter ] bi
assoc-union H{ } assoc-like ; inline
: disambiguate ( nfa -- nfa ) : disambiguate ( nfa -- nfa )
expand-ors [ expand-ors [
dup new-transitions '[ dup new-transitions '[
[ [
_ swap '[ _ get-transitions ] assoc-map _ swap '[ _ get-transitions ] assoc-map
harvest-values harvest-values
] preserving-epsilon ] [
[ drop tagged-epsilon? ] assoc-filter
] bi H{ } assoc-union-as
] assoc-map ] assoc-map
] change-transitions ; ] change-transitions ;