#! /bin/ksh
#   comment, under wish... \
    __tcl=7.6; __tk=4.2; \
    export TCL_LIBRARY="~/lib/tcl$__tcl"; export TK_LIBRARY="~/lib/tk$__tk"; \
    exec ~/bin/wish$__tk $0 "$@"

#    __tcl=8.0a1; __tk=8.0a1;

                              #  #####  #
                              # #       #
                              # #  #### #
                        #     # #     # #
                         #####   #####  #######

#  ver	 date	      description
# =====	 ===========  =========================================================
#  1.0	 Nov 25 1996  Introduction
#  2.0	 Dec 08 1996  Interactive (via entry widget).  Pause, Show/Hide Ladder
#  2.1	 Dec 13 1996  Supports more pattern types. Uses cached real
#                       trajectories.  Balls start on sides where launched.
#  2.2	 Dec 15 1996  More improvements to cacheing.
#                       John LoVerso's <2>button autorepeat on "Step" button.
#  2.3	 Dec 18 1996  Pattern Database.  Optional stationary "2" throw.
#                       Optional b/w-w/b ladder canvas.  Welcome message.
#  2.4	 Dec 30 1996  General "sprucing up".  Add sizing variability to the
#                       ladder diagram.  Simple ladder EPS output.
#                       Sundrie options.
#  2.5	 Jan 06 1997  Tidy up "dog ends" on ladder diagram.  Add "repeat"
#                       function to ladder.  Slight reformatting of ladder.
#                       Fixed obscure caching gotcha.  More text in "Welcome!".

proc Error {msg} { global def;  set def(mess) $msg }

#  def() ("defaults"):
#
# Fixed:
#   v     = version
#   l	  = swaplist
#   peel  = a global register from which actual throws are "peeled" off
#   h	  = hand space (distance between hands)
#   s	  = scoop percent
#   q	  = throw quantize time unit (throw "w" takes q*w seconds to travel)
#   t	  = time quantum (smallest unit of time)
#   a	  = acceleration due to gravity (ft/s**2)
#   i	  = hand that throws first ({L}, {R})
#   cx	  = canvas width  (in pixels)
#   cy	  = canvas height (in pixels)
#   d	  = diameter of balls
#   b	  = "begin"; where numbering for initial positioning starts/increments
#	     also used as 'nil' ball placeholder for '0' swap values
#   c	  = ball colors from /usr/lib/X11/rgb.txt
#   k	  = backgroup color from /usr/lib/X11/rgb.txt
#   lad   = boolean; indicates visibility of the ladder diagram
#   llen  = number of itterations of pattern represented in ladder
#   lmax  = maximum number of itterations of pattern represented in ladder
#   pause = boolean; indicates pause mode
#   2     = boolean; indicates stationary "2" throw (vs. thrown)
#   n     = boolean; indicates canvas white-on-black
#   f     = boolean; indicates filtering "2" throws active
#   lasp  = "ladder aspect"; a sizing factor for the ladder diagram
#   lasp2 = ladder diagram unit size (in centimeters)
#
# Derived:
#   nam   = name of executable
#   Nam   = Capitalized name of executable
#   s	  = scoop distance (converted from percentage)
#   w	  = wait between frames in milliseconds
#   clen  = number of colors supported
#
array set def {
    {v}  {2.5}
    {l}  {}     {peel}  {}
    {h}	 {2.0}	   {s}	{0.3}
    {q}	 {0.3}	   {t}	{0.05}	 {a}  {32.0}
    {i}	 {R}
    {cx} {350}	   {cy} {350}	 {d}  {24}
    {b}	 {1000}
    {c}	 {
	#ff0000 #00ff00 #0000ff #ffff00 #ff00ff #00ffff #ffffff
	#ff6060 #60ff60 #6060ff
	#ff8000 #ff0080 #80ff00 #00ff80 #8000ff #0080ff
	#ff80c0 #ffc080 #80ffc0 #c0ff80 #80c0ff #c080ff
    }
    {k}	 {gray50}  {lad} {1} {llen} {1}  {lmax} {5}  {pause}  {0}
    {2}  {1}         {n} {1}    {f} {1}
    {lasp} {1.0} {lasp2} {0.75}
}
array set def \
    [list \
	 {nam}  [file rootname [file tail [info script]]] \
	 {s}    [expr $def(h) * $def(s)] \
	 {w}    [expr int( ($def(t) * 1000.0 / $def(q)) + 0.5)] \
	 {clen} [llength $def(c)] \
	]
set def(Nam) \
    [string toupper [string range $def(nam) 0 0]][string range $def(nam) 1 end]

#  Alternate Ladder aspects (mapped to fonts):
#
array set lasp {
    {0.4} {5x8}
    {0.6} {5x8}
    {0.8} {fixed}
    {1.0} {fixed}
    {1.5} {10x20}
}

array set canvbgfg {{bg:0} {white} {fg:0} {black} {bg:1} {black} {fg:1} {white}}

#  Here's where we manage tweaks and toggles to the variables associated with
#    "check" and "radio" menu items.
#
proc Vartrap {vname vix op} {

    global def toggle canvbgfg trajcacheR

    switch -exact $vname {
	{def} {
	    switch -exact $vix {
		{2} {
		    catch {unset trajcacheR(2)}
		    if {[lsearch -exact $def(l) {2}] > -1} EntryReturn
		}
		{n} {
		    .ladd.lad2.c configure -bg $canvbgfg(bg:$def(n))
		    .ladd.lad2.c itemconfig {laddertext} \
			    -fill $canvbgfg(fg:$def(n))
		}
		{lad} {
		    if {$def(lad)} {
			pack .ladd.lad2 -expand 1 -fill both
		    } else {
			pack forget .ladd.lad2;  .ladd configure -width 1
		    }
		}
		{lasp} ShowLadder
		{llen} EntryReturn
	    }
	}
    }
}
#  Trap the writes to "def":
#
trace variable def w {Vartrap}

