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