Artifact cafcddc6287b545f3c0eab34aa73ff2af0fb94a3:

• File packages/iter/lib/iter.tcl — part of check-in [6842ef1911] at 2015-11-03 13:10:04 on branch trunk — Rename various packages in list format .

  First commit of sql .

  Early version of entity-attribute-value model in test/lib/data.tcl . It has a context column , but the idea of using an events and attributes in the "what" colun comes in the next changeset . (user: pooryorick size: 10920)

#! /bin/env tclsh

package require {ycl proc}

package require ycl::iter::vso

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

shelf new [namespace current]

package require ycl::iter::for
rename for {}
#interp alias {} [namespace current]::for {} [yclprefix]::iter::for::for
namespace import [yclprefix]::iter::for::for

namespace import [yclprefix]::proc::checkargs

namespace eval doc {}

namespace eval i {}

variable counter
trace add variable counter read "incr [::list [namespace current]::counter] ;#"

variable doc::iproc {
	description {
		returns an iterator creator routine

	}
	iterator creator {
		description {
			The first thing an iterator yields is its name.
		}
	}
}
proc iproc {pargs init body} {
	if {[lindex $pargs end] eq {args}} {
		set lastarg [lindex $pargs end]
		set argvals [lrange $pargs 0 end-1]
	} else {
		set argvals $pargs
	}
	set fargs {}
	foreach argname $argvals {
		if {[llength $argname] > 1} {
			set argname [lindex $argname 0]
		}
		append fargs " \[set [::list $argname]]"
	}
	if {[info exists lastarg]} {
		append fargs " \{*\}\[set [::list $lastarg]]"
	}

	set coroscript {
		::coroutine {{iterns}}::i::[set {{counter}}] ::apply {{function}} {{fargs}}}

	set script "
	$init
	set yield \[yield \[info coroutine]]
	$body
	"
	set function [::list $pargs $script [uplevel namespace current]]

	set coroscript [::string map [::list {{{iterns}}} [namespace current] {{{counter}}} [
		::list [namespace current]::counter] {{{function}}} [
		::list $function] {{{fargs}}} $fargs
	] $coroscript]
	return [::list $pargs $coroscript]
}

::proc iter {init body args} {
	variable counter
	if {[llength $args] == 1} {
		set args [lindex $args 0]
	}
	set args1 [::list]
	set status [catch {set names [::dict keys $args]} res ropts]
	if $status {
		return -code error "wrong # args"
	}
	if {[lindex [::dict keys $args] end] eq "args"} {
		set args1 [::dict get $args args]
		::dict unset args args
	}
	coroutine i::$counter ::apply [::list $names [join [::list $init {
		set yield [yield [info coroutine]]
	} $body \n]] [uplevel namespace current]] {*}[::dict values $args] {*}$args1
}

###### iterator creators ######

proc empty {*}[iproc {} {} {}]

proc list {*}[iproc args {} {
	set length [llength $args] 
	for {set i 0} {$i<$length} {incr i} {
		set args [lassign $args[set args {}] first]
		yield $first
	}
}]

proc string {*}[iproc string {} {
	for {set i 0} {$i < [::string length $string]} {incr i} {
		yield [::string index $string $i]
	}
}]

###### iterator operations ######

proc all iter {
	for item in $iter {
		if {!$item} {
			return 0
		}
	}
	return 1
}

proc any iter {
	for item in $iter {
		if {$item} {
			return 1
		}
	}
	return 0
}

proc cat {*}[iproc iter {} {
	for item in $iter {
		for item2 in $item {
			yield $item
		}
	}
}]

proc chain {*}[iproc args {} {
	foreach iter $args {
		for item in $iter {
			yield $item
		}
	}
}]
interp alias {} [namespace current]::ilist {} [namespace current]::list]

proc dict args {
	switch [llength $args] {
		1 {
			lassign $args[unset args] dict
			return [iter {} {
				foreach {key val} $dict {
					yield $key 
					yield $val
				}} dict $dict]
		}
		2 {
			lassign $args mode dict
			switch $mode {
				keys -
				values {
					return [iter {} { foreach item [::dict $mode $dict] { yield $item } } \
						dict $dict mode $mode]
				}
				items {
					return [iter {} { foreach {key val} $dict { yield [::list $key $val]} } \
						dict $dict]
				}
				default { return -code error "unknown mode for dict: $mode" }
			}
		}
	}
}

proc drop {iter n} {
	for item in $iter {
		if {[incr n -1] == 0} break
	}
	return $iter
}