#  evalable calculators for the X coordinate
#
array set xcalc {
    {0L} {$s * $V}	    {0R} {$h + ( $s * $U )}
    {1L} {$s + ( $h * $U )} {1R} {$h * $V}
    {2L} {0.0}   	    {2R} {$h + $s}
}

#  switch hands (e.g., "set side $swhand([expr $throw % 2]$side)")
#
array set swhand {{0L} {L} {1L} {R} {0R} {R} {1R} {L}}

#  boolean toggle array
#
array set toggle {{0} {1} {1} {0}}

#  Here's our simple database of swaps:
#
array set Swaps {
    {3 3} 3
    {3 4} {{4 2} {4 4 1}}
    {3 5} {{5 2 2} {5 3 1} {4 5 1 2} {5 2 4 1}}
    {3 6} {
	{6 2 2 2} {6 2 3 1} {6 3 1 2} {4 6 1 2 2} {4 6 1 3 1} {6 2 2 4 1}
	{6 3 1 4 1} {6 3 1 6 1 3 1}}
    {3 7} {
	{7 2 2 2 2} {7 2 2 3 1} {7 2 3 1 2} {7 3 1 2 2} {7 3 1 3 1}
	{4 7 1 2 2 2} {4 7 1 2 3 1} {4 7 1 3 1 2} {7 2 2 2 4 1} {7 2 3 1 4 1}
	{7 3 1 2 4 1} {7 2 3 1 6 1 3 1}}
    {4 4} 4
    {4 5} {{5 3} {5 5 2} {5 5 5 1}}
    {4 6} {
	{6 3 3} {6 4 2} {5 6 2 3} {5 6 4 1} {6 3 5 2} {6 4 5 1} {6 6 2 2}
	{6 6 3 1} {5 5 6 1 3} {5 6 6 1 2} {6 3 5 5 1} {6 3 6 4 1} {6 4 6 1 3}
	{6 6 2 5 1} {5 6 6 1 5 1} {6 3 6 6 1 2} {6 6 2 6 1 3} {5 6 6 1 6 1 3}
	{6 3 6 6 1 5 1} {6 4 6 1 6 4 1} {6 6 2 6 1 6 4 1}}
    {4 7} {
	{7 3 3 3} {7 3 4 2} {7 4 2 3} {7 4 4 1} {7 5 2 2} {7 5 3 1} {5 7 2 3 3}
	{5 7 2 4 2} {5 7 4 1 3} {5 7 5 1 2} {6 7 2 2 3} {6 7 2 4 1} {6 7 3 1 3}
	{7 3 3 5 2} {7 3 4 5 1} {7 3 6 2 2} {7 3 6 3 1} {7 4 2 5 2} {7 4 6 1 2}
	{7 5 2 5 1} {7 7 2 2 2} {7 7 2 3 1} {7 7 3 1 2} {5 5 7 1 3 3}
	{5 5 7 1 4 2} {5 6 7 1 2 3} {5 7 2 4 5 1} {5 7 2 6 2 2} {5 7 2 6 3 1}
	{5 7 5 1 5 1} {5 7 7 1 2 2} {5 7 7 1 3 1} {6 3 7 5 1 2} {6 7 2 2 5 2}
	{6 7 2 6 1 2} {6 7 3 1 5 2} {7 3 3 5 5 1} {7 3 3 6 4 1} {7 3 4 6 1 3}
	{7 3 6 2 5 1} {7 3 7 2 2 3} {7 3 7 2 4 1} {7 3 7 3 1 3} {7 4 2 5 5 1}
	{7 4 6 1 5 1} {7 5 2 6 1 3} {7 7 2 2 5 1} {7 7 3 1 5 1} {5 5 7 1 6 2 2}
	{5 5 7 1 6 3 1} {5 7 2 4 6 1 3} {5 7 2 6 2 5 1} {5 7 2 7 2 2 3}
	{5 7 2 7 2 4 1} {5 7 2 7 3 1 3} {5 7 5 1 6 1 3} {5 7 7 1 2 5 1}
	{6 3 7 5 1 5 1} {6 3 7 7 1 2 2} {6 3 7 7 1 3 1} {6 7 2 2 5 5 1}
	{6 7 2 6 1 5 1} {6 7 3 1 5 5 1} {6 7 3 1 6 4 1} {7 3 3 6 6 1 2}
	{7 3 3 7 5 1 2} {7 3 6 2 6 1 3} {7 3 7 2 2 5 2} {7 3 7 2 6 1 2}
	{7 3 7 3 1 5 2} {7 4 2 7 2 4 2} {7 4 2 7 5 1 2} {7 4 6 1 6 1 3}
	{7 5 2 7 1 3 3} {7 7 2 2 6 1 3} {7 7 3 1 6 1 3} {5 5 7 1 7 2 2 3}
	{5 5 7 1 7 2 4 1} {5 5 7 1 7 3 1 3} {5 6 6 1 7 1 3 3} {5 7 2 6 2 6 1 3}
	{5 7 2 7 2 6 1 2} {5 7 5 1 7 1 3 3} {5 7 7 1 2 6 1 3} {6 3 7 7 1 2 5 1}
	{6 7 2 2 7 5 1 2} {6 7 2 6 1 6 1 3} {6 7 3 1 6 6 1 2} {6 7 3 1 7 5 1 2}
	{7 3 3 6 6 1 5 1} {7 3 3 7 5 1 5 1} {7 3 3 7 7 1 2 2} {7 3 3 7 7 1 3 1}
	{7 3 4 6 1 6 4 1} {7 3 7 2 2 5 5 1} {7 3 7 2 6 1 5 1} {7 3 7 3 1 5 5 1}
	{7 3 7 3 1 6 4 1} {7 4 2 7 2 4 5 1} {7 4 2 7 2 6 2 2} {7 4 2 7 2 6 3 1}
	{7 4 2 7 5 1 5 1} {7 4 2 7 7 1 2 2} {7 4 2 7 7 1 3 1} {7 4 6 1 7 1 3 3}
	{7 5 2 6 1 6 4 1} {7 7 2 2 7 1 3 3} {7 7 3 1 7 1 3 3}
	{5 5 7 1 7 2 6 1 2} {5 6 6 1 7 1 6 3 1} {5 7 2 7 2 6 1 5 1}
	{5 7 5 1 7 1 6 3 1} {5 7 7 1 2 7 1 3 3} {6 4 6 1 7 7 1 3 1}
	{6 7 2 2 7 5 1 5 1} {6 7 2 2 7 7 1 2 2} {6 7 2 2 7 7 1 3 1}
	{6 7 3 1 6 6 1 5 1} {6 7 3 1 7 5 1 5 1} {6 7 3 1 7 7 1 2 2}
	{6 7 3 1 7 7 1 3 1} {7 3 3 7 7 1 2 5 1} {7 3 6 2 6 1 6 4 1}
	{7 3 7 2 2 7 5 1 2} {7 3 7 2 6 1 6 1 3} {7 3 7 3 1 6 6 1 2}
	{7 3 7 3 1 7 5 1 2} {7 4 2 5 7 1 6 3 1} {7 4 2 7 2 6 2 5 1}
	{7 4 2 7 7 1 2 5 1} {7 4 6 1 7 1 6 3 1} {7 5 2 7 1 3 6 4 1}
	{7 5 2 7 1 7 2 2 3} {7 5 2 7 1 7 2 4 1} {7 5 2 7 1 7 3 1 3}
	{7 7 2 2 6 1 6 4 1} {7 7 3 1 6 1 6 4 1} {7 7 3 1 7 1 6 3 1}
	{5 6 6 1 7 1 7 3 1 3} {5 7 2 7 2 6 1 6 1 3} {5 7 5 1 7 1 7 2 2 3}
	{5 7 5 1 7 1 7 2 4 1} {5 7 5 1 7 1 7 3 1 3} {6 7 2 2 7 7 1 2 5 1}
	{6 7 3 1 7 7 1 2 5 1} {7 3 4 6 1 7 7 1 3 1} {7 3 7 2 2 7 5 1 5 1}
	{7 3 7 2 2 7 7 1 2 2} {7 3 7 2 2 7 7 1 3 1} {7 3 7 3 1 6 6 1 5 1}
	{7 3 7 3 1 7 5 1 5 1} {7 3 7 3 1 7 7 1 2 2} {7 3 7 3 1 7 7 1 3 1}
	{7 4 6 1 7 1 7 3 1 3} {7 7 2 2 7 1 3 6 4 1} {7 7 2 2 7 1 7 2 2 3}
	{7 7 2 2 7 1 7 2 4 1} {7 7 2 2 7 1 7 3 1 3} {7 7 3 1 7 1 3 6 4 1}
	{7 7 3 1 7 1 7 2 2 3} {7 7 3 1 7 1 7 2 4 1} {7 7 3 1 7 1 7 3 1 3}
	{5 7 7 1 2 7 1 7 2 2 3} {5 7 7 1 2 7 1 7 2 4 1} {5 7 7 1 2 7 1 7 3 1 3}
	{7 3 7 2 2 7 7 1 2 5 1} {7 3 7 3 1 7 7 1 2 5 1} {7 4 2 7 5 1 7 1 6 3 1}
	{7 4 6 1 6 1 7 2 6 3 1} {7 4 6 1 6 1 7 7 1 3 1} {7 5 2 6 1 7 2 7 2 4 1}
	{7 5 2 7 1 7 3 1 6 4 1} {7 7 3 1 6 1 7 2 6 3 1} {7 7 3 1 6 1 7 7 1 3 1}
	{6 7 2 6 1 6 1 7 7 1 3 1} {7 4 6 1 7 1 3 7 7 1 3 1}
	{7 7 2 2 6 1 7 2 7 2 4 1} {7 7 2 2 7 1 7 3 1 6 4 1}
	{7 7 3 1 6 1 7 2 7 2 4 1} {7 7 3 1 7 1 3 7 7 1 3 1}
	{7 7 3 1 7 1 7 3 1 6 4 1} {7 3 7 2 6 1 6 1 7 7 1 3 1}
	{7 4 6 1 7 1 7 3 1 7 7 1 3 1} {7 7 3 1 7 1 7 2 2 7 7 1 3 1}
	{7 7 3 1 7 1 7 3 1 7 7 1 3 1}}
    {5 5} 5
    {5 6} {{6 4} {6 6 3} {6 6 6 2} {6 6 6 6 1}}
    {5 7} {
	{7 4 4} {7 5 3} {6 7 3 4} {6 7 5 2} {7 4 6 3} {7 5 6 2} {7 7 3 3}
	{7 7 4 2} {6 6 7 2 4} {6 6 7 5 1} {6 7 5 6 1} {6 7 7 2 3} {6 7 7 4 1}
	{7 4 6 6 2} {7 4 7 5 2} {7 5 6 6 1} {7 5 7 2 4} {7 5 7 5 1} {7 7 3 6 2}
	{7 7 4 6 1} {7 7 7 2 2} {7 7 7 3 1} {6 6 6 7 1 4} {6 6 7 7 1 3}
	{6 7 5 7 1 4} {6 7 7 2 6 2} {6 7 7 7 1 2} {7 4 6 6 6 1} {7 4 6 7 5 1}
	{7 4 7 5 6 1} {7 4 7 7 2 3} {7 4 7 7 4 1} {7 5 6 7 1 4} {7 7 3 6 6 1}
	{7 7 3 7 2 4} {7 7 3 7 5 1} {7 7 4 7 1 4} {7 7 7 2 6 1} {6 7 7 2 6 6 1}
	{6 7 7 2 7 2 4} {6 7 7 2 7 5 1} {6 7 7 7 1 6 1} {7 4 7 7 2 6 2}
	{7 4 7 7 7 1 2} {7 5 7 2 7 5 2} {7 7 3 6 7 1 4} {7 7 4 7 1 6 3}
	{7 7 7 2 7 1 4} {6 7 7 2 6 7 1 4} {6 7 7 7 1 7 1 4} {7 4 7 7 2 6 6 1}
	{7 4 7 7 2 7 5 1} {7 4 7 7 7 1 6 1} {7 5 7 2 7 5 6 1} {7 5 7 2 7 7 4 1}
	{7 7 3 7 2 7 5 2} {7 7 7 2 7 1 6 3} {7 5 6 7 1 7 7 4 1}
	{7 5 7 2 7 7 7 1 2} {7 7 3 7 2 7 5 6 1} {7 7 3 7 2 7 7 4 1}
	{7 7 4 7 1 6 7 5 1} {7 7 4 7 1 7 7 2 3} {7 7 4 7 1 7 7 4 1}
	{7 5 7 2 7 7 7 1 6 1} {7 7 3 6 7 1 7 7 4 1} {7 7 3 7 2 7 7 7 1 2}
	{7 7 7 2 7 1 6 7 5 1} {7 7 7 2 7 1 7 7 2 3} {7 7 7 2 7 1 7 7 4 1}
	{7 7 3 7 2 7 7 7 1 6 1} {7 7 4 7 1 7 7 2 7 5 1}
	{7 7 7 2 7 1 7 7 2 7 5 1}}
    {6 6} 6
    {6 7} {{7 5} {7 7 4} {7 7 7 3} {7 7 7 7 2} {7 7 7 7 7 1}}
    {7 7} 7
}

