basis/regexp/disambiguate/disambiguate.factor

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