ycl

Artifact [24f20cc320]
Login

Artifact [24f20cc320]

Check-ins Using Download Hex

Artifact 24f20cc3203681e43ee79507a06c25583acb9c75:

#! /bin/env tclsh

namespace import ::tcl::mathop::!
namespace import ::tcl::mathop::-
namespace import ::tcl::mathfunc::abs
namespace import ::tcl::mathfunc::max

package require {ycl proc}
[yclprefix]::proc alias [yclprefix]::proc::alias
alias [yclprefix]::proc::argsswitch
alias [yclprefix]::proc::checkargs
alias [yclprefix]::proc::optswitch
alias [yclprefix]::proc::stub
package require {ycl parse tcl commands}
alias [yclprefix]::parse::tcl::commands::commands
#package require struct::list
#namespace import ::struct::list::list

package require {ycl eval}
alias [yclprefix]::eval::block

package require {ycl string map}
alias [yclprefix]::string::map
alias strim [yclprefix]::string::trim

alias list_ ::list


variable doc::add {
	description {
		like lappend
			but only adds each item if it isn't already in the list
	}
}
proc add {listname args} {
	upvar $listname list
	# create the variable if it doesn't exist
	append list {}
	consume arg args {
		if {$arg ni $list} {
			lappend list arg
		}
	}
	return $list
}


variable doc::addp {
	description {
		like prepend

			but only adds each item if it isn't already in the list
	}
}
proc addp {listname args} {
	upvar $listname list
	lmap arg args {
		if {$arg in $list} continue
		::lindex $arg
	}
	prepend list {*}$args
	return $list
}


proc all {items in {test {}}} {
	switch [::llength [info level 0]] {
		3 {
			set test $in
			consume item items {
				if {[uplevel 1 [concat $test [list_ $item]]]} {
					continue
				}
				return 0
			}
			return 1
		}
		4 {
			::foreach item $items {
				if {$item in $test} {
					continue
				}
				return 0
			}
			return 1
		}
	}
	::foreach item $items {
		if {![{*}$test $items]} {
			return 0
		}
	}
	return 1
}


proc any {items in {test {}}} {
	switch [::llength [info level 0]] {
		3 {
			set test $in
			::foreach item $items {
				if {[uplevel 1 [concat $test [list_ $item]]]} {
					return 1
				}
			}
			return 0
		}
		4 {
			::foreach item $items {
				if {$item in $test} {
					return 1
				}
			}
			return 0
		}
	}
}


proc are {items in {test {}}} {
	set res [list_]
	switch [::llength [info level 0]] {
		3 {
			set test $in
			::foreach item $items {
				::lappend res [expr {[uplevel 1 [concat $test [list_ $item]]]}]
			}
		}
		4 {
			::foreach item $items {
				::lappend res [expr {$item in $test}]
			} 
		}
	}
	return $res
}


variable doc::compare {
	description {
		returns

			or 

				the index of the first item that fails the comparison

				-1
	}
}
proc compare {op list1name list2name} {
	upvar $list1name list1 $list2name list2
	set res -1
	set i 0
	llength list1 len1
	llength list2 len2
	set len [expr {min($len1 ,$len2)}]
	::foreach item1 $list1 item2 $list2 {
		if {$i >= $len} {
			set res $i
			break
		}
		if {![uplevel 1 [list_ $op $item1 $item2]]} {
			set res $i
			break
		}
		incr i
	}
	return $res
}


block {
	foreach op {complement subset} {
		try [string map [list_ @op@ $op] {
			stub @op@ {list1name list2name} {
				package require {ycl list list}
				package require {ycl shelf shelf}
				alias shelf [yclprefix] shelf shelf
				package require {ycl set}
				alias yset [yclprefix]::set
			} {
				upvar $list1name list1 $list2name list2

				set cmd1 [new [info cmdcount]_list]
				$cmd1 .init list $list1

				set cmd2 [new [info cmdcount]_list]
				$cmd2 .init list $list2

				set res [yset @op@ $cmd1 $cmd2]
				rename $cmd1 {}
				rename $cmd2 {}
				return $res
			}
		}]
	}
}


#left trim common whitespace

