basis/regexp/transition-tables/transition-tables.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs fry hashtables kernel sequences
   4 vectors regexp.utils ;
   5 IN: regexp.transition-tables
   6
   7 TUPLE: transition from to obj ;
   8 TUPLE: literal-transition < transition ;
   9 TUPLE: class-transition < transition ;
  10 TUPLE: default-transition < transition ;
  11
  12 TUPLE: literal obj ;
  13 TUPLE: class obj ;
  14 TUPLE: default ;
  15 : make-transition ( from to obj class -- obj )
  16     new
  17         swap >>obj
  18         swap >>to
  19         swap >>from ;
  20
  21 : <literal-transition> ( from to obj -- transition )
  22     literal-transition make-transition ;
  23
  24 : <class-transition> ( from to obj -- transition )
  25     class-transition make-transition ;
  26
  27 : <default-transition> ( from to -- transition )
  28     t default-transition make-transition ;
  29
  30 TUPLE: transition-table transitions start-state final-states ;
  31
  32 : <transition-table> ( -- transition-table )
  33     transition-table new
  34         H{ } clone >>transitions
  35         H{ } clone >>final-states ;
  36
  37 : maybe-initialize-key ( key hashtable -- )
  38     2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
  39
  40 : set-transition ( transition hash -- )
  41     #! set the state as a key
  42     2dup [ to>> ] dip maybe-initialize-key
  43     [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
  44     2dup at* [ 2nip insert-at ]
  45     [ drop [ H{ } clone [ insert-at ] keep ] 2dip set-at ] if ;
  46
  47 : add-transition ( transition transition-table -- )
  48     transitions>> set-transition ;