proc empty? {iter} {
	for item in $iter {
		return 0
	}
	return 1
}

proc enum {*}[iproc iter {} {
	set i -1
	for item in $iter { yield [::list [incr i] $item] }
}]

proc expand iter {
	set res [::list]
	for item in $iter {
		lappend res $item 
	}
	return $res
}

proc extend args {
	switch [llength $args] {
		1 {
			return [iter {} {
				foreach iter $args {
					for item in $iter {
						set res [::list]
						foreach piece $item {
							lappend res {*}$piece
						}
						yield $res[set res [::list]]
					}
				}
			} args $args]
		}
		default {
			return [extend [zip {*}$args]]
		}
	}
}

proc in {iter needle} {
	for item in $iter {
		if {[expr {$needle eq $item}]} {
			return 1
		}
	}
	return 0
}

proc last iter {
	for item in $iter {}
	return $item
}

proc length iter {
	last [reduce {apply {{x y} {incr x}}} 0 $iter]
}

proc next iter {
	for item in $iter {
		return $item
		break
	}
	return -code break
}

proc repeat {*}[iproc {iter {n -1}} {} {
	set buf [::list]
	for item in $iter {
		lappend buf $item
		yield $item
	}
	if {$n == 0} {
		return
	}
	incr n -1
	for {} {$n != 0} {incr n -1} {
		foreach item $buf {
			yield $item
		}
	}
}]

proc range {iter first {length end}} {
	set length [expr {$length eq "end" ? 0: $length}]
	if {$first eq "end"} {
		iter {} {
			set res [::list]
			for item in $iter {
				lappend res $item
				if {[incr length] == 0} break
			}
			if {[namespace which $iter] ne {}} {
				for item in $iter {
					lappend res $item
					set res [lreplace $res[set res {}] 0 0]
				}
			}
			foreach item $res {
				yield $item
			}
		} iter $iter length -$length
	} else {
		set first [expr {max(0,$first)}]
		iter {} {
			set i -1
			for item in $iter {
				if {[incr i] == $first} break
			}
			if {![info exists item]} {
				return
			}
			yield $item
			set i 1
			for item in $iter {
				if {$length > 0 && [incr i] > $length} break
				yield $item
			}
		} iter $iter first $first length $length
	}
}

proc take {iter {n 1}} {
	if {$n > 0} {
		return [range $iter 0 $n]
	} else {
		return [range $iter end [expr {-$n}]]
	}
}


proc tee {iter {n 2}} {
	if {$n == 1} {
		return $iter
	}
	set tees [::list]
	set feeder [iter {} {
		set buf [::list]
		set indexes [::dict create]
		#initialization from tees
		for {set i 0} {$i<$n} {incr i} {
			::dict set indexes $i 0
		}
		::while 1 {
			set id [yield]
			set idx [::dict get $indexes $id]
			if {$idx >= [llength $buf]} {
				if {[namespace which $iter] ne {}} {
					for item in $iter {
						lappend buf $item
						break
					}
				}
			}
			if {$idx >= [llength $buf]} {
				::dict unset indexes $id
				if {![::dict size $indexes]} {
					rename [info coroutine] {}
				}
				yield [::list 0 {}]
			} else {
				::dict incr indexes $id
				yield [::list 1 [lindex $buf $idx]]
				if {[set minidx  [::tcl::mathfunc::min {*}[::dict values $indexes]]] > 0} {
					set buf [lrange $buf[set buf {}] $minidx end]
					foreach key [::dict keys $indexes] {
						::dict incr indexes $key -$minidx
					}
				}
			}
			
		}
	} iter $iter n $n]
	trace add command $feeder delete [::list apply {{iter args} {
		rename $iter {}
	}} $iter]
	for {set i 0} {$i<$n} {incr i} {
		set tee [iter {} {
			#initialize the underlying iterator with id
			::while 1 {
				#send id to the underlying iterator
				$feeder
				lassign [$feeder $i] status res 
				if {$status} {
					yield $res
					continue
				}
				return
			}
		} feeder $feeder i $i]
		lappend tees $tee
	}
	foreach tee $tees {
		trace add command $tee delete [::list apply {{feeder tees oldname newname op} {
			foreach tee $tees {
				if {[namespace which $tee] ne {} && $oldname ne $tee} {
					return
				}
			}
			rename $feeder {}
				
		}} $feeder $tees]
	}
	return $tees
}

