4. Arrays

set presidents [list Reagan Bush Clinton]
# => Reagan Bush Clinton


set nested [list this that [list the other]]
llength $nested
# => 3


set tune [list The Star-spangled Banner]
list #0 = [lindex $tune 0] #1 = [lindex $tune 1]
# => #0 = The #1 = Star-spangled

set a [list quick brown fox]
# => quick brown fox

set a "Why are you teasing me?"
# => Why are you teasing me?

set lines [list]
foreach {l} [split {
    The boy stood on the burning deck,
    It was as hot as glass.
} \n ] {
    set line [string trimleft $l]
    if {[string length $line]} {
        lappend lines $line
    }
}
puts $lines
# => {The boy stood on the burning deck,} {It was as hot as glass.}

set f [open $mydatafile]          ;# Automatically raises error on failure
set biglist [split [read $f] \n]

lappend banner1 Costs only \$4.95
set banner2 [list Costs only \$4.95]
set banner3 [split {Costs only $4.95}]
expr {"$banner1" == "$banner2" && "$banner2" == "$banner3"}
# => 1

set ships [list Niña Pinta Santa María]   ;# WRONG (4 ships)
llength $ships
# => 4

set ships [list Niña Pinta {Santa María}] ;# right (3 ships)
llength $ships
# => 3

set list [list red yellow green]
puts [list I have $list marbles.]
# => I have {red yellow green} marbles.

set list [list red yellow green]
puts "I have $list marbles."
# => I have red yellow green marbles.


set lists {
    {{just one thing}}
    {Mutt Jeff}
    {Peter Paul Mary}
    {{to our parents} {Mother Theresa} God}
    {{pastrami} {ham and cheese} {peanut butter and jelly} {tuna}}
    {{recycle tired, old phrases} {ponder big, happy thoughts}}
    {{recycle tired, old phrases}  {ponder big, happy thoughts}  {sleep and dream peacefully}  }
}
proc commifySeries {args} {
    if {[regexp , $args]} {
        set sepchar ";"
    } else {
        set sepchar ,
    }
    # Tcl has a switch command, nyah nyah nyah
    switch [llength $args] {
        0 { return {} }
        1 { eval return $args }
        2 { return [join $args { and }] }
        default {
            set args [lreplace $args end end [concat and [lindex $args end]]]
            return [join $args "$sepchar "]
        }
    }
}

# => just one thing

# => Mutt and Jeff

# => Peter, Paul, and Mary

# => to our parents, Mother Theresa, and God

# => pastrami, ham and cheese, peanut butter and jelly, and tuna

# => recycle tired, old phrases and ponder big, happy thoughts

# => recycle tired, old phrases; ponder big, happy thoughts; and sleep and dream peacefully

# There is no equivalent to $#ARRAY in Tcl.



proc whatAboutThatList args {
    variable people
    append res "The list now has [set len [llength $people]] elements.\n"
    append res "The index of the last element is [incr len -1].\n"
    append res "Element #3 is `[lindex $people 3]'."
}

set people [list Crosby Stills Nash Young]
whatAboutThatList
# => The list now has 4 elements.
# => The index of the last element is 3.
# => Element #3 is `Young'.

set people [lrange $people 0 end-1]
whatAboutThatList
# => The list now has 3 elements.
# => The index of the last element is 2.
# => Element #3 is `'.

# append 10001-(length of list) null elements to the list:
for {set i [llength $people]} {$i <= 10000} {incr i} {
    lappend people {}
}
whatAboutThatList
# => The list now has 10001 elements.
# => The index of the last element is 10000.
# => Element #3 is `'.

foreach user $badUsers {
    complain $user
}

foreach key [lsort [array names env]] {
    puts $key=$env($key)
}

foreach {user} $allUsers {
    set diskSpace [getUsage $user]
    if {$diskSpace > $MAXQUOTA} {
        complain $user
    }
}

# Tcl has no implicit variables like Perl's $_.
foreach _ [exec who] {
    if [regexp tchrist $_] {
        puts $_
    }
}


# Tcl does not sneak in references unexpectedly.
# If you need to mutate a list, this is the preferred
# idiom:

#     set mylist [mutate $mylist args]

# You *can* 'simulate' manipulation by reference by
# using call-by-name and connecting a local variable
# to a variable with that name in the outer scope:



proc timesSeven {listname} {
    upvar $listname listref
    for {set i 0} {$i < [llength $listref]} {incr i} {
        set listref [lreplace $listref $i $i [expr {[lindex $listref $i] * 7}]]
    }
}

variable res {}
set fruits [list Apple Blackberry]
set fruitRef fruits
# the variable fruitRef is now set to the name of the fruit list,
# which makes it a kind of reference variable
foreach fruit [set $fruitRef] {
    append res "$fruit tastes good in a pie.\n"
}
puts $res
# => Apple tastes good in a pie.
# => Blackberry tastes good in a pie.

lsort -unique [list how much wood would a wood chuck chuck]
# => a chuck how much wood would


