PN 2007.10.20
This page is dedicated to Knuth sections 7.2.1.1 and 7.2.1.2
All the routines on this page generate a sequence of objects, so they are all objects of an iterative type.
An iterate type provides for 3 basic functions, init, next and more.
init gets things rolling and returns the first value in the sequence.
next gives you the next value in the sequence or an invalid value
more tells you if the last value you just got with init or next is a valid value or not.
Typically a value of an empty list is the standard invalid value. Because all these routines return a sequence of values which mean something in relation to each other, the empty list {} is never a valid returned value. However in some cases {{}},the empty set, may be returned as a valid value.
The iterate command returns a handle to an iterative type of the kind that you have requested in the command. There is a seemingly endless variety of these as this page will demonstrate. The handle is it followed by a self appointed number, e.g. it4. This handle is an iterative object and is typically invoked in this way:
set o [iterate ....]
for {set i [$o init]} {[$o more]} {set i [$o next]} {
do something with $i
}
"type delete" $oWhen you are iterating a number of sequences in the same program this form of expression is easier to use than the namespace version. Because they all have the same init, next and more commands, the commands have to be disambiguated by using the object name all the time.
Therefore these iterative objects have been implemented in the form of something I call a type. A type consists of a namespace for the object, plus, in the case of these iterative types, the 3 commands implemented as object procedures: "$o init", "$o next" and "$o more". To avoid having to use quotes everywhere the ["type create"] command makes these available at a more readable level. The contents of the namespace remains private. The [iterate] command uses ["type create"] inside it as part of creating the iterative object.
For now I have decided not to have the objects self-destruct when they have completed their tour of duty, just in case the user wants to start them from the beginning again. So for now the user is responsible for destroying the object. You do this using the type delete command as seen above. This deletes the namespace ::$o, the command $o which was created by ["type create"] and the commands ["$o *"].
Some of these iterative objects could have a [prev] and a [less] command as well but in the interests of brevity I have not included these.
The iterative objects are designed to be able to be restarted by invoking [init] again, but they are not reentrant. This means you cannot be in two different places at once within the one object.
Most of the iterative objects have been implemented using list structures instead of arrays as these appeared to be the most efficient. However, I was bemused to discover that [lset] was no improvement on the old [lreplace] and appeared marginally slower much of the time, but [lset] is more readable, so I have used [lset].
To begin, here are the [type] commands. I have not applied ["type create"] to type itself, though this is valid and would make type into a universal metaobject. ["type create"] is not used much and is usually hidden inside something else. ["type delete"] is easy enough to type the few times you need it. I also choose not to type [type] because this name is probably polluted enough already.
In TOOT this same ["type create"] command is used to replace the '[unknown] command. This has the effect of making everything potentially typed. I choose not to do this because I like to have more control over what is typed and what isn't. Also I already reuse [unknown] to expand the initial command word (instead of compacting the first two words which is the intention of ["type create"]) so as to enable currying within lambda expressions. If you try to do both without careful structure you can end up in a curry/type loop, forever expanding and contracting the command word.
proc "type create" t {
set str "
proc $t {cmd args} {
set p \"$t \$cmd\""
append str {
if { [ info proc $p ] == {} } {
global errorInfo
error "No proc: $p" $errorInfo
return
}
uplevel 1 [ linsert $args 0 $p ]
}
append str "
}"
eval $str
}
proc "type delete" t {
namespace delete $t
foreach i [info proc "$t *"] {rename $i {} }
rename $t {}
}I keep these two routines in my personal lambda package which includes other essential items like:
proc {} {} {}and [set-] the uncomplaining [set].
[iterate count radix length ]
Usage:
iterate count 2 5
This is the basic counting routine, but implemented as a list with the 0 index changing the most frequently, which is the reverse of the usual number system paradigm. Both radix and length are both integers. They should be >= 2.
I have included a time check, though I am unsure what the best protocol is for handling this. In a more verbose version of the routine, a check could be made for tk and a continue/cancel dialogue box posted.
[count] doesn't need a private namespace.
"type create" iterate
proc "iterate count" {radix length} {
# get an object name
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
if { $radix < 2 || $length < 2} {
error "Iterate count radix and length must both be greater than 2"
return
}
# roughly 1,000,000 iterations per minute
if { [set i [expr $length*log10($radix)-6]] > 1 } {
puts "iteration will take roughly [expr round(pow(10,$i))] minutes"
}
set str "
namespace eval ::$obj {
variable curr
}"
eval $str
set str "
proc \"$obj init\" {} {
return \[set ::${obj}::curr [list [string repeat "0 " $length ]] $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \[expr {\$::${obj}::curr != {} } $cb
}"
eval $str
set str "
proc \"$obj next\" {} {
for {set i 0} {\$i < $length } {incr i} {
if { \[set j \[lindex \$::${obj}::curr \$i $cb$cb < [expr $radix -1] } {
return \[lset ::${obj}::curr \$i \[expr \$j +1$cb$cb
} else {
lset ::${obj}::curr \$i 0
}
}
return \[set ::${obj}::curr {} $cb
}"
eval $str
return $obj
}The important special case is radix=2 for a binary list. The [next] command could be fine-tuned for this special case. In the binary case the result can be used as a mask over another list of any kinds of objects to step through the elements of a powerset over the objects:
proc mask {set mask} {
set p [list]
foreach i $set m $mask {
if { $m != 0 } {lappend p $i}
}
return $p
}Creating a special powerset iterative object is more trouble than it is worth. It is simpler to use something like the following:
set a { feet shod soft press grass }
set o [iterate count 2 [llength $a]]
for { set i [mask $a [$o init]]} {[$o more]} {set i [mask $a [$o next]]} {
puts $i
}
"type delete" $oIt would be better to create a functional object which operates on iterative objects.
[iterate gray length ]
Usage:
iterate gray 26
Gray Code is a form of enumeration where only one digit changes with each invocation. [iterate gray] iterates binary numbers in standard Gray order. This is Knuth 7.2.1.1 Alg G
proc "iterate gray" length {
# get an object name
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set str "
namespace eval ::$obj {
variable curr
variable parity 0
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::parity 0
return \[set ::${obj}::curr [list [string repeat "0 " $length ]] $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \[expr {\$::${obj}::curr != {}} $cb
}"
eval $str
set str "
proc \"$obj next\" {} {
if { \$::${obj}::curr == {} } { return {}}
set ::${obj}::parity \[expr {1 - \$::${obj}::parity} $cb
if { \$::${obj}::parity == 1 } {
set j 0
} else {
for { set j 1 } { \[lindex \$::${obj}::curr \[expr \$j -1 $cb $cb == 0 } { incr j} {}
}
if { \$j == $length } { return \[set ::${obj}::curr {} $cb }
return \[lset ::${obj}::curr \$j \[expr {1 -\[lindex \$::${obj}::curr \$j $cb } $cb$cb
}"
eval $str
return $obj
}
set o ["iterate gray" 5]
for { set i [$o init] } { [$o more]} {set i [$o next]} { puts $i }
"type delete" $oThe next iterator is the "Loopless Gray" from Knuth 7.2.1.1 Alg L. This uses extra housekeeping to run a bit faster.
proc "iterate looplessGray" length {
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set str "
namespace eval ::$obj {
variable curr
variable f
}"
eval $str
set str "
proc \"$obj init\" {} {
for {set i 0} {\$i <= $length } {incr i} {set ::${obj}::f(\$i) \$i }
return \[set ::${obj}::curr [list [string repeat "0 " $length ]] $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \[expr {\$::${obj}::curr != {}} $cb
}"
eval $str
set str "
proc \"$obj next\" {} {
if { \$::${obj}::curr == {} } { return {}}
set j \$::${obj}::f(0)
set ::${obj}::f(0) 0
if { \$j >= $length } { return \[set ::${obj}::curr {} $cb }
lset ::${obj}::curr \$j \[expr { 1 -\[lindex \$::${obj}::curr \$j $cb } $cb
set ::${obj}::f(\$j) \$::${obj}::f(\[incr j $cb)
set ::${obj}::f(\$j) \$j
return \$::${obj}::curr
}"
eval $str
return $obj
}
time {
set o ["iterate looplessGray" 15]
for { set i [$o init] } { [$o more]} {set i [$o next]} { }
"type delete" $o
} 10[iterate mixedradix radixlist ]
Usage:
iterate mixedradix {1 1 1 3 4 1 5}The next iterator is the mixed radix iterator from Knuth 7.2.1.1 Alg M. The argument is an ordered list of radix lengths. The point of this routine is that some elements can be 1. This is because this routine is used later to enumerate over sets of subsets
proc "iterate mixedRadix" r {
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set rl [llength $r]
set str "
namespace eval ::$obj {
variable curr
}"
eval $str
set str "
proc \"$obj init\" {} {
return \[set ::${obj}::curr [list [string repeat "0 " $rl ]] $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \[expr {\$::${obj}::curr != {}} $cb
}"
eval $str
set str "
proc \"$obj next\" {} {
for {set j 0} { \$j < $rl } { incr j } {
set i \[ expr {\[lindex \$::${obj}::curr \$j $cb +1} $cb
if { \$i >= \[lindex [list $r ] \$j $cb } {
lset ::${obj}::curr \$j 0
} else {
return \[lset ::${obj}::curr \$j \$i $cb
}
}
return \[set ::${obj}::curr {} $cb
}"
eval $str
return $obj
}
set o ["iterate mixedRadix" {1 3 1 5 9} ]
for { set i [$o init] } { [$o more]} {set i [$o next]} { puts $i }
"type delete" $o
proc "setIndex" {listset index} {
set p [list ]
foreach i $listset j $index {
if { $j == [list ]} break
lappend p [lindex $i $j]
}
return $p
}
set sims { () () () () {() (1234)} () { () (16) (26) (56) (346)} }
set simsindex {}
foreach i $sims {
lappend simsindex [llength $i]
}
set o ["iterate mixedRadix" $simsindex ]
for { set i [setIndex $sims [$o init]] } { [$o more]} {set i [setIndex $sims [$o next]]} {
puts $i
}
"type delete" $o[iterate mixedRadixGray radixlist ]
The Loopless mixed radix Gray generation Knuth 7.2.1.1 Alg H. This method changes only one coordinate by + or - 1 at each step. Each radix is >= 2
proc "iterate mixedRadixGray" r {
# elements of r must be >= 2
foreach i $r {
if { $i < 2 } {
global errorInfo
error "Each radix must be 2 or more for mixedRadixGray.
$errorInfo"
return
}
}
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set rl [llength $r]
set str "
namespace eval ::$obj {
variable curr
variable f
variable o
}"
eval $str
set str "
proc \"$obj init\" {} {
for { set j 0 } { \$j <= $rl } {incr j} {
set ::${obj}::f(\$j) \$j
set ::${obj}::o(\$j) 1
}
return \[set ::${obj}::curr [list [string repeat "0 " $rl ]] $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \[expr {\$::${obj}::curr != {}} $cb
}"
eval $str
set str "
proc \"$obj next\" {} {
if { ! \$::${obj}::more } { return {}}
set j \$::${obj}::f(0)
set ::${obj}::f(0) 0
if { \$j >= $rl } {return \[set ::${obj}::curr {} $cb }
lset ::${obj}::curr \$j \[expr { \[lindex \$::${obj}::curr \$j $cb + \$::${obj}::o(\$j)} $cb
if { \[lindex \$::${obj}::curr \$j $cb == 0 || \[lindex \$::${obj}::curr \$j $cb == \[lindex [list $r] \$j $cb -1 } {
set ::${obj}::o(\$j) \[expr - \$::${obj}::o(\$j) $cb
set ::${obj}::f(\$j) \$::${obj}::f(\[incr j$cb)
set ::${obj}::f(\$j) \$j
}
return \$::${obj}::curr
}"
eval $str
return $obj
}
set o ["iterate mixedRadix" {2 3 2 5 3} ]
for { set i [$o init] } { [$o more]} {set i [$o next]} { puts $i }
"type delete" $oThe next routine is for loopless subforest generation, Knuth 7.2.1.1 Alg K. This is an elaboration of the mixedRadix Gray just above. Quite a bit if data is required to describe the forest. Three lists are required and here Knuth's notation has been copied for easy back reference.
If the forest has n nodes, we have three lists from element 0 to element n.
The elements 1 to n are used to describe the node relationships and the 0 element is used to describe the starting point.
The nodes' numbers must be assigned in postorder, that is left subtree, then right subtree then parent.
The c list describes the parent child relationship. If the node is a leaf it has the value 0 otherwise the node contains the node number of its leftmost child. c(0) should be the root node of the first tree.
The r and l lists describe sibling relationships in a doubly linked list
node i in the r list contains the node number of its immediate right sibling, 0 otherwise. r(0) = c(0) the root node of the first tree
node i in the l list contains the node number of its immediate left sibling, 0 otherwise. l(0) = n which is the root node of the last tree.
proc "iterate looplessForest" {c r l } {
# we should be able to do some editing here
# c r and l all same length, values all <= [llength $c ]-1
foreach i {}{
if { $i < 2 } {
global errorInfo
error "Each radix must be 2 or more for mixedRadixGray.
$errorInfo"
return
}
}
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set n [expr [llength $c ] -1]
set str "
namespace eval ::$obj {
variable cl [list $c]
variable c
variable rl [list $r]
variable r
variable ll [list $l]
variable l
variable a
variable f
variable more 1
}"
eval $str
set str "
proc \"$obj init\" {} {
for { set j 0 } { \$j <= $n } {incr j} {
set ::${obj}::c(\$j) \[lindex \$::${obj}::cl \$j $cb
set ::${obj}::r(\$j) \[lindex \$::${obj}::rl \$j $cb
set ::${obj}::l(\$j) \[lindex \$::${obj}::ll \$j $cb
set ::${obj}::a(\$j) 0
set ::${obj}::f(\$j) \$j
}
set ::${obj}::l(0) $n
set ::${obj}::r($n) 0
set ::${obj}::r(0) \$::${obj}::c(0)
set ::${obj}::l(\$::${obj}::c(0)) 0
set ::${obj}::more 1
return [list [string repeat "0 " $n]]
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
if { ! \$::${obj}::more } { return {}}
set q \$::${obj}::l(0)
set p \$::${obj}::f(\$q)
set ::${obj}::f(\$q) \$q
set p1 \[expr {\$p -1} $cb
set cp \$::${obj}::c(\$p)
if { \$p == 0 } {
set ::${obj}::more 0
return [list]
}
if { \$::${obj}::a(\$p) == 1 } {
set ::${obj}::a(\$p) 0
if { \$cp != 0 } {
set q \$::${obj}::r(\$p1)
set ::${obj}::r(\$p) \$q
set ::${obj}::l(\$q) \$p
}
} else {
set ::${obj}::a(\$p) 1
if { \$cp != 0 } {
set q \$::${obj}::r(\$p)
set ::${obj}::l(\$q) \$p1
set ::${obj}::r(\$p1) \$q
set ::${obj}::r(\$p) \$cp
set ::${obj}::l(\$cp) \$p
}
}
set ::${obj}::f(\$p) \$::${obj}::f(\$::${obj}::l(\$p))
set ::${obj}::f(\$::${obj}::l(\$p)) \$::${obj}::l(\$p)
set curr [list {}]
for { set k 1 } { \$k <= $n } { incr k} {
lappend curr \$::${obj}::a(\$k)
}
return \$curr
}"
eval $str
return $obj
}
set o ["iterate looplessSubforest" {2 0 1 0 0 0 4 3} {2 0 7 6 5 0 0 0} {7 0 0 0 0 4 3 2} ]
for { set i [$o init] } { [$o more]} {set i [$o next]} { puts $i }
"type delete" $oThis is Knuth 7.2.1.1 Alg A
The description for this is not particularly clear. The idea is to start with (1 0 0 ... ) and then to compute binary digits to add onto the left side. The step A4 should be accomplished by a literal shift rather than by a change in the pointers, j k i and h. So instead of shifting and then computing the added bit we compute the added bit then simply insert which causes a shift. This is why k j i and h are -1 mod n compared to their Alg a settings. Steps A4 and A5 have been swapped over.
Each new digit is inserted at the beginning of the list, automatically shifting it.
The required value at each stage is the initial sublist
proc "iterate binShift" {n} {
if { $n < 3 || $n > 32 } {
error "binShift only works for 3<=n<=32"
return
}
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
array set table1 {3 1 4 1 5 2 6 1 7 1 8 {1 5} 9 4 10 3 11 2 12 {3 4} 13 {1 3}
14 {1 11} 15 1 16 {2 3} 17 3 18 7 19 {1 5} 20 3 21 2 22 {1 7} 23 5 24 {1 3}
25 3 26 {1 7} 28 3 29 2 30 {1 15} 31 3 32 {1 27} }
set k [expr (0-1) %$n]
set j [expr ([lindex $table1($n) 0] -1)%$n]
if { [llength $table1($n)] > 1 } {
set i [expr ([lindex $table1($n) 1] -1)%$n]
set h [expr ([lindex $table1($n) 0] + [lindex $table1($n) 1]-1)%$n]
}
set str "
namespace eval ::$obj {
variable x
variable r 0
variable more 0
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::x \"1[string repeat " 0" [expr $n -1]]\"
set ::${obj}::more 1
set ::${obj}::r 0
return \[ lrange \$::${obj}::x 0 [expr $n-1] $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
if { ! \$::${obj}::more } { return {}}
if { \$::${obj}::r >= [expr $n -1]} {
if { \$::${obj}::r == [expr $n -1]} {
set m 0
} else {
set ::${obj}::more 0
return [list]
}
} else {"
if { [llength $table1($n)] == 1} {
append str "
set m \[expr \[lindex \$::${obj}::x $k $cb != \[lindex \$::${obj}::x $j $cb$cb"
} else {
append str "
set m \[expr \[lindex \$::${obj}::x $k $cb != \[lindex \$::${obj}::x $j $cb != \[lindex \$::${obj}::x $i $cb != \[lindex \$::${obj}::x $h $cb $cb"
}
append str "
}
set ::${obj}::x \[linsert \$::${obj}::x 0 \$m $cb
if { \$m == 1 } {
set ::${obj}::r 0
} else {
incr ::${obj}::r
}
return \[ lrange \$::${obj}::x 0 [expr $n-1] $cb
}"
eval $str
return $obj
}
set o ["iterate binShift" 3 ]
for { set i [$o init] } { [$o more]} {set i [$o next]} { puts $i }
"type delete" $o
set o ["iterate binShift" 4 ]
for { set i [$o init] } { [$o more]} {set i [$o next]} { puts $i }
"type delete" $o
set o ["iterate binShift" 8 ]
set q {}
for { set i [$o init] } { [$o more]} {set i [$o next]} {
lappend q $i
# puts $i
}
puts [llength [ lsort -unique $q ]]
"type delete" $o
The next routines generate digits in a de Bruijn cycle. The next two routines are inductive. The first accepts a deBruijn cycle and outputs a new one with the radix increased by 1. The second accepts a deBruijn cycle and outputs a new one with double the radix of the input cycle.
To verify the input and output cycles it is helpful to have a validating routine.
proc "deBruijn is" f {
# count the number of characters
for { set i 0 } { $i < [llength $f]} { incr i} {
set p([lindex $f $i]) {}
}
set m [llength [array names p]]
# the length of f should be pow(m,n)
set n [expr log([llength $f])/log($m)]
if { $n != round($n) } {return 0}
set n [expr round($n)]
set q {}
eval lappend f [lrange $f 0 [expr $n -2]]
for { set i 0 } { $i < pow($m,$n) } {incr i} {
lappend q [lrange $f $i [expr $i + $n -1]]
}
set s [llength [ lsort -unique $q]]
if { $s == pow($m,$n) } {
return 1
}
return 0
}
set f {0 0 1 1 0 2 1 2 2}
"deBruijn is" $fThis is Knuth 7.2.1.1 Alg R
The idea here is to supply a known de Bruijn cycle of radix n and use it to generate a cycle of radix n+1
proc "iterate deBruijnR" {f} {
# calculate m and n
for { set i 0 } { $i < [llength $f]} { incr i} {
set p([lindex $f $i]) {}
}
set m [llength [array names p]]
set n [expr round(log([llength $f])/log($m))]
set mn [llength $f]
set mn1 [expr $mn *$m]
if { $n < 1 } {
error "deBruijnR only works for n >= 2"
return
}
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set str "
namespace eval ::$obj {
variable f { $f }
variable x 0
variable y \" \"
variable t \" \"
variable fi 0
variable more $mn1
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::x 0
set ::${obj}::more $mn1
set ::${obj}::t \" \"
set ::${obj}::y \" \"
set ::${obj}::fi 0
return \$::${obj}::x
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
if { ! \$::${obj}::more } { return {}}
if { \$::${obj}::x != 0 && \$::${obj}::t >= $n} {
} else {
set ::${obj}::y \[lindex \$::${obj}::f \$::${obj}::fi $cb
set ::${obj}::fi \[expr (\$::${obj}::fi +1) % $mn $cb
}
while 1 {
if { \$::${obj}::y == 1 } {
incr ::${obj}::t
} else {
set ::${obj}::t 0
}
if { \$::${obj}::t == $n && \$::${obj}::x != 0 } {
set ::${obj}::y \[lindex \$::${obj}::f \$::${obj}::fi $cb
set ::${obj}::fi \[expr (\$::${obj}::fi +1) % $mn $cb
} else {
break
}
}
set ::${obj}::x \[expr (\$::${obj}::x + \$::${obj}::y) %$m $cb
set ::${obj}::more \[expr (\$::${obj}::more +1)%$mn1 $cb
return \$::${obj}::x
}"
eval $str
return $obj
}
set o ["iterate deBruijnR" {0 0 1 1 0 2 1 2 2} ]
set p {}
for { set i [$o init] } { [$o more]} {set i [$o next]} {
lappend p $i
}
"deBruijn is" $p
"type delete" $oThis next version again generates digits in a de Bruijn cycle. This time it uses a de Bruijn cycle of radix n to generate a de Bruijn cycle of radix 2*n. This is Knuth 7.2.1.1 Alg D
set f {0 0 1 1 0 2 1 2 2}proc "iterate deBruijnD" {f} {
# calculate m and n
for { set i 0 } { $i < [llength $f]} { incr i} {
set p([lindex $f $i]) {}
}
set m [llength [array names p]]
set n [expr round(log([llength $f])/log($m))]
set mn [llength $f]
set mn2 [expr $mn * $mn ]
set r [expr ($m+1)%2 +1]
if { $n < 1 } {
error "deBruijnR only works for n >= 2"
return
}
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set str "
namespace eval ::$obj {
variable f { $f }
variable x $m
variable y \" \"
variable t \" \"
variable fi 0
variable xd $m
variable yd \" \"
variable td \" \"
variable fid 0
variable more $mn2
variable d 4
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::x $m
set ::${obj}::more $mn2
set ::${obj}::t \" \"
set ::${obj}::y \" \"
set ::${obj}::fi 0
set ::${obj}::xd $m
set ::${obj}::td \" \"
set ::${obj}::yd \" \"
set ::${obj}::fid 0
if { \$::${obj}::t != $n || \$::${obj}::x >= $r } {
set ::${obj}::y \[lindex \$::${obj}::f \$::${obj}::fi $cb
set ::${obj}::fi \[expr (\$::${obj}::fi +1) % $mn $cb
}
if { \$::${obj}::x != \$::${obj}::y } {
set ::${obj}::x \$::${obj}::y
set ::${obj}::t 1
} else {
incr ::${obj}::t
}
set ::${obj}::d 4
return \$::${obj}::x
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
if { ! \$::${obj}::more } { return {}}
#D1
if { \$::${obj}::d == 1 } {
if { \$::${obj}::t != $n || \$::${obj}::x >= $r } {
set ::${obj}::y \[lindex \$::${obj}::f \$::${obj}::fi $cb
set ::${obj}::fi \[expr (\$::${obj}::fi +1) % $mn $cb
}
if { \$::${obj}::x != \$::${obj}::y } {
set ::${obj}::x \$::${obj}::y
set ::${obj}::t 1
} else {
incr ::${obj}::t
}
set ::${obj}::d 3
}
# D3
if { \$::${obj}::d == 3 } {
set ::${obj}::d 4
set ::${obj}::more \[expr (\$::${obj}::more +1)%$mn2 $cb
return \$::${obj}::x
}
# D4
while 1 {
set ::${obj}::yd \[lindex \$::${obj}::f \$::${obj}::fid $cb
set ::${obj}::fid \[expr (\$::${obj}::fid +1) % $mn $cb
if { \$::${obj}::xd != \$::${obj}::yd } {
set ::${obj}::xd \$::${obj}::yd
set ::${obj}::td 1
} else {
incr ::${obj}::td
}
if { \$::${obj}::td == $n && \$::${obj}::xd < $r &&
( (\$::${obj}::t < $n) || (\$::${obj}::xd < \$::${obj}::x) ) } {
} else {
break
}
}
set ::${obj}::more \[expr (\$::${obj}::more +1)%$mn2 $cb
if { \$::${obj}::td == $n && \$::${obj}::xd < $r && \$::${obj}::xd == \$::${obj}::x } {
set ::${obj}::d 4
return \$::${obj}::xd
}
if { \$::${obj}::td == $n && \$::${obj}::xd < $r } {
set ::${obj}::d 3
} else {
set ::${obj}::d 1
}
return \$::${obj}::xd
}"
eval $str
return $obj
}
set o ["iterate deBruijnD" {0 0 1 1 0 2 1 2 2} ]
set q {}
for { set i [$o init] } { [$o more]} {set i [$o next]} {
lappend q $i
}
"deBruijn is" $q
"type delete" $oFinally from Knuth Section 7.2.1.1 we have Alg F (Prime and preprime string generation)
From Knuth:
"Definition P - A string is prime if it is nonempty and (lexicographically) less than all of its proper suffixes. For example, 01101 is not prime because it is greater than 01 (ed. the 01 suffix as in 011(01) ); but 01102 is prime because it is less than 1102, 102, 02 and 2 ... Definition Q. - A string is preprime if it is a nonempty prefix of a prime on some alphabet. "
Prime strings and preprimes turn out to be useful things to be able to generate.
proc "iterate preprimeString" {m n} {
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set str "
namespace eval $obj {
variable a
variable more 1
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::a [ list -1[string repeat " 0" $n]]
set ::${obj}::more 1
return \[list \[lrange \$::${obj}::a 1 end $cb 1 $cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
if {! \$::${obj}::more} { return {}}
for {set j $n} {\[lindex \$::${obj}::a \$j $cb == [expr $m -1]} {incr j -1 } {}
if { \$j == 0 } {
set ::${obj}::more 0
return {}
}
lset ::${obj}::a \$j \[expr \[lindex \$::${obj}::a \$j $cb +1 $cb
for { set k \[expr \$j +1$cb } {\$k <= $n } {incr k } {
lset ::${obj}::a \$k \[lindex \$::${obj}::a \[expr \$k -\$j $cb $cb
}
return \[list \[lrange \$::${obj}::a 1 end $cb \$j$cb
}"
eval $str
return $obj
}
time {
set o ["iterate preprimeString" 3 4 ]
for { set i [$o init] } { [$o more]} {set i [$o next]} { }
"type delete" $o
} 8This routine looked like a candidate for an array implementation but it turned out to be 10% slower.
preprimeString is now used to generate de Bruijn cycles, radix m, length n
This is a nontrivial example of one iterator using another. deBruijnP deletes its preprimeString object but does not delete itself.
proc "iterate deBruijnP" {m n} {
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set str "
namespace eval ::$obj {
variable curr
variable more 1
variable i 0
variable j 0
variable k 0
}
set d \[\"iterate preprimeString\" $m $n $cb"
eval $str
set str "
proc \"$obj init\" {} {
foreach {::${obj}::i ::${obj}::j } \[\"$d init\"$cb {}
set ::${obj}::more 1
set ::${obj}::k 0
return 0
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
incr ::${obj}::k
if { \$::${obj}::k >= \$::${obj}::j } {
# Get next preprime duple
while 1 {
foreach {::${obj}::i ::${obj}::j} \[\"$d next\"$cb {}
if { \[\"$d more\"$cb == 0 } {
\"type delete\" $d
set ::${obj}::more 0
return {}
}
if { $n % \$::${obj}::j == 0} break
}
set ::${obj}::k 0
}
return \[lindex \$::${obj}::i \$::${obj}::k $cb
}"
eval $str
return $obj
}
set o ["iterate deBruijnP" 3 4 ]
set q {}
set g 0
for { set i [$o init] } { [$o more]} {set i [$o next]} {
puts "$i [set ::${o}::i] [set ::${o}::j] [set ::${o}::k]"
lappend q $i
incr g
if { $g > 100 } break
}
"deBruijn is" $q
"type delete" $o
time {
set o ["iterate deBruijnP" 2 12 ]
for { set i [$o init] } { [$o more]} {set i [$o next]} {}
"type delete" $o
} 10Knuth 7.1.2.1 Alg L generates all the permutations of items in a list.
The list should be sorted but the routine sorts it anyway. This routine handles repeated elements, that is general lists.
proc "iterate lexiPerm" a {
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set n [expr [llength $a] -1]
set str "
namespace eval ::$obj {
variable a
variable more 1
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::a {[lsort $a]}
set ::${obj}::more 1
return \$::${obj}::a
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
for {set j [expr $n -1]} {\$j >= 0 && \[lindex \$::${obj}::a \$j$cb >= \[lindex \$::${obj}::a \[expr \$j +1 $cb$cb} {incr j -1} {}
if { \$j < 0 } {
set ::${obj}::more 0
return {}
}
for {set l $n} { \[lindex \$::${obj}::a \$j$cb >= \[lindex \$::${obj}::a \$l] && \$l > \$j } { incr l -1 } {}
# interchange j, l
set k \[lindex \$::${obj}::a \$j$cb
lset ::${obj}::a \$j \[lindex \$::${obj}::a \$l$cb
lset ::${obj}::a \$l \$k
for {set k \[expr \$j + 1$cb; set l $n} {\$k < \$l} {incr k; incr l -1} {
# interchange k, l
set m \[lindex \$::${obj}::a \$k$cb
lset ::${obj}::a \$k \[lindex \$::${obj}::a \$l$cb
lset ::${obj}::a \$l \$m
}
return \$::${obj}::a
}"
eval $str
return $obj
}
time {
set o ["iterate lexiPerm" {1 2 2 3} ]
for { set i [$o init] } { [$o more]} {set i [$o next]} {puts $i }
"type delete" $o
} 8This routine is for generating the permuation of distinct elements. This routine works by swapping two positions in the permutation to get the next one. This is similar to the idea of Gray order. There is a minimum of change from one value to the next in the sequence. It is called Plain Changes because it is used for bell-ringing.
Plain Changes Knuth 7.2.1.2 Alg P
In this case the argument should be a list of distinct elements
proc "iterate plainChanges" a {
for {set i 0} { [info proc ::it$i] != {} } { incr i} {}
"type create" [set obj it$i]
set cb \]
set n [llength $a]
set n1 [ expr $n -1]
set str "
namespace eval ::$obj {
variable a
variable c [list [concat 0 [string repeat "0 " $n ]]]
variable o [list [concat 0 [string repeat "1 " $n ]]]
variable more 1
}"
eval $str
set str "
proc \"$obj init\" {} {
set ::${obj}::a [list [concat 0 $a ]]
set ::${obj}::c [list [concat 0 [string repeat "0 " $n ]]]
set ::${obj}::o [list [concat 0 [string repeat "1 " $n ]]]
set ::${obj}::more 1
return \[string range \$::${obj}::a 1 end$cb
}"
eval $str
set str "
proc \"$obj more\" {} {
return \$::${obj}::more
}"
eval $str
set str "
proc \"$obj next\" {} {
if { ! \$::${obj}::more } { return {}}
set j $n
set s 0
while 1 {
set q \[expr \[lindex \$::${obj}::c \$j$cb + \[lindex \$::${obj}::o \$j$cb$cb
if { \$q >= 0 } {
if { \$q != \$j } {
set k \[expr \$j - \[lindex \$::${obj}::c \$j$cb + \$s$cb
set l \[expr \$j - \$q + \$s$cb
set m \[lindex \$::${obj}::a \$k$cb
lset ::${obj}::a \$k \[lindex \$::${obj}::a \$l$cb
lset ::${obj}::a \$l \$m
lset ::${obj}::c \$j \$q
return \[string range \$::${obj}::a 1 end$cb
}
if { \$j == 1 } {
set ::${obj}::more 0
return {}
} else {
incr s
}
}
lset ::${obj}::o \$j \[expr - \[lindex \$::${obj}::o \$j$cb$cb
incr j -1
}
}"
eval $str
return $obj
}
time {
set o ["iterate plainChanges" {1 2 3 4} ]
for { set i [$o init] } { [$o more]} {set i [$o next]} {puts $i }
"type delete" $o
} 8Thats all for today folks - will add some more soon