basis/regexp/minimize/minimize.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See https://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 ;
   6 IN: regexp.minimize
   7
   8 : table>state-numbers ( table -- assoc )
   9     transitions>> keys H{ } zip-index-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         [ final-states>> '[ _ in? ] bi@ = ]
  21         [ transitions>> '[ _ at keys ] bi@ set= ]
  22     } 3&& ;
  23
  24 :: initialize-partitions ( transition-table -- partitions )
  25     ! Partition table is sorted-array => ?
  26     transition-table transitions>> keys sort :> states
  27     states length 2/ sq <hash-set> :> out
  28     states [| s1 i1 |
  29         states [| s2 |
  30             s1 s2 transition-table initially-same?
  31             [ s1 s2 2array out adjoin ] when
  32         ] i1 each-from
  33     ] each-index out ;
  34
  35 : same-partition? ( s1 s2 partitions -- ? )
  36     { [ [ sort-pair 2array ] dip in? ] [ drop = ] } 3|| ;
  37
  38 : stay-same? ( s1 s2 transition partitions -- ? )
  39     [ '[ _ transitions>> at ] bi@ ] dip
  40     '[ [ at ] dip _ same-partition? ] with assoc-all? ;
  41
  42 :: partition-more ( partitions transition-table -- partitions changed? )
  43     partitions cardinality :> size
  44     partitions members [
  45         dup first2 transition-table partitions stay-same?
  46         [ drop ] [ partitions delete ] if
  47     ] each partitions dup cardinality size = not ;
  48
  49 : partition>classes ( partitions -- synonyms ) ! old-state => new-state
  50     members inv-sort [ swap ] H{ } assoc-map-as ;
  51
  52 : (state-classes) ( transition-table -- partition )
  53     [ initialize-partitions ] keep '[ _ partition-more ] loop ;
  54
  55 : assoc>set ( assoc -- keys-set )
  56     [ drop dup ] assoc-map ;
  57
  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 ;
  61
  62 : canonical-state? ( state transitions state-classes -- ? )
  63     '[ dup _ at =  ] swap '[ _ at has-conditions? ] bi or ;
  64
  65 : delete-duplicates ( transitions state-classes -- new-transitions )
  66     dupd '[ _ _ canonical-state? ] filter-keys ;
  67
  68 : combine-states ( table -- smaller-table )
  69     dup state-classes
  70     [ transitions-at ] keep
  71     '[ _ delete-duplicates ] change-transitions ;
  72
  73 : combine-state-transitions ( hash -- hash )
  74     [ H{ } clone ] dip over '[
  75         _ [ 2array <or-class> ] change-at
  76     ] assoc-each [ swap ] assoc-map ;
  77
  78 : combine-transitions ( table -- table )
  79     [ [ combine-state-transitions ] assoc-map ] change-transitions ;
  80
  81 : minimize ( table -- minimal-table )
  82     clone
  83     number-states
  84     combine-states
  85     combine-transitions
  86     expand-ors ;