# bc.tcl
#    Bc tcl is a tcl library which implements backtracking with
#    constraints.  Backtracking and constraints are implemented
#    totally within vanilla tcl (developed under version 7.3). 
#

###############################################################################
# Global data --
#    All global data is contained within the array, bc_info.
#
set bc_info(constraint_list) {}		;# list of constraints
set bc_info(count_choicepoint) 0	;# choicepoint counter
set bc_info(count_choose) 0		;# bc_choose counter
set bc_info(count_fail) 0		;# fail counter
set bc_info(count_grind) 0		;# grind counter
set bc_info(count_loop) 0		;# bc_loop counter
set bc_info(ellipsis) 1			;# truncated output flag
set bc_info(message) ""			;# the last message
set bc_info(meter) ""			;# the progress meter
set bc_info(state_list) {}		;# list of state variables
set bc_info(trace_data) {}		;# variables to trace, if trace_eval
set bc_info(trace_eval) 0		;# trace evaluation flag
set bc_info(trace_fail) 0		;# trace failures flag
set bc_info(trace_level) 0		;# trace level
set bc_info(trace_parse) 0		;# trace parsing flag
set bc_info(version) 0.81		;# bc tcl version
set bc_info(zchoice_point) {}		;# choice point list
set bc_info(zcurrent) -1		;# the current strip
set bc_info(zlength) -1			;# the size of the current strip
set bc_info(zlevel) 0			;# the current strip's evaluation level
set bc_info(zlink) -1			;# link back to previous strip
set bc_info(zpc) -1			;# the position in the current strip
set bc_info(zraw_list) {}		;# list of all parsed scripts
set bc_info(zstrip) {}                  ;# currently evaluated strip
set bc_info(zstrip_list) {}		;# list of all parsed zstrips
set bc_info(zthread_list) {}		;# thread list

###############################################################################
# bc_eval [script]
#    takes as an argument a tcl script.  The script is converted into
#    a strip (see _bc_create_strip_) and evaluated (_bc_grind_) with
#    constraints and backtracking active.  Every script or script
#    fragment containing choice points must be bc_eval'ed.
#
proc bc_eval {args} {
    _bc_procedure_ 5

    ###########################################################################
    # Turn the script into a strip and grind away at it.
    #
    _bc_grind_ [_bc_link_thread_ [_bc_current_thread_]] \
	    [uplevel 1 info level] \
	    [_bc_create_strip_ [join $args]] \
	    0
    _bc_return_
}

###############################################################################
# _bc_create_strip_ script
#    creates a strip from a script.  A strip is a list in which each
#    element is a command.  Each script within bctcl is converted to
#    a strip the first time it is encountered and henceforth evaluated
#    as a strip.
#
proc _bc_create_strip_ {script} {
    _bc_procedure_ 5

    ###########################################################################
    # Set aliases to some of the globals (for readability).
    #
    upvar #0 bc_info(zstrip_list) zstrip_list
    upvar #0 bc_info(zraw_list) zraw_list

    ###########################################################################
    # First check to see if we've encountered this script before (all
    # scripts are kept in raw form in zraw_list.  If this is a new
    # script, then we must parse it and add the script to zraw_list
    # and the strip to zstrip_list.
    #
    # Note: parsing a script is a relatively expensive operation
    #    because it involves we must, essentially, examine the script
    #	 character by character.  We expect in a program using
    #	 backtracking to evaluate some scripts many times.  Therefore
    #	 we cache the strips and scripts.
    #
    #	 A more efficient search of zraw_list would, of course, be
    #	 desirable. 
    #
    set strip_index [lsearch -exact $zraw_list $script]
    if {$strip_index < 0} {
	lappend zraw_list $script
	lappend zstrip_list [_bc_parse_ $script]

	set strip_index [expr [llength $zstrip_list] - 1]
    }
    _bc_return_ $strip_index
}

