Keith Vetter 2002-11-25 - This is from an old graphics class I took back in 1994. It shows a person juggling from 3 to 20 balls in either the cascade or even ball juggling pattern.
I added the juggling man just last night--with the design borrowed from Flag signalling.
The goal of this program was not just to show a perfect juggler--although if you turn on the perfect button it will do that. Rather, the goal was to add errors into each throw and see how the juggler responds. I've remove much of that code, but still each throw is unique, based on how fast the ball must be released before the next ball lands.
One undocumented feature is that you can use the up and down arrows to zoom in and out.
KBK Lovely! Now if we can get Vince Darley to add site swap notation (http://www.juggling.org/help/siteswap/ ), we'll be all set.
Vince Ok, you've tempted me ;-)
AM If I remember correctly, the physics behind juggling is not at all trivial - you need a certain rhythmic motion which is difficult to learn. I do not remember the details, unfortunately.
##+################################################################
#
# tkjuggler.tcl -- an interactive juggling program.
# by Keith P. Vetter
#
# Revisions:
# KPV Nov, 1994 - initial revision for UCB CS285, Fall 1994
# KPV Nov 25, 2002 - removed 3d YART support; added juggler
#
package require Tk
##+################################################################
#
# Juggle -- controls the animation. Probable should rewrite using after to
# avoid the update call, perhaps later.
#
proc juggle {{delta 1}} {
global ss
while {1} { ;# Go until button press
incr ss(t) $delta ;# Another clock tick
for {set j 0} {$j < $ss(num)} {incr j} {;# For each ball
move_ball $ss(t) $j ;# Move it
}
move_hands
update ;# Show it on the screen
if {$ss(stop) || $delta == 0} return ;# Should we stop
}
}
##+###############################################################
#
# Init - Initializes all non-varying state variables
#
proc init {} {
global ss
set ss(pattern) cascade ;# Juggling pattern
set ss(perfect) 0 ;# Add randomness
set ss(stop) 1 ;# Animation on/off
set ss(h) 300 ;# Height
set ss(flight) 64
set ss(num) 5
set ss(v,h) $ss(h) ;# Display variants of above
set ss(v,flight) $ss(flight)
set ss(v,num) $ss(num)
set ss(w) 140
set ss(s) 40 ;# Size of the ball
set ss(s2) [expr {$ss(s)/2}] ;# Half the size of the ball
set ss(startstop) Start
set ss(scale) 1
set ss(colors) {magenta2 orange2 MediumPurple2 orchid2 SpringGreen2}
lappend ss(colors) lightslateblue PaleVioletRed2 chartreuse DarkOrchid2
lappend ss(colors) lightslateblue PaleVioletRed2 chartreuse DarkOrchid2
lappend ss(colors) purple2 cyan2 goldenrod2 plum2 HotPink2 deepskyblue
lappend ss(colors) firebrick2 slateblue1 maroon2 DarkGoldenrod2
lappend ss(colors) coral2 thistle2 skyblue2
}
##+###############################################################
#
# Display - Sets up the display with its canvas and sliders
#
proc display {} {
global ss
foreach w [winfo child .] { ;# Delete any existing widgets
destroy $w
}
set ss(ch) [expr [winfo screenheight .] - 300];# Canvas height
set ss(cw) 664 ;# Canvas width
frame .ftop
frame .fbot
pack .fbot -side bottom -fill x
pack .ftop -side top -expand 1 -fill both
catch {image create photo ::img::blank -width 1 -height 1}
make_canvas
frame .fstop -relief sunken -bd 1
button .stop -textvariable ss(startstop) -command startstop -width 5
frame .fqbtn -relief sunken -bd 1
button .qbtn -text { Quit } -command exit
button .about -image ::img::blank -command About -highlightthickness 0
pack .fqbtn .fstop -side right -expand yes -in .fbot
pack .stop -in .fstop -side left -expand yes -padx 3m -pady 2m
pack .qbtn -in .fqbtn -side left -expand yes -padx 3m -pady 2m
bind .stop <2> juggle ;# Single step
scale .s1 -label Height -orient horizontal -from 1 -to 1000
.s1 config -relief ridge -showvalue 1 -variable ss(v,h)
scale .s2 -label "Flight Time" -orient horizontal -from 1 -to 500
.s2 config -relief ridge -showvalue 1 -variable ss(v,flight)
scale .s4 -label Balls -orient horizontal -from 3 -to 20
.s4 config -relief ridge -showvalue 1 -variable ss(v,num)
pack .s1 .s2 .s4 -side left -in .fbot
bind .s1 <ButtonRelease-1> "set_value height"
bind .s2 <ButtonRelease-1> "set_value flight"
bind .s4 <ButtonRelease-1> "set_value balls"
frame .frb ;# Radiobuttons for patterns
radiobutton .cascade -text "Cascade" -var ss(pattern) \
-value cascade -command reinit -anchor w
radiobutton .shower -text "Shower" -var ss(pattern) \
-value shower -command reinit -anchor w
radiobutton .even -text "Even" -var ss(pattern) \
-value even -command reinit -anchor w
pack .frb -side left -in .fbot -padx 1
pack .cascade .even -in .frb -side top -expand yes -anchor w -fill x
frame .fcb ;# Checkbuttons for options
checkbutton .crandom -text "Perfect" -var ss(perfect) -anc w
checkbutton .cback -text "Outside" -var ss(back) -command reinit -anc w
pack .fcb -side left -in .fbot -padx 1
pack .crandom .cback -in .fcb -side top -expand no -anchor w -fill x
place .about -in .fbot -relx 1 -rely 0 -anchor ne
wm withdraw . ;# Update to get sizes
wm geom . +0+0
wm deiconify .
wm title . "Tk Juggler"
}
##+#####################################################
#
# Make_canvas - Creates the canvas on which all output will be done
#
proc make_canvas {} {
global ss
scrollbar .vscroll -relief sunken -command ".c yview"
set c2 [expr {$ss(cw) / 2}]
canvas .c -relief raised -borderwidth 2 -height $ss(ch) -width $ss(cw) \
-bg steelblue3 -highlightthickness 0
.c config -scrollregion [list -$c2 -1200 $c2 500]
.c config -yscrollcommand ".vscroll set" -yscrollincrement 1
.c config -highlightcolor [.c cget -bg]
.c yview moveto .4
flagman ;# Draws are flagman
wink 0
pack .vscroll -in .ftop -side right -fill y
pack .c -in .ftop -fill both -expand 1
bind .c <2> ".c scan mark %x %y"
bind .c <B2-Motion> ".c scan drag %x %y"
bind .c <MouseWheel> {%W yview scroll [expr {- (%D / 120) * 20}] units}
bind .c <Configure> {Recenter %W %h %w}
bind . <Up> {scaler 1}
bind . <Down> {scaler 0}
focus .c ;# So mouse wheel works
}
##+######################################################
#
# Recenter - Called when window gets resized.
#
proc Recenter {W h w} {
set h [expr {$h / 2.0}] ; set w [expr {$w / 2.0}]
$W config -scrollregion [list -$w -1200 $w 500]
}
##+#####################################################
#
# Move_ball - Moves ball WHO to parameter value T. It flies in a
# parabola going through points (-w,0), (0,height), (w,0).
#
proc move_ball {t w} {
global ball ss
switch $ball($w,ss) {
"LR" { ;# Left to right toss
place_obj ball$w [tossing $t $w]
if {$t >= $ball($w,catch)} { ;# ...just got caught
catch_ball $w 1
set ball($w,ss) HR
}
}
"HR" { ;# Hold in right hand
if {$t >= $ball($w,toss)} { ;# ...just got tossed
set ball($w,ss) $ss(HR)
toss_ball $w 1
place_obj ball$w [tossing $t $w]
}
}
"RL" { ;# Right to left toss
place_obj ball$w [tossing $t $w]
if {$t == $ball($w,catch)} { ;# ...just got caught
catch_ball $w 0
set ball($w,ss) HL
}
}
"HL" { ;# Hold in left hand
if {$t >= $ball($w,toss)} { ;# ...just got tossed
set ball($w,ss) $ss(HL)
toss_ball $w 0
place_obj ball$w [tossing $t $w]
}
}
"SL" { ;# Start in left hand
place_obj ball$w [tossing $ball($w,toss) $w]
set ball($w,ss) "HL"
}
"SR" { ;# Start in right hand
place_obj ball$w [tossing $ball($w,toss) $w]
set ball($w,ss) "HR"
}
}
}
##+#####################################################
#
# Tossing - Figures out the path for a ball: x,y
#
# u = (2t/sqrt(k)*f - 1)
# x = w*u
# y = kh * (1 - u^2)
#
proc tossing {time who} {
global ball ss
set t [expr {$time - $ball($who,toss)}] ;# Time since the toss
set f $ball($who,flight) ;# Flight time
set u [expr {-1 + 2.0 * $t / $f}] ;# range -1 to 1
set x [expr {$ball($who,x) + ((1 + $u)/2) * $ball($who,w)}]
set y [expr {-($ball($who,kh) * (1 - $u * $u))}];# Y is a parabola
return [list $x $y]
}
##+#####################################################
#
# Create_hand - Creates a new hand, and put them anywhere on the canvas
#
proc create_hand {name} {
global ss
.c delete hand$name
.c create arc 0 -$ss(s) $ss(s) $ss(s) -fill orange -outline orange \
-tag "hands hand$name hand_x$name" -start 0 -extent -180
foreach {x1 y1 x2 y2} [.c bbox hand_x$name] break
set color [lindex [.c config -bg] 4] ;# Erasure color
.c create arc $x1 0 $x2 $ss(s) -fill $color -outline "" \
-tag "hands hand$name hand_y$name" -start 0 -extent -180
.c lower hand$name
.c lower flagman
place_obj hand_x$name {0 0} -1
place_obj hand_y$name {0 0} -1
}
##+#####################################################
#
# Create_ball - Creates a new ball
#
proc create_ball {n} {
global ss
.c delete ball$n
set color [lindex $ss(colors) 0] ;# Take head of the list
set ss(colors) "[lrange $ss(colors) 1 end] $color" ;# Put head at end
.c create oval -$ss(s2) -$ss(s2) $ss(s2) $ss(s2) -fill $color \
-tag "balls ball$n"
#.c create text 0 0 -text $n -tag "balls ball$n" -anchor c
}
##+#####################################################
#
# New_balls - Deletes then recreates the balls
#
proc new_balls {} {
global ss
.c delete balls
for {set i 0} {$i < $ss(num)} {incr i} {
create_ball $i
}
juggle 0 ;# Update the display
}
##+#####################################################
#
# Startstop - Manipulates the start / stop button
#
proc startstop {} {
global ss
if {$ss(startstop) == "Start"} {
set ss(startstop) "Stop"
set ss(stop) 0
after 1 juggle
} else {
set ss(startstop) "Start"
set ss(stop) 1
}
}
##+#####################################################
#
# Set_value
#
# Handles changing the values of any juggling parameter. We late-bind
# so we only change on button release.
#
proc set_value who {
global ss
if {$who == "height"} {
set ss(h) $ss(v,h) ;# Just get the height
return
} elseif {$who == "flight"} {
set ss(flight) $ss(v,flight) ;# Get new flight time
} elseif {$who == "balls"} {
set ss(num) $ss(v,num) ;# New number of balls
}
adjust
reinit ;# Update global values
}
##+#####################################################
#
# Reinit -- Initializes the ss variables for the balls
#
proc reinit {} {
global ss
set ss(t) 0 ;# Start at time 0
set ss(h) $ss(v,h) ;# Height
set ss(flight) $ss(v,flight) ;# Flight time
set ss(num) $ss(v,num) ;# How many balls
set ss(w) [expr {round($ss(scale) * 140)}] ;# Width of hands
.cback config -state normal
set ss(LR) HR ;# State transitions
set ss(RL) HL
set ss(HR) RL ;# Even does weirdness
set ss(HL) LR
$ss(pattern) ;# Set up for given pattern
}
##+#####################################################
#
# Best - Sets up the hold time for N balls
#
# empty (e) = P3 - BALL(n-1)
# = (2f+h) - (n-1)(2f+2h)/n
# = (2f - h(n-2)) / n
# hold (h) = (2f - en) / (n-2)
#
# Also h + e = time between balls = (2f+2h)/n
#
# Constraints: at the start the last ball must be in the air
# BALL(n-1) < P3
# ==> hold < 2f / (n-2)
# ==> empty < 2f / n
# alt. hold time less than time between balls
# hold < (2f+2h)/n
# hold < 2f / (n-2)
#
# Best: e == h ==> h = f / (n-1)
#
# To compute: the last ball starts at the exact moment when the first ball
# is launched. The hand is empty until the ball lands.
#
proc best {} {
global ss
set ss(hold) $ss(flight)
if {$ss(num) > 1} {
set ss(hold) [expr {round(1.0 * $ss(flight) / ($ss(num) - 1))}]
}
}
##+#####################################################
#
# Move_hands - Positions the hands correctly.
#
proc move_hands {} {
global hand ss
if {[.c find withtag hands] == ""} return ;# No hands, do nothing
.c delete arms
foreach h {0 1} {
set where [where_hands $ss(t) $h] ;# Where it belongs
foreach {x y} $where break
set x [expr {$x - 1 - $h}] ;# Fudge factor
set y [expr {$y - 1}] ;# Fudge factor
place_obj hand$h [list $x $y] -1 ;# Put into place
set w [expr {3 * $ss(s) / 4}]
set y [expr {$y + $w}]
.c create line $ss(elbowx,$h) $ss(elbowy,$h) $x $y -tag arms \
-fill gray95 -width $w
if {$hand($h,ss) == "full"} { ;# Does it have a ball in it?
set b ball$hand($h,ball) ;# Yep, then move the ball also
place_obj $b $where
}
}
.c lower arms hands
}
##+#####################################################
#
# Where_hands - Determines where H hand should be at time T
#
proc where_hands {t h} {
global hand ss
set d [expr {$hand($h,duration) - 1}]
if {$d <= 0} {set d 1}
if {$hand($h,ss) == "full"} {
set p [expr {1.0 - (1.0*$hand($h,toss) - $t -1) / $d}]
set y [expr {$hand($h,y) - $ss(s) * (4 * ($p * ($p - 1)))}]
} else {
set p [expr {(1.0 * $hand($h,catch) - $t) / $hand($h,duration)}]
set y [expr {$ss(s2) * (4 * ($p * ($p - 1)))}]
}
set w [expr {$ss(w) + $ss(shift)}] ;# Biggest width
if $h { ;# X depends on which hand
set x [expr {$w - 2 * $p * $ss(shift)}]
} else {
set x [expr {-$w + 2 * $p * $ss(shift)}]
}
set x [expr {round($x)}]
set y [expr {round($y)}]
return [list $x $y]
}
##+#####################################################
#
# Adjust - Adjust the flight & hold time so that their sum is a
# multiple of the number of balls. This way, we get no round off
# errors in computing where the balls should start.
#
proc adjust {} {
global ss
if {$ss(pattern) != "cascade"} return
set n $ss(num) ;# Number of balls
set f $ss(flight) ;# Flight time
set h $ss(hold) ;# Hold time
set r [expr {($f + $h) % $n}] ;# How much we're off by
if {$r != 0} {
if {$r > $n / 2} {
set r [expr {$r - $n}]
}
set ss(flight) [expr {$ss(flight) - $r}] ;# Adjust flight down
set ss(v,flight) $ss(flight) ;# Set the scale
}
}
##+#####################################################
#
# Toss_ball - Called when a ball has just been tossed. We need to
# update the hand info.
#
proc toss_ball {who which} {
global ball hand ss
set next [next_ball $who $which] ;# Next ball to land here
set hand($which,ss) empty ;# No longer holding a ball
set hand($which,ball) -1 ;# Ball in hand
set hand($which,catch) $ball($next,catch) ;# Next ball to land here
set hand($which,duration) [expr {$ball($next,catch) - $ss(t)}]
}
##+#####################################################
#
# Catch_ball - Called when ball WHO lands in hand WHICH. Generates a
# new toss and updates the hand information.
#
proc catch_ball {who which} {
global ball hand ss
set dirs(RL) to_right
set dirs(LR) to_left
set next [next_ball $who $which] ;# Next ball to land here
set when [expr {($ss(t) + $ball($next,catch)) /2.0}];# Time for us to leave
set when [expr {round($when)}]
if {$when == $ss(t)} { ;# Problem when WHO == NEXT
set when [expr {$ss(t) + $ss(hold)}]
}
if {0 && $which == 0} {
puts -nonewline "catch $who: time $ss(t) catch($next) "
puts -nonewline "$ball($next,catch) when $when "
puts "when: +[expr {$when - $ss(t)}]"
}
new_toss $who $when $dirs($ball($who,ss)) $which
set hand($which,ss) full ;# Holding a ball
set hand($which,ball) $who ;# Ball in hand
set hand($which,toss) $ball($who,toss);# When we throw it
set hand($which,duration) [expr {$ball($who,toss) - $ss(t)}]
set u [expr {-1 + 2.0/$ball($who,flight)}]
set y [expr {$ball($who,kh) * (1 - $u*$u)}]
set hand($which,y) $y
}
##+#####################################################
#
# Next_ball - Returns the next ball after WHO to land in hand WHICH
#
proc next_ball {w h} {
global ss
incr w -1
if {$ss(pattern) == "even"} {
if {$w == -1} {
set w [expr {$ss(n2) - 1}]
} elseif {$w == $ss(n2) - 1} {
set w [expr {$ss(num) - 1}]
}
} elseif {$w == -1} {
set w [expr {$ss(num) - 1}]
}
return $w
}
##+#####################################################
#
# New_toss - Sets up ball WHO for being tossed again at time WHEN
# in direction DIR.
# new height = k * height
# new flight = sqrt(k) * flight
#
proc new_toss {who when dir xhand} {
global ball ss
set k 1 ;# Scaling factor
set f $ss(flight) ;# Total flight time
set x 0 ;# Overlap into holding time
if {! $ss(perfect)} { ;# Should we add randomness?
set x [expr {int(rand() * $ss(hold))}] ;# Use this much of hold time
set f [expr {$ss(flight) + $x}] ;# New flight time
set k [expr {1.0 * $f / $ss(flight)}]
set k [expr {$k * $k}]
}
if {$dir == "to_right" && $ss(pattern) == "shower"} {
set f $ss(flight2) ;# Special low path
set k [expr {1.0 * $f / $ss(flight)}]
set k [expr {$k * $k}]
}
set ball($who,k) $k ;# Random height scale factor
set ball($who,toss) $when ;# Time of the toss
set ball($who,flight) $f ;# New flight time
set ball($who,catch) [expr {$when + $f}] ;# Time of catch
set ball($who,kh) [expr {$k * $ss(h)}] ;# How high this toss goes
set ball($who,w) [expr {2 * $ss(w)}]
if {$ss(pattern) == "even"} {
set ball($who,w) [expr {-2*$ss(shift)}]
}
set ball($who,x) [expr {-($ss(w) - $ss(shift))}]
if {$xhand == 1} {
set ball($who,w) [expr {-$ball($who,w)}]
set ball($who,x) [expr {-$ball($who,x)}]
}
if {$ss(pattern) == "shower" && $ss(back) == 1} {
set ball($who,w) [expr {-$ball($who,w)}]
set ball($who,x) [expr {-$ball($who,x)}]
}
}
##+#####################################################
#
# Dump - Dumps out the ss of a ball or all the balls
#
proc dump {} {
global ball hand ss
puts ""
for {set i 0} {$i < $ss(num)} {incr i} {
set msg "Ball $i: $ball($i,ss)"
set msg "$msg toss [format %4d $ball($i,toss)]"
set msg "$msg catch[format %4d $ball($i,catch)]"
set msg "$msg flight[format %4d $ball($i,flight)]"
set msg "$msg x [format %4d $ball($i,x)]"
set msg "$msg w [format %4d $ball($i,w)]"
set msg "$msg k $ball($i,k)"
set msg "$msg kh $ball($i,kh)"
puts $msg
}
for {set i 0} {$i < 2} {incr i} {
set msg "Hand $i: [format %5s $hand($i,ss)]"
set msg "$msg ball [format %2s $hand($i,ball)]"
set msg "$msg toss [format %4d $hand($i,toss)]"
set msg "$msg catch [format %4d $hand($i,catch)]"
set msg "$msg duration $hand($i,duration)"
set msg "$msg y $hand($i,y)"
puts $msg
}
puts "time: $ss(t)"
puts ""
}
##+#####################################################
#
# Init_ball - Given the starting position of a ball, it determines the
# ss the ball is in and what its toss/catch values should be.
#
proc init_ball {who time} {
global ball ss
if {$time < $ss(p1)} { ;# Left to right
set ball($who,ss) LR
new_toss $who [expr {-$time}] to_right 0
} elseif {$time < $ss(p2)} { ;# Hold right
set ball($who,ss) SR
set ball($who,ss) HR
new_toss $who [expr {$ss(p2) - $time}] to_left 1
} elseif {$time < $ss(p3)} { ;# Right to left
set ball($who,ss) RL
new_toss $who [expr {$ss(p2) - $time}] to_left 1
} elseif {$time < $ss(p4)} { ;# Hold left
set ball($who,ss) SL
set ball($who,ss) HL
new_toss $who [expr {$ss(p4) - $time}] to_right 0
} else {
puts "ERROR: init_ball $who $time: time out of range"
}
}
##+#####################################################
#
# Startup - Re-init the balls so that they all start in the hands.
# Not fully working yet.
#
proc startup {} {
global ss ball
set newss(LR) SL ;# Cheap way to avoid an if
set newss(HR) SR
set newss(RL) SR
set newss(HL) SL
set max $ss(t) ;# Find longest in air
for {set i 0} {$i < $ss(num)} {incr i} {
if {$ball($i,toss) < $max} { set max $ball($i,toss) }
}
set max [expr {$ss(t) - $max}]
for {set i 0} {$i < $ss(num)} {incr i} { ;# Adjust everyone by max
set ball($i,toss) [expr {$ball($i,toss) + $max}]
set ball($i,catch) [expr {$ball($i,toss) + $ball($i,flight)}]
set ball($i,ss) $newss($ball($i,ss))
move_ball 0 $i
}
}
##+#####################################################
#
# Init_hands - Initializes where the hands are
#
proc init_hands {} {
global ball ss hand
if {$ss(pattern) == "shower"} return
set hand(0,y) 20
set hand(1,y) 20
toss_ball 0 0 ;# Just tossed off ball 0
if {[expr {($ss(num) % 2) == 0}]} {
toss_ball [expr {$ss(num) / 2}] 1
return
}
set hand(0,toss) 0 ;# When ball gets tossed
set who [expr {$ss(num) / 2}] ;# Ball in the right hand
set hand(1,ss) full ;# It has a ball in it
set hand(1,ball) $who ;# Which ball
set hand(1,toss) $ball($who,toss) ;# When toss will happen
set hand(1,catch) 0 ;# When next ball lands
set hand(1,duration) $ss(hold) ;# How long we hold ball for
}
##+#####################################################
#
# Cascade - Sets up balls & hands for the cascade pattern
#
proc cascade {} {
global ball ss
best ;# Set up HOLD
adjust
set ss(pattern) cascade ;# Indicate this pattern
set ss(t) 0 ;# Start at time 0
set ss(shift) [expr {(1 - 2*$ss(back)) * $ss(s)}]
set ss(p1) $ss(flight) ;# Cycle timings
set ss(p2) [expr {$ss(p1) + $ss(hold)}]
set ss(p3) [expr {$ss(p2) + $ss(flight)}]
set ss(p4) [expr {$ss(p3) + $ss(hold)}]
set ss(total) $ss(p4)
.c delete balls
for {set i 0} {$i < $ss(num)} {incr i} {
create_ball $i
init_ball $i [expr {$ss(total) * $i / $ss(num)}]
}
#startup ;# Put into start position
create_hand 0
create_hand 1
init_hands
juggle 0 ;# Put them in position
juggle 0 ;# Don't ask, it looks better
}
##+#####################################################
#
# Shower - Sets up for the shower pattern
#
proc shower {} {
global ball ss
set ss(pattern) shower ;# Indicate this pattern
set ss(t) 0
set ss(shift) 0 ;# Get rid of the shift
.c delete hands
## total = f + 2hold + f2
## f2 = total/n ==> f/(n-2)
## hold = 1/2 * (total / n) ==> f/2(n-2)
set ss(flight2) [expr {round($ss(flight) / ($ss(num) - 2.0))}]
if {$ss(flight2) <= 1} { set ss(flight2) 2 }
if {$ss(flight2) >= 5} { set ss(flight2) 4 }
set ss(hold) [expr {round($ss(flight2) / 2.0)}]
set ss(p1) $ss(flight2) ;# Cycle timings
set ss(p2) [expr {$ss(p1) + $ss(hold)}]
set ss(p3) [expr {$ss(p2) + $ss(flight)}]
set ss(p4) [expr {$ss(p3) + $ss(hold)}]
set ss(total) $ss(p4)
.c delete balls
for {set i 0} {$i < $ss(num)} {incr i} {
create_ball $i
init_ball $i [expr {$ss(total) * $i / $ss(num)}]
}
juggle 0 ;# Put them in position
}
##+#####################################################
#
# Even - Sets up for even ball pattern
#
proc even {} {
global ball hand ss
set ss(pattern) even ;# Indicate this pattern
set ss(t) 0
set ss(shift) [expr {(1 - 2*$ss(back)) * 2*$ss(s)}] ;# Bigger shift
set ss(w) [expr {round($ss(scale) * 110)}] ;# Width of hands
set ss(HR) LR ;# Change the transitions
set ss(HL) RL
set ss(hold) [expr {$ss(flight) / ($ss(num) - 1)}]
set ss(total) [expr {$ss(flight) + $ss(hold)}]
set n2 [expr {round($ss(num) / 2.0)}] ;# Balls in left hand
set n3 [expr {$ss(num) - $n2}] ;# Balls in right hand
set ss(n2) $n2
.c delete balls
for {set i 0} {$i < $n2} {incr i} { ;# Left hand
create_ball $i ;# New ball
set t [expr {-$ss(total) * $i / $n2}] ;# When it got tossed
new_toss $i $t xxx 0 ;# Put in then toss values
set ball($i,ss) RL ;# Reset the ss info
if [expr {$t > $ss(flight)}] {
set ball($i2,ss) SL
set ball($i2,ss) HL
}
}
set offset [expr {$n2 == $n3 ? $ss(hold) : 0}]
for {set i $n2} {$i < $ss(num)} {incr i} { ;# Right hand
set i2 [expr {$i - $n2}] ;# Ball in other hand
create_ball $i
set t [expr {-$ss(total) * $i2 / $n3}] ;# When it got tossed
set t [expr {-$offset + $t}] ;# Offset it a little
new_toss $i $t xxx 1 ;# Put in the toss values
set ball($i,ss) LR ;# Reset the ss info
if [expr {$t > $ss(flight)}] {
set ball($i,ss) SR
set ball($i,ss) HR
}
}
create_hand 0
create_hand 1
toss_ball 0 0
toss_ball $n2 1
juggle 0 ;# Put them in position
juggle 0 ;# Don't ask, it looks better
}
proc wink {onoff} {
catch {after cancel $::ss(wink)}
if {$onoff} {
.c lower reye
.c raise wink flagman
set ::ss(wink) [after 500 {wink 0}]
} else {
.c lower wink
.c raise reye flagman
set delay [expr {int(1000 * (10 + 40*rand()))}]
set ::ss(wink) [after $delay {wink 1}]
}
}
##+#####################################################
#
# Place_obj
#
# Moves OBJ to absolute coordinates (x,y). If center is 0 then the
# top left corner moves to (x,y). If center is 1 then the object is
# centered at (x,y). If center is -1, then only centered in x.
#
proc place_obj {obj xy {center 1}} {
global ss
foreach {x y} $xy break
set bb [.c bbox $obj] ;# Where it is
set x [expr {$x - $ss(s2)}] ;# Center at this point
if {$center != -1} {
set y [expr {$y - $ss(s2)}]
}
set dx [expr {$x - [lindex $bb 0]}] ;# Delta in X
set dy [expr {$y - [lindex $bb 1]}] ;# Delta in Y
.c move $obj $dx $dy ;# Move into place
}
proc About {} {
tk_messageBox -icon info -parent . -title "About TkJuggler" \
-message "Tk Juggler\n\nby Keith Vetter\nNovember, 2002"
}
proc flagman {} {
# stolen from http://wiki.tcl.tk/3208
.c create rect {-5000 110 5000 5000} -fill grey -outline grey -tag flagman
.c create poly {-80 280 -20 280 0 80 20 280 80 280 100 -136 0 \
-160 -100 -136} -fill white -tag flagman
.c create oval {-40 -236 40 -140} -fill orange -outline orange -tag flagman
.c create line {-16 -200 -16 -188} -tag {flagman reye}
.c create line {-8 -194 -24 -194} -tag {flagman wink}
.c create line {16 -200 16 -188} -tag flagman
.c create arc -24 -216 24 -160 -start 210 -extent 125 -style arc \
-tag flagman
.c create rect {-36 -236 36 -216} -fill white -outline white -tag flagman
.c create poly {-80 -120 -100 -120 -100 0 -60 0 -60 -120} -fill grey95 \
-tag flagman
.c create poly {80 -120 100 -120 100 0 60 0 60 -120} -fill grey95 \
-tag flagman
.c lower wink
array set ::ss {elbowx,0 -80 elbowy,0 -10 elbowx,1 80 elbowy,1 -10}
}
proc scaler {bigger} {
global ss
if {$bigger} {
if {$ss(scale) > 2} return
set f 1.25
} else {
if {$ss(scale) < .15} return
set f .8
}
.c scale all 0 0 $f $f
foreach w {scale s s2 w v,h elbowx,0 elbowx,1} {
set ss($w) [expr {$ss($w) * $f}]
}
set ss(v,flight) [expr {round($ss(v,flight) / $f)}]
adjust
reinit
}
##+##############################################################
#################################################################
#################################################################
init ;# One time inits
display ;# Set up all the widgets
reinit ;# Inits for this pattern
startstop