# This is an order of magnitude slower than the previous solution.
foreach e $list {
    array set unique [list $e {}]
}
array names unique
# => a wood much chuck how would

# Use the TclX standard package (contained in
# the ActiveTcl distribution).
package require Tclx
set listA [list 1 1 2 2 3 3 3 4 5]
set listB [list 1 2 4]
set res [intersect3 $listA $listB]
# [intersect3] yields three result lists;
# we want the first one:
lindex $res 0
# => 3 5

# Use the TclX standard package (contained in
# the ActiveTcl distribution).
package require Tclx
set listA [list 1 1 2 2 3 3 3 4 5]
set listB [list 1 2 4 4 6 7]
foreach {difference intersection -} [intersect3 $listA $listB] break
set union [union $listA $listB]
list $difference $intersection $union
# => {3 5} {1 2 4} {1 2 3 4 5 6 7}

set members [list Time Flies]
lappend members An Arrow
# => Time Flies An Arrow


set members [list Time Flies]
set initiates [list An Arrow]
set members [concat $members $initiates]
# => Time Flies An Arrow


set members [list Time Flies An Arrow]
set members [linsert $members 2 Like]
# => Time Flies Like An Arrow


set members [list Time Flies Like An Arrow]
set members [lreplace $members 0 0 Fruit]
set members [lreplace $members end-1 end A Banana]
# => Fruit Flies Like A Banana

set list [list 0 1 2 3 4 5 6 7 8 9]
set rlist [list]
for {set i [expr {[llength $list]-1}]} {$i >= 0} {incr i -1} {
    lappend rlist [lindex $list $i]
}
puts $rlist
# => 9 8 7 6 5 4 3 2 1 0


set list [list 0 1 2 3 4 5 6 7 8 9]
lsort -decreasing $list
# => 9 8 7 6 5 4 3 2 1 0

proc splice-ish {listname number} {
    upvar $listname list
    set length [llength $list]
    if {$number < 0} {
        set number [expr {abs($number)}]
        set res [lrange $list end-[expr {$number-1}] end]
        set list [lrange $list 0 end-$number]
    } else {
        set res [lrange $list 0 [expr {$number-1}]]
        set list [lrange $list $number end]
    }
    return $res
}


proc shift2 {listname} {
    upvar $listname list
    return [splice-ish list 2]
}

set friends [list Peter Paul Mary Jim Tim]
foreach {this that} [shift2 friends] break
list $this $that $friends
# => Peter Paul {Mary Jim Tim}


proc pop2 {listname} {
    upvar $listname list
    return [splice-ish list -2]
}

set beverages [list Dew Jolt Cola Sprite Fresca]
set pair [pop2 beverages]
list $beverages $pair
# => {Dew Jolt Cola} {Sprite Fresca}

set matchIdx [lsearch $list $criterion]
if {$matchIdx >= 0} {
    set match [lindex $list $matchIdx]
    ## do something with $match
} else {
    ## unfound
}


set matchIdx [lsearch $list $criterion]
if {$matchIdx >= 0} {
    ## found in [lindex $list $matchIdx]
} else {
    ## unfound
}


Employee is an [incr Tcl] class with the members category,
name, salary, ssn, and age.