###############################################################################
# _bc_grind_ _zlink_ _zlevel_ _zcurrent_ _zpc_
#    evaluates a strip.  _zlink_ and _zlevel_ provide the context in
#    which it is to be evaluated.  _zlink_ is the current "thread"
#    (see _bc_link_thread) and _zlevel_ is the tcl level at which the
#    commands in the strip should be evaluated.
#
#    _zcurrent_ is the index to the strip to be evaluated (within
#    zstrip_list).  _zpc_ is the position within the strip to begin
#    evaluation.  
#
proc _bc_grind_ {_zlink_ _zlevel_ _zcurrent_ _zpc_} {
    _bc_procedure_ 5
    global errorCode
    global errorInfo

    ###########################################################################
    # Some housekeeping.
    # Set aliases to some of the globals (for readability).
    #
    incr bc_info(count_grind)
    set grind_instance $bc_info(count_grind)

    upvar #0 bc_info(zcurrent) zcurrent
    upvar #0 bc_info(zlength) zlength
    upvar #0 bc_info(zlevel) zlevel
    upvar #0 bc_info(zlink) zlink
    upvar #0 bc_info(zpc) zpc
    upvar #0 bc_info(zstrip) zstrip
    upvar #0 bc_info(zstrip_list) zstrip_list
    upvar #0 bc_info(zthread_list) zthread_list

    ###########################################################################
    # Save the evaluation level.
    # Set the global thread info (zlink, zlevel, zcurrent, and zpc).
    #
    set zlevel_previous $zlevel

    set zlink $_zlink_
    set zlevel $_zlevel_
    set zcurrent $_zcurrent_
    set zpc $_zpc_

    set zstrip [lindex $zstrip_list $zcurrent]
    set zlength [llength $zstrip]

    ###########################################################################
    # This weirdness is part of an optimization which, as is often true,
    # obscures the code.
    # If we are already evaluating at this level (zlevel ==
    # zlevel_previous) then there is already an instance of _bc_grind_
    # operating at this level.
    # So we throw an exception which will be caught by than instance
    # of _bc_grind_ which will do our evaluation for us.
    #
    if {$zlevel == $zlevel_previous} {
	if {$bc_info(trace_eval)} {
		bc_puts stderr "_bc_grind_: THROW BACK"
	}
	error "BC_GRIND" "BC_GRIND" "BC_GRIND"
    }

    ###########################################################################
    # Once we begin grinding we never stop.  All execution is from
    # within this loop until ultimate success or failure.
    #
    while 1 {

        #######################################################################
	# Process the current strip as long as zpc is within bounds.
	#
	while {($zpc >= 0) && ($zpc < $zlength)} {

	    ###################################################################
	    # Get the next item (command) from the strip.
	    # Trace it, if desired.
	    # Increment zpc.
	    #
	    set zitem [lindex $zstrip $zpc]
	    if {$bc_info(trace_eval)} {
		foreach variable $bc_info(trace_data) {
		    bc_peek $variable
		}
		bc_puts stderr [concat "_bc_grind_($grind_instance):" \
			"/$zlink $zlevel $zcurrent $zpc/[_bc_pic_ 50 $zitem]"]
	    }
	    incr zpc

	    ###################################################################
	    # This is the core of the backtracking evaluation.
	    # Evaluate the item in at the appropriate level (zlevel)
	    # and catch any exception.
	    # If it was a normal return, continue with the next
	    # command from the strip.
	    # Otherwise:
	    #    If it's not an error (return_code != 1) then pass it
	    #	 through.
	    #	 It it's an error besides "BC_GRIND", pass it through.
	    #	 Finally, it's a BC_GRIND error (see above, log it if
	    #	 desired).
	    #
	    # Notice that if a statement fails (by invoking bc_fail),
	    # the global thread info (zlevel, zlink, zcurrent, and
	    # zpc) will have already been adjusted by the time we get
	    # back here.
	    #
	    set script "uplevel #$zlevel {$zitem}"
	    set return_code [catch $script return_value]
	    if {$return_code != 0} {
		if {$return_code != 1} {
		    return -code $return_code $return_value
		} elseif {$errorCode != "BC_GRIND"} {
		    error $return_value $errorInfo
		} elseif {$bc_info(trace_eval)} {
		    bc_puts stderr "_bc_grind_: CATCH"
		}
	    }
	}

	#######################################################################
	# We get here because we've completed a strip.
	# We want to link back to the thread that was active when the
	# strip was invoked, and continue.
	#
	# If zlink is less than zero, we've exhausted all the strips,
	# break the loop and exit _bc_grind_.
	#
	# Otherwise, we restore the previous thread (indicated by
	# zlink) and continue.
	#
	if {$zlink < 0} {
	    if {$bc_info(trace_eval)} {
		bc_puts stderr "_bc_grind_: LINK TO -1"
	    }
	    break
	}

	set zthread [lindex $zthread_list $zlink]
	if {$bc_info(trace_eval)} {
	    bc_puts stderr [concat "_bc_grind_: LINK TO" \
		    "$zlink/[_bc_pic_ 50 $zthread]/"]
	}
	_bc_restore_thread_ $zthread
    }

    ###########################################################################
    # We've done everything we can, let's get out of here.
    #
    if {$bc_info(trace_eval)} {
	bc_puts stderr "_bc_grind_: exit (level = [info level])"
    }

    _bc_return_
}

###############################################################################
# _bc_goto_ item
#    implements a jump within the current strip by setting the zpc to item.
#
proc _bc_goto_ {item} {
    _bc_procedure_ 9
    set bc_info(zpc) $item
    _bc_return_
}