##this version didn't look closely enough at whitespace differences
#proc dedent list {
#	set max [dict create] 
#	::foreach item $list {
#		if {[regexp -indices -- {^\s+\S} $item found]} {
#			lassign $found first last 
#			#don't add one to the distance becasue \S is the last character
#			dict incr max [expr {$last-$first}]
#		} elseif {[regexp -indices -- {^\S} $item found]} {
#			#An unindented line, so there's no common whitespace to unindent
#			dict incr max 0 1
#			break
#		} else {
#			#empty line or line containing only blank space.  Ignore.
#		}
#	}
#	set count [::lindex [lsort -integer [dict keys $max]] 0] 
#	if {$count > 0} {
#		return [::struct::list mapfor item $list[set list [list_]] {
#			string range $item $count end
#		}]
#	} else {
#		return $list
#	}
#}


variable doc::dedent_exact {
	description
		remove reasonably identical common whitespace from the beginning of items
		in a list

			each tab bumps the common whitespace count up to the next multiple of 8

}
proc dedent listname {
	upvar $listname list
	set common {}
	set comlength -1
	set remove -1
	::foreach line $list {
		set i 0
		set foundprint 0
		split line {}
		::foreach char $line {
			if {$char eq "\t"} {
				set i [expr {$i + (8 * ($i / 8 + 1) - $i)}]
			} elseif {[string is space $char]} {
				incr i
			} elseif {$char eq {}} {
				break
			} else {
				set foundprint 1
				break
			}
		}
		if {$foundprint} {
			if {$remove == -1 || $i < $remove} {
				set remove $i
			}
		}
	}
	::foreach line $list[set list {}] {
		set count 0
		set i 0
		set chars [::split $line {}]
		::foreach char $chars {
			if {$char eq "\t"} {
				set i [expr {$i + (8 * ($i / 8 + 1) - $i)}]
			} elseif {[string is space $char]} {
				incr i
			} else break
			if {$i > $remove} break
			incr count
		}
		::lappend list [string range $line $count end]
	}
	return
}


variable doc::dedent_exact {
	description
		remove exactly identical common whitespace from the beginning of items
		in a list
}
proc dedent_exact listname {
	upvar $listname list
	set comlength -1
	set llength [::llength $list]
	set i 0
	set done 0
	while 1 {
		set char1 {}
		for {set j 0} {$j < $llength} {incr j} {
			set string $list
			lindex string $j
			if {$char1 eq {}} {
				set char1 [string index $string $i]
			}
			if {$char1 ne {}} {
				set char2 [string index $string $i]
				if {$char2 ne {}}  {
					if {[string is space $char1] && $char1 eq $char2} {
						continue
					} else {
						set done 1
						break
					}
				}
			}
		}
		if {$done || $char1 eq {}} {
			break
		} else {
			incr i
		}
	}
	if {$i > 0} {
		::foreach item $list[set list {}] {
			::lappend list [string range $item $i end]
		}
	}
	return
}



variable doc::filter {
	description {
		Filters items out of a list using another list as a mask.
	}
}
proc filter {listname mask} {
	upvar $listname list
	set res {}
	::foreach item $list i $mask {
		if {$i} {
			::lappend res $item
		}
	}
	set list $res[set res {}]
	return
}


variable doc::consume {
	description
		like [foreach]
			but accepts the names of lists

			and consumes their contents incrementally

		if the lists operated on are modified in the process

			the result of the process is affected

		stops as soon as one list is empty

}
proc consume args {
	pop args script
	dict size $args
	set len 0
	::foreach {names listname} $args[set args {}] {
		set newlist list[incr i]
		upvar $listname $newlist
		upvar $listname thislist
		llength thislist thislen
		set len [max $len $thislen]
		set newnames {}
		::foreach name $names {
			set newname name[incr i]
			upvar $name $newname
			lappend newnames newname
		}
		lappend args newnames newlist
	}
	set go 1
	while 1 {
		::foreach {names listname} $args {
			llength $listname llen
			if {!$llen} {
				set go 0
				break
			}
			take $listname {*}$names
		}
		if {!$go} break
		set code [catch {uplevel 1 $script} cres copts]
		if {$code == 0 || $code == 4} continue elseif {$code == 3} break else {
			dict incr copts -level
			return -code $code -options $copts $cres
		}
	}
	return
}


