# -*- tcl -*-
# 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 snit   ; # Tcllib | OO system used
package require struct ; # Tcllib | extended list, set operations.

# ### ### ### ######### ######### #########
## Implementation

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

    # ### ### ### ######### ######### #########
    ## Instance API

    #constructor {args} {}
    #destructor  {}

    method =   {b} {}
    method --> {b} {}

    method serialize {} {}
    method deserialize {value} {}
    method deserialize_merge {value} {}

    method states {} {}
    method state {cmd s args} {}

    method startstates {} {}
    method start?      {s} {}
    method start?set   {states} {}
    method start       {cmd args} {}

    method finalstates {} {}
    method final?      {s} {}
    method final?set   {states} {}
    method final       {cmd args} {}

    method symbols     {} {}
    method symbols@    {state} {}
    method symbols@set {states} {}
    method symbol      {cmd sym} {}

    method next  {s sym args} {}
    method !next {s sym args} {}
    method nextset {states sym} {}

    method is {cmd} {}

    method reachable_states   {} {}
    method unreachable_states {} {}
    method reachable          {s} {}

    method useful_states   {} {}
    method unuseful_states {} {}
    method useful          {s} {}

    method epsilon_closure {s} {}

    method clear {} {}

    # ### ### ### ######### ######### #########
    ## Instance API. FA operations. Defering to the operations package.

    method reverse {} {
	package require grammar::fa::op
	op::reverse $self
    }

    method complete {{sink {}}} {
	package require grammar::fa::op
	op::complete $self $sink
    }

    method remove_eps {} {
	package require grammar::fa::op
	op::remove_eps $self
    }

    method trim {{what !reachable|!useful}} {
	package require grammar::fa::op
	op::trim $self $what
    }

    method determinize {{mapvar {}}} {
	if {$mapvar ne ""} {upvar 1 $mapvar map}
	package require grammar::fa::op
	op::determinize $self map
    }

    method minimize {{mapvar {}}} {
	if {$mapvar ne ""} {upvar 1 $mapvar map}
	package require grammar::fa::op
	op::minimize $self map
    }

    method complement {} {
	package require grammar::fa::op
	op::complement $self
    }

    method kleene {} {
	package require grammar::fa::op
	op::kleene $self
    }

    method optional {} {
	package require grammar::fa::op
	op::optional $self
    }

    method union {fa {mapvar {}}} {
	if {$mapvar ne ""} {upvar 1 $mapvar map}
	package require grammar::fa::op
	op::union $self $fa map
    }

    method intersect {fa {mapvar {}}} {
	if {$mapvar ne ""} {upvar 1 $mapvar map}
	package require grammar::fa::op
	op::intersect $self $fa map
    }

    method difference {fa {mapvar {}}} {
	if {$mapvar ne ""} {upvar 1 $mapvar map}
	package require grammar::fa::op
	op::difference $self $fa map
    }

    method concatenate {fa {mapvar {}}} {
	if {$mapvar ne ""} {upvar 1 $mapvar map}
	package require grammar::fa::op
	op::concatenate $self $fa map
    }

    method fromRegex {regex {over {}}} {
	package require grammar::fa::op
	op::fromRegex $self $regex $over
    }

    # ### ### ### ######### ######### #########
    ## 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} {
	set alen [llength $args]
	if {($alen != 2) && ($alen != 0) && ($alen != 3)} {
	    return -code error "wrong#args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"
	}

	array set order    {} ; set nondete     {}
	array set start    {} ; set scount      0 
	array set final    {} ; set reach       {}
	array set symbol   {} ; set reachvalid  0 
	array set transym  {} ; set useful      {}
	array set transinv {} ; set usefulvalid 0
	array set nondets  {}
	array set 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 {}

    # --- --- --- --------- --------- ---------

    method = {b} {
	$self deserialize [$b serialize]
    }

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

    # --- --- --- --------- --------- ---------

    method 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 \
		]
    }

    method deserialize {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
    }

    method deserialize_merge {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
    }

    # --- --- --- --------- --------- ---------

    method states {} {
	return [array names order]
    }

    method state {cmd s 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
    }

    # --- --- --- --------- --------- ---------

    method startstates {} {
	return [array names start]
    }

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

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

    method start {cmd 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
    }

    # --- --- --- --------- --------- ---------

    method finalstates {} {
	return [array names final]
    }

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

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

    method final {cmd 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
    }

    # --- --- --- --------- --------- ---------

    method symbols {} {
	return [array names symbol]
    }

    method symbols@ {s} {
	$self StateCheck $s
	upvar #0 ${selfns}::trans_$order($s) jump
	if {![info exists jump]} {return {}}
	return [array names jump]
    }

    method symbols@set {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]
    }

    method symbol {cmd sym 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
    }

    # --- --- --- --------- --------- ---------

    method next {s sym 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
    }

    method !next {s sym 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
	}
    }

    method nextset {states 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
    }

    # --- --- --- --------- --------- ---------

    method is {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\""
    }

    # --- --- --- --------- --------- ---------

    method 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
    }

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

    method reachable {s} {
	$self StateCheck $s
	return [struct::set contains [$self reachable_states] $s]
    }

    # --- --- --- --------- --------- ---------

    method 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
    }

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

    method useful {s} {
	$self StateCheck $s
	return [struct::set contains [$self useful_states] $s]
    }

    # --- --- --- --------- --------- ---------

    method epsilon_closure {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
    }

    # --- --- --- --------- --------- ---------

    method 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.

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

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

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

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

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

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

    method Next {s sym 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
    }

    method !Next {s sym 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
    }

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

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

    method InvalidateReach {} {
	set reachvalid 0
	set reach      {}
	return
    }

    method InvalidateUseful {} {
	set usefulvalid 0
	set useful     {}
	return
    }

    method NonDeterministic {s 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
    }

    method CheckSerialization {value startst states acc trans 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.

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Package Management

package provide grammar::fa 0.1
