basis/regexp/minimize/minimize.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences regexp.transition-tables fry assocs
   4 accessors locals math sorting arrays sets hashtables regexp.dfa
   5 combinators.short-circuit regexp.classes ;
   6 IN: regexp.minimize
   7
   8 : table>state-numbers ( table -- assoc )
   9     transitions>> keys <enum> [ swap ] H{ } assoc-map-as ;
  10
  11 : number-states ( table -- newtable )
  12     dup table>state-numbers transitions-at ;
  13
  14 : has-conditions? ( assoc -- ? )
  15     values [ condition? ] any? ;
  16
  17 : initially-same? ( s1 s2 transition-table -- ? )
  18     {
  19         [ drop <= ]
  20         [ transitions>> '[ _ at keys ] bi@ set= ]
  21         [ final-states>> '[ _ in? ] bi@ = ]
  22     } 3&& ;
  23
  24 :: initialize-partitions ( transition-table -- partitions )
  25     ! Partition table is sorted-array => ?
  26     H{ } clone :> out
  27     transition-table transitions>> keys :> states
  28     states [| s1 |
  29         states [| s2 |
  30             s1 s2 transition-table initially-same?
  31             [ s1 s2 2array out conjoin ] when
  32         ] each
  33     ] each out ;
  34
  35 : same-partition? ( s1 s2 partitions -- ? )
  36     { [ [ sort-pair 2array ] dip key? ] [ drop = ] } 3|| ;
  37
  38 : assemble-values ( assoc1 assoc2 -- values )
  39     dup keys '[ _ swap [ at ] curry map ] bi@ zip ;
  40
  41 : stay-same? ( s1 s2 transition partitions -- ? )
  42     [ '[ _ transitions>> at ] bi@ assemble-values ] dip
  43     '[ _ same-partition? ] assoc-all? ;
  44
  45 : partition-more ( partitions transition-table -- partitions )
  46     over '[ drop first2 _ _ stay-same? ] assoc-filter ;
  47
  48 : partition>classes ( partitions -- synonyms ) ! old-state => new-state
  49     sort-keys
  50     [ drop first2 swap ] assoc-map
  51     <reversed>
  52     >hashtable ;
  53
  54 :: (while-changes) ( ..a obj quot: ( ..a obj -- ..b obj' ) comp: ( ..b obj' -- ..a key ) old-key -- ..a obj )
  55     obj quot call :> new-obj
  56     new-obj comp call :> new-key
  57     new-key old-key =
  58     [ new-obj ]
  59     [ new-obj quot comp new-key (while-changes) ]
  60     if ; inline recursive
  61
  62 : while-changes ( obj quot pred -- obj' )
  63     3dup nip call (while-changes) ; inline
  64
  65 : (state-classes) ( transition-table -- partition )
  66     [ initialize-partitions ] keep
  67     '[ _ partition-more ] [ assoc-size ] while-changes ;
  68
  69 : assoc>set ( assoc -- keys-set )
  70     [ drop dup ] assoc-map ;
  71
  72 : state-classes ( transition-table -- synonyms )
  73     clone [ [ nip has-conditions? ] assoc-partition ] change-transitions
  74     [ assoc>set ] [ (state-classes) partition>classes ] bi* assoc-union ;
  75
  76 : canonical-state? ( state transitions state-classes -- ? )
  77     '[ dup _ at =  ] swap '[ _ at has-conditions? ] bi or ;
  78
  79 : delete-duplicates ( transitions state-classes -- new-transitions )
  80     dupd '[ drop _ _ canonical-state? ] assoc-filter ;
  81
  82 : combine-states ( table -- smaller-table )
  83     dup state-classes
  84     [ transitions-at ] keep
  85     '[ _ delete-duplicates ] change-transitions ;
  86
  87 : combine-state-transitions ( hash -- hash )
  88     [ H{ } clone ] dip over '[
  89         _ [ 2array <or-class> ] change-at
  90     ] assoc-each [ swap ] assoc-map ;
  91
  92 : combine-transitions ( table -- table )
  93     [ [ combine-state-transitions ] assoc-map ] change-transitions ;
  94
  95 : minimize ( table -- minimal-table )
  96     clone
  97     number-states
  98     combine-states
  99     combine-transitions
 100     expand-ors ;