variable doc::head {
	description
		assign to $listname all the in items that list that precede
		$tail
}
proc head {listname tail} {
	llength tail length
	upvar $listname list
	llength list
	if {$len < $length} {
		error [list_ {tail longer than list}]
	}
	# go easy on storage by not copying any ranges
	for {set i 0} {$i < $length} {incr i} {
		set tailend $tail
		lindex tailend end-$i
		set listend $list
		lindex listend end-$i
		if {$tailend ne $listend} {
			error [list_ {bad tail} index end-$i]
		}
	}
	lrange list 0 end-$length
}


variable doc::join {
	description
		like [::join]
			but accepts a variable name and assigns the result to that variable
}
proc join {listname args} {
	upvar $listname list
	set list [::join $list[set list {}] {*}$args]
}


# {to do} rename this to [append]
proc lappend {listname args} {
	upvar $listname list
	::foreach arg $args {
		upvar $arg var
		::lappend list $var
	}
	return $list
}

proc lappend* {listname args} {
	upvar $listname list
	::foreach arg $args {
		upvar $arg var
		::lappend list {*}$var[set var {}]
	}
	return $list
}


variable doc::layer {
	description {
		{Add or remove layers of list structure}
	}
	args {
		layers {
			description {
				{number of layers to remove}
			}
			default {}
			positional true 
		}
		list {
			description {
				{the list to strip layers from}
			}
		}
	}
}
proc layer {layers list} {
	if {[set direction [expr {$layers == 0 ? 0 : $layers/abs($layers) : 0}]] == 1} {
		while {$layers} {
			set list {*}[unvar list]
			incr $layers $direction
		}
	} else {
		while {$layers} {
			set list [list_ [unvar list]]
			incr $layers $direction
		}
	}
	return $list
}


variable doc::lindex {
	description
		like lindex

			except

				$listname is the name of the list to operate on

				each index must be the index of an item in the list 
}

proc lindex {listname args} {
	upvar $listname list
	llength args argslen
	llength list 
	if {$argslen == 1 && [::llength [::lindex $args 0]] > 1} {
		set res $list
		lindex res {*}[::lindex $args 0]
	} elseif {$argslen == 0} {
		return
	} else {
		set res $list
		consume idx args {
			llength idx idxlen
			lassign $idx idx1
			rangecheck len idx1 
			set res [::lindex $res[set res {}] $idx]
		}
	}
	set list $res[set res {}]
	return
}


proc linsert {listname args} {
	upvar $listname list
	set list [::linsert $list[set list {}] {*}$args]
}


proc list {listname args} {
	upvar $listname list
	set list $args
	return
}


variable doc::llength {
	description
		store the length of the list named $listname
			or
				in the provided variable name

				in $len
}
proc llength {listname args} {
	set argslen [::llength $args]
	upvar $listname list
	if {$argslen == 0} {
		set varname len
	} elseif {$argslen == 1} {
		lassign $args varname
	} else {
		error [list_ {too many arguments}]
	}
	upvar $varname var
	set var [::llength $list]
	return $var
}

if 0 {
	doc lmap
		description

			like [::lmap]

				but

					caller provides names of lists instead of lists

					the result is stored in the first named list
}
proc lmap args {
	pop args body
	set script ::lmap 
	llength args
	if {$len < 2 || $len % 2} {
		#generate the standard error
		::lmap {*}$args
	} else {
		set resname $args
		lindex resname 1
		consume {names listname} args {
			set part { @names@ [set @listname@][set @listname@ {}] }
			map @names@ [list_ $names] @listname@ [::list $listname] part 
			append script $part
		}
		append script { } [list_ $body]
		upvar $resname res
		set res [uplevel 1 $script]
		return
	}
}


proc lrange {listname args} {
	upvar $listname list
	set list [::lrange $list[set list {}] {*}$args]
	return
}


proc lreplace {listname args} {
	upvar $listname list
	set list [::lreplace $list[set list {}] {*}$args]
	return
}


