fa.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/*  (c) 2004-1007 Andreas Kupries*/
/*  Grammar / Finite Automatons / Container*/

/*  ### ### ### ######### ######### #########*/
/*  Package description*/

/*  A class whose instances hold all the information describing a*/
/*  single finite automaton (states, symbols, start state, set of*/
/*  accepting states, transition function), and operations to define,*/
/*  manipulate, and query this information.*/

/*  ### ### ### ######### ######### #########*/
/*  Requisites*/

package require grammar::fa::op ; /*  Heavy FA operations.*/
package require snit            ; /*  OO system in use*/
package require struct::list    ; /*  Extended list operations.*/
package require struct::     ; # Extended =   operations = .

/*  ### ### ### ######### ######### #########*/
/*  Implementation*/

snit::type ::grammar::fa {
    /*  ### ### ### ######### ######### #########*/
    /*  Type API. A number of operations on FAs*/

    /*  ### ### ### ######### ######### #########*/
    /*  Instance API*/

    /* constructor {args} {}*/
    /* destructor  {}*/

    ret  =   {b} ()
    method --> {b} {}

    ret  serialize () {}
    ret  deserialize (type value) {}
    ret  deserialize_merge (type value) {}

    ret  states () {}
    ret  state (type cmd , type s , type args) {}

    ret  startstates () {}
    ret  start?      (type s) {}
    ret  start?set   (type states) {}
    ret  start       (type cmd , type args) {}

    ret  finalstates () {}
    ret  final?      (type s) {}
    ret  final?set   (type states) {}
    ret  final       (type cmd , type args) {}

    ret  symbols     () {}
    ret  symbols@    (type state) {}
    ret  symbols@set (type states) {}
    ret  symbol      (type cmd , type sym) {}

    ret  next  (type s , type sym , type args) {}
    ret  !next (type s , type sym , type args) {}
    ret  nextset (type states , type sym) {}

    ret  is (type cmd) {}

    ret  reachable_states   () {}
    ret  unreachable_states () {}
    ret  reachable          (type s) {}

    ret  useful_states   () {}
    ret  unuseful_states () {}
    ret  useful          (type s) {}

    ret  epsilon_closure (type s) {}

    ret  clear () {}

    /*  ### ### ### ######### ######### #########*/
    /*  Instance API. Complex FA operations.*/
    /*  The heavy lifting is done by the operations package.*/

    ret  reverse    ()                          {op::reverse    $self}
    ret  complete   (optional sink ={)}                 {op::complete   $self $sink}
    method remove_eps {}                          {op::remove_eps $self}
    method trim       {{what !reachable|!useful}} {op::trim       $self $what}
    ret  complement ()                          {op::complement $self}
    ret  kleene     ()                          {op::kleene     $self}
    ret  optional   ()                          {op::optional   $self}
    ret  fromRegex  (type regex , optional over ={)}           {op::fromRegex  $self $regex $over}

    method determinize {{mapvar {}}} {
    if {$mapvar ne ""} {upvar 1 $mapvar map}
    op::determinize $self map
    }

    ret  minimize (optional mapvar ={)} {
    if {$mapvar ne ""} {upvar 1 $mapvar map}
    op::minimize $self map
    }

    ret  union (type fa , optional mapvar ={)} {
    if {$mapvar ne ""} {upvar 1 $mapvar map}
    op::union $self $fa map
    }

    ret  intersect (type fa , optional mapvar ={)} {
    if {$mapvar ne ""} {upvar 1 $mapvar map}
    op::intersect $self $fa map
    }

    ret  difference (type fa , optional mapvar ={)} {
    if {$mapvar ne ""} {upvar 1 $mapvar map}
    op::difference $self $fa map
    }

    ret  concatenate (type fa , optional mapvar ={)} {
    if {$mapvar ne ""} {upvar 1 $mapvar map}
    op::concatenate $self $fa map
    }

    /*  ### ### ### ######### ######### #########*/
    /*  Internal data structures.*/

    /*  State information:*/
    /*  - Order    : Defined for all states, values provide creation order.*/
    /*  - Start    : Defined for states which are "start" (Input processing begins in).*/
    /*  - Final    : Defined for states which are "final" ("accept" input).*/
    /*  - Transinv : Inverse transitions. Per state the set of (state,sym)'s*/
    /*               which have transitions into the state. Defined only for*/
    /*               states which have inbound transitions.*/
    /** 
     *# Transinv is maintained to make state deletion easier: Direct
     *# access to the states and transitions which are inbound, for
     *# their deletion.
 */

    variable order        ; /*  Map : State -> Order of creation*/
    variable final        ; /*  Map : State -> .   Exists <=> Is a final State*/
    variable start        ; /*  Map : State -> .   Exists <=> Is a start State*/
    variable transinv     ; /*  Map : State -> {(State, Sym)}*/

    /*  Global information:*/
    /*  - Scount     : Counter for creation order of states.*/

    variable scount     0  ; /*  Counter for orderering states.*/

    /*  Symbol information:*/
    /*  - Symbol : Defined for all symbols, values irrelevant.*/

    variable symbol       ; /*  Map : Symbol -> . Exists = Symbol declared.*/

    /*  Transition data:*/
    /*  - TransN  : Dynamically created instance variables. Transition tables*/
    /*              for single states. Defined only for states which have*/
    /*              transitions.*/
    /*  - Transym : List of states having transitions on that symbol.*/

    /*  Transym is maintained for symbol deletion. Direct access to the transitions*/
    /*  we have to delete as well.*/

    /*  selfns::trans_$order(state) : Per state map : symbol -> list of destinations.*/
    variable transym      ; /*  Map : Sym -> {State}*/

    /*  Derived information:*/
    /*  - Reach       : Cache for set of states reachable from start.*/
    /*  - Reachvalid  : Boolean flag. True iff the reach cache contains valid data*/
    /*  - Useful      : Cache for set of states able to reach final.*/
    /*  - Usefulvalid : Boolean flag. True iff the useful cache contains valid data*/
    /*  - Nondete     : Set of states which are non-deterministic, because they have*/
    /*                   epsilon-transitions.*/
    /*  -  EC          : Cache of epsilon-closures*/

    variable reach      {} ; /*  Set of states reachable from 'start'.*/
    variable reachvalid 0  ; /*  Boolean flag, if 'reach' is valid.*/

    variable useful      {} ; /*  Set of states able to reach 'final'.*/
    variable usefulvalid 0  ; /*  Boolean flag, if 'useful' is valid.*/

    variable nondete    {} ; /*  Set of non-deterministic states, by epsilon/non-epsilon.*/
    variable nondets       ; /*  Per non-det state the set of symbols it is non-det in.*/

    variable ec            ; /*  Cache of epsilon-closures for states.*/


    /*  ### ### ### ######### ######### #########*/
    /*  Instance API Implementation.*/

    constructor {args} {
     alen =  [llength $args]
    if {($alen != 2) && ($alen != 0) && ($alen != 3)} {
        return -code error "wrong/* args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"*/
    }

    array  order =     {} ;  nondete =      {}
    array  start =     {} ;  scount =       0
    array  final =     {} ;  reach =        {}
    array  symbol =    {} ;  reachvalid =   0
    array  transym =   {} ;  useful =       {}
    array  transinv =  {} ;  usefulvalid =  0
    array  nondets =   {}
    array  ec =        {}

    if {$alen == 0} return

    foreach {cmd object} $args break
    switch -exact -- $cmd {
        = - := - <-- - as {
        if {$alen != 2} {
            return -code error "wrong/* args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"*/
        }
        $self = $object
        }
        deserialize {
        if {$alen != 2} {
            return -code error "wrong/* args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"*/
        }
        /*  Object is actually a value, the deserialization to use.*/
        $self deserialize $object
        }
        fromRegex {
        /*  Object is actually a value, the regular expression to use.*/
        if {$alen == 2} {
            $self fromRegex $object
        } else {
            $self fromRegex $object [lindex $args 2]
        }
        }
        default {
        return -code error "bad assignment: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"
        }
    }
    return
    }

    /*  destructor {}*/

    /*  --- --- --- --------- --------- ---------*/

    ret  = {b} (
    $type self , type deserialize [$, type b , type serialize]
    )

    method --> {b} {
    $b deserialize [$self serialize]
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  serialize () {
    set ord {}
    foreach {s n} [array get order] {
        lappend ord [list $s $n]
    }
    set states {} ; # Dictionary
    foreach item [lsort -index 1 -integer -increasing $ord] {
        set s [lindex $item 0]
        set sdata {}

        # Dict data per state :

        lappend sdata [info exists start($s)]
        lappend sdata [info exists final($s)]

        # Transitions from the state.

        upvar #0 ${selfns}::trans_$order($s) jump

        if {![info exists jump]} {
        lappend sdata {}
        } else {
        lappend sdata [array get jump]
        }

        # ----------------------
        lappend states $s $sdata
    }

    return [::list \
        grammar::fa \
        [array names symbol] \
        $states \
        ]
    }

    ret  deserialize (type value) {
    $self CheckSerialization $value st states acc tr newsymbols
    $self clear

    foreach s   $states     {set order($s)    [incr scount]}
    foreach sym $newsymbols {set symbol($sym) .}
    foreach s   $acc        {set final($s)    .}
    foreach s   $st         {set start($s)    .}

    foreach {sa sym se} $tr {$self Next $sa $sym $se}
    return
    }

    ret  deserialize_merge (type value) {
    $self CheckSerialization $value st states acc tr newsymbols

    foreach s   $states     {set order($s)    [incr scount]}
    foreach sym $newsymbols {set symbol($sym) .}
    foreach s   $acc        {set final($s)    .}
    foreach s   $st         {set start($s)    .}

    foreach {sa sym se} $tr {$self Next $sa $sym $se}
    return
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  states () {
    return [array names order]
    }

    ret  state (type cmd , type s , type args) {
    switch -exact -- $cmd {
        add {
        set args [linsert $args 0 $s]
        foreach s $args {
            if {[info exists order($s)]} {
            return -code error "State \"$s\" is already known"
            }
        }
        foreach s $args {set order($s) [incr scount]}
        return
        }
        delete {
        set args [linsert $args 0 $s]
        $self StateCheckSet $args

        foreach s $args {
            unset -nocomplain start($s)                   ; # Start/Initial indicator
            unset -nocomplain final($s)                   ; # Final/Accept indicator

            # Remove all inbound transitions.
            if {[info exists transinv($s)]} {
            set src $transinv($s)
            unset    transinv($s)

            foreach srcitem $src {
                struct::list assign $srcitem sin sym
                $self !Next $sin $sym $s
            }
            }

            # We remove transition data only after the inbound
            # ones. Otherwise we screw up the removal of
            # looping transitions. We have to consider the
            # backpointers to us in transinv as well.

            upvar #0  ${selfns}::trans_$order($s) jump
            if {[info exists jump]} {
            foreach sym [array names jump] {
                $self !Transym $s $sym
                foreach nexts $jump($sym) {
                $self !Transinv $s $sym $nexts
                }
            }

            unset ${selfns}::trans_$order($s) ; # Transitions from s
            }
            unset order($s)                               ; # State ordering

            # Removal of a state may break the automaton into
            # disconnected pieces. This means that the set of
            # reachable and useful states may change, and the
            # cache cannot be used from now on.

            $self InvalidateReach
            $self InvalidateUseful
        }
        return
        }
        rename {
        set alen [llength $args]
        if {($alen != 1)} {
            return -code error "wrong#args: [list $self] state rename s s'"
        }
        $self StateCheck $s
        set snew [lindex $args 0]
        if {[info exists order($snew)]} {
            return -code error "State \"$snew\" is already known"
        }

        set o $order($s)
        unset order($s)                               ; # State ordering
        set   order($snew) $o

                # Start/Initial indicator
        if {[info exists start($s)]} {
            set   start($snew) $start($s)
            unset start($s)
        }
                # Final/Accept indicator
        if {[info exists final($s)]} {
            set   final($snew) $final($s)
            unset final($s)
        }
        # Update all inbound transitions.
        if {[info exists transinv($s)]} {
            set   transinv($snew) $transinv($s)
            unset transinv($s)

            # We have to perform a bit more here. We have to
            # go through the inbound transitions and chane the
            # listed destination state to the new name.

            foreach srcitem $transinv($snew) {
            struct::list assign $srcitem sin sym
            upvar #0 ${selfns}::trans_$order($sin) jump
            upvar 0 jump($sym) destinations
            set pos [lsearch -exact $destinations $s]
            set destinations [lreplace $destinations $pos $pos $snew]
            }
        }

        # Another place to change are the back pointers from
        # all the states we have transitions to, i.e. transinv
        # for all outbound states.

        upvar #0 ${selfns}::trans_$o jump
        if {[info exists jump]} {
            foreach sym [array names jump] {
            foreach sout $jump($sym) {
                upvar 0 transinv($sout) backpointer
                set pos [lsearch -exact $backpointer [list $s $sym]]
                set backpointer [lreplace $backpointer $pos $pos [list $snew $sym]]
            }

            # And also to update: Transym information for the symbol.
            upvar 0 transym($sym) users
            set pos [lsearch -exact $users $s]
            set users [lreplace $users $pos $pos $snew]
            }
        }

        # Changing the name of a state does not change the
        # reachables / useful states per se. We just may have
        # to replace the name in the caches as well.

        # - Invalidation will do the same, at the expense of a
        # - larger computation later.

        $self InvalidateReach
        $self InvalidateUseful
        }
        exists {
        set alen [llength $args]
        if {$alen != 0} {
            return -code error "wrong#args: [list $self] state exists s"
        }
        return [info exists order($s)]
        }
        default {
        return -code error "Expected add, exists, delete, or rename, got \"$cmd\""
        }
    }
    return
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  startstates () {
    return [array names start]
    }

    ret  start? (type s) {
    $self StateCheck $s
    return [info exists start($s)]
    }

    ret  start?set (type states) {
    $self StateCheckSet $states
    foreach s $states {
        if {[info exists start($s)]} {return 1}
    }
    return 0
    }

    ret  start (type cmd , type args) {
    # Note: Adding or removing start states does not change
    # usefulness, only reachability
    switch -exact -- $cmd {
        add {
        if {[llength $args] < 1} {
            return -code error "wrong#args: start add state ..."
        }
        $self StateCheckSet $args
        foreach s $args {set start($s) .}
        $self InvalidateReach
        }
        set {
        if {[llength $args] != 1} {
            return -code error "wrong#args: start set states"
        }
        set states [lindex $args 0]
        $self StateCheckSet $states
        array unset start
        foreach s $states {set start($s) .}
        $self InvalidateReach
        }
        remove {
        if {[llength $args] < 1} {
            return -code error "wrong#args: start remove state ..."
        }
        $self StateCheckSet $args
        foreach s $args {
            unset -nocomplain start($s)
        }
        $self InvalidateReach
        }
        clear {
        if {[llength $args] != 0} {
            return -code error "wrong#args: start clear"
        }
        array unset start
        $self InvalidateReach
        }
        default {
        return -code error "Expected add, clear, remove, or set, got \"$cmd\""
        }
    }
    return
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  finalstates () {
    return [array names final]
    }

    ret  final? (type s) {
    $self StateCheck $s
    return [info exists final($s)]
    }

    ret  final?set (type states) {
    $self StateCheckSet $states
    foreach s $states {
        if {[info exists final($s)]} {return 1}
    }
    return 0
    }

    ret  final (type cmd , type args) {
    # Note: Adding or removing start states does not change
    # reachability, only usefulness
    switch -exact -- $cmd {
        add {
        if {[llength $args] < 1} {
            return -code error "wrong#args: final add state ..."
        }
        $self StateCheckSet $args
        foreach s $args {set final($s) .}
        $self InvalidateUseful
        }
        set {
        if {[llength $args] != 1} {
            return -code error "wrong#args: final set states"
        }
        set states [lindex $args 0]
        $self StateCheckSet $states
        array unset final
        foreach s $states {set final($s) .}
        $self InvalidateReach
        }
        remove {
        if {[llength $args] < 1} {
            return -code error "wrong#args: final remove state ..."
        }
        $self StateCheckSet $args
        foreach s $args {
            unset -nocomplain final($s)
        }
        $self InvalidateUseful
        }
        clear {
        if {[llength $args] != 0} {
            return -code error "wrong#args: final clear"
        }
        array unset final
        $self InvalidateReach
        }
        default {
        return -code error "Expected add, clear, remove, or set, got \"$cmd\""
        }
    }
    return
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  symbols () {
    return [array names symbol]
    }

    ret  symbols@ (type s , optional t ={)} {
    $self StateCheck $s
    if {$t ne ""} { $self StateCheck $t}
    upvar /* 0 ${selfns}::trans_$order($s) jump*/
    if {![info exists jump]} {return {}}
    if {$t eq ""} {
        /*  No destination, all symbols.*/
        return [array names jump]
    }
    /*  Specific destination, locate the symbols going there.*/
     result =  {}
    foreach sym [array names jump] {
        if {[lsearch -exact $jump($sym) $t] < 0} continue
        lappend result $sym
    }
    return [lsort -uniq $result]
    }

    ret  symbols@set (type states) {
    # Union (fa symbol@ s, f.a. s in states)

    $self StateCheckSet $states
    set result {}
    foreach s $states {
        upvar #0 ${selfns}::trans_$order($s) jump
        if {![info exists jump]} continue
        foreach sym [array names jump] {
        lappend result $sym
        }
    }
    return [lsort -uniq $result]
    }

    ret  symbol (type cmd , type sym , type args) {
    switch -exact -- $cmd {
        add {
        set args [linsert $args 0 $sym]
        foreach sym $args {
            if {$sym eq ""} {
            return -code error "Cannot add illegal empty symbol \"\""
            }
            if {[info exists symbol($sym)]} {
            return -code error "Symbol \"$sym\" is already known"
            }
        }
        foreach sym $args {set symbol($sym) .}
        }
        delete {
        set args [linsert $args 0 $sym]
        $self SymbolCheckSetNE $args
        foreach sym $args {
            unset symbol($sym)

            # Delete all transitions using the removed symbol.

            if {[info exists transym($sym)]} {
            foreach s $transym($sym) {
                $self !Next $s $sym
            }
            }
        }
        }
        rename {
        set alen [llength $args]
        if {$alen != 1} {
            return -code error "wrong#args: [list $self] symbol rename sym newsym"
        }
        $self SymbolCheckNE $sym
        set newsym [lindex $args 0]

        if {$newsym eq ""} {
            return -code error "Cannot add illegal empty symbol \"\""
        }
        if {[info exists symbol($newsym)]} {
            return -code error "Symbol \"$newsym\" is already known"
        }

        unset symbol($sym)
        set symbol($newsym) .

        if {[info exists transym($sym)]} {
            set   transym($newsym) [set states $transym($sym)]
            unset transym($sym)

            foreach s $states {
            # Update the jump tables for each of the states
            # using this symbol, and the reverse tables as
            # well.

            upvar #0 ${selfns}::trans_$order($s) jump
            set   jump($newsym) [set destinations $jump($sym)]
            unset jump($sym)

            foreach sd $destinations {
                upvar 0 transinv($sd) backpointer
                set pos [lsearch -exact $backpointer [list $s $sym]]
                set backpointer [lreplace $backpointer $pos $pos [list $s $newsym]]
            }
            }
        }
        }
        exists {
        set alen [llength $args]
        if {$alen != 0} {
            return -code error "wrong#args: [list $self] symbol exists sym"
        }
        return [info exists symbol($sym)]
        }
        default {
        return -code error "Expected add, delete, exists, or rename, got \"$cmd\""
        }
    }
    return
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  next (type s , type sym , type args) {
    ## Split into checking and functionality ...

    set alen [llength $args]
    if {($alen != 2) && ($alen != 0)} {
        return -code error "wrong#args: [list $self] next s sym ?--> s'?"
    }
    $self StateCheck  $s
    $self SymbolCheck $sym

    if {($alen == 2) && [set cmd [lindex $args 0]] ne "-->"} {
        return -code error "Expected -->, got \"$cmd\""
    }

    if {$alen == 0} {
        # Query transition table.
        upvar #0 ${selfns}::trans_$order($s) jump
        if {![info exists jump($sym)]} {return {}}
        return $jump($sym)
    }

    set nexts [lindex $args 1]
    $self StateCheck $nexts

    upvar #0 ${selfns}::trans_$order($s) jump
    if {[info exists jump($sym)] && [struct::set contains $jump($sym) $nexts]} {
        return -code error "Transition \"($s, ($sym)) --> $nexts\" is already known"
    }

    $self Next $s $sym $nexts
    return
    }

    ret  !next (type s , type sym , type args) {
    set alen [llength $args]
    if {($alen != 2) && ($alen != 0)} {
        return -code error "wrong#args: [list $self] !next s sym ?--> s'?"
    }
    $self StateCheck  $s
    $self SymbolCheck $sym

    if {$alen == 2} {
        if {[lindex $args 0] ne "-->"} {
        return -code error "Expected -->, got \"[lindex $args 0]\""
        }
        set nexts [lindex $args 1]
        $self StateCheck $nexts
        $self !Next $s $sym $nexts
    } else {
        $self !Next $s $sym
    }
    }

    ret  nextset (type states , type sym) {
    $self SymbolCheck   $sym
    $self StateCheckSet $states

    set result {}
    foreach s $states {
        upvar #0 ${selfns}::trans_$order($s) jump
        if {![info exists jump($sym)]} continue
        struct::set add result $jump($sym)
    }
    return $result
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  is (type cmd) {
    switch -exact -- $cmd {
        complete {
        # The FA is complete if Trans(State, Sym) != {} for all
        # states and symbols (Not counting epsilon transitions).
        # Without symbols the FA is deemed complete. Note:
        # States with epsilon transitions can use symbols
        # indirectly! Need their closures for exact
        # computation.

        set nsymbols [llength [array names symbol]]
        if {$nsymbols == 0} {return 1}
        foreach s [array names order] {
            upvar #0 ${selfns}::trans_$order($s) jump
            if {![info exists jump]} {return 0}
            set njsym [array size jump]
            if {[info exists jump()]} {
            set  njsym [llength [$self symbols@set [$self epsilon_closure $s]]]
            incr njsym -1
            }
            if {$njsym != $nsymbols}  {return 0}
        }
        return 1
        }
        deterministic {
        # The FA is deterministic if it has on start state, no
        # epsilon transitions, and the transition function is
        # State x Symbol -> State, and not
        # State x Symbol -> P(State).

        return [expr {
            ([array size start] == 1) &&
            ![llength $nondete] &&
            ![array size nondets]
        }] ;#{}
        }
        epsilon-free {
        # FA is epsion-free if there are no states having epsilon transitions.
        return [expr {![llength $nondete]}]
        }
        useful {
        # The FA is useful if and only if we have states and
        # all states are reachable and useful.

        set states [$self states]
        return [expr {
            [struct::set size $states] &&
            [struct::set equal $states [$self reachable_states]] &&
            [struct::set equal $states [$self useful_states]]
        }] ;# {}
        }
    }
    return -code error "Expected complete, deterministic, epsilon-free, or useful, got \"$cmd\""
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  reachable_states () {
    if {$reachvalid} {return $reach}
    if {![array size start]} {
        set reach {}
    } else {
        # Basic algorithm like for epsilon_closure, except that we
        # process all transitions, not only epsilons, and that
        # the initial state is fixed to start.

        set reach   [array names start]
        set pending $reach
        array set visited {}
        while {[llength $pending]} {
        set s [struct::list shift pending]
        if {[info exists visited($s)]} continue
        set visited($s) .
        upvar #0 ${selfns}::trans_$order($s) jump
        if {![info exists jump]} continue
        if {![array size  jump]} continue
        foreach sym [array names jump] {
            struct::set add reach   $jump($sym)
            struct::set add pending $jump($sym)
        }
        }
    }
    set reachvalid 1
    return $reach
    }

    ret  unreachable_states () {
    # unreachable = states - reachables
    return [struct::set difference \
        [$self states] [$self reachable_states]]
    }

    ret  reachable (type s) {
    $self StateCheck $s
    return [struct::set contains [$self reachable_states] $s]
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  useful_states () {
    if {$usefulvalid} {return $useful}

    # A state is useful if a final state
    # can be reached from it.

    if {![array size final]} {
        set useful {}
    } else {
        # Basic algorithm like for epsilon_closure, except that we
        # process all transitions, not only epsilons, and that
        # the initial set of states is fixed to final.

        set useful      [array names final]
        array set known [array get final]
        set pending $useful
        array set visited {}
        while {[llength $pending]} {
        set s [struct::list shift pending]
        if {[info exists visited($s)]} continue
        set visited($s) .

        # All predecessors are useful, and have to be visited as well.
        # We get the predecessors from the transinv structure.

        if {![info exists transinv($s)]} continue
        foreach before $transinv($s) {
            set before [lindex $before 0]
            if {[info exists visited($before)]} continue
            lappend pending $before
            if {[info exists known($before)]} continue
            lappend useful $before
            set known($before) .
        }
        }
    }
    set usefulvalid 1
    return $useful
    }

    ret  unuseful_states () {
    # unuseful = states - useful
    return [struct::set difference \
        [$self states] [$self useful_states]]
    }

    ret  useful (type s) {
    $self StateCheck $s
    return [struct::set contains [$self useful_states] $s]
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  epsilon_closure (type s) {
    # Iterative graph traversal. Keeps a set of states to look at,
    # and adds to them everything it can reach from the current
    # state via epsilon-transitions. Loops are handled through the
    # visited array to weed out all the states already processed.

    $self StateCheck $s

    # Prefer cached information
    if {[info exists ec($s)]} {
        return $ec($s)
    }

    set closure [list $s]
    set pending [list $s]
    array set visited {}
    while {[llength $pending]} {
        set t [struct::list shift pending]
        if {[info exists visited($t)]} continue
        set visited($t) .
        upvar #0 ${selfns}::trans_$order($t) jump
        if {![info exists jump()]} continue
        struct::set add closure $jump()
        struct::set add pending $jump()
    }
    set ec($s) $closure
    return $closure
    }

    /*  --- --- --- --------- --------- ---------*/

    ret  clear () {
    array unset order    ; set nondete     {}
    array unset start    ; set scount      0
    array unset final    ; set reach       {}
    array unset symbol   ; set reachvalid  0
    array unset transym  ; set useful      {}
    array unset transinv ; set usefulvalid 0
    array unset nondets
    array unset ec

    # Locate all 'trans_' arrays and remove them as well.

    foreach v [info vars ${selfns}::trans_*] {
        unset $v
    }
    return
    }

    /*  ### ### ### ######### ######### #########*/
    /*  Instance Internals.*/

    ret  StateCheck (type s) {
    if {![info exists order($s)]} {
        return -code error "Illegal state \"$s\""
    }
    }

    ret  StateCheckSet (type states) {
    foreach s $states {
        if {![info exists order($s)]} {
        return -code error "Illegal state \"$s\""
        }
    }
    }

    ret  SymbolCheck (type sym) {
    if {$sym eq ""} return
    if {![info exists symbol($sym)]} {
        return -code error "Illegal symbol \"$sym\""
    }
    }

    ret  SymbolCheckNE (type sym) {
    if {($sym eq "") || ![info exists symbol($sym)]} {
        return -code error "Illegal symbol \"$sym\""
    }
    }

    if 0 {
    /*  Unused. Activate when needed.*/
    ret  SymbolCheckSet (type symbols) {
        foreach sym $symbols {
        if {$sym eq ""} continue
        if {![info exists symbol($sym)]} {
            return -code error "Illegal symbol \"$sym\""
        }
        }
    }
    }

    ret  SymbolCheckSetNE (type symbols) {
    foreach sym $symbols {
        if {($sym eq "") || ![info exists symbol($sym)]} {
        return -code error "Illegal symbol \"$sym\""
        }
    }
    }

    ret  Next (type s , type sym , type nexts) {
    # Modify transition table. May update the set of
    # non-deterministic states. Invalidates reachable
    # cache, as states may become reachable. Updates
    # the transym and transinv mappings.

    upvar #0 ${selfns}::trans_$order($s) jump

    $self InvalidateReach
    $self InvalidateUseful
    # Clear closure cache when epsilons change.
    if {$sym eq ""} {array unset ec}

    if {[info exists transym($sym)]} {
        struct::set include transym($sym) $s
    } else {
        set transym($sym) [list $s]
    }

    if {[info exists transinv($nexts)]} {
        struct::set include transinv($nexts) [list $s $sym]
    } else {
        set transinv($nexts) [list [list $s $sym]]
    }

    if {![info exists jump($sym)]} {
        set jump($sym) [list $nexts]
    } else {
        struct::set include jump($sym) $nexts
    }
    $self NonDeterministic $s $sym
    return
    }

    ret  !Next (type s , type sym , type args) {
    upvar #0 ${selfns}::trans_$order($s) jump
    # Anything to do at all ?
    if {![info exists jump($sym)]} return
    $self InvalidateReach
    $self InvalidateUseful
    # Clear closure cache when epsilons change.
    if {$sym eq ""} {array unset ec}

    if {![llength $args]} {
        # Unset all transitions for (s, sym)
        # Update transym and transinv mappings as well, if existing.

        $self !Transym $s $sym
        foreach nexts $jump($sym) {
        $self !Transinv $s $sym $nexts
        }

        unset jump($sym)
    } else {
        # Remove the single transition (s, sym) -> nexts
        set nexts [lindex $args 0]

        struct::set exclude jump($sym) $nexts
        $self !Transinv $s $sym $nexts

        if {![struct::set size $jump($sym)]} {
        $self !Transym $s $sym
        unset jump($sym)
        if {![array size jump]} {
            unset jump
        }
        }
    }

    $self NonDeterministic $s $sym
    return
    }

    ret  !Transym (type s , type sym) {
    struct::set exclude transym($sym) $s
    if {![struct::set size $transym($sym)]} {
        unset transym($sym)
    }
    }

    ret  !Transinv (type s , type sym , type nexts) {
    if {[info exists transinv($nexts)]} {
        struct::set exclude transinv($nexts) [list $s $sym]
        if {![struct::set size $transinv($nexts)]} {
        unset transinv($nexts)
        }
    }
    }

    ret  InvalidateReach () {
    set reachvalid 0
    set reach      {}
    return
    }

    ret  InvalidateUseful () {
    set usefulvalid 0
    set useful     {}
    return
    }

    ret  NonDeterministic (type s , type sym) {
    upvar #0 ${selfns}::trans_$order($s) jump

    # Epsilon rule, whole state check. Epslion present <=> Not a DFA.

    if {[info exists jump()]} {
        struct::set include nondete $s
    } else {
        struct::set exclude nondete $s
    }

    # Non-determinism over a symbol.

    upvar #0 ${selfns}::trans_$order($s) jump

    if {[info exists jump($sym)] && [struct::set size $jump($sym)] > 1} {
        if {![info exists nondets($s)]} {
        set nondets($s) [list $sym]
        } else {
        struct::set include nondets($s) $sym
        }
        return
    } else {
        if {![info exists nondets($s)]} return
        struct::set exclude nondets($s) $sym
        if {![struct::set size $nondets($s)]} {
        unset nondets($s)
        }
    }
    return
    }

    ret  CheckSerialization (type value , type startst , type states , type acc , type trans , type syms) {
    # value is list/3 ('grammar::fa' symbols states)
    # !("" in symbols)
    # states is ordered dict (key is state, value is statedata)
    # statedata is list/3 (start final trans|"")
    # start is boolean
    # final is boolean
    # trans is dict (key in symbols, value is destinations)
    # destinations is set of states

    upvar 1 $startst startstates \
        $states  sts \
        $acc     a \
        $trans   t \
        $syms    symbols

    set prefix "error in serialization:"
    if {[llength $value] != 3} {
        return -code error "$prefix list length not 3"
    }

    struct::list assign $value   stype symbols statedata

    if {$stype ne "grammar::fa"} {
        return -code error "$prefix unknown type \"$stype\""
    }
    if {[struct::set contains $symbols ""]} {
        return -code error "$prefix empty symbol is not legal"
    }

    if {[llength $statedata] % 2 == 1} {
        return -code error "$prefix state data is not a dictionary"
    }
    array set _states $statedata
    if {[llength $statedata] != (2*[array size _states])} {
        return -code error "$prefix state data contains duplicate states"
    }
    set startstates {}
    set sts {}
    set p   {}
    set a   {}
    set e   {}
    set l   {}
    set m   {}
    set t   {}
    foreach {k v} $statedata {
        lappend sts $k
        if {[llength $v] != 3} {
        return -code error "$prefix state list length not 3"
        }

        struct::list assign $v begin accept trans

        if {![string is boolean -strict $begin]} {
        return -code error "$prefix expected boolean for start, got \"$begin\""
        }
        if {$begin} {lappend startstates $k}
        if {![string is boolean -strict $accept]} {
        return -code error "$prefix expected boolean for final, got \"$accept\""
        }
        if {$accept} {lappend a $k}

        if {[llength $trans] % 2 == 1} {
        return -code error "$prefix transition data is not a dictionary"
        }
        array set _trans $trans
        if {[llength $trans] != (2*[array size _trans])} {
        return -code error "$prefix transition data contains duplicate symbols"
        }
        unset _trans

        foreach {sym destinations} $trans {
        # destinations = list of state
        if {($sym ne "") && ![struct::set contains $symbols $sym]} {
            return -code error "$prefix illegal symbol \"$sym\" in transition"
        }
        foreach dest $destinations {
            if {![info exists _states($dest)]} {
            return -code error "$prefix illegal destination state \"$dest\""
            }
            lappend t $k $sym $dest
        }
        }
    }
    return
    }

    /*  ### ### ### ######### ######### #########*/
    /*  Type API implementation.*/

    /*  ### ### ### ######### ######### #########*/
    /*  Type Internals.*/

    /*  ### ### ### ######### ######### #########*/
}

/*  ### ### ### ######### ######### #########*/
/*  Initialization. Specify the container constructor command to use by*/
/*  the operations package.*/

::grammar::fa::op::constructor ::grammar::fa

/*  ### ### ### ######### ######### #########*/
/*  Package Management*/

package provide grammar::fa 0.3