#  Make sure all arguments in pattern are integer-only (or a=10, b=11,...)
#
array set numbers {
    a 10 b 11 c 12 d 13 e 14 f 15 g 16 h 17 i 18 j 19 k 20 l 21 m 22
    n 23 o 24 p 25 q 26 r 27 s 28 t 29 u 30 v 31 w 32 x 33 y 34 z 35
}
proc numbonly {args} {
    
    global numbers
    
    set rc {}
    
    foreach arg $args {
	foreach innerarg $arg {
	    if {![regexp {^0*([0-9]+)$} $innerarg x appendme]} {
		set innerarg [string tolower [string range $innerarg 0 0]]
		if {[catch {set numbers($innerarg)} appendme]} {
		    Error {You must provide numbers only as parameters!}
		    return {}
		}
	    }
	    lappend rc $appendme
	}
    }
    return $rc
}

#  Get the highest swap value in the list.
#
proc lgreatest {l} {
    set w 0;  foreach W $l { if {$W > $w} { set w $W } };  return $w
}

#  Get number of balls
#
proc numofballs {swapl} {
    
    global def
    
    set tot 0;  foreach i $swapl { incr tot $i }
    
    #  Check for legit siteswap characteristics.
    #
    if {$tot % [set slen [llength $swapl]]} {
	Error "Sum of throws $tot not div by num of throws $slen!"
	return 0
    }
    
    return [expr $tot / $slen]
}

#  Recursively remove downstream ladder entries.
#
proc RemoveDownstream {ix} {

    global ladder

    if {[catch {set ladder($ix)} ladderix]} { error $ladderix }

    #  This is a legit node.  Is there a link to another node?
    #
    if {[string length [set next [lindex $ladderix 1]]]} {
	#
	#  Yep.  Remove that node first.
	#
	unset ladder([RemoveDownstream $next])
    }	

    return $ix
}

#  Generate the ladder, en route to checking for collisions
#
proc GenerateLadder {l ballct ld} {
    
    upvar $ld ladder
    global def swhand ballpos
    
    #  Set up the balls.  Get an array of initial configuration,
    #    so we can tell when we've cycled thru the pattern.
    #
    for \
	{set b 0; set pos 0; set S $def(i);
	    catch {unset ladder}; catch {unset ballpos}} \
	{$b < $ballct} \
	{incr pos; set S $swhand(1$S)} \
	{
	    set ix   [list $pos $S]
	    set jump [lindex $l [expr $pos % [llength $l]]]
	    set nxt  [list [expr $pos + $jump] $swhand([expr $jump % 2]$S)]
	    
	    #  Does this node preexist?
	    #
	    if {[catch {set ladder($ix)} B]} {
		#
		#  No.  No problem!  Is this a non-zero throw?
		#
		if {$jump} {
		    #
		    #  Yes.  Create this ladder entry, and the "jump"ed entry,
		    #    add side/ball to the "mat", add "jump"ed index to the
		    #    "rmme" array for cleanup, create "ballpos" entry for
		    #    this ball, and prepare to process the next ball.
		    #
		    lappend mat $S[set ladder($nxt) [set ladder($ix) $b]]
		    set rmme($nxt) {}
		    set ballpos($b) [concat $ix $jump]
		    incr b
		} else {
		    #
		    #  No (it's a zero throw).  No ball involved.  Just slug a
		    #    "pseudo-ball" in there.
		    #
		    lappend mat $S$def(b)
		}
	    } else {
		#
		#  Yes, the node preexists.  Create the "jump"ed entry,
		#    add this side/ball to the "mat", and add "jump"ed
		#    array to the "rmme" array for cleanup.
		#
		lappend mat $S[set ladder($nxt) $B]
		set rmme($nxt) {}
	    }
	}

    #  Now that we've placed the balls, let's remove the "jump"ed balls.
    #
    foreach i [array names rmme] { unset ladder($i) }

    #  Set up to interminably cycle thru the swap list ('til done, anyway!)
    #
    set Cycles [expr $def(llen) + 1]
    for {set swapl $l; set n 0; set N {}; set S $def(i); set cycle 0; set t 0} \
	{![string length $N]} {set swapl $l} {
	    #
	    #  Cycle thru this itteration of the swap list
	    #
	    foreach s $swapl {
		#
		#  Get the ball where we are.
		#  Of course, if there is no ball, it's a "zero" site value...
		#
		if {[catch {lindex $ladder([set oldix [list $n $S]]) 0} b]} {
		    #
		    #  No ball.  Let's give it a BIG ball number
		    #
		    set b $def(b)
		}
		
		#  Where is this ball going next?
		#
		set nextn [expr $n + $s]
		set nextS $swhand([expr $s % 2]$S)
		
		#  Is there a ball already resident in our target location?
		#
		if {[info exists ladder([set newix [list $nextn $nextS]])]} {
		    Error "Collision: step [expr $nextn + 1] in $nextS hand!"
		    return 0
		}

		#  Append the next location to the list on this location,
		#  and put the ball in the next location.
		#
		set ladder($oldix) [list [set ladder($newix) $b] $newix]
		
		#  Have we cycled thru?  Create the comparison array....
		#
		lappend prog "$S$b"
		lappend prix $oldix
		if {[llength $prog] > $pos} {
		    set prog [lrange $prog 1 end]
		    set prix [lrange $prix 1 end]
		}
		
		#  ...now compare to the initial array.
		#
		if {[string match $mat $prog]} {
		    incr cycle
		    if {($cycle >= $Cycles) && $t} {
			set N [lindex $prix 0];  break
		    }
		}
		
		#  Next location, next hand
		#
		incr n
		set  S $swhand(1$S)
	    }

	    set t 1
	}

    #  Now we remove the "dog ends" ladder entries.
    #
    set found 0
    foreach i [lsort -command byrung [array names ladder]] {

	if {![set found [expr $found || [string match $i $N]]]} continue
	if {[catch {RemoveDownstream $i}]} continue

	#  Remove the link to the removed node.
	#
	catch {set ladder($i) [lindex $ladder($i) 0]}
    }

    return 1
}

#  Clearinghouse proc for checks/initializations.
#
proc sundriechecks {l bc sc hW ld} {
    
    upvar $bc ballcount; upvar $sc swapcount; upvar $hW highW; upvar $ld ladder
    
    if {![string length $l]} {
	Error {You must type something in before pressing <Return>!}
	return 0
    }
    if {![set ballcount [numofballs $l]]} { return 0 }
    set swapcount [llength $l]
    set highW     [lgreatest $l]
    
    return [GenerateLadder $l $ballcount ladder]
}

#  For sorting ladder indexes, by "rung" number.
#
proc byrung {a b} { return [expr [lindex $a 0] - [lindex $b 0]] }

#  Create the animation sequences, in real coords (vs. canvas "pixel" coords).
#
proc CreateRealCoords {l s h a rvar cvar} {
    
    global xcalc def swhand ballpos ballcount ball ladder trajcacheR
    upvar $rvar throwreal;  upvar $cvar throwcanv
    
    #  Checks and initializations on the <Enter>ed swap pattern.
    #
    if {![sundriechecks $l ballcount swapcount highW ladder]} { return 0 }
    
    #  Create new defaults for select parameters to this proc
    #
    foreach i {l s h a} { set def($i) [set $i] }
    
    array set exprYarr \
	[list {x} "[expr $a / 2.0] * \$time * ( \$T - \$time )" {2} {0.0}]
    
    #  Generate the "mainstay" coordinate lists; these are the fundamental
    #    trajectories used when a ball is actually thrown.
    #
    #  W = throw number ({0, 1, 2, 3, ...})
    #
    for {set W 1} {$W <= $highW} {incr W} {
	
	#  We may not even need to calculate for this trajectory...
	#
	if {[lsearch -exact $l $W] < 0} continue
	
	#  Also, we may have already calculated this one...
	#
	if {[info exists trajcacheR($W)]}  continue
	set trajcacheR($W) {}
	
	#   exprY = calculator for Y ordinate
	#   eo    = even or odd depending on the throw
	#
	if {$W == 2 && $def(2)} {
	    set exprY $exprYarr(2);  set eo 2
	} else {
	    set exprY $exprYarr(x);  set eo [expr $W % 2]
	}

	#   T  = Completion time for throw "W"
	#
	set T [expr $W * $def(q)]
	
	#  Create trajectories for each hand.
	#
	foreach S {L R} {
	    
	    set exprX $xcalc($eo$S)
	    
	    #  Step thru time, actually calculating the trajectories.
	    #
	    for {set time 0.0; set n 0} {$time < $T} \
		{set time [expr $time + $def(t)]; incr n} {
		    
		    #   U  = "Done" ratio.  V  = "Remaining to be done" ratio.
		    #
		    set V [expr 1.0 - [set U [expr $time / $T]]]
		    
		    set throwreal([list $W $S $n]) \
			[list [eval expr $exprX] [eval expr $exprY]]
		}		    
	}
    }
    
    #  Now generate the "setup" coordinate lists; these are the "waiting"
    #    setup trajectories used to get the pattern started.
    #
    set origY [expr ($a / 8.0) * $highW * $highW * $def(q) * $def(q)]

    catch {unset ball}

    for {set b 0} {$b < $ballcount} {incr b} {

	set hitime   [expr $def(q) * double( [lindex $ballpos($b) 0])]
	set ball($b) [list \
			  [set W [lindex $ballpos($b) 2]] \
			  [set S [lindex $ballpos($b) 1]] \
			  [set n [expr $def(b) * $b]]]
	
	set origX $xcalc(2$S)

	for {set time 0.0} {$time < $hitime} \
	    {set time [expr $time + $def(t)]; incr n} {
		
		set throwreal([set ix [list $W $S $n]]) \
		    [list [eval expr $origX] [eval expr $origY - double( $b)]]
	    }

	#  Let's leave a "hole" in the real and canv animation arrays,
	#    in case we have some left over from cache.
	#
	if {$n} { catch {unset throwreal($ix) throwcanv($ix)} }
    }

    return 1
}

#  Convert a Real coordinate to a Canvas (pixel) coordinate.
#
proc Cart2Canv {R xL xR yU yD rd cx cy} {
    return \
	[list \
	     [expr int(($cx * ([lindex $R 0] - $xL) / ($xR - $xL)) + $rd)] \
	     [expr int(($cy * ([lindex $R 1] - $yU) / ($yD - $yU)) + $rd)]]
}

#  Convert all Real coordinates to their Canvas (pixel) coordinates
#    (for this swap pattern, that is!).
#
proc CreateCanvCoords {cx cy varreal varcanv} {
    
    global def
    upvar $varreal real;  upvar $varcanv canv
    
    set m 0.1;  set w [lgreatest $def(l)]
    
    set xw [expr  $def(s) + $def(h)];  set xm [expr  $xw * $m]
    set xL [expr -1.0 * $xm];  set xR [expr  $xw + $xm]
    
    set yh [expr  ($def(a) / 8.0) * $w * $w * $def(q) * $def(q)]
    set ym [expr  $yh * $m]
    set yD [expr -1.0 * $ym];  set yU [expr  $yh + $ym]
    
    #  This is a combined ball radius offset with a "round up" value.
    #
    set rd [expr 0.5 - ($def(d) / 2.0)]

    foreach W $def(l) {

	if {[info exists done($W)]} continue;  set done($W) {}

	foreach i [array names real "$W *"] {
	    set canv($i) [Cart2Canv $real($i) $xL $xR $yU $yD $rd $cx $cy]
	}
    }
}

#  Repaint the ladder diagram.
#
proc ShowLadder {} {
    
    global ladder def lasp canvbgfg
    
    .ladd.lad2.c delete all
    
    set hiLix \
	[lindex \
	     [lindex \
		  [set Lix [lsort -command byrung [array names ladder]]] \
		  end] \
	     0]

    .ladd.lad2.c config -scrollregion \
	[list \
	     0.0c 0.0c \
	     [expr $def(lasp) * $def(lasp2) * 6.5]c \
	     [expr $def(lasp) * $def(lasp2) * ($hiLix + 2.5)]c] \
	-width [expr $def(lasp) * $def(lasp2) * 6.5]c
    
    set o [expr $def(lasp) * $def(lasp2) * 1.5]; #  y offset
    set r [expr $def(lasp) * $def(lasp2) * 0.4]; #  radius of ladder diag. balls

    for {set n 0} {$n <= $hiLix} {incr n} {
	.ladd.lad2.c create text \
	    [expr $def(lasp) * $def(lasp2) * 0.75]c \
	    [expr ($def(lasp) * $def(lasp2) * double( $n)) + $o]c \
	    -text [expr $n + 1] -font $lasp($def(lasp)) -tag {laddertext} \
	    -fill $canvbgfg(fg:$def(n))
    }

    array set LR \
	[list \
	     {L}    [expr $def(lasp) * $def(lasp2) * 3.0] \
	     {R}    [expr $def(lasp) * $def(lasp2) * 5.0] \
	     \
	     {LL:L} [expr $def(lasp) * $def(lasp2) * 2.0]c \
	     {LL:R} [expr $def(lasp) * $def(lasp2) * 4.0]c \
	     {LL:s} {90.0} \
	     {RR:L} [expr $def(lasp) * $def(lasp2) * 4.0]c \
	     {RR:R} [expr $def(lasp) * $def(lasp2) * 6.0]c \
	     {RR:s} {270.0} \
	    ]

    foreach S {L R} {
	.ladd.lad2.c create text \
	    $LR($S)c [expr $def(lasp) * $def(lasp2) * 0.5]c \
	    -text $S -font $lasp($def(lasp)) \
	    -tag {laddertext} -fill $canvbgfg(fg:$def(n))
    }
    
    #  First, paint the "balls" in the ladder diagram:
    #
    foreach lix $Lix {
	
	set n [lindex $lix 0];  set S [lindex $lix 1]

	#  If this is a "space-holding" ball, no actual ball; skip the rest.
	#
	if {[string match $def(b) [lindex [set next $ladder($lix)] 0]]} continue

	set col [lindex $def(c) [expr [lindex $next 0] % $def(clen)]]
	
	.ladd.lad2.c create oval \
	    [expr $LR($S) - $r]c \
	    [expr ($def(lasp) * $def(lasp2) * double( $n)) + $o - $r]c \
	    [expr $LR($S) + $r]c \
	    [expr ($def(lasp) * $def(lasp2) * double( $n)) + $o + $r]c \
	    -fill $col
	
	set nex [lindex $next 1]
	
	#  We also have to have a destination point for the ligature
	#
	if {[string length [set Nn [lindex $nex 0]]]} {
	    
	    set NS [lindex $nex 1]
	    
	    #  An exception for the case where the throw is "2" (no arc)
	    #
	    if {($Nn - $n) == 2 && $def(2)} { set X {LR} } else { set X $S$NS }
	    
	    switch -exact $X {
		{LL} - {RR} {
		    .ladd.lad2.c create arc \
			$LR($X:L) \
			[expr ($def(lasp) * $def(lasp2) * double( $n)) + $o]c \
			$LR($X:R) \
			[expr ($def(lasp) * $def(lasp2) * $Nn)         + $o]c \
			-start $LR($X:s) -extent 180.0 \
			-fill {} -outline $col -style arc
		}
		{LR} - {RL} {
		    .ladd.lad2.c create line \
			$LR($S)c  \
			[expr ($def(lasp) * $def(lasp2) * double( $n)) + $o]c \
			$LR($NS)c \
			[expr ($def(lasp) * $def(lasp2) * $Nn)         + $o]c \
			-fill $col
		}
	    }
	}
    }
}

proc Pause {} {
    
    global def toggle
    
    set def(pause) $toggle($def(pause))

    if {$def(pause)} {
	.buts.paus configure -text {Continue}
	.buts.step configure -state normal
	catch {after cancel $def(after)}
    } else {
	.buts.paus configure -text {Pause}
	.buts.step configure -state disabled
	paintnext
    }
}

proc ClearAnimation {} {
    global def balls;  set def(peel) {};  .c delete all;  catch {unset balls}
}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
#
#  Here we actually build the interface
#
proc ShowPatterns {b h} {

    global def Swaps SWAPLIST Swapslist

    set Name "balls=$b,maxheight=$h"

    if {[catch {toplevel .$Name} err]} { raise .$Name;  return }

    pack [button .$Name.ex -text {Dismiss} -command "destroy .$Name"] \
	-side bottom -fill x
    pack [scrollbar .$Name.sb -orient vertical -command ".$Name.lb yview"] \
	-fill y -side right
    pack [listbox .$Name.lb -yscrollcommand ".$Name.sb set"] \
	-expand 1 -fill both

    set n 0
    foreach i $Swaps([list $b $h]) {
	if {$def(f)} { if {[lsearch -exact $i {2}] > -1} continue }
	.$Name.lb insert end [set Swapslist($Name:$n) $i]
	incr n
    }

    bind .$Name.lb <Double-Button-1> \
	"set SWAPLIST \$Swapslist($Name:\[.$Name.lb curselection]); EntryReturn"
}

proc GiveWelcome {} {

    global def

    set Name {welome}

    if {[catch {toplevel .$Name} err]} { raise .$Name;  return }

    set Mytext \
	[join [list \
		   "-*-\nWelcome to $def(nam) v$def(v)!!!\n-*-\n\n" \
		   "it's under development by Ron A. Zajac\n\n" \
		   "$def(Nam) is written in \"wish\", a windowing shell " \
		   "built upon John Ousterhout's tcl/Tk language.\n\n" \
		   "$def(Nam) uses a vanilla wish, and should run on " \
		   "many platforms.\n\n" \
		   "Newer versions (as available) are available from the\n" \
		   ">>> Juggling Information Service <<<\nat URL:\n\n" \
		   "http://www.juggling.org/programs/src/\n\n" \
		   {Please feel free to contact me with any } \
		   "suggestments or encouragements:\n\n" \
		   {zajac@nortel.com} \
		  ] {}]

    pack [button .$Name.ex -text {Dismiss} -command "destroy .$Name"] \
	-side bottom -fill x
    pack [message .$Name.ms -aspect 162 -text $Mytext -justify center] \
	-expand 1 -fill both
}

proc PSprint {} {

    global psDAT ladder

    set hiLix \
	[lindex [lindex [lsort -command byrung [array names ladder]] end] 0]

    .ladd.lad2.c postscript \
	-file $psDAT(outfile) \
	-pageheight 11.0i \
	-width 6.5c -height [expr $hiLix + 2.5]
    
    catch {exec chmod 644 $psDAT(outfile)}

    destroy $psDAT(lad)
}

proc PostscriptLadder {} {

    global psDAT

    array set psDAT {
	outfile  {ladder.eps}
	lad      {.psladder}
    }

    if {[catch {toplevel $psDAT(lad)} err]} { raise $psDAT(lad);  return }

    pack [frame $psDAT(lad).file] -fill x
    pack [label $psDAT(lad).file.lab -text File:] -side left
    pack [entry $psDAT(lad).file.ent -textvariable psDAT(outfile)] -fill x
    bind $psDAT(lad).file.ent <Return> PSprint
    bind $psDAT(lad).file.ent <Escape> "destroy $psDAT(lad)"
    pack [frame $psDAT(lad).buts] -fill x
    button $psDAT(lad).buts.acce -text Accept  -command PSprint
    button $psDAT(lad).buts.dism -text Cancel -command "destroy $psDAT(lad)"
    pack $psDAT(lad).buts.acce $psDAT(lad).buts.dism \
	-expand 1 -side left -fill x
}

pack [frame .menfr] -fill x

set m .menfr.file.file
pack [menubutton .menfr.file -text {File} -menu $m] -side left
menu $m -tearoff 0
$m add command -label {New} -command "exec $argv0 &"
$m add separator
$m add command -label {Exit} -command {destroy .}

set m .menfr.patt.patt
pack [menubutton .menfr.patt -text {Patterns} -menu $m] -side left
menu $m -tearoff 0
$m add check -label {Filtering "2" throws} -variable def(f)
$m add separator
$m add command -label {Number of Balls:}
foreach i [lsort [array names Swaps]] {

    set Swb [lindex $i 0];  set Swh [lindex $i 1]
    if {![info exists Sw(b:$Swb)]} {
	$m add cascade -label "$Swb balls" -menu $m.m_$Swb
	menu $m.m_$Swb -tearoff 0
	$m.m_$Swb add command -label {Maximum Throw Height}
	set Sw(b:$Swb) {}
    }
    $m.m_$Swb add command -label "$Swb balls, $Swh high" \
	-command "ShowPatterns $Swb $Swh"
}

set m .menfr.ladd.ladd
pack [menubutton .menfr.ladd -text {Ladder} -menu $m] -side left
menu $m -tearoff 0
$m add check -label {Visible}        -variable def(lad)
$m add check -label {White-on-black} -variable def(n)
$m add separator
$m add command -label {Generate EPS} -command {PostscriptLadder}
$m add separator
$m add cascade -label {Sizes} -menu $m.size
menu [set m2 $m.size] -tearoff 0
foreach i [lsort [array names lasp]] {
    $m2 add radio -label $i -variable def(lasp) -value $i
}
$m add separator
$m add cascade -label {Pattern Repeat} -menu $m.repeat
menu [set m2 $m.repeat] -tearoff 0
for {set i 1} {$i <= $def(lmax)} {incr i} {
    $m2 add radio -label $i -variable def(llen) -value $i
}

set m .menfr.opti.opti
pack [menubutton .menfr.opti -text {Options} -menu $m] -side left
menu $m -tearoff 0
$m add check -label {Stationary "2" throws} -variable def(2)
unset Sw

set m .menfr.info.info
pack [menubutton .menfr.info -text "$def(Nam) v$def(v)" -menu $m] -side right
menu $m -tearoff 0
$m add command -label {Welcome!} -command {GiveWelcome}

pack [frame .ladd] -fill y -side right
pack [frame .ladd.lad2] -expand 1 -fill both
pack [scrollbar .ladd.lad2.s -orient vertical -command {.ladd.lad2.c yview}] \
    -fill y -side right
pack [canvas .ladd.lad2.c -width [expr $def(lasp) * $def(lasp2) * 6.5]c \
	  -bg $canvbgfg(bg:$def(n)) -yscrollcommand {.ladd.lad2.s set}] \
    -expand 1 -fill y -side right

pack [frame .buts] -fill x -side bottom
pack [button .buts.paus -text Pause  -command {Pause}]    -fill x -side left
pack [button .buts.step -text Step   -command {paintnext} -state disabled] \
    -fill x -side left
pack [button .buts.rest -text Restart -command ClearAnimation] -fill x

pack [frame .ent] -fill x -side bottom
pack [label .ent.l -text {Swap Pattern:}] -side left
pack [entry .ent.e -textvariable SWAPLIST] -fill x

bind .ent.e <Return> EntryReturn

proc EntryReturn {} {

    global def SWAPLIST throwreal throwcanv
    
    catch {after cancel $def(after)}
    
    ClearAnimation
    
    array set def \
	[list \
	     {l}    [numbonly [string trim $SWAPLIST]] \
	     {mess} {Calculating REAL...} \
	    ]
    update
    
    if {![CreateRealCoords \
	      $def(l) $def(s) $def(h) $def(a) throwreal throwcanv]} return
    
    set def(mess) {Calculating CANVAS...}
    update
    CreateCanvCoords $def(cx) $def(cy) throwreal throwcanv
    ShowLadder
    set def(mess) {Animating}
    paintnext
}

pack [frame   .mes] -fill x -side bottom
pack [label   .mes.l -text {Message:}] -side left
pack [message .mes.m -fg red -aspect 1000 -textvariable def(mess)] -fill x

pack [scale .s \
	  -tickinterval 100 -font 6x10 -orient h -from 10 -to 1000 \
	  -variable def(w)] \
    -fill x -side bottom

pack [canvas .c -width $def(cx) -height $def(cy) -bg $def(k)] \
    -expand 1 -fill both

bind RepeatButton <2> {

    global def tkPriv

    tkButtonDown %W
    set tkPriv(brepeat) 1
    after $def(w) tkButtonRepeat %W
}
bind RepeatButton <ButtonRelease-2> {

    global tkPriv

    tkButtonUp %W
    set tkPriv(brepeat) 0
}
# derived from tkButtonUp
proc tkButtonRepeat w {

    global def tkPriv

    if {!$tkPriv(brepeat)} return

    if {$w == $tkPriv(buttonWindow)} {
	if {($w == $tkPriv(window)) && ([$w cget -state] != "disabled")} {
	    uplevel #0 [list $w invoke]
	}
    }
    after $def(w) tkButtonRepeat $w
}

regsub Button [bindtags .buts.step] "RepeatButton Button" b
bindtags .buts.step $b
#
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

#  This routine "peels off" throws from the swaplist.  Zero throws are ignored.
#
proc peeloff {} {
    
    global def
    
    for {set peel 0} {!$peel} {} {
	if {[llength $def(peel)]} {
	    set peel      [lindex $def(peel) 0]
	    set def(peel) [lrange $def(peel) 1 end]
	} else {
	    set def(peel) $def(l)
	}
    }
    return $peel
}

#  Here is where the animation is done.
#
proc paintnext {} {
    
    global ballcount ball balls throwcanv swhand def
    
    if {![info exists ballcount]} return
    
    set launches 0; #   Perhaps later I'll do something with this
    
    #  Loop over each ball
    #
    for {set n 0} {$n < $ballcount} {incr n} {
	
	#  Has this ball been encountered yet?
	#
	if {[catch {set balls($n)} aball]} {
	    #
	    #  The ball is unknown; create it!
	    #
	    set xy $throwcanv([set ix $ball($n)])
	    set x  [lindex $xy 0];  set y  [lindex $xy 1]
	    
	    #  Only the first ball is actually launched at this time
	    #    (the rest are "in the wings").
	    #
	    if {!$n} { incr launches;  peeloff }
	    
	    set bcol [lindex $def(c) [expr $n % $def(clen)]]
	    set balls($n) \
		[list [.c create oval \
			   $x $y [expr $x + $def(d)] [expr $y + $def(d)] \
			   -fill $bcol -outline $bcol] $ix]
	} else {
	    #
	    #  The ball is a known one, KEEP it rolling!
	    #
	    set path  [lindex $aball 0];  set ix [lindex $aball 1]
	    set throw [lindex $ix 0];   set side [lindex $ix 1]
	    set frame [expr [lindex $ix 2] + 1]
	    
	    #  Pick up the next ball location.  If it runs off the end of the
	    #    array, figure out which array to start it on, and try again.
	    #
	    while {[catch {set throwcanv([list $throw $side $frame])} xy]} {
		#
		#  Off the end of the array!  Time to (re)launch!
		#
		incr launches
		if {$frame < $def(b)} {
		    set side $swhand([expr $throw % 2]$side)
		}
		#  Get our next throw.
		#
		set throw [peeloff];  set frame 0
	    }
	    
	    #  Set this ball to it's new state
	    #
	    set balls($n) [list $path [list $throw $side $frame]]
	    set x [lindex $xy 0];  set y [lindex $xy 1]
	    
	    #  Move it to it's new position
	    #
	    .c coords $path $x $y [expr $x + $def(d)] [expr $y + $def(d)]
	}
    }
    
    # if {$launches > 1} WeHaveCollided
    
    if {!$def(pause)} { set def(after) [after $def(w) paintnext] }
}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
			   ######  #    #  #####
			   #       ##   #  #    #
			   #####   # ## #  #    #
			   #       #   ##  #    #
			   ######  #    #  #####
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