proc lreverse {listname args} {
	upvar $listname list
	set list [::lreverse $list[set list {}] {*}$args]
	return
}


proc lsort {listname args} {
	upvar $listname list
	set list [::lsort {*}$args $list[set list {}]]
}


variable doc::order {
	description {
		orders a list
	}
	args

		listname
			name of a variable whose value is the list to be ordered

				and

					where the result is stored

		ordername
			name of a variable whose value is the indices specifying the new
			order

			the first item in each index is the index of the item to take

			any additional items are the order for that item

}
proc order {listname ordername} {
	upvar $listname list $ordername order
	set res {}
	llength list llen
	consume idx order {
		llength idx
		if {$len > 1} {
			set idx1 $idx
			lindex idx1 0
			set inner $list
			lindex inner $idx1
			set idx1 $idx
			lrange idx1 1 end
			order inner idx1
			lappend res inner
		} else {
			set item $list
			lindex item $idx
			lappend res item
		}
	}
	set list $res[set res {}]
	return
}


variable doc::pick {
	description {
		pick certain elements from a list by index or range with an optional
		step

		Returns a list of selected items
	}
}
proc pick {listname args} {
	upvar $listname list
	set res {}
	llength list llen
	consume pick args {
		llength pick
		if {$len == 1} {
			set item $list
			lindex item $pick
			lappend res item
		} elseif {$len > 1 && $len < 4} {
			if {$len == 2} {
				lassign $pick[set pick {}] start stop
				set step 1
			} elseif {$len == 3} {
				lassign $pick[set pick {}] start stop step
			}
			map end [- $llen 1] start
			set $start [expr $start]
			map end [- $llen 1] stop
			set stop [expr $stop]
			if {$step > 0} {
				for {set i $start} {$i <= $stop} {incr i $step} {
					set item $list
					lindex item $i
					lappend res item
				}
			} elseif {$step < 0} {
				for {set i $stop} {$i >= $start} {incr i $step} {
					set item $list
					lindex item $i
					::lappend res item
				}
			} else {
				return -code error [list_ {step may not be 0}]
			}
		} else {
			return -code error [list_ {wrong # args}]
		}
	}
	return $res
}


variable doc::pop {
	synopsis
		pop name ?args?
	description
		with args
			accepts a name
				removes enough items from the end of the corresponding value to
				assign one item to each name in $args

				assigns the remaining item to $name
		without args
			remove one item from the end of the value and returns it

			assigns remaining items to $name
	args
		name
			the name of a list

}
proc pop {listname args} {
	upvar $listname list 
	set error {not enough items in list}
	llength args
	if {$len} {
		llength args
		set idx [expr {$len - 1}] 
		llength list
		if {$len <= $idx} {
			error [list_ $error]
		}
		set list2 $list
		lrange list2 end-$idx end
		uplevel 1 [list_ ::lassign $list2 {*}$args]
		lreplace list end-$idx end
		return
	} else {
		llength list
		if {!$len} {
			error [list_ $error]
		}
		set item $list
		lindex item end
		set res $item
		lreplace list end end
		return $res
	}
}


variable doc::prefix {
	description
		determine whether the value in $list1var is a prefix of the value in
		$list2var

		if $list1var is omitted

			the name "prefix" is used
}
proc prefix {list1var args} {
	llength args
	if {$len} {
		set list2var $args[set args {}]
		lindex list2var 0
	} else {
		set list2var $list1var
		set list1var prefix
	}
	upvar $list1var list1 $list2var list2
	llength list1
	::foreach item1 $list1 item2 $list2 {
		if {$item1 ne $item2} {
			set list1 0
			return
		}
		if {[incr len -1] == 0} break
	}
	set list1 1
	return
}



proc prepend {varname args} {
	upvar $varname var
	# create the variable if it doesn't exist
	lappend var
	linsert var 0 {*}$args
	return $var
}


variable doc::rangecheck {
	description {
		given the name of a length variable and the name of an index variable
			convert the value in the variable name $indexname to a numeric
			index of an item in a list having length named by $lengthname 

			if the idx falls outside the range of existing indices
				return an error
	}
}
proc rangecheck {lenname idxname} {
	upvar $lenname len $idxname idx
	if {![string is double -strict $idx]} {
		if {$idx eq {end}} {
			set idx [expr {$len-1}] 
		} elseif {[regexp {^\s*(.*)\s*([-+])\s*(\S*)\s*$} $idx -> val1 op val2]} {
			if {![string is double -strict $val1]} {
				if {$val1 eq {end}} {
					set val1 $len
				}
			}
			set idx [expr $val1 $op $val2 - 1]
		}
	}
	if {$idx >= $len || $idx < 0} {
		error [list_ {index out of range} $idx]
	}
}


variable doc::randindex {
	description
		copy $count items randomly from a list
}
proc randindex {listname {count 1}} {
	upvar $listname list
	llength list
	while {[incr count -1] > -1} {
		set index $list
		lindex index [expr {int(rand()*$len)}]
		lappend res index
	}
	llength res
	if {$len == 1} {
		lindex res 0
		return $res
	} else {
		return $res
	}
}



variable {doc::require prefix} {
	description {
		Given a specification of allowed prefixes

			returns the allowed prefix from the list

		spec is a nested dictionary where the value of each allowed prefix is
		the empty string

	}

}
proc {require prefix} {spec cmd} {
	set end 0
	foreach key $cmd {
		lappend keys key
		if {[dict exists $spec {*}$keys]} {
			set pass $keys
			if {![dict size [dict get $spec {*}$keys]]} {
				set end 1
			}
		} else {
			break
		}
	}
	if {$end} {
		return $pass
	} else {
		return {}
	}
}



variable doc::rlindex {
	description
		like ::lindex
			but returns an error when an index is out-of-bounds
	args
		listname

			name of a variable containing the list

			and in which the result is stored

		indicesname
			
			name of a variable containing the indices
}
proc rlindex {listname indicesname} {
	upvar $listname list $indicesname indices 
	consume idx indices {
		llength list
		if {$idx < $len && $idx >= 0} {
			lindex list $idx
		} else {
			return -code error [list_ {greater than last index!} $idx]
		}
	}
	return
}


#this is a crazy version of sl that doesn't split on ;
#see http://wiki.tcl.tk/39972
proc slwild script {
	set res {}
	set parts {}
	split script \n
	consume part script {
		lappend parts part
		set part $parts
		join part \n
		if {[info complete $part]} {
			set parts {}
			strim part
			if {$part eq {}} {
				continue
			}
			if {[string index $part 0] eq {#}} {
				continue
			}
			#lack of brackets around the list command is intended!
			::lappend res {*}[uplevel 1 [namespace which list_] $part]
		}
	}
	return $res 
}


variable doc::sl {
	description {
		scripted list

		Takes one argument, processes it as a scripted script, and concatenates
		all the words of all the commands in to a single list. 
	}
}
proc sl script {
	concat {*}[uplevel 1 [list_ [namespace which ss] $script]]
}


variable doc::split {
	description
		like [::split]
			but accepts a variable name
				and stores the result in that variable 
}
proc split {listname args} {
	upvar $listname list
	set list [::split $list[set list {}] {*}$args]
}


variable doc::ss {
	description {
		scripted script

		takes one argument, treats it as a script, splits it into commands,
		discards comments, performs substitutions on the words in the commands,
		and returns a list of the commands.
	}

}
proc ss script {
	::lmap part [commands $script] {
		if {[string index $part 0] eq {#}} continue
		uplevel 1 [namespace which list_] $part
	}
}


variable doc::struncate {
	description {
		truncate a list to the given string length while ensuring that the
		result remains a valid list
	}
}
proc struncate {listvar truncate} {
	upvar $listvar list
	set length 0
	set newlist {}
	set spaces 0
	while {[llength list]} {
		set list [lassign $list[set list {}] item]
		if {$length > 0} {
			# account for delimiting whitespace in result
			incr length 1
		}
		set ilength [string length $item]
		set length [expr {$ilength + $length}]
		lappend newlist item
		if {$length + $spaces >= $truncate} break
		incr spaces
	}

	# shorten the final item as needed
	set extra [expr {$length + $spaces - $truncate}]
	if {$extra > 0} {
		set last $newlist
		lindex last end
		set last [string range $last[set last {}] 0 end-$extra]
		lreplace newlist end end $last
	}
	set list $newlist
	return
}



variable doc::tail {
	description
		given the name of list A
			and the name of list B

			assign to the name of A all the items in A that follow the initial
			items which must form prefix B.

		if $listname is omitted
			the name "tail" is used
}
block {
	set body {
		llength args
		@argswitch@
		upvar $listname list
		llength prefix
		::foreach item1 $list item2 $prefix {
			if {$item1 ne $item2} {
				error [list_ {bad prefix}]
			}
			if {[incr i] >= $len} break
		}
		llength prefix
		lrange list $len end
		return
	}

	map @argswitch@ [argsswitch {
		{$len == 0} {
			set prefix $listname
			set listname tail
		}
		{$len == 1} {
			lassign $args prefix
		}
	}] body

	proc tail {listname args} $body 
}


variable doc::take {
	description
		with args
			like lassign
				but
					accepts the name of a list and assigns the result to $name

					returns an error when there are not enough items in the
					list to populate the named variables
		without args
			accepts the name of a list

				returns the first item in the list

				assigns the remaining items to $name
	args
		name
			the name of list
}
proc take {listname args} {
	upvar $listname list
	llength args arglen
	llength list 
	if {$arglen} {
		if {$arglen > $len} {
			error [list_ {not enough items in the list} need $arglen have $len]
		}
		set list [uplevel 1 [list_ ::lassign $list[set list {}] {*}$args]]
		return
	} else {
		if {!$len} {
			error [list_ {not enough items in the list} needed 1]
		}
		set list [lassign $list[set list {}] res]
		return $res
	}
}


proc trim listname {
	upvar $listname list
	set res {}
	consume x list {
		regexp {^\s*(.*?)\s*} $x -> trimmed
		lappend res trimmed
	}
	set list $res
	return
}


proc unique listname {
	upvar $listname list
	set res {}
	consume item list {
		dict set res $item {}
	}
	set list [dict keys $res]
	return $list
}


proc unpack {list args} {
	if {[llength list] < [llength args]} {
		error [list_ {not enough items in the list} needed [::llength $args]]
	}
	tailcall lassign $list {*}$args
}


proc unpackvar {name args} {
	upvar $name list
	set list [uplevel 1 [list_ [namespace which unpack] $list[set list {}] {*}$args]]
}


proc unset {name args} {
	upvar $name var
	set lastkey $args
	lindex lastkey end
	lreplace args end end
	llength args argslen
	if {$argslen} {
		set list $var
		lindex list {*}$args
		llength list
		if {$lastkey >= $len} {
			return -code error [list_ {index out of range}]
		}
		lreplace list $lastkey $lastkey
		lset var {*}$args $list[set list {}]
	} else {
		lreplace var $lastkey $lastkey
	}
}


stub var {varname listname args} {
	aliases {
		{ycl ns} {
			nsjoin join
		}

	}
} {
	if {![absolute? $listname]} {
		set listname [upcall 1 vresolve]
	}
	set listname [upvar 1 ]
}


proc which {items in {test {}}} {
	set res {} 
	set level [info level 0]
	llength level
	switch $len {
		3 {
			set test $in
			set i 0
			consume item items {
				if {[uplevel 1 [concat $test [list_ $item]]]} {
					lappend res i
				}
				incr i
			}
		}
		4 {
			set i 0
			consume item items {
				if {$item in $test} {
					lappend res i
				}
				incr i
			}
		}
	}
	return $res
}


variable doc::zip {
	description
		insert items in the second list between items in the first

}
proc zip {list1name args} {
	upvar $list1name list[incr i]
	llength list1 length
	::lappend consume item$i list$i
	::lappend items item$i
	consume arg args {
		incr i
		upvar $arg list$i
		::lappend consume item$i list$i
		::lappend items item$i
		llength $arg length2
		if {$length2 != $length} {
			error [list_ {bad length} list $i exected $length actual $length2]
		}
	}
	set res {}
	consume {*}$consume {
		lappend res {*}$items
	}
	set list1 $res
	return
}