Version 31 of iterate

Updated 2007-10-21 03:55:53 by pn

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 interative 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" $o

When 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 availbale 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 begining 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 to 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 [unkown] to expand the inital 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 ]

Useage:

 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 numer system paradigm. Both radix and length are both integhers. 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] doesnt 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" $o

It would be better to create a functional object which operates on iterative objects.


Binary Gray

[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" $o

The 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

Mixed Radix Iterators

[iterate mixedradix radixlist ]

Useage:

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 hanges 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" $o

Subforest Generation

The 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 refernce.

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 bescribe 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 otheriwse. 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" $o

Binary bit-shift

This 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

de Bruijn Cycles

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" $f

This 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" $o

This 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" $o

Prime and preprime string generation

Finally 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
    } 8