basis/regexp/disambiguate/disambiguate.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs fry kernel locals math math.bits
   4 regexp.ast regexp.classes regexp.transition-tables sequences
   5 sets ;
   6 IN: regexp.disambiguate
   7
   8 TUPLE: parts in out ;
   9
  10 : make-partition ( choices classes -- partition )
  11     zip [ first ] partition [ values ] bi@ parts boa ;
  12
  13 : powerset-partition ( sequence -- partitions )
  14     [ length [ 2^ iota ] keep ] keep '[ _ <bits> _ make-partition ] map rest ;
  15
  16 : partition>class ( parts -- class )
  17     [ out>> [ <not-class> ] map ]
  18     [ in>> <and-class> ] bi prefix <and-class> ;
  19
  20 : singleton-partition ( integer non-integers -- {class,partition} )
  21     dupd
  22     '[ _ [ class-member? ] with filter ] keep
  23     prefix f parts boa
  24     2array ;
  25
  26 : add-out ( seq partition -- partition' )
  27     [ nip in>> ] [ out>> append ] 2bi parts boa ;
  28
  29 : intersection ( seq -- elts/f )
  30     [ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
  31
  32 : meaningful-integers ( partition table -- integers )
  33     [ [ in>> ] [ out>> ] bi ] dip
  34     '[ [ _ at ] map intersection ] bi@ diff ;
  35
  36 : class-integers ( classes integers -- table )
  37     '[ _ over '[ _ class-member? ] filter ] H{ } map>assoc ;
  38
  39 : add-integers ( partitions classes integers -- partitions )
  40     class-integers '[
  41         [ _ meaningful-integers ] [ ] bi add-out
  42     ] map ;
  43
  44 :: class-partitions ( classes -- assoc )
  45     classes [ integer? ] partition :> ( integers classes )
  46
  47     classes powerset-partition classes integers add-integers
  48     [ [ partition>class ] [ ] bi 2array ] map sift-keys
  49     integers [ classes singleton-partition ] map append ;
  50
  51 : new-transitions ( transitions -- assoc ) ! assoc is class, partition
  52     values [ keys ] gather [ tagged-epsilon? ] reject class-partitions ;
  53
  54 : get-transitions ( partition state-transitions -- next-states )
  55     [ in>> ] dip '[ _ at ] gather sift ;
  56
  57 : disambiguate ( nfa -- nfa )
  58     expand-ors [
  59         dup new-transitions '[
  60             [
  61                 _ swap '[ _ get-transitions ] assoc-map
  62                 harvest-values
  63             ] [
  64                 [ drop tagged-epsilon? ] assoc-filter
  65             ] bi H{ } assoc-union-as
  66         ] assoc-map
  67     ] change-transitions ;