http://www.juggling.org/help/siteswap/

##+################################################################
#
# 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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References