1 ! Copyright (C) 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators.short-circuit
4 hash-sets kernel math regexp.classes regexp.transition-tables
5 sequences sets sorting ;
8 : table>state-numbers ( table -- assoc )
9 transitions>> keys H{ } zip-index-as ;
11 : number-states ( table -- newtable )
12 dup table>state-numbers transitions-at ;
14 : has-conditions? ( assoc -- ? )
15 values [ condition? ] any? ;
17 : initially-same? ( s1 s2 transition-table -- ? )
20 [ final-states>> '[ _ in? ] bi@ = ]
21 [ transitions>> '[ _ at keys ] bi@ set= ]
24 :: initialize-partitions ( transition-table -- partitions )
25 ! Partition table is sorted-array => ?
26 transition-table transitions>> keys natural-sort :> states
27 states length 2/ sq <hash-set> :> out
30 s1 s2 transition-table initially-same?
31 [ s1 s2 2array out adjoin ] when
35 : same-partition? ( s1 s2 partitions -- ? )
36 { [ [ sort-pair 2array ] dip in? ] [ drop = ] } 3|| ;
38 : stay-same? ( s1 s2 transition partitions -- ? )
39 [ '[ _ transitions>> at ] bi@ ] dip
40 '[ [ at ] dip _ same-partition? ] with assoc-all? ;
42 :: partition-more ( partitions transition-table -- partitions changed? )
43 partitions cardinality :> size
45 dup first2 transition-table partitions stay-same?
46 [ drop ] [ partitions delete ] if
47 ] each partitions dup cardinality size = not ;
49 : partition>classes ( partitions -- synonyms ) ! old-state => new-state
50 members natural-sort <reversed> [ swap ] H{ } assoc-map-as ;
52 : (state-classes) ( transition-table -- partition )
53 [ initialize-partitions ] keep '[ _ partition-more ] loop ;
55 : assoc>set ( assoc -- keys-set )
56 [ drop dup ] assoc-map ;
58 : state-classes ( transition-table -- synonyms )
59 clone [ [ nip has-conditions? ] assoc-partition ] change-transitions
60 [ assoc>set ] [ (state-classes) partition>classes ] bi* assoc-union ;
62 : canonical-state? ( state transitions state-classes -- ? )
63 '[ dup _ at = ] swap '[ _ at has-conditions? ] bi or ;
65 : delete-duplicates ( transitions state-classes -- new-transitions )
66 dupd '[ drop _ _ canonical-state? ] assoc-filter ;
68 : combine-states ( table -- smaller-table )
70 [ transitions-at ] keep
71 '[ _ delete-duplicates ] change-transitions ;
73 : combine-state-transitions ( hash -- hash )
74 [ H{ } clone ] dip over '[
75 _ [ 2array <or-class> ] change-at
76 ] assoc-each [ swap ] assoc-map ;
78 : combine-transitions ( table -- table )
79 [ [ combine-state-transitions ] assoc-map ] change-transitions ;
81 : minimize ( table -- minimal-table )