###############################################################################
# _bc_parse_ script
#    parse script into individual statements in a list (in bc
#    parlance this is a strip).  The strip is returned.
#
#    The parsing is not proven to be correct, however every element of
#    the resulting strip has been approved by 'info complete'.
#	
#    This code is not pretty, brace yourself.
#
proc _bc_parse_ {script} {
    _bc_procedure_ 9

    set zstrip {}
    set bitem ""
    
    ###########################################################################
    # Split script at new lines and process that list which is called
    # alist.
    #
    set alist [split $script "\n"]

    ###########################################################################
    # Basically, what we do is check an item for completeness (using
    # 'info complete') if it is not complete we'll join it with the
    # next item and try again.
    # Comments and blank lines are discarded.
    # Each resulting line is then split on semicolons and the process
    # repeated.
    # The result is a list of the individual commands of the script.
    #
    foreach aitem $alist {

        #######################################################################
        # We use bitem to collect incomplete aitem's.
	# In the process we trim white space.
	# Discard empty lines and comments.
	#
	if {$bitem != ""} {
	    set bitem [string trim "$bitem\n[string trim $aitem]"]
	} else {
	    set bitem [string trim $aitem]
	}

	if { [regexp "^$|^#" $bitem] } {
	    set bitem ""
	    continue
	}

	#######################################################################
	# If we have a complete line (in bitem) then we've got at
	# least one command.
	# However, there may be multiple command on this line so split
	# the line at semicolons, and check.
	#
	if {[info complete $bitem]} {

	    ###################################################################
	    # Split on semicolons, the result is called clist.
	    # Process each item in a manner similar to the above,
	    # collecting the items into complete items (in zitem).
	    # The resulting items are placed in zstrip.
	    #
	    set clist [split $bitem ";"]
	    set zitem ""
	    foreach citem $clist {
		
		if {$zitem != "" } {
		    set zitem [string trim "$zitem;[string trim $citem]"]
		} else {
		    set zitem [string trim $citem]
		}

		# If we encounter a comment, we want to skip
		# everything left on this line.
		#
		if {[regexp "^#" $zitem]} {
		    break;
		}
		if {($zitem != "") && [info complete $zitem]} {
		    lappend zstrip [string trim $zitem]
		    set zitem ""
		}
	    }
	    
	    ###################################################################
	    # We're done with this bitem.
	    #
	    set bitem ""
	}
    }
    
    ###########################################################################
    # Add any leftover item to the list, but first check that it is
    # complete.
    # If desired display each individual item.
    #
    if {$zitem != ""} {
	if {[info complete $zitem]} {
	    lappend zstrip $zitem
	    set zitem ""
	} else {
	    error "_bc_parse_: Malformed input string near \"$bitem\"."
	}
    }

    if {$bc_info(trace_parse)} {
	set i 0
	foreach z $zstrip {
	    bc_puts stderr [_bc_pic_ 50 [format "z\[%d\] = %s" $i $z]]
	    incr i
	}
    }

    _bc_return_ $zstrip
}

###############################################################################
# bc_while test body
#   implements a while loop for bc_eval.
#   The semantics are the normal ones:
#       'test' is an expression, and 'body' is a script which is
#	evaluated repeatedly as long as 'test' is not false. 
#
proc bc_while {test body} {
    _bc_procedure_ 5

    ###########################################################################
    # Create a strip which evaluates the test condition and exits
    # (_bc_goto_ -1) if it is false, otherwise the body is evaluated
    # and then we repeat (_bc_goto_ 0).
    #
    # Now process the strip.
    #
    set strip \
	    [_bc_create_strip_ \
		    [concat \
			    "if {!($test)} {_bc_goto_ -1};" \
			    "$body;" \
			    "_bc_goto_ 0"]]

    _bc_grind_ [_bc_link_thread_ [_bc_current_thread_]] \
	    $bc_info(zlevel) \
	    $strip \
	    0
    _bc_return_
}

###############################################################################
# bc_for start test next body
#   implements a 'for' loop for bc_eval.  Start is the start script,
#   test is the terminating condition, next is a script which is
#   evaluated at the end of each iteration, and body is the body of
#   the loop.
#
proc bc_for {start test next body} {
    _bc_procedure_ 5

    ###########################################################################
    # Create a strip which performs the start script, then enters a
    # bc_while loop with the given test and a body consisting of the
    # given body followed by the next script.
    #
    # Process the strip.
    #
    set strip \
	    [_bc_create_strip_ \
		    [concat \
			    "$start;" \
			    "bc_while {$test} {$body; $next}"]]
	    
    _bc_grind_ [_bc_link_thread_ [_bc_current_thread_]] \
	    $bc_info(zlevel) \
	    $strip \
	    0
    _bc_return_
}

###############################################################################
# bc_loop start next test body
#    is one of two ways to enter choice points in a bctcl program (the
#    other is bc_choose).  The semantics of the arguments are reminiscent
#    of those for the arguments to bc_for:
#	 The start script is evaluated once and the loop is entered.
#
#	 The test condition is evaluated, if false bc_fail is invoked
#	 causing a backtrack to the previous choice point.
#
#	 If the test is OK, then a choice point is inserted and the
#	 body script is evaluated and the execution continues with the
#	 code following the bc_loop.
#
#	 A failure (bc_fail) within the body or any subsequent code
#	 causes a backtrack to the choice point inserted above,
#	 followed by an evaluation of the next script followed by the
#	 test, choice point, and then the body as above.
#
proc bc_loop {start test next body} {
    _bc_procedure_ 5

    ###########################################################################
    # We keep a count of the number of bc_loops invoked.
    # Prepare the choice point so that it will return the the strip we
    # create below AT POSITION 3.
    #
    incr bc_info(count_loop)
    set choice_point "\[list \
	    \$bc_info(zlink) \
	    \$bc_info(zlevel) \
	    \$bc_info(zcurrent) \
	    3\]"

    ###########################################################################
    # Now we create a strip (as is done in bc_for and bc_while):
    #
    #	 0  Make sure the bc global information available.
    #	 1  Evaluate the start script.
    #	 2  Skip to the test (_bc_goto_ 4).
    #	 3  Evaluate the next script.
    #	 4  Evaluate the test, and invoke bc_fail, if necessary.
    #	 5  Insert the choice point.
    #	 6  Evaluate the body script.
    # 
    #
    # Note--the eval's are necessary to ensure that next and start
    # take up single entries in the strip.  This is necesary to ensure
    # that the evaluation of the test is in position 4 and that the
    # evaluation of next is in position 3.  These are hard wired
    # constants, sigh.
    #
    # Now process the strip.
    #
    set strip \
	    [_bc_create_strip_ \
		    [concat \
			    "global bc_info;" \
			    "eval {$start};" \
			    "_bc_goto_ 4;" \
			    "eval {$next};" \
			    "if {!($test)} {bc_fail {bc_loop: {!($test)}}};" \
			    "_bc_choice_point_ $choice_point;" \
			    "$body" \
			    ]]

    _bc_grind_ [_bc_link_thread_ [_bc_current_thread_]] \
	    $bc_info(zlevel) \
	    $strip \
	    0
    _bc_return_
}

# bc_choose [script] ...
# 	evaluates its argument scripts as backtrackable choices.
#	The first script is evaluated, any subsequent unresolved
#	failure returns to this choice point and the next script is
#	evaluated (with the state variables restored to their previous
#	values).
#	If the choices are exhausted, then 'bc_choose' causes a
#	failure.
#
proc bc_choose {args} {
    _bc_procedure_ 5

    ###########################################################################
    # We keep a count of the number of bc_chooses invoked.
    #
    incr bc_info(count_choose)

    ###########################################################################
    # Now we create a strip (as is done in bc_for and bc_while):
    #
    #	 0  Make sure the bc global information available.
    #	 1  Place each script in the strip preceded by a choice point.
    #	 2  If we reach the end, then we've failed.
    #
    # Note--the eval's are necessary to ensure that each script
    # take up single entries in the strip.
    #
    # Now process the strip.
    #
    set raw_strip {}
    append raw_strip "global bc_info;"
    set zpc 1
    foreach script $args {
	    set zpc [expr $zpc + 3]
	    set choice_point "\[list \
		\$bc_info(zlink) \
		\$bc_info(zlevel) \
		\$bc_info(zcurrent) \
		$zpc\]"
	append raw_strip \
	       "_bc_choice_point_ $choice_point;" \
	       "eval \{$script\};" \
	       "_bc_goto_ -1;"
    }
    append raw_strip "bc_fail {bc_choose: choices exhausted};";
    set strip [_bc_create_strip_ $raw_strip]

    _bc_grind_ [_bc_link_thread_ [_bc_current_thread_]] \
	    $bc_info(zlevel) \
	    $strip \
	    0
    _bc_return_
}

###############################################################################
# bc_constrain variable_list expression
#    sets constraints.  Henceforth a change to any of the variables in
#    variable_list will cause the expression to be evaluated.  If it
#    evaluates to false, then bc_fail will be called causing the
#    program to backtrack.
#
#    The constraint mechanism is straight forward without
#    optimization or intelligence.  An annoying consequence introduces
#    a synchronization problem.  Consider the code fragment:
#
#	 set b 1
#	 set a 2
#	 bc_constrain {a b} { a > b }
#	 set b 3
#	 set a 4
#
#    This will fail on the statement "set b 3" since at that time a
#    still has the value 2.  The work-around is to only list a in the
#    constraint list and always set a after b.  This is ugly but a
#    complete (transparent) solution will require flow analysis of the
#    program.  It is left to the reader to ...
#
#    A constrained variable must be a global variable and must be part
#    of the program's state. Hmmm.. I think these conditions are true-drc.
#
proc bc_constrain {variable_list expression} {
    _bc_procedure_ 5

    ###########################################################################
    # Constraint_list refers to the global constraint_list.
    # The constraint_list is a list of list.  The first item in each
    # sublist is a variable name and the remaining items are
    # expressions which depend on the variable.
    #
    upvar #0 bc_info(constraint_list) constraint_list

    ###########################################################################
    # For each variable in the variable_list.
    #
    foreach variable $variable_list {

        #######################################################################
	# Step through the constraint_list.
	# If the variable is already in the list, add this expression
	# to the list of expressions depending on it.
	#
	set found 0
	set length [llength $constraint_list]
	for {set i 0} {$i < $length} {incr i} {
	    set constraint [lindex $constraint_list $i]
	    if {$variable == [lindex $constraint 0]} {
		set found 1
		set constraint [linsert $constraint 1 "\{$expression\}"]
		set constraint_list \
			[lreplace $constraint_list $i $i $constraint]
		break
	    }
	}

	#######################################################################
	# If the variable was not found, add to the constraint_list.
	# Also set a trace on the variable.
	#
	if {!$found} {
	    lappend constraint_list [list $variable [list $expression]]
	    uplevel #$bc_info(zlevel) \
		    trace variable $variable w _bc_check_constraint_
	}	
    }

    _bc_return_
}

###############################################################################
# _bc_check_constraint_ name element op
#    is invoked by tcl when a constrained variable is accessed.  The
#    calling sequence for the procedure is specified by tcl.  Name is
#    the name of the variable, element is the subscript if this is an
#    array reference, and op is the operation.
#
proc _bc_check_constraint_ {name element op} {
    _bc_procedure_ 5

    ###########################################################################
    # Determine if the reference is to an array element and set
    # fullname to the complete reference name.
    # Get the value assigned to the variable.
    #
    if {$element == ""} {
	set fullname $name
    } else {
	set fullname "${name}($element)"
    }
    set value [uplevel #$bc_info(zlevel) set $fullname]

    ###########################################################################
    # Search the constraint_list for this variable (referenced either
    # as its fullname or simply name.
    # For each expression that depends on this variable, evaluate the
    # expression (in the proper context, of course).
    # If an expression fails, invoke bc_fail.
    #
    set found 0
    foreach constraint $bc_info(constraint_list) {
	set variable [lindex $constraint 0]
	if {($name == $variable) || ($fullname == $variable)} {
	    set found 1
	    set length [llength $constraint]
	    for {set i 1} {$i < $length} {incr i} {
		set expression [lindex $constraint $i]
		if {!([uplevel #$bc_info(zlevel) expr "$expression"])} {
		    set message "$fullname = $value violates {$expression}"
		    uplevel #$bc_info(zlevel) bc_fail $message
		    _bc_return_
		}
	    }
	    break
	}
    }

    ###########################################################################
    # If we did not find the variable in the constraint_list, remove
    # the trace.
    # Hmmm... perhaps we should throw an error--drc.
    #
    if {!$found} {
	uplevel #$bc_info(zlevel) \
		trace vdelete $fullname w _bc_check_constraint_
    }

    _bc_return_
}

###############################################################################
# bc_state [name] ...
#    specifies that the name variables are part of the program state.
#    This implicitly makes them global variables.  The value of all
#    active state variables are saved at each choice point and upon
#    backtracking to a choice point the values are restored.
#
proc bc_state {args} {
    _bc_procedure_ 9

    ###########################################################################
    # For each variable, make the variable global and add it to the
    # list of state variables.
    # We refuse to put anything in 'bc_info' in the list, mainly
    # because the possible consequences are too much to contemplate)
    #
    foreach variable $args {
	if {$variable == "bc_info" \
		|| [string match "bc_info(*" $variable]} {
	    error [format "%s may not be part of bc_state." $variable]
	}

	uplevel #$bc_info(zlevel) global $variable
	if {[lsearch -exact $bc_info(state_list) $variable] < 0} {
	    lappend bc_info(state_list) $variable
	}
    }

    _bc_return_
}

###############################################################################
# _bc_save_state_
#   saves the current value of all state variables.  It returns a list
#   of scripts which will restore the variables to their current
#   state (Hmmm...why isn't this be a single script--drc).  If a state
#   variable does not exist at the time that _bc_save_state_ is
#   invoked, that variables will be unset when the state is restored.
#
proc _bc_save_state_ {} {
    _bc_procedure_ 5

    set items {}
    set save {}

    ###########################################################################
    # For each variable in the state
    # Make it accessible (i.e., global).
    # If it is an array add each item individually to the list of
    # items and set it up so that the entire array is unset before
    # the items are restored.
    # If we have a simple variable, add it to the 'items' list.
    #
    foreach variable $bc_info(state_list) {

        global $variable
        if {[array exists $variable]} {
          set elements [array names $variable]
          lappend save [list unset -nocomplain $variable]
	    foreach name $elements {
	        lappend items [format "%s(%s)" $variable $name]
	    }
        } else {
	    lappend items $variable
        }
    }

    ###########################################################################
    # These items are implicitly part of the state.
    #
    lappend items bc_info(constraint_list)
    lappend items bc_info(meter)

    ###########################################################################
    # For each item,  if it currently exists, add the statement to
    # restore it, otherwise add a statement to unset it.
    #
    foreach item $items {
	if {[uplevel #0 info exists $item]} {
	    lappend save [list set $item [uplevel #0 set $item]]
	} else {
	    #lappend save "if \[info exists $item\] {[list unset $item]}"
            lappend save [list unset -nocomplain $item]
	}
    }

    _bc_return_ $save
}

###############################################################################
# _bc_restore_state_ restore
#   restores the program state.  The argument, restore, is a list of
#   scripts returned by _bc_save_state.
#
proc _bc_restore_state_ {restore} {
    _bc_procedure_ 5

    ###########################################################################
    # Make the global zlevel accessible as zlevel.
    #
    upvar #0 bc_info(zlevel) zlevel

    ###########################################################################
    # Turn off all constraints.
    # Evaluate each of the restore scripts.
    # Turn the constraints back on.
    #
    foreach constraint $bc_info(constraint_list) {
	set variable [lindex $constraint 0]
	uplevel #$zlevel trace vdelete $variable w _bc_check_constraint_
    }
    foreach s $restore {
	uplevel #$zlevel $s
    }
    foreach constraint $bc_info(constraint_list) {
	set variable [lindex $constraint 0]
	uplevel #$zlevel trace variable $variable w _bc_check_constraint_
    }

    _bc_return_
}

###############################################################################
# _bc_choice_point_ zthread
#   places a choice point in the program flow.  Zthread is a bctcl
#   thread which is a list consisting of the current level, a link to
#   the previous thread, an index to the current strip, and the
#   current position in the strip.  A choice point is a point in the
#   program flow to which we will return if and when bc_fail is
#   invoked. 
#
#   Choice points are kept on a global stack (zchoice_point).  Bc_fail
#   returns to the choice point on top of the stack.  Each item on the
#   stack contains a thread and the restore scripts returned from
#   _bc_save_state_.
#
proc _bc_choice_point_ {zthread} {
    _bc_procedure_ 5

    ###########################################################################
    # We count choice points.
    # Log the choice point, if desired.
    # Push the choice point onto the stack.
    #
    incr bc_info(count_choicepoint)

    if {$bc_info(trace_fail)} {
	bc_puts stderr [_bc_pic_ 50 "_bc_choice_point_: THREAD $zthread"]
    }
    
    set bc_info(zchoice_point) \
	    [linsert $bc_info(zchoice_point) 0 \
	    [list $zthread [_bc_save_state_]]]
    _bc_return_
}

###############################################################################
# bc_fail [message]
#   is where the magic happens.  Invoking bc_fail causes execution to
#   resume at the last choice point (the top of the zchoice_point
#   stack).  The choice point is popped from the stack.  The optional
#   message is saved in the global message and is displayed if desired. 
#
proc bc_fail {args} {
    _bc_procedure_ 5

    ###########################################################################
    # Make the global zchoice_point stack available as zchoice_point.
    #
    upvar #0 bc_info(zchoice_point) zchoice_point

    ###########################################################################
    # Count failures.
    # Save the message and display it, if desired.
    # Check for an empty zchoice_point stack.
    # Pop the choice point from the stack.
    #
    incr bc_info(count_fail)
    set bc_info(message) $args
    if {$bc_info(trace_fail)} {
	bc_puts stderr [_bc_pic_ 50 "bc_fail: FAILURE $bc_info(message)"]
    }
    if {[llength $zchoice_point] <= 0} {
	if {$bc_info(trace_fail)} {
	    bc_puts stderr "bc_fail: TOTAL FAILURE all choices exhausted"
	}

	error "bc_fail: all choices exhausted"
    }    
    set link_restore [lindex $zchoice_point 0]
    set zchoice_point [lreplace $zchoice_point 0 0]

    ###########################################################################
    # We have the choice point to restore, get the components.
    # Log it, if desired.
    # Restore the thread and the state.
    #
    set zthread [lindex $link_restore 0]
    set restore [lindex $link_restore 1]
    if {$bc_info(trace_fail)} {
	bc_puts stderr [_bc_pic_ 50 "bc_fail: BACKTRACK TO /$zthread/"]
	bc_puts stderr [_bc_pic_ 50 "bc_fail: RESTORE $restore"]
    }
    _bc_restore_state_ $restore
    _bc_restore_thread_ $zthread

    _bc_return_
}

###############################################################################
# _bc_current_thread_
#   saves and returns a the current thread.
#
proc _bc_current_thread_ {} {
    _bc_procedure_ 9

    _bc_return_ [_bc_thread_ $bc_info(zlink) \
	    $bc_info(zlevel) \
	    $bc_info(zcurrent) \
	    $bc_info(zpc)]
}

###############################################################################
# _bc_thread_ zlink zlevel zcurrent zpc
#   creates and returns a thread from the individual components.
#
proc _bc_thread_ {zlink zlevel zcurrent zpc} {
    _bc_procedure_ 5
    _bc_return_ [list $zlink $zlevel $zcurrent $zpc]
}
    

###############################################################################
# _bc_link_thread_ zthread
#   places zthread in the global list of threads (zthread_list) and
#   returns the index.  Multiple instances of the same thread are not
#   harmful but are unnecessary, so zthread_list is examined to see if
#   zthread is already in the list.
#
proc _bc_link_thread_ {zthread} {
    _bc_procedure_ 5

    ###########################################################################
    # Make the global zthread list accessible as zthread_list.
    # Search the list for zthread.
    # If it is not on there, insert it.
    # In either case, return the index.
    #
    upvar #0 bc_info(zthread_list) zthread_list

    set zthread_index -1
    if {$bc_info(zcurrent) >= 0} {
	set zthread_index [lsearch -exact $zthread_list $zthread]
	if {$zthread_index < 0} {
	    lappend zthread_list $zthread
	    set zthread_index [expr [llength $zthread_list] - 1]
	}
    }
    _bc_return_ $zthread_index
}

###############################################################################
# _bc_restore_thread_ zthread
#   restores a thread saved by '_bc_current_thread_'.  Restoring a
#   thread means execution will continue from the point at which the
#   thread was saved.
#
proc _bc_restore_thread_ {zthread} {
    _bc_procedure_ 5

    ###########################################################################
    # Make everything the was it was.
    #
    set bc_info(zlink) [lindex $zthread 0]
    set bc_info(zlevel) [lindex $zthread 1]
    set bc_info(zcurrent) [lindex $zthread 2]
    set bc_info(zpc) [lindex $zthread 3]

    set bc_info(zstrip) [lindex $bc_info(zstrip_list) $bc_info(zcurrent)]
    set bc_info(zlength) [llength $bc_info(zstrip)]
    _bc_return_
}

###############################################################################
# proc _bc_procedure_ [trace_level]
#   should be invoked at the beginning of each procedure in the
#   bactracking library.  It makes 'bc_info' global within the
#   procedure.  It also sets the trace level for the procedure (in a
#   local variable, _bc_trace_level_ (used for debugging).  If an
#   argument is provided, it is the trace level, otherwise the level
#   is zero. 
#
#   The 'bc_info(trace_level)' exceeds a routine's trace level a
#   message is displayed on the error stream as it is entered.
#   Likewise, if 'trace_level' exceeds its trace level a message is
#   displayed upon exit. 
#
proc _bc_procedure_ {args} {
    global bc_info

    ###########################################################################
    # Make 'bc_info' global.
    # Set the procedure's trace level.
    # Display the entry message, if desired.
    #
    uplevel 1 global bc_info

    upvar 1 _bc_trace_level_ _bc_trace_level_
    upvar 1 _bc_debug_ _bc_debug_

    set _bc_trace_level_ 0
    if {[regexp {^[+-]?[0-9][0-9]*$} $args]} {
	set _bc_trace_level_ $args
    }

    set _bc_debug_ [expr $bc_info(trace_level) > $_bc_trace_level_]

    if {$bc_info(trace_level) > $_bc_trace_level_} {
	bc_puts stderr "ENTER [_bc_pic_ 50 [info level -1]]"
    }
}

###############################################################################
# proc _bc_return_ [value]
#   should replace 'return' in the routines in the backtracking library.
#   It displays a return message if 'trace_level' exceeds the
#   routine's trace level (set in '_bc_procedure_').  The calling
#   routine is forced to return with the supplied value. 
#
proc _bc_return_ {args} {
    global bc_info

    ###########################################################################
    # We want to access the callers _bc_trace_level_ as
    # _bc_trace_level_.
    # Is a value to be returned?
    # If so is_a_value will be non-zero.
    # Value is the value.
    # If we should log this exit, do so.
    #
    upvar 1 _bc_trace_level_ _bc_trace_level_
    set is_a_value [llength $args]
    set value [join $args]
    if {$bc_info(trace_level) > $_bc_trace_level_} {
	if {$is_a_value} {
	    bc_puts stderr [concat "LEAVE [lindex [info level -1] 0]" \
		    "RETURN \"[_bc_pic_ 40 $value]\""]
	} else {
	    bc_puts stderr "LEAVE [lindex [info level -1] 0]"
	}
    }

    ###########################################################################
    # Do the return.
    #
    if {$is_a_value} {
	return -code return $value
    } else {
	return -code return
    }
}

###############################################################################
# The following routines are utility routines mostly for debugging purposes.
###############################################################################

# bc_dump 
#	dumps everything in 'bc_info' to the error stream, 'stderr'.
#
proc bc_dump {} {
    _bc_procedure_ 9

    # Step through the elements of 'bc_info' in sorted order.
    #
    foreach name [lsort [array names bc_info]] {

        # If the item is a list (this is pretty hokey) display it's
	# elements individually.
	# Otherwise, display the item.
	#
	if {[string match *_list $name]} {
	    bc_puts stderr \
		    "bc_dump: bc_info($name)"
	    set i 0
	    foreach item $bc_info($name) {
		bc_puts stderr \
			"bc_dump:     \[$i\] = [_bc_pic_ 40 $item]"
		incr i
	    }
	} else {
	    bc_puts stderr [concat "bc_dump: bc_info($name) = " \
		    "[_bc_pic_ 40 $bc_info($name)]"]
	}
    }

    _bc_return_
}

# bc_dump_zstrips
#       dumps the zstrips.
#
proc bc_dump_zstrips {} {
    _bc_procedure_ 9

    set zcurrent 0
    foreach zstrip $bc_info(zstrip_list) {
	set zpc 0
	bc_puts stderr [_bc_pic_ 50 "zstrip $zcurrent/$zstrip"]
	foreach zitem $zstrip {
	    bc_puts stderr [_bc_pic_ 50 "       $zcurrent $zpc/$zitem"]
	    incr zpc
	}
	incr zcurrent
    }

    _bc_return_
}

# _bc_pic_ size [string] [string]
#	is a message formating utility.
#	The argument strings are joined into a single string.
#	The resulting string is truncated to the length indicated by
#	'size'.
#	If space permits an ellipsis is included in the resulting
#	string to indicate the trucation (the resulting string, with
#	ellipsis, is still less than 'size' characters long).
#	Also, newline characters are replaced with '\n'.
#
#	If the global variable 'bc_info(ellipsis)' is zero the
#	truncation is skiped and the original strings are returned in
#	full length.
#
proc _bc_pic_ {size args} {
    global bc_info

    # Create the string.
    # If 'ellipsis' is on, do the work, otherwise just return the
    # string.
    #
    set string [join $args]

    if {$bc_info(ellipsis)} {

        # Replace all newlines with '\n'.
	# If the string is longer than 'size', we truncate.
	# If 'size' is large enough, we replace the end of the
	# truncated string with the ellipsis.
	# 
	regsub -all "\n" $string "\\n" string
	if {[string length $string] > $size} {
	    if {$size > 7} {
		set string "[string range $string 0 [expr $size - 6]] ... "
	    } else {
		set string [string range $string 0 [expr $size -1]]
	    }
	}
    }

    return $string
}

# bc_puts args
#	is a replacement for 'puts' which places a prefix before the
#	first printed line which indicates the backtracking evaluation
#	progress (the results of '_bc_indent_').
#
proc bc_puts {args} {
    set gotstream 0
    set gotnonewline 0
    set length [llength $args]

    # Step through the arguments.
    # What we are looking for are the options to 'puts'.
    #
    for {set i 0} {$i < $length} {incr i} {
	set a [lindex $args $i]

	# Check if this argument indicates the output stream.
	#
	if {! $gotstream && [regexp {^(stdout|stderr|file[0-9]*)$} $a]} {
	    set gotstream 1
	    continue
	}

	# Maybe this argument is "-nonewline".
	#
	if {! $gotnonewline && $a == "-nonewline"} {
	    set gotnonewline 1
	    continue
	}

	# If neither of the above, we've encountered the first "real"
	# argument.
	# Replace this string with itself preceded by the indentation
	# string obtained from '_bc_indent_'.
	# Break out of the loop since there is nothing more to be done.
	#
	set args [lreplace $args $i $i "[_bc_indent_]$a"]
	break
    }

    
    # Create the corresponding 'puts' command and do it.
    #
    set args [linsert $args 0 "puts"]
    eval $args
}

# bc_peek [output stream] [Varname] ...
#	is a debugging utility.
#	The argument names are evaluated in the calling environment
#	and the results displayed using 'bc_puts' and '_bc_pic_'.
#	The output stream may optionally be supplied.
#
proc bc_peek {args} {
    set stream stdout

    # Check if an output stream was provided.
    #
    if {([llength $args] > 0) \
	    && [regexp "^(stdout|stderr)$" [lindex $args 0]]} {
	set stream [lindex $args 0]
	set args [lrange $args 1 end]
    }

    # Format and display each variable.
    #
    foreach variable $args {
	bc_puts $stream "$variable = [_bc_pic_ 50 [uplevel 1 set $variable]]"
    }
}

# bc_show_state 
#	displays the current values of the state variables on the
#	error stream.
#
proc bc_show_state {} {
    global bc_info

    set _items_ {}

    # Step through the state variables, creating a list of items,
    # '_items_', to be displayed..
    #
    foreach variable $bc_info(state_list) {

        # Make sure it's accessible.
	# Check if it is an array, if so prepare to display each item
	# individually.
	# 
	global $variable

	if {[catch {array names $variable} names] == 0} {
	    foreach name $names {
		lappend _items_ [format "%s(%s)" $variable $name]
	    }
	} else {
	    lappend _items_ $variable
	}
    }

    # Step through the items to be displayed.
    # If it exists, display it, otherwise note that it is not defined.
    #
    foreach _item_ $_items_ {
	if {[info exists $_item_]} {
	    bc_puts stderr \
	            [format "state: %s = %s" \
		    $_item_ \
		    [_bc_pic_ 40 [set $_item_]]]
	} else {
	    bc_puts stderr [format "state: %s undefined" $_item_]
	}
    }
}

# _bc_indent_ 
#	returns a string for indenting backtracking related output.
#
proc _bc_indent_ {} {
    _bc_procedure_ 9

    set indent "$bc_info(meter)> "

    _bc_return_ $indent
}

# bc_meter indicator
#
proc bc_meter {indicator} {
    _bc_procedure_ 9

    set bc_info(meter) "$bc_info(meter)$indicator"
    
    _bc_return_
}