proc weave {*}[iproc args {} {
	for item in [zip {*}$args] {
		foreach piece $item {
			yield $piece
		}
	}
}]

proc zip {*}[iproc args {
	foreach input $args {
		if {[uplevel [::list namespace which $input]] eq {}} {
			return -code error "no such iterator: $input"
		}
	}
} {
	set arglen [llength $args]
	::while 1 {
		set res [::list]
		set done 1
		for {set i 0} {$i<$arglen} {incr i} {
			set arg [lindex $args $i]
			set res1 [$arg]
			if {[namespace which $arg] eq {}} {
				lset args $i [empty]
				lappend res {}
			} else {
				lappend res $res1
				set done 0
			}
		}
		if {$done} {
			return
		} else {
			yield $res
		}
	}
}]


proc before {*}[iproc {cmdprefix iter} {} {
	for item in $iter {
		if {[{*}$cmdprefix $item]} {
			break
		}
		yield $item
	}
}]

proc between {*}[iproc {start end iter} {} {
	for item in $iter {
		if {[{*}$start $item]} {
			yield $item
			break
		}
	}
	for item in $iter {
		yield $item
		if {[{*}$end $item]} {
			break
		}
	}
}]

proc after {*}[iproc {cmdprefix iter} {} {
	for item in $iter {
		if {[{*}$cmdprefix $item]} {
			break
		}
	}
	for item in $iter {
		yield $item
	}
}]

proc when {*}[iproc {cmdprefix iter} {} {
	for item in $iter {
		if {[{*}$cmdprefix $item]} {
			break
		}
	}
	yield $item
	for item in $iter {
		yield $item
	}
}]

proc filter {*}[iproc {cmdprefix iter} {} {
	for item in $iter {
		if {[{*}$cmdprefix $item]} {
			yield $item
		}
	}
}]


proc compose {cmds args} {
	if {[llength $args] > 1} {
		return [iter {} {
			foreach arg $args {
				yield [compose $cmds $arg]
			}
		} cmds $cmds args $args]
	} else {
		foreach cmd $cmds {
			set args [map $cmd $args]
		}
		return $args
	}
}

proc map {cmdprefix args} {
	if {[llength $args] == 1} {
		return [iter {} {
			for item in $iter {
				yield [{*}$cmdprefix $item]
			} 
		} cmdprefix $cmdprefix iter $args]
	} else {
		return [iter {} {
			foreach  iter $args {
				yield [map $cmdprefix $iter]
			}
		} cmdprefix $cmdprefix args $args]
	}
}

proc mapx {*}[iproc {cmdprefix args} {} {
	if {[llength $args] > 1} {
		set args [list {*}$args]
	}
	for item in $args {
		yield [{*}$cmdprefix {*}$item]
	}
}]

#like iterate (tcllib::generator)
proc recurse {*}[iproc {cmdprefix args} {} {
	::while 1 {
		yield $args
		set args [{*}$cmdprefix {*}$args]
	}
}]

proc reduce {*}[iproc {cmdprefix z iter} {} {
	for item in $iter {
		set z [{*}$cmdprefix $z $item]
		yield $z
	}
}]
interp alias {} [namespace current]::foldl {} [namespace current]::reduce

proc while {*}[iproc {cmdprefix iter} {} {
	for item in $iter {
		if {[{*}$cmdprefix $item] eq 0} {
			break
		}
		yield $item
	}
}]

proc classify {*}[iproc {cmdprefix iter} {} {
	for item in $iter {
		set class [{*}$cmdprefix $item]
		yield [::list $class $item]
	}
}]

proc split {*}[iproc {cmdprefix iter} {} {
	set buf [::list]
	set delimlast 0
	for item in [classify $cmdprefix $iter] {
		set delimlast 0
		foreach {class item} $item {
			if {$class} {
				set delimlast 1
				yield $buf
				set buf [::list]
				yield $item
			} else {
				lappend buf $item
			}
		}
	}
	if {$delimlast || [llength $buf]} {
		yield $buf
	}
}]

proc delimit {delim iter} {
	split [::list apply {{delim item} {expr {$item eq $delim}}} $delim] $iter
}

###### mathematical operators ######
proc product {iter} {
	reduce ::tcl::mathop::* 1 $iter
}
proc sum {iter} {
	reduce ::tcl::mathop::+ 0 $iter
}

::apply [::list {} {
	foreach name [info commands [namespace current]::*] {
		[namespace current] subcmd [namespace tail $name] [namespace tail $name]
	}
} [namespace current]]