#! /usr/bin/env tclsh
namespace eval implementation {
package require {ycl proc}
[yclprefix] proc alias [yclprefix]::proc::alias
alias [yclprefix]::proc::optswitch
[yclprefix] proc aliases {
{ycl eval} {
eset
upcall
}
{ycl iter async}
{ycl list} {
lreplace
take
}
{ycl coro call} {
autocall
body
call
bye
hi
reply
}
{ycl ns}
{ycl proc} {
imports
optswitch
}
}
namespace eval doc {}
variable doc {
description {
every type of structure can be viewed as a recursive ordered set
therefore
this interface should be able to serve as the general interface
to every type of structure /object
in other words
this is the quinteseential object
"set" is a higher-level construct than "iterator"
}
interfaces {
set {
routines {
count {
description {
return a count of objects in the set
}
args {
max {
the maximum count to return
}
}
}
next {
description {
return the next item in the set
}
}
}
}
}
}
proc all {a test} {
while 1 {
set value [uplevel $a next]
if {![uplevel $test [list $value]]} {
return 0
}
}
return 1
}
proc any {a test} {
eset name ns join [namespace current] [info coroutine]_any
upcall 1 select $a $test name $name
while 1 {
$name
rename $name {}
return 1
}
return 0
}
variable doc::complement {
description
produces the members of a that are not in b
args
name
description
the name of an iterator routine to create
if not provided
returns the result as a list
default
none
}
proc complement {a b args} {
lreplace a 0 0 [upcall 1 ns which [lindex $a 0]]
lreplace b 0 0 [upcall 1 ns which [lindex $b 0]]
set name [upcall 1 prep [list [
namespace which complement_coro] $a $b] {*}$args]
# we only get to here if a name was not supplied
list_ $name
}
proc complement_coro {a b} {
hi
while 1 {
set item [{*}$a next]
if {![{*}$b has $item]} {
reply $item
}
}
bye
return
}
variable doc::equal {
description
determine whether two sets are equivalent
}
proc equal {a b} {
lreplace a 0 0 [upcall 1 namespace which [lindex $a 0]]
lreplace b 0 0 [upcall 1 namespace which [lindex $b 0]]
eset name ns join [namespace current] [info cmdcount]_equal
set equal 1
foreach {a1 b1} [list $a $b $b $a] {
$a1 cursor -1
$a1 cursor -1
set name [upcall 1 complement $a1 $b1 name $name]
while 1 {
eset item $name
set equal 0
rename $name {}
break
}
if {!$equal} {
break
}
}
return $equal
}
proc list_ set {
set res {}
while 1 {
lappend res [upcall 1 $set next]
}
return $res
}
proc prep {cmd args} {
foreach {opt val} $args {
optswitch $opt {
name {
set $opt $val
}
}
}
set unique [namespace current]::[info cmdcount]
if {[info exists name]} {
set named 1
} else {
set name ${unique}_autocall
set named 0
}
set name2 [coroutine ${unique}_coro {*}$cmd]
upcall 1 [namespace which autocall] $name $name2
if {$named} {
return -level 2 $name
} else {
return $name
}
}
proc product {{{input var}} args} {
upvar ${input var} input
take input a b
lreplace a 0 0 [upcall 1 ns which [lindex $a 0]]
lreplace b 0 0 [upcall 1 ns which [lindex $b 0]]
while {[llength $args]} {
take args arg
optswitch $arg {
name {
take args topname
}
}
}
if {[llength $input]} {
set name [upcall 1 prep [list [ns which {product coro}] $a $b]]
while {[llength $input]} {
take input next
lreplace next 0 0 [upcall 1 namespace which [lindex $next 0]]
set name [prep [list {product coro} $name $next]]
set name [async transform [list $name next] [
list [ns which apply] [list value {
lassign $value[set value {}] a b
lappend a $b
return $a
} [namespace current]]]]
if {![llength $input]} {
if {[info exists topname]} {
upcall 1 rename $name $topname
return
}
}
# we only get to here if a name was not supplied
set input [list_ $name]
return
}
} else {
set name [upcall 1 prep [list [
namespace which {product coro}] $a $b] {*}$args]
}
# we only get to here if a name was not supplied
set input [list_ $name]
return
}
proc {product coro} {a b} {
set res {}
hi
set seen {}
while 1 {
set item1 [{*}$a next]
while 1 {
set item2 [{*}$b next]
lappend seen $item2
reply [list $item1 $item2]
}
break
}
while 1 {
set item1 [{*}$a next]
foreach item2 $seen {
reply [list $item1 $item2]
}
}
bye
}
proc select {a test args} {
lreplace a 0 0 [upcall 1 ns which [lindex $a 0]]
lreplace test 0 0 [upcall 1 ns which [lindex $test 0]]
set name [upcall 1 [namespace which prep] [list [
namespace which select_coro] $a $test] {*}$args]
# we only arrive at this point if no name was supplied
set res {}
while 1 {
lappend res [$name]
}
return $res
}
proc select_coro {a test} {
hi
set i 0
while 1 {
set value [upcall 1 {*}$a next]
if {[upcall 1 {*}$test $value]} {
set args [reply [list $i $value]]
while {[llength $args]} {
take args arg
optswitch $arg {
next {}
}
}
}
incr i
}
bye
return
}
variable doc::subset {
description {
determine whether $a is a subset of $b
}
}
proc subset {a b} {
set a [upcall 1 namespace which $a]
set b [upcall 1 namespace which $b]
set name2 [complement $a $b name [
ns join [namespace current] [info cmdcount]]]
set res 0
while 1 {
$name2
incr res
break
}
expr {$res == 0}
}
variable doc::tail {
produces the remainder of the sequence $b that immediately follows the
initial sequence in $a
if $a is not an initial sequence of values in $b
returns an error whose value is the length of the initial sequence of $b
that did match an initial sequence in $a
}
proc tail {a b args} {
lreplace a 0 0 [upcall 1 ns which [lindex $a 0]]
lreplace b 0 0 [upcall 1 ns which [lindex $b 0]]
eset name upcall 1 prep [list [namespace which tail_coro] $a $b] {*}$args
# we only get to here if no name was provided
list_ $name
}
proc tail_coro {a b} {
hi
set len 0
while 1 {
set item1 [{*}$a next]
set item2 [{*}$b next]
if {$item1 ne $item2} {
return -code error $len
}
incr len
}
while 1 {
set item2 [{*}$b next]
reply $item2
}
bye
}
imports [namespace parent] [namespace current] {
all
any
complement
equal
product
select
subset
tail
}
}