#! /bin/env tclsh

package require {ycl string expand}
namespace import [yclprefix]::string::expand
package require {ycl shelf shelf}

[yclprefix] shelf shelf .spawn [namespace current]


proc after_ {_ args} {
	namespace upvar $_ beginning beginning delayed delayed queues queues
		
	switch [lindex $args 0] {
		cancel {
			$_ cancel $args
		}
		idle {
			if {[llength $args] > 1} {
				set script [join $args]
			} else {
				set script [lindex $args 0]
			}
			return [$_ push idle default $script]
		}
		info {
			$_ info [lindex $args 0]
		}
	}

	if {[llength $args] == 1} {
		set delay [lindex $args 0]
		set script {}
		return [$_ push_delayed $delay $script]
	} elseif {[llength $args] > 1} {
		set args [lassign $args[set args {}] delay]
		if {[llength $args] > 1} {
			set script [lindex $args 0]
		} else {
			set script [join $args]
		}
		if {$delay == 0} {
			return [$_ push default $script]
		} else {
			return [$_ push_delayed $delay $script]
		}
	} else {
		error [list {wrong # args}]
	}
	return $id
}
[namespace current] .method after after_

proc cancel {_ args} {
	namespace upvar $_ canceled canceled delayed delayed idlequeues idlequeues queues queues
	foreach arg $args {
		dict set canceled $arg {}

		# Can't just delete an event here because this routine may have been
		# called in a script evaluated by [loop] , which has taken a copy of
		# the queues .  Instead, keep a list of canceled events .


		#set found [$_ find {*}$args]
		#if {[llength $found] == 4} {
		#	lassign $found qtype qname queue idx
		#	dict set $qtype $qname [lreplace $queue[set queue {}] $idx $idx]
		#} elseif {[llength $found] == 2} {
		#	set idx [lindex $found 1]
		#	set delayed [lreplace $delayed[set delayed {}] $idx $idx]
		#} else {
		#	error [list {internal error}]
		#}
	}
	return
}
[namespace current] .method cancel

proc push {_ args} {
	if {[llength $args] == 3} {
		lassign $args[set args {}] qtype name script
		set qtype [dict get {normal queues idle idlequeues}]
	}
	if {[llength $args] == 2} {
		set qtype queues
		lassign $args name script
	} elseif {[llength $args] == 1} {
		set qtype queues
		set name default
		lassign $args script
	} elseif {[llength $args] > 0} {
		error [list {wrong # args} [llength 4args]]
	}
	namespace upvar $_ count count idlequeues idlequeues queues queues
	set id [incr count]
	dict update $qtype $name queue {
		lappend queue [list $id $script]
	}
	return $id
}
[namespace current] .method push

proc push_delayed {_ delay script} {
	namespace upvar $_ count count delayed delayed
	set id [incr count] 
	set adjusted [expr {[clock milliseconds] + $delay}]
	if {$adjusted >= [lindex [lindex delayed end] 0]} {
		set idx [llength $delayed]
		lappend delayed [list $adjusted $id $script] 
	} else {
		set idx [expr {[lsearch -exact -bisect -index 1 $delayed $adjusted]} + 1]
		set delayed [linsert $delayed[set delayed {}] $idx [
			list $id $script $adjusted]]
	}
	return $id
}
[namespace current] .method push_delayed


variable doc::find {
	description {
		Find  event on the queue by id, or, if not found by id, by script.
	}
	value {
		A list of {queue queue_name id indices} for each found event , or if
		the queue name is delayed, {queue queue_name id index} .
	}
}

if 1 [expand run data {
	proc find {_ args} [string map [list @quesearch@ {
		foreach qtype [list queues idlequeues] {
			dict for {qname queue} [set $qtype] {
				set found [lsearch -exact -index 0 $queue $id]
				if {$found >= 0} {
					return [list $qtype $qname $queue $found]
				}
			}
		}

	}] {
		namespace upvar $_ delayed delayed idlequeues idlequeues queues queues
		set id [lindex $args 0]

		set found [lsearch -exact -index 0 $delayed $id]
		if {$found >= 0} {
			return [list delayed $found]
		}

		@quesearch@

		# Now search for a script
		if {[llength $args] > 1} {
			set id [join $args]
		} else {
			set id [lindex $args 0]
		}
		
		set found [lsearch -exact -index 1 $delayed $script]
		if {$found >= 0} {
			return [list delayed $found]
		}

		@quesearch@

		return
	}]
	[namespace current] .method find
}]



proc info_ {_ args} {
	namespace upvar $_ delayed delayed idlequeues idlequeues queues queues
	if {![llength $args]} {
		return [dict create  normal $queues idle $idlequeues delayed $delayed]
	}
	set id [lindex $args 0]
	set found [$_ find $id]
	if {[llength $found]} {
	} elseif {[llength $found] == 2} {
	} else {
		return
	}
}
[namespace current] .method info info_


proc init {_ args} {
	$_ $ active {}
	$_ $ beginning [clock milliseconds]
	$_ $ delayed_script {}
	$_ $ delayed {}
	$_ $ callers {}
	$_ $ canceled {}
	$_ $ count 0
	# For better performance, make sure the builtin queues are first
	dict set queues default {}
	$_ $ queues $queues 
	$_ $ time [clock milliseconds]

	dict set idlequeues default {}
	$_ $ idlequeues $idlequeues 

	coroutine ${_}::loop $_ loop_coro
}
[namespace current] .method init


proc loop_coro _ [expand run data {
	namespace upvar $_ active active callers callers canceled canceled \
		delayed delayed idlequeues idlequeues queues queues time time

	set args {}
	#set args [yieldto return -level 0]
	while 1 {
		set serviced 0

		# Scheduled scripts could modify the queue, to pluck off all the ripe
		# appointments before evaluating any of them .
		set ready {}
		while {[llength $delayed]} {
			set now [clock milliseconds]
			lassign [lindex $delayed 0] id script adjusted
			if {$now >= $adjusted} {
				set delayed [lreplace $delayed[set delayed {}] 0 0]
				lappend ready $id $script
			} else {
				break
			}
		}

		foreach {id script} $ready {
			[$ service {
				# even if an event was canceled, it still counts for the
				# purposes of determining whether the queues are empty
				incr serviced
				if {[dict exists $canceled $id]} {
					dict unset canceled $id
				} else {
					namespace eval :: $script
				}
			} $]
			
		}

		# In this iteration , only process appointments already on the queue,
		# not anthing queued up by the scripts being evaluated
		set ready $queues
		set queues {}
		while 1 {
			set empty 1
			#service one event from each queue
			dict for {name queue} $ready {
				if {[llength $active] && $name ni $active} continue 
				if {![llength $queue]} continue 
				dict update ready $name queue {
					set queue [lassign $queue[set queue {}] event]
					lassign $event id script
				}
				set empty 0
				[$ service $]
			}
			if {$empty} break
		}


		if {!$serviced} {
			# service one event from each idle queue

			# event loop is empty, wait for someone else to restart it
			dict for {name queue} $idlequeues {
				if {[llength $active] && $name ni $active} continue 
				if {![llength $queue]} continue 
				set queue [lassign $queue[set queue {}] event]
				dict set idlequeues $name $queue
				lassign $event id script
				[$ service $]
			}
		}
		lassign [lindex $callers end] callercoro callercmd
		if {$callercmd eq {}} {
			if {!$serviced} {
				if {[llength $delayed]} {
					# Assume the event loop is running
					after [expr {$adjusted - $now}] [list after idle [
						list $_ resume [info coroutine]]]
					yield
					continue
				} else {
					set callers [lreplace $callers[
						set callers {}] end end]
					after 100 [list after idle [list [info coroutine]]]
					if {[namespace which $callercoro] eq {}} {
						yield
					} else {
						yieldto $callercoro
					}
				}
			}
		} else {
			try {
				namespace eval :: $callercmd
			} on continue {} {
				continue
			}
			set callers [lreplace $callers[
				set callers {}] end end]
			if {[namespace which $callercoro] eq {}} {
				yield
			} else {
				yieldto $callercoro
			}
		}
	}
}]


[namespace current] .method loop_coro
[namespace current] .method loop


proc quit _ {
	rename  ${_}::loop {}
	coroutine ${_}::loop $_ loop_coro
	set quit 1
}
[namespace current] .method quit


proc resume {_ loopid} {
	if {[namespace which $loopid] ne {}} {
		tailcall $loopid
	}
}
[namespace current] .method resume

proc service  {_ args} {
	namespace upvar $_ callers callers active active
	set args [dict merge {queues {} cmd {}} $args[set args {}]]
	dict update args cmd cmd queues queues {}
	lappend callers [list [info coroutine] $cmd]
	yieldto $_ loop 
}
[namespace current] .method service

[namespace current] init