lappend employees [Employee #auto {manager John 120000 {}}]
lappend employees [Employee #auto {engineer Susie 100000 {}}]
lappend employees [Employee #auto {programmer Harold 90000 {}}]
foreach employee $employees {
    if {[$employee category] eq "engineer"} {
        set highestEngineer $employee
        break
    }
}
$highestEngineer name
# => Susie

# If the test is matching an element's value against
# an exact string, a wildcard pattern, or a regular
# expression, use the standard package TclX (contained
# in the ActiveTcl distribution).



package require Tclx
set matching [lmatch [list ab ac bc dk ab] a*]
# => ab ac ab


# If another type of test is necessary, or TclX is
# unavailable, a foreach loop is useful:



# TEST could have been a regular proc, of course
interp alias {} TEST {} string match a*
set matching [list]
foreach e [list ab ac bc dk ab] {
    if {[TEST $e]} {
        lappend matching $e
    }
}
set matching
# => ab ac ab

set numsorted [lsort -real [list 38 388.7 1.56 279 1e7]]
# => 1.56 38 279 388.7 1e7


set descending [lsort -decreasing -real [list 38 388.7 1.56 279 1e7]]
# => 1e7 388.7 279 38 1.56

# Generic code for using a custom comparison in a list sort:

#     set ordered [lsort -command compare $unordered]

# Tcl doesn't have a standard map command as used by the following
# examples.

# Pool (<URL: http://www.purl.org/NET/akupries/soft/pool/index.htm>)
# includes a command, ::pool::list::apply, which is similar to Perl's
# map.



package require Pool_Base
namespace import ::pool::list::apply
set unordered [list 1+7 5-2 3+4]
proc compute e {list [expr $e] $e}
proc second args {lindex $args 1}
set precomputed [apply compute $unordered]
set orderedPrecomputed [lsort -integer -index 0 $precomputed]
set ordered [apply second $orderedPrecomputed]
# => 5-2 3+4 1+7


Employee is an [incr Tcl] class with the members category,
name, salary, ssn, and age.



apply names $employees
# => Betsy Ewan Fran Andy Carl Diane
set ordered [lsort -command Employee::compare-name $employees]
apply names $ordered
# => Andy Betsy Carl Diane Ewan Fran

foreach employee [lsort -command Employee::compare-name $employees] {
    puts "[$employee name] earns \$[$employee salary]"
}
# => Andy earns $110000
# => Betsy earns $120000
# => Carl earns $90000
# => Diane earns $80000
# => Ewan earns $115000
# => Fran earns $110000

set sortedEmployees [lsort -command Employee::compare-name $employees]
foreach employee $sortedEmployees {
    puts "[$employee name] earns \$[$employee salary]"
}
# load bonus array
foreach employee $sortedEmployees {
    if {[info exists bonus([$employee ssn])]} {
        puts "[$employee name] got a bonus!"
    }
}
# => Andy earns $110000
# => Betsy earns $120000
# => Carl earns $90000
# => Diane earns $80000
# => Ewan earns $115000
# => Fran earns $110000
# => Ewan got a bonus!
# => Fran got a bonus!


# The class procedure Employee::compare-name-or-age looks
# like this:

#     proc compare-name-or-age {a b} {
#         set cmp [string compare [[namespace parent]::$a name] [[namespace parent]::$b name]]
#         if {$cmp != 0} {
#             return $cmp
#         } else {
#             return [expr {[[namespace parent]::$a age]-[[namespace parent]::$b age]}]
#         }
#     }



lappend employees [Employee #auto {{} Andy  95000 28}] ;# add another Andy
set sorted [lsort -command Employee::compare-name-or-age $employees]
apply names-and-ages $sorted
# => {Andy 28} {Andy 30} {Betsy 43} {Carl 30} {Diane 27} {Ewan 37} {Fran 35}

set circular [concat [lrange $list 1 end] [lindex $list 0]]
set circular [concat [lindex $list end] [lrange $list 0 end-1]]


proc grabAndRotate {listname} {
    upvar $listname list
    set first [lindex $list 0]
    set list [concat [lrange $list 1 end] $first]
    return $first
}
while 1 {
    set process [grabAndRotate processes]
    puts "Handling process $process"
    after 1000
}

proc FisherYatesShuffle {listname} {
    upvar $listname list
    for {set i [expr {[llength $list]-1}]} {$i >= 0} {incr i -1} {
        set j [expr {int(rand()*$i+1)}]
        if {$i != $j} {
            set temp [lindex $list $i]
            set list [lreplace $list $i $i [lindex $list $j]]
            set list [lreplace $list $j $j $temp]
        }
    }
}


#   Several shuffle algorithms in Tcl are compared for performance
#   here: <URL: http://mini.net/cgi-bin/nph-wikit/941.html>.
#   This is a very efficient algorithm for small lists:


proc K {x y} {return $x}
 
proc shuffle5a { list } {
    set n 1
    set slist {}
    foreach item $list {
        set index [expr {int(rand()*$n)}]
        set slist [linsert [K $slist [set slist {}]] $index $item]
        incr n
    }
    return $slist
} ;# Christoph Bauer

# @@INCOMPLETE@@
# @@INCOMPLETE@@

package require math 1.2
 
# n2pat N len : produce the $N-th pattern of length $len
proc n2pat {N len} {
    set i 1
    set pat [list]
    while {$i <= $len + 1} {
        lappend pat [expr {$N % $i}]
        set N [expr {int($N/$i)}]
        incr i
    }
    return $pat
}
 
# pat2perm pat : turn pattern returned by n2pat into
# permutation of integers.
proc pat2perm {args} {
    if {[llength $args] == 1} {
        set pat [lindex $args 0]
    } else {
        set pat $args
    }
    set source [list]
    for {set i 0} {$i < [llength $pat]} {incr i} {
        lappend source $i
    }
    set perm [list]
    while {[llength $pat]} {
        set i [lindex $pat end]
        set pat [lrange $pat 0 end-1]
        lappend perm [lindex $source $i]
        set source [lreplace $source $i $i]
    }
    return $perm;
}
 
# n2perm N len : generate the $Nth permutation of $len objects
proc n2perm {N len} {
    return [pat2perm [n2pat $N $len]]
}
 
proc main {} {
    while {[gets stdin _] >= 0} {
        set data [split $_]
        set len [llength $data]
        set numPermutations [::math::factorial $len]
        for {set i 0} {$i < $numPermutations} {incr i} {
            set permutation [list]
            foreach {p} [n2perm $i [expr {$len - 1}]] {
                lappend permutation [lindex $data $p]
            }
            puts $permutation
        }
    }
}
 
main