103 lines
2.3 KiB
Tcl
103 lines
2.3 KiB
Tcl
package require Thread
|
|
package require Tk
|
|
|
|
# Make the shared state
|
|
canvas .c ;# So we can allocate the display lines in one loop
|
|
set m [thread::mutex create]
|
|
for {set i 0} {$i<100} {incr i} {
|
|
set bucket b$i ;# A handle for every bucket...
|
|
tsv::set buckets $bucket 50
|
|
lappend buckets $bucket
|
|
lappend lines [.c create line 0 0 0 0]
|
|
}
|
|
tsv::set still going 1
|
|
|
|
# Make the "make more equal" task
|
|
lappend tasks [thread::create {
|
|
# Perform an atomic update of two cells
|
|
proc transfer {b1 b2 val} {
|
|
variable m
|
|
thread::mutex lock $m
|
|
set v [tsv::get buckets $b1]
|
|
if {$val > $v} {
|
|
set val $v
|
|
}
|
|
tsv::incr buckets $b1 [expr {-$val}]
|
|
tsv::incr buckets $b2 $val
|
|
thread::mutex unlock $m
|
|
}
|
|
|
|
# The task itself; we loop this round frequently
|
|
proc task {mutex buckets} {
|
|
variable m $mutex b $buckets i 0
|
|
while {[tsv::get still going]} {
|
|
set b1 [lindex $b $i]
|
|
if {[incr i] == [llength $b]} {set i 0}
|
|
set b2 [lindex $b $i]
|
|
|
|
if {[tsv::get buckets $b1] > [tsv::get buckets $b2]} {
|
|
transfer $b1 $b2 1
|
|
} else {
|
|
transfer $b1 $b2 -1
|
|
}
|
|
}
|
|
}
|
|
thread::wait
|
|
}]
|
|
|
|
# Make the "mess things up" task
|
|
lappend tasks [thread::create {
|
|
# Utility to pick a random item from a list
|
|
proc pick list {
|
|
lindex $list [expr {int(rand() * [llength $list])}]
|
|
}
|
|
proc transfer {b1 b2 val} {
|
|
variable m
|
|
thread::mutex lock $m
|
|
set v [tsv::get buckets $b1]
|
|
if {$val > $v} {
|
|
set val $v
|
|
}
|
|
tsv::incr buckets $b1 [expr {-$val}]
|
|
tsv::incr buckets $b2 $val
|
|
thread::mutex unlock $m
|
|
}
|
|
|
|
# The task to move a large amount between two random buckets
|
|
proc task {mutex buckets} {
|
|
variable m $mutex b $buckets
|
|
while {[tsv::get still going]} {
|
|
set b1 [pick $b]
|
|
set b2 [pick $b]
|
|
transfer $b1 $b2 [expr {[tsv::get buckets $b1] / 3}]
|
|
}
|
|
}
|
|
thread::wait
|
|
}]
|
|
|
|
# The "main" task; we keep GUI operations in the main thread
|
|
proc redisplay {} {
|
|
global m buckets lines
|
|
thread::mutex lock $m
|
|
set i 1
|
|
foreach b $buckets l $lines {
|
|
.c coords $l $i 0 $i [tsv::get buckets $b]
|
|
incr i 2
|
|
}
|
|
thread::mutex unlock $m
|
|
after 100 redisplay
|
|
}
|
|
|
|
# Start tasks and display
|
|
.c configure -width 201 -height 120
|
|
pack .c
|
|
redisplay
|
|
foreach t $tasks {
|
|
thread::send -async $t [list task $m $buckets]
|
|
}
|
|
|
|
# Wait for user to close window, then tidy up
|
|
tkwait window .
|
|
tsv::set still going 0
|
|
thread::broadcast thread::exit
|