Artifact a3460587d59a64f91a5926a20c38dd88dc754bdc:

• File packages/graph/lib/navigate.tcl — part of check-in [5e83cd0a3b] at 2020-03-21 15:16:29 on branch trunk — {graph navigate} new package

  new dict and list functions (user: pooryorick size: 3606)

#! /usr/bin/env tclsh

namespace eval interface {
	package require {ycl proc}
	[yclprefix] proc alias alias [yclprefix] proc alias
	alias aliases [yclprefix] proc aliases

	aliases {
		{ycl dir}
		{ycl eval} {
			upcall
		}
		{ycl ns} {
			nsjoin join
			object
		}
		{ycl proc} {
			imports
		}
		{ycl struct tree}
	}


	proc new name {
		variable systemns
		set new [upcall 1 object $name]
		$new .extend $systemns
		return $new
	}

	variable systemns [nsjoin [namespace parent] system]

	imports $systemns [namespace current] {
		aliases
		imports
	}

	imports [namespace parent] [namespace current] {
		new
	}
}


namespace eval system {
	aliases {
		{ycl dict} {
			dincr incr
		}
		{ycl eval} {
			upcall
		}
		{ycl list} {
			lsort
		}
		{ycl list ordered} {
			ensure
		}
	}
	proc .init _ {
		$_ .vars bad current map moving trail
		set bad {}
		set current {}
		set map {}
		set moving 0
		set trail {}
		return $_
	}

	proc bad {_ current next} {
		$_ .vars bad
		dincr bad $current $next tries
	}

	
	proc check {_ route} {
		$_ .vars bad
		set len [expr {[llength $route]-1}]
		for {set i 0} {$i < $len} {incr i} {
			set hop [lindex $route $i]
			set next [lindex $hop [expr {$i+1}]]
			if {[dict exists $bad $hop $next]} {
				return $i
			}
		}
		return -1
	}


	proc connect {_ from to how} {
		$_ .vars map
		dict set map $from $to $how
		return
	}


	proc current {_ args} {
		$_ .vars current
		switch [llength $args] {
			0 {}
			1 {
				set current [lindex $args 0]
			}
			default {
				error [list {wrong # args}]
			}
		}
		return $current
	}


	proc move {_ to args} {
		$_ .vars bad current moving trail
		set trail {}
		if {$moving} {
			error [list {alreay moving}]
		}
		set moving 1
		$_ .vars current map
		set advanced 1
		set routes [$_ routes $current $to]
		set route [$_ select $current $routes $bad]
		if {$route eq {}} {
			error [list {no good route}]
		}

		if {[$_ check [list $current {*}$route]] >= 0} continue
		set advanced 0

		foreach next $route {
			set action [dict get $map $current $next]
			set cmd $action
			if {$next eq $to} {
				lappend cmd {*}$args
			}
			lappend trail $next
			set status [catch {
				upcall 1 {*}$action $current $next
			} cres copts]
			if {$status} {
				$_ bad $current $next
				set moving 0
				return -options $copts $cres
			} else {
				set current $next
				set advanced 1
			}
		}
	}


	proc neighbors {_ current} {
		$_ .vars map
		set res {}
		if {![dict exists $map $current]} {
			error [list {no route from} $current]
		}
		set map1 [dict get $map $current]
		dict keys $map1
	}



	proc routes {_ from to} {
		set res {}
		set trails {}
		foreach neighbor [$_ neighbors $from] {
			lappend trails [list $neighbor]
		}
		while {[llength $trails]} {
			set newtrails {}
			foreach trail $trails[set trails {}] {
				set current [lindex $trail end]
				if {$current eq $to} {
					lappend res $trail
				} elseif {$current eq {}} {
					# skip bad trail
				} else {
					foreach neighbor [$_ neighbors $current] {
						if {$neighbor in $trail} {
							# ignore cyclic trail
						} else {
							lappend trails [list {*}$trail $neighbor]
						}
					}
				}
			}
		}
		return $res
	}


	proc select {_ current routes bad} {
		lsort routes -command [list ::apply {l1 l2} {
			expr {[llength $l1] - [llength $l2]}
		}]
		foreach route $routes[set routes {}] {
			if {[$_ check [list $current {*}$route]] >= 0} continue
			return $route
		}
	}




	proc trail _ {
		$_ .vars trail
		return $trail
	}

	imports [namespace parent] [namespace current] {
		.init
		connect
		move
		neighbors
		routes
		trail
	}
}