1 ! Copyright (C) 2009 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs kernel math math.bits regexp.ast
4 regexp.classes regexp.transition-tables sequences sets ;
5 IN: regexp.disambiguate
9 : make-partition ( choices classes -- partition )
10 zip [ first ] partition [ values ] bi@ parts boa ;
12 : powerset-partition ( sequence -- partitions )
13 [ length [ 2^ <iota> ] keep ] keep '[ _ <bits> _ make-partition ] map rest ;
15 : partition>class ( parts -- class )
16 [ out>> [ <not-class> ] map ]
17 [ in>> <and-class> ] bi prefix <and-class> ;
19 : singleton-partition ( integer non-integers -- {class,partition} )
21 '[ _ [ class-member? ] with filter ] keep
25 : add-out ( seq partition -- partition' )
26 [ nip in>> ] [ out>> append ] 2bi parts boa ;
28 : meaningful-integers ( partition table -- integers )
29 [ [ in>> ] [ out>> ] bi ] dip
30 '[ [ _ at ] map intersect-all ] bi@ diff ;
32 : class-integers ( classes integers -- table )
33 '[ _ over '[ _ class-member? ] filter ] H{ } map>assoc ;
35 : add-integers ( partitions classes integers -- partitions )
37 [ _ meaningful-integers ] [ ] bi add-out
40 :: class-partitions ( classes -- assoc )
41 classes [ integer? ] partition :> ( integers classes )
43 classes powerset-partition classes integers add-integers
44 [ [ partition>class ] [ ] bi 2array ] map sift-keys
45 integers [ classes singleton-partition ] map append ;
47 : new-transitions ( transitions -- assoc ) ! assoc is class, partition
48 values [ keys ] gather [ tagged-epsilon? ] reject class-partitions ;
50 : get-transitions ( partition state-transitions -- next-states )
51 [ in>> ] dip '[ _ at ] gather sift ;
53 : disambiguate ( nfa -- nfa )
55 dup new-transitions '[
57 _ swap '[ _ get-transitions ] assoc-map
60 [ drop tagged-epsilon? ] assoc-filter
61 ] bi H{ } assoc-union-as
63 ] change-transitions ;