basis/regexp/negation/negation.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs hashtables kernel namespaces regexp.ast
   4 regexp.classes regexp.dfa regexp.disambiguate regexp.minimize
   5 regexp.nfa regexp.transition-tables sequences sets vectors ;
   6 IN: regexp.negation
   7
   8 CONSTANT: fail-state -1
   9
  10 : add-default-transition ( state's-transitions -- new-state's-transitions )
  11     clone dup
  12     [ [ fail-state ] dip keys [ <not-class> ] map <and-class> ] keep set-at ;
  13
  14 : fail-state-recurses ( transitions -- new-transitions )
  15     clone dup
  16     [ fail-state t associate fail-state ] dip set-at ;
  17
  18 : add-fail-state ( transitions -- new-transitions )
  19     [ add-default-transition ] assoc-map
  20     fail-state-recurses ;
  21
  22 : inverse-final-states ( transition-table -- final-states )
  23     [ transitions>> keys ] [ final-states>> ] bi diff fast-set ;
  24
  25 : negate-table ( transition-table -- transition-table )
  26     clone
  27         [ add-fail-state ] change-transitions
  28         dup inverse-final-states >>final-states ;
  29
  30 : renumber-states ( transition-table -- transition-table )
  31     dup transitions>> keys [ next-state ] H{ } map>assoc
  32     transitions-at ;
  33
  34 : box-transitions ( transition-table -- transition-table )
  35     [ [ [ 1vector ] assoc-map ] assoc-map ] change-transitions ;
  36
  37 : unify-final-state ( transition-table -- transition-table )
  38     dup [ final-states>> members ] keep
  39     '[ -2 epsilon _ set-transition ] each
  40     HS{ -2 } clone >>final-states ;
  41
  42 : adjoin-dfa ( transition-table -- start end )
  43     unify-final-state renumber-states box-transitions
  44     [ start-state>> ]
  45     [ final-states>> members first ]
  46     [ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ;
  47
  48 : ast>nfa ( parse-tree -- minimal-dfa )
  49     construct-nfa disambiguate ;
  50
  51 : ast>dfa ( parse-tree -- minimal-dfa )
  52     ast>nfa construct-dfa minimize ;
  53
  54 M: negation nfa-node
  55     term>> ast>dfa negate-table adjoin-dfa ;