#/bin/sh
# the next line restarts using tclsh \
exec wish "$0" "$@"

# TkSol

# Version 1.0   (02/18/94) Copyright (c) 1993 by Bao Trinh.
# Version 1.8.2 (22/09/04) Copyright (c) 2004 by Steven Atkinson.

########
# Init #
########

proc Init {} {

    global argv Var

    option add *highlightThickness 0

    set Var(version)	1.8.2
    set Var(debug)	0
    set Var(flip)	3		;# number of cards to flip over
    set Var(canvas_color) grey		;# / lavender
    set Var(cardback_fg) rosybrown3	;# foreground (main) color / purple
    set Var(cardback_bg) grey80		;# background color 
    set Var(showpicture) yes
    
    if {![RunningWindows]} {
	set Var(cardback)	default	;# bitmap of face down card
	set Var(bg_picture)	default ;# background picture
    } else {				;# windows can't handle links
	set Var(cardback)	x.xbm
	set Var(bg_picture)	kittyt.xbm
    }

    set dir /usr/local/lib/tksol
    if {[file isdirectory $dir] == 0} {
        if {[file isdirectory [pwd]/cardbacks] == 0} {
            Stderr "Can't find working directory in '$dir' or '[pwd]'"
            exit 1
        } else { set dir [pwd] }
    } 
    set Var(base_dir)		$dir
    set Var(cards_dir)		$Var(base_dir)/cards
    set Var(cardbacks_dir)	$Var(base_dir)/cardbacks
    set Var(picture_directory)	$Var(base_dir)/pictures
    set Var(maskfile)		$Var(base_dir)/mask.xbm
    set Var(placefile)		$Var(base_dir)/place.xbm

    ### extra speed_multiplier as tksol was first written 10 years ago!
    ### increase this value if your cpu is too fast. I have a k6-2 400
    set Var(speed_multiplier)	5
    set Var(speed)		50

    set Var(card.padwidth)	80	;# the padded width of the card
    set Var(card.padheight)	100	;# the padded height of the card
    set Var(card.width)		72	;# the actual width of the card
    set Var(card.height)	99	;# the actual height of the card

    set Var(stack_spacing)	8	;# spacing between card stacks
    set Var(stack.up_spacing)	15	;# spacing between faced up cards
    set Var(stack.down_spacing)	8	;# spacing between faced down cards
    set Var(stack.side_spacing)	15	;# horizontal spacing between cards
    set Var(side_margin)	15	;# left and right margins
    set Var(top_level)		15	;# position of top level stacks
    set Var(bottom_level)	150	;# position of bottom level stacks

    set Var(button.font)		6x13
    set Var(button.width)		15
    set Var(button.foreground)		White
    set Var(button.background)		DeepSkyBlue1
    set Var(button.activeForeground)	White		;# RosyBrown1
    set Var(button.activeBackground)	SteelBlue	;# DeepSkyBlue1

    set Var(card.blackForeground)	black
    set Var(card.blackBackground)	azure
    set Var(card.redForeground)		red2
    set Var(card.redBackground)		azure

    if [file readable ~/.tksolrc] {
        if { [catch {source ~/.tksolrc}] != 0 } {
		Stderr {tksol: error reading "~/.tksolrc".}
	}
    }

    ################
    # Command Line #
    ################

    # (courtesy of ical)
    while {[llength $argv] != 0} {

	set arg [lindex $argv 0]
	set argv [lrange $argv 1 end]
	set start 0

 	case $arg in {
	    "-flip" {
		set Var(flip) [lindex $argv 0]
		if {$Var(flip) > 8} {set Var(flip) 8}
		set start 1
	    }
	    "-speed" {
		set Var(speed) [lindex $argv 0]
		if {$Var(speed) > 100} {set Var(speed) 100} \
		    elseif {$Var(speed) < 1} {set Var(speed) 1}
		set start 1
	    }
	    "-spacing" {
		set Var(stack_spacing)  [lindex $argv 0]
		if {$Var(stack_spacing) > 20} {set Var(stack_spacing) 20} \
		   elseif {$Var(stack_spacing)<1} {set Var(stack_spacing) 1}
		set start 1
	    }
	    "-back" {
		set Var(canvas_color) [lindex $argv 0]
		set start 1
   	    }
	    "-black" {
		set Var(card.blackForeground) [lindex $argv 0]
		set start 1
	    }
	    "-red" {
		set Var(card.redForeground) [lindex $argv 0]
		set start 1
	    }
	    "-debug" {
		set Var(debug) 1
	    }
	    default {
		Stderr "Usage: tksol \[options\]
	-flip	<number>	; number of cards to flip
	-speed	<number>	; speed of card movement
	-spacing <number>	; pixels between the playing stacks
	-back	<colour>	; canvas background color
	-red	<colour>	; red suit colour
	-black	<colour>	; black suit colour
	-debug			; turn on debugging mode"
	exit -1
	    }
	}
	set argv [lrange $argv $start end]
    }
}

#################
# Create Canvas #
#################

proc CreateCanvas {} {

    global Var Card Image argv0 argv

    set canvas_width [expr (7 * $Var(card.padwidth)) + \
		           (2 * $Var(side_margin)) + \
			   (6 * $Var(stack_spacing))]
    # the height is, to a certain extent, really arbitrary
    set canvas_height [expr $Var(card.padheight) * 4.5]
    set Var(canvas_width) $canvas_width
    set Var(canvas_height) $canvas_height

    # create the canvas
    canvas .canvas -width $canvas_width -height $canvas_height \
      -back $Var(canvas_color) -relief raise

    if {[info exists Var(bg_picture)]} DrawBackgroundPicture

    # create the dividing line
    set midpt [expr ($Var(top_level) + $Var(bottom_level) + \
		     $Var(card.padheight)) / 2]
    .canvas create line 0 $midpt $canvas_width $midpt -fill black -state disabled

    ### images of type bitmap allow for transparency (at the corners) ;->
    ### images : cardback, placeholder, each card back and front
    set Image(cardback) \
        [image create bitmap -file $Var(cardbacks_dir)/$Var(cardback)\
	-maskfile $Var(maskfile) -background $Var(cardback_bg) \
	-foreground $Var(cardback_fg)]

    set Image(placeholder) \
	[image create bitmap -file $Var(placefile) \
        -maskfile $Var(maskfile) -background gray60 \
        -foreground $Var(canvas_color)]

    # create the top level placeholders
    .canvas create image $Var(side_margin) $Var(top_level) \
	-image $Image(placeholder) -tags {flip_Tag} -anchor nw

    set x [expr $Var(side_margin) + $Var(card.padwidth) + $Var(stack_spacing)]
    set Var(DrawRightX) $x ;### Var(DrawRightY) is Var(top_level)

    set skip [expr $Var(card.padwidth) + $Var(stack_spacing)]
    set x [expr $Var(side_margin) + (3 * $Var(stack_spacing)) + \
           (3 * $Var(card.padwidth))]
    foreach s {0 1 2 3} {
	.canvas create image $x $Var(top_level) \
	    -image $Image(placeholder) -tags [list endspot${s}_Tag] \
	    -anchor nw
	incr x $skip
    }

    # create the bottom level placeholders, which are invisible
    ### doesn't behave well if an image

    set x $Var(side_margin)

    foreach s {0 1 2 3 4 5 6} {
            eval .canvas create rectangle $x $Var(bottom_level) \
                [expr $x + $Var(card.width)] \
                [expr $Var(bottom_level) + $Var(card.height)] \
                -outline {{}} -tags playspot${s}_Tag
            incr x $skip
        }

    wm sizefrom . user
    wm iconname . "TkSol"
    wm title . "TkSolitaire $Var(version)"
    wm command . [concat $argv0 $argv]
    wm group . .
    wm resizable . 0 0

    ### buttons can be squeezed, but only here, not when they are packed !!!
    set Var(button_options) { -fore $Var(button.foreground) \
        -pady .7 -padx 4 -back $Var(button.background) \
        -activeforeground $Var(button.activeForeground) \
        -activebackground $Var(button.activeBackground) \
        -width $Var(button.width) -relief groove \
    }
    ### the normal button font (6x13) is too big on windows
    if {![RunningWindows]} {
        append Var(button_options) { -font $Var(button.font)}
    }

    frame .button -back  $Var(canvas_color) -relief raise -bd 2

    eval button .button.deal	$Var(button_options) \
	-text "deal"	-command "NewGame"
    eval button .button.undo	$Var(button_options) \
	-text "undo"	-command "Undo"
    eval button .button.options	$Var(button_options) \
	-text "options"	-command "ChangeOptions"
    eval button .button.quit	$Var(button_options) \
	-text "quit"	{-command { destroy . }}
    eval button .button.finish	$Var(button_options) \
	-text "finish"	-command "AutoFinish"

    # now create the score label
    label .button.score -width 6 -font $Var(button.font) -text "0" \
	-textvariable Var(score) -anchor e -relief flat -bg $Var(canvas_color)

    ### create the card bitmaps, temporarily hidden 
    set index 0
    for {set card_no 1} {$card_no < 14} {incr card_no} {
	foreach suit {h s d c} col {red black red black} {
	    set i [image create bitmap -file $Var(cards_dir)/${suit}${card_no} \
		-maskfile $Var(maskfile) \
		-foreground $Var(card.${col}Foreground) \
		-background $Var(card.${col}Background)]
	    set item [.canvas create image 0 0 -image $i \
		 -state hidden -anchor nw ]
	    set Card($item) ${suit}${card_no}
	    set Image($item) $i
	    incr index
	}
    }

    # Finally, Abracadabra ...
    pack .button.deal .button.options .button.quit -side left -anchor w
    ### before: quit-undo-options-deal
    ### now   : deal-undo-options-quit , which is ~maybe~ more standard

    pack .button.score -side right -padx 5
    # .button.undo is packed by NewGame (ie. since EndGame unpack it)
    # .button.finish is packed when autofinish is enabled
    pack .button -side top -fill x
    pack .canvas
}

###########
# Newgame #
###########

proc NewGame {} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global EndStk0 EndStk1 EndStk2 EndStk3
    global Var Flag UndoStk WorkStk Card

    set Var(score) 0
    set Flag(setupworkstack) 0
    set Flag(dragworkstack) 0
    set Flag(slidingstack) 0
    set Flag(autofinish) 0
    set WorkStk(size) 0
    set WorkStk(info) {}
    set UndoStk(top) 0

    # set all the end stacks to empty, we only need to keep a single card here
    foreach i {0 1 2 3} {
	set EndStk${i}(suit) empty
	set EndStk${i}(number) 0
    }
    # setup the play stacks
    foreach i {0 1 2 3 4 5 6} { set PlayStk${i}(size) 0 }

    .canvas dtag workstk_Tag workstk_Tag
    .canvas dtag drawright_Tag drawright_Tag
    .canvas dtag drawleft_Tag drawleft_Tag
    .canvas dtag up_Tag up_Tag
    .canvas dtag down_Tag down_Tag
    foreach i {0 1 2 3} {
	.canvas dtag endstk${i}_Tag endstk${i}_Tag
    }
    foreach i {0 1 2 3 4 5 6} {
	.canvas dtag playstk${i}_Tag playstk${i}_Tag
    }

    CheckBackgroundPicture
    pack forget .button.finish

    ### I'm not too sure on this packing, but works for me
    ### previously: pack .button.undo -side left -anchor w
    # repack withdrawn buttons
    pack .button.undo -after .button.deal -side left
    pack .button.options -after .button.undo -side left


    ##############
    # Deal Cards #
    ##############

    # find out the index of the lowest entry in the Card array
    set offset [lindex [lsort -integer [array names Card]] 0]
    set index 0
    foreach item_no [ShuffleDeck] {
	# add in offset since Card doesn't start at 0!
	set UnsortDeck($index) [expr $item_no + $offset]
	incr index
    }

    # layout the cards on the table
    set card_no 0
    set x $Var(side_margin)
    set x_incr [expr $Var(card.padwidth) + $Var(stack_spacing)]

    foreach s {0 1 2 3 4 5 6} {
	set y $Var(bottom_level)
	set index 0

	# first the face down cards
	for {set down 0} {$down < $s} {incr down} {
	    set item $UnsortDeck($card_no)
	    DisplayCard $item FaceDown $x $y \
		[list playstk${s}_Tag down_Tag]
	    set PlayStk${s}($index) $item
	    incr y $Var(stack.down_spacing)
	    incr card_no
	    incr index
	}
	# then the single face up card
	set item $UnsortDeck($card_no)
	DisplayCard $item FaceUp $x $y [list playstk${s}_Tag up_Tag]

	set PlayStk${s}($index) $item
	set PlayStk${s}(size) [expr $index + 1];	# index starts at 0

	incr x $x_incr
	incr card_no
    }

    # now put the remaining cards face down on the draw_left stack
    for {} {$card_no < 52} {incr card_no} {
	DisplayCard $UnsortDeck($card_no) FaceDown $Var(side_margin) \
	    $Var(top_level) {drawleft_Tag down_Tag}
    }
}

###########
# Shuffle #
###########

proc ShuffleDeck {} {

    # first create the sorted deck
    for {set card 0} {$card < 52} {incr card} {
	set card_struct $card
	### now uses tcl's built-in random.
	lappend card_struct [expr int(rand() * 1000)]
	lappend sorted_deck $card_struct
    }

    # now shuffle the deck by sorting it based on the random number field
    set shuffled_deck [lsort -command SortCard $sorted_deck]
    foreach i $shuffled_deck {
	lappend rtn_val [lindex $i 0]
    }

    return $rtn_val
}

#####################
# sort two card structures based on the random number associated with each

proc SortCard {a b} {
    set num_a [lindex $a 1]
    set num_b [lindex $b 1]
    if {$num_a > $num_b} { return 1 }
    if {$num_a < $num_b} { return -1 }
    return 0
}

###############
# DisplayCard #
###############

proc DisplayCard {item state x y tag_list} {

    global Var Card Image

    if {$state == "FaceDown"} {set i cardback} else {set i $item}

    # raise the current card above the rest because of the shuffling
    .canvas raise $item all
    # now move it to the proper position and display it
    .canvas coord $item $x $y
    .canvas itemconfig $item -image $Image($i) -tags $tag_list -state normal
}

#######################################################
# Flip the card up and move it to the drawright stack #
#######################################################

proc MoveRight {{offset 0} {card_no 1} {pushundoflag yes}} {

    global Var Card WorkStk LastFlipOffset

    # find the topmost card on the DrawLeft stack
    set drawleft_list [.canvas find withtag drawleft_Tag]
    set item [lindex $drawleft_list [expr [llength $drawleft_list] - 1]]
    set card $Card($item)
    scan $card "%c%d" suit number
    set suit [format "%c" $suit]

    # the tags get reset in DisplayCard so there's no need to delete them here
    DisplayCard $item FaceUp [expr $Var(DrawRightX) + $offset] \
	$Var(top_level) {up_Tag drawright_Tag}

    if { $pushundoflag == "yes" } {
	PushUndoStack $item drawleft_Tag drawright_Tag $card_no
    }

    # prevent double clicking on a face down card from blowing up [bug]
    set WorkStk(size) 0
    set LastFlipOffset $offset
}

###################################################################
# Flip up more than one card and move them to the drawright stack #
###################################################################

proc MoveRightMany {} {

    global Var

    # first, reset the drawright stack
    set card_list [.canvas find withtag drawright_Tag]
    set coords [.canvas coord drawright_Tag]
    foreach card $card_list {
	.canvas coord $card [lindex $coords 0] [lindex $coords 1]
    }
    set how_many $Var(flip)
    # invoke MoveRight up to "how_many" times, passing in a different 
    # offset each time
    set cards [llength [.canvas find withtag drawleft_Tag]]
    # there will be at least one because we are clicking on it ...
    set offset 0
    for {set card_no 1} {$card_no <= $how_many && $cards > 0} {incr card_no} {
	MoveRight $offset $card_no
	incr offset $Var(stack.side_spacing)
	incr cards -1
    }
}

################################################################
# Flip the cards down and move them back to the drawleft stack #
################################################################

proc MoveLeft {} {

    global Var

    ### currently disabled
    # penalty for flipping the stack is:
    # switch $Var(flip) 3 {set x -10} 2 {set x -20} 1 {set x -30} default {set x 0}
    # incr Var(score) $x

    # can we trust "find" to return a list in order? [bug]
    foreach item [.canvas find withtag drawright_Tag] {
	# note that drawleft_Tag has to come *BEFORE* down_Tag in the
	# taglist; see key binding for reasoning behind this restriction
	DisplayCard $item FaceDown $Var(side_margin) $Var(top_level) \
	    {drawleft_Tag down_Tag}
	# note that the above find return the bottom most card first;
	# DisplayCard does a raise which will raise the last card in
	# the foreach item list above all others; we want it to be the
	# other way around so let's invoke a "lower" here
	.canvas lower $item drawleft_Tag
    }
    # push onto the undostack a special undo command
    PushUndoStack 0 MoveLeft MoveLeft
}

#########################################################
# Flip a facedown card up if it's on top of a playstack #
#########################################################

proc FlipUp {} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global Var Flag Card WorkStk

    set item [.canvas find withtag current]

    # first, find out which playstack we are located in
    set tag_list [.canvas gettags current]
    set tag_index [lsearch -glob $tag_list playstk?_Tag]
    if {$tag_index == -1} {	;# this should not be happening!
	Stderr "Error FlipUp> Can't find stack we are flipping up from!"
	return
    }
    # now see if the card is the topmost
    scan [lindex $tag_list $tag_index] "playstk%d_Tag" s
    eval set top_index [expr \$PlayStk${s}(size) - 1]
    eval set top_item \$PlayStk${s}($top_index)
    if {$top_item == $item} {
	# find out the current location
	set item_coord [.canvas coords $item]
	DisplayCard $item FaceUp [lindex $item_coord 0] \
	    [lindex $item_coord 1] [list playstk${s}_Tag up_Tag]

	incr Var(score) 3
	PushUndoStack $item playstk${s}_Tag playstk${s}_Tag

	# prevent double clicking on a face down card from blowing up [bug]
	# find out if there is a better way to handle this!!!!!!!!!!!!!!!!
	# how about putting the current card on the working stack?????????
	set WorkStk(size) 0

	# if this is the last face down card on all the playstacks, allow
	# the user to autofinish
		#below was: && Var(flip) == 1
	if {!$Flag(autofinish)} {
	    set down_size [llength [.canvas find withtag down_Tag]]
	    set drawleft_size [llength [.canvas find withtag drawleft_Tag]]
	    if {$down_size == $drawleft_size} {
		set Flag(autofinish) 1
		pack .button.finish -side left -anchor w
	    }
	}
    }
}


##################################################################
# Setup the working stack for either dragging or double clicking #
##(button1-click)#################################################

proc SetupWorkStack {x y {cheat 0}} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global EndStk0 EndStk1 EndStk2 EndStk3
    global lastX lastY oldX oldY
    global Var Flag WorkStk Card

    ### WorkStk(0)	: the current_item
    ### WorkStk(1..N)	: array of items ontop, bootom -> top, tagged workstk_Tag
    ### WorkStk(size)	: number (N) of ontop items
    ### WorkStk(stack)	: which stack the current_item is from
    ### WorkStk(info)	: Bao's mysterious field which here is item's coords

    ### decisions
    if { $Flag(dragworkstack) || $Flag(slidingstack) } return

    ### set current_item [.canvas find withtag current]
    ### (above) works but (below) doesn't generate Error
    ### halo = 2, stops the beneath face-down card getting grabbed 
    set current_item [.canvas find closest $x $y 1]
    if {$current_item == ""} {
	Stderr "Error SetupWorkStack: Cannot find the card at $x $y!"
	return
    }
    ### check we don't grab the bg_picture
    ### tried disabling it, but it's not enough
    # if {[lsearch [.canvas gettags $current_item] bg_picture] > -1} return
    ### but using the halo = 2  fixes this problem :>

    set Flag(setupworkstack) 1
    set Flag(dragworkstack) 0
    set Flag(cheating) $cheat

    # first, clear the working stack
    .canvas dtag workstk_Tag workstk_Tag

    set lastX $x
    set lastY $y

    # save the current position in case we don't go anywhere later on
    set oldX $lastX
    set oldY $lastY

    # find out which stack we are located in first
    set tag_list [.canvas gettags $current_item]
    if {[lsearch -exact $tag_list drawright_Tag] != -1} {
	set WorkStk(info) [.canvas coord $current_item]
	if {$Var(flip) > 1} {
	    # make sure this is the topmost card on the drawright stack
	    # [bug] is there a quicker way to do this? [bug]
	    set card_list [.canvas find withtag drawright_Tag]
	    set list_length [llength $card_list]
	    if {$current_item != [lindex $card_list [expr $list_length - 1]]} {
		set Flag(setupworkstack) 0
		return
	    }
	}
	set current_stk drawright_Tag
    } else {
	set index [lsearch -glob $tag_list playstk?_Tag]
	if {$index != -1} {
	    set current_stk [lindex $tag_list $index]
	} else {
	    set index [lsearch -glob $tag_list endstk?_Tag]
	    # no checking necessary since it has to be in an endstack
	    set current_stk [lindex $tag_list $index]
	}
    }

    set WorkStk(stack) $current_stk
    set WorkStk(0) $current_item
    set WorkStk(size) 1
    .canvas addtag workstk_Tag withtag $current_item

    # see if we have to add more items to the working stack, ie. playstack
    if {[string match playstk?_Tag $current_stk]} {
	# first find the index of the "current" item on the playstack
	scan $current_stk "playstk%d_Tag" s
	eval set bound \$PlayStk${s}(size)
	for {set index 0} {$index < $bound} {incr index} {
	    eval set item \$PlayStk${s}($index)
	    if {$item == $current_item} {
		set WorkStk(size) [expr $bound - $index]
		incr index;	# we have already assigned the first item
		break
	    }
	}
	# now get all the cards that are on top of the "current" item
	for {set stk_index 1} {$index < $bound} {incr index; incr stk_index} {
	    eval set item \$PlayStk${s}($index)
	    set WorkStk($stk_index) $item
	    .canvas addtag workstk_Tag withtag $item
	}
    }
 
    # note that we don't need to raise the cards in the working stack since
    # they will be raise when they are displayed or moved around ...

    if {$Var(debug)} {DebugWorkStack SetupWorkStack}
}

#################################
# Drag the working stack around #
#################################

proc DragWorkStack {x y} {

    global lastX lastY Var Flag
    global WorkStk Card

    #### decisions
    if {$Flag(setupworkstack) == 0} return

    set Flag(dragworkstack) 1

    .canvas raise workstk_Tag all
    .canvas move workstk_Tag [expr $x - $lastX] [expr $y - $lastY]
    set lastX $x
    set lastY $y
}


#########################################################
# Move the working stack to a new location, if possible #
##(button-release)#######################################

proc ProcessWorkStack {x y} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global EndStk0 EndStk1 EndStk2 EndStk3
    global Card WorkStk Var Flag UndoStk
    global oldX oldY

    set Flag(setupworkstack) 0

    #### decisions
    if {$Flag(dragworkstack) == 0} return

    set Flag(dragworkstack) 0

    # if the working stack is empty, probably because it is explicitly set
    # by the routines that flip up a down card, then don't do anything
    if {$WorkStk(size) < 1} return

    if {$Var(debug)} {DebugWorkStack ProcessWorkStack}

    set item_no $WorkStk(0)
    set card $Card($item_no)
    scan $card "%c%d" suit number
    set suit [format "%c" $suit]

    # we could have use workstk_Tag instead of current also ...
    set workstk_coord [.canvas bbox $item_no]

    if {$WorkStk(size) == 1} {
   	# do we overlap any endstack
	foreach s {0 1 2 3} {
	    # make sure we don't match ourselves
	    if {[string match endstk${s}_Tag $WorkStk(stack)]} {
		continue
	    }
	    set endstk_coord [.canvas bbox endspot${s}_Tag]
	    if {[StackOverlap $workstk_coord $endstk_coord]} {
		# check to see if it is the next card to go there
		eval set endstk_suit \$EndStk${s}(suit)
		eval set endstk_card \$EndStk${s}(number)
		if {$endstk_suit == $suit && \
		    $endstk_card == [expr $number - 1]} {
		    # set EndStk${s}(number) $number
		    MoveWorkStack EndStk${s} MoveJump
		    PushUndoStack $WorkStk(0) $WorkStk(stack) \
			endstk${s}_Tag $WorkStk(info)
		    ScoreEndStk
		    return
		} elseif {$number == 1 && $endstk_suit == "empty"} {
		    # setup endstack info here, not in MoveWorkStack!
		    # Bzzzt, now done in MoveWorkStack instead!!!
		    # set EndStk${s}(suit) $suit
		    # set EndStk${s}(number) 1
		    MoveWorkStack EndStk${s} MoveJump
		    PushUndoStack $WorkStk(0) $WorkStk(stack) \
			endstk${s}_Tag $WorkStk(info)
		    # before scoring, check not moving between endstk's
		    if {![string match endstk?_Tag $WorkStk(stack)]} {
			ScoreEndStk
		    }
		    return
		}
	    }
	} ;# foreach 

	if {$Flag(cheating)} {
	    set coords [.canvas bbox drawleft_Tag]
	    if {[StackOverlap $workstk_coord $coords]} {
	    MoveWorkStack LeftStk MoveJump
	    set UndoStk(top) 0	;### no undo for cheaters
	    }
	} ;# if cheating

    }

    # do we overlap a playstack
    foreach s {0 1 2 3 4 5 6} {

	# make sure we don't match ourselves
	if {[string match playstk${s}_Tag $WorkStk(stack)]} {
	    continue
	}

	eval set playstk_size \$PlayStk${s}(size)
	if {$playstk_size > 0} {

	    # find the coordinate of the topmost item in the playstack
	    eval set top_index [expr \$PlayStk${s}(size) - 1]
	    eval set top_item \$PlayStk${s}($top_index)

	    # don't do anything if the topmost item is facedown
	    set tag_list [.canvas gettags $top_item]
	    if {[lsearch -exact $tag_list down_Tag] != -1} {continue}

	    set playstk_coord [.canvas bbox $top_item]

	    if {[StackOverlap $workstk_coord $playstk_coord]} {

		# see if we have both a number and color (mis)match
		set top_card $Card($top_item)
		scan $top_card "%c%d" top_suit top_number
		set top_suit [format "%c" $top_suit]

		if {$top_number == [expr $number + 1]} {

		    if {$suit == "h" || $suit == "d"} {
			set suit_color red
		    } else { set suit_color black }
		    if {$top_suit == "h" || $top_suit == "d"} {
			set topsuit_color red
		    } else { set topsuit_color black }

		    if {$suit_color != $topsuit_color} {
			MoveWorkStack PlayStk${s} MoveJump
			PushUndoStack $WorkStk(0) $WorkStk(stack) \
			    playstk${s}_Tag $WorkStk(info)
			ScorePlayStk
			return
		    }
		}
	    }
	} else {
	    # see if we are dragging a King to an empty playstack
	    if {$number == 13} {
		#set playstk_coord [.canvas coords playspot${s}_Tag]
		set playstk_coord [.canvas bbox playspot${s}_Tag]
		if {[StackOverlap $workstk_coord $playstk_coord]} {
		    MoveWorkStack PlayStk${s} MoveJump
		    PushUndoStack $WorkStk(0) $WorkStk(stack) \
			playstk${s}_Tag $WorkStk(info)
		    ScorePlayStk
		    return;
		}
	    };# number == 13
	}
    }

    # if we get down to here, then we can't go anywhere so warp back to
    # our original location

    # find out the original topleft corner of the card
    set coord [.canvas coord $item_no]
    set corner_x [lindex $coord 0]
    set corner_y [lindex $coord 1]
    SlideWorkStack \
	"[expr $oldX - ($x - $corner_x)] [expr $oldY - ($y - $corner_y)]" \
	"$corner_x $corner_y"

    ### Clean up

    ### this messes up (a stuttered) double click
    # .canvas dtag workstk_Tag workstk_Tag
}


####################################################################
# See if we can move the card on the working stack to an end stack #
##(double-click or button2)#########################################

proc ClearWorkStack {} {

    # note that a double click will always generate a single click first,
    # so the working stack already contains the cards we are interested in
    # (except for the case where we double click on a facedown card [bug])

    global EndStk0 EndStk1 EndStk2 EndStk3
    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global WorkStk Var Flag Card

    ### decisions
    ### Don't include setupworkstack in logic check, as button release precedes
    ### a double-click, and will clear this flag.
    if { $Flag(dragworkstack)} {return}
    set Flag(setupworkstack) 0

    if {$Var(debug)} {DebugWorkStack ClearWorkStack}

    # ignore double click on a card already on an EndStack
    if {[string match endstk?_Tag $WorkStk(stack)]} {return}

    set item_no $WorkStk(0)
    set card $Card($item_no)
    scan $card "%c%d" suit number
    set suit [format "%c" $suit]

    # if there is more than one card on the working stack, then the "current"
    # card that we double clicked on can't be the one on top so ignore
    if {$WorkStk(size) != 1} {
	CheckClearKing $number ;### unless it's a king
	return
    }

    # if the card is an ace, find an empty end stack and move it there
    if {$number == 1} {
	foreach endstk_no {0 1 2 3} {
	    if {[set EndStk${endstk_no}(suit)] == "empty"} break
	}
    } else {
	set endstk_no -1
	# see if the end stack for the current suit exists
	foreach s {0 1 2 3} {
	    eval set stk_suit \$EndStk${s}(suit)
	    if {$stk_suit == $suit} {
		eval set stk_card \$EndStk${s}(number)
		if {$stk_card == [expr $number - 1]} {
		    # found the corresponding endstack & number is ok
		    set endstk_no $s
		}
                break
	    }
	}
	if {$endstk_no == -1} {
	    ### found no corresponding endstack
	    ### but if card is a King look for an empty stack
	    CheckClearKing $number
	    return
	}
    }

    # now simply move the card on the working stack to the end stack
    MoveWorkStack EndStk${endstk_no} MoveSlide
    PushUndoStack $WorkStk(0) $WorkStk(stack) endstk${endstk_no}_Tag \
	$WorkStk(info)

    ScoreEndStk
}


########################################
### Check for double clicking a king ###
########################################

proc CheckClearKing {number} {
    global WorkStk Var
    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6

    if {$Var(debug)} {Stderr "\[CheckClearKing\] $number" }

    if {$number != 13 } {return}

    foreach i {0 1 2 3 4 5 6} {
	eval set stacki \$PlayStk${i}(size)
	if {$stacki == 0} { ; # stack i is empty
	    MoveWorkStack PlayStk$i MoveSlide
	    PushUndoStack $WorkStk(0) $WorkStk(stack) \
		playstk${i}_Tag  $WorkStk(info)
	    ScorePlayStk
	    break
	}
    }; #foreach
}

##############################################################
# Move the cards on the working stack to the given new stack #
##############################################################

proc MoveWorkStack {newstk type {info {}}} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global EndStk0 EndStk1 EndStk2 EndStk3
    global Var WorkStk Card LastFlipOffset

    if {$WorkStk(size) < 1} {
	Stderr "Error MoveWorkStack: WorkStk(size) is $WorkStk(size)!"
	return
    }

    if {$Var(debug)} {
	Stderr "\[MoveWorkStack\]"
	Stderr "\tWorkStk(size) is $WorkStk(size)"
	for {set i 0} {$i < $WorkStk(size)} {incr i} {
	    set item $WorkStk($i)
	    Stderr "\tWorkStk($i) is $Card($item)"
	}
    }

    # raise the card we are moving to the top
    .canvas raise workstk_Tag all

    if {[string match PlayStk? $newstk]} {	;# moving to a playstack
	scan $newstk "PlayStk%d" newstk_no
	# find the coordinates of the topmost item in the destination playstack
	eval set newstk_size \$${newstk}(size)
	if {$newstk_size == 0} {	;# playstack is empty
	    # find the coordinates of the placeholder instead
	    set new_coords [.canvas coords playspot${newstk_no}_Tag]
	    set top_index -1  		;# increment it below
	    set newy [lindex $new_coords 1]
	} else {
	    # find the coordinates of the topmost item in the stack
	    eval set top_index [expr \$${newstk}(size) - 1]
	    eval set top_item \$${newstk}($top_index)
	    set new_coords [.canvas coord $top_item]
	    if {[lsearch -exact [.canvas gettags $top_item] up_Tag] != -1} {
		set newy [expr [lindex $new_coords 1]+$Var(stack.up_spacing)]
	    } else { 
		set newy [expr [lindex $new_coords 1]+$Var(stack.down_spacing)] 
	    }
	}

	set newx [lindex $new_coords 0]

	# move all the cards on the working stack over to the playstack
	set old_coords [.canvas coord $WorkStk(0)]
	if {$type == "MoveSlide"} {	;# slide the stack over
	    SlideWorkStack [list $newx $newy] $old_coords
	} else {			;# jump in one step to the new location
	    set oldx [lindex $old_coords 0]
	    set oldy [lindex $old_coords 1]
	    .canvas move workstk_Tag [expr $newx - $oldx] [expr $newy - $oldy]

	}

	# update the playstack to include the new cards
	for {set newcard 0} {$newcard < $WorkStk(size)} {incr newcard} {
	    incr top_index
	    set ${newstk}($top_index) $WorkStk($newcard)
	}
	incr ${newstk}(size) $WorkStk(size)

	# update the tags of the cards we have just moved over
	.canvas itemconfig workstk_Tag -tags \
	    [list playstk${newstk_no}_Tag up_Tag]

    } elseif {[string match EndStk? $newstk]} {
	# find the coordinates of the destination endstack
	set card $Card($WorkStk(0))
	scan $card "%c%d" suit number
	set suit [format "%c" $suit]
	eval set endstk_suit \$${newstk}(suit)
	if {$endstk_suit == "empty"} {
	    set ${newstk}(suit) $suit
	}
	set ${newstk}(number) $number
	scan $newstk "EndStk%d" newstk_no

	set new_coords [.canvas coords endspot${newstk_no}_Tag]
	# move the single card over
	if {$type == "MoveSlide"} {
	    SlideWorkStack $new_coords [.canvas coord $WorkStk(0)]
	}

	# again, we do this just to be on the safe side
	.canvas coords $WorkStk(0) [lindex $new_coords 0] \
	    [lindex $new_coords 1]

	# update the tags of the card
	.canvas itemconfig $WorkStk(0) \
	    -tags [list endstk${newstk_no}_Tag up_Tag]
	# update of the endstack top item is done somewhere else [bug]
	# look at ClearWorkStack and ProcessWorkStack, should move here [bug]
	# -- this is already done (see above)! [bug]

	# we should really keep a number of playing cards somewhere
	if {$EndStk0(number) == 13 && $EndStk1(number) == 13 && \
	    $EndStk2(number) == 13 && $EndStk3(number) == 13} { 
	    EndGame
	}

    } elseif {[string match RightStk $newstk]} {
	### Move a card back to the drawleft from the play/end stacks

	SlideWorkStack [lrange $info 0 1] [.canvas coord $WorkStk(0)]

	### Tricky here to get the card back where we want it.
	### LastFlipOffset is set in Undo and also MoveRight
	if {$LastFlipOffset == 0} {
	    ### the cards have been left in one stack
	    .canvas coord $WorkStk(0) $Var(DrawRightX) $Var(top_level)
	} else {
	    ### they're still staggered  and it goes back where it was
	    .canvas coord $WorkStk(0) [lindex $info 0] [lindex $info 1]
	}

	.canvas itemconfig $WorkStk(0) -tags {drawright_Tag up_Tag}

    } elseif {[string match LeftStk $newstk]} {
	### Move cards back from the right to the left drawstack

	# bah, this may/will not work with clipping! [bugbugbug]
	# use some bogus card with clipping as the tag instead ... [bugbugbug]
	# -- hum, it looks like this DOES work after all [bug]
	# the reason is that we are only interested in the location, _not_
	# on any cards located at that location ...

	set flip_coords [.canvas coord flip_Tag]
	SlideWorkStack $flip_coords [.canvas coord $WorkStk(0)]

	# flip the card over
	DisplayCard $WorkStk(0) FaceDown [lindex $flip_coords 0] \
	    [lindex $flip_coords 1] {drawleft_Tag down_Tag}

    } else {
	Stderr "Error MoveWorkStack> Moving to an invalid stack \($newstk\)"
	return
    }

    # if we are dragging from an endstack, update its top card number
    if {[string match endstk?_Tag $WorkStk(stack)]} {
	scan $WorkStk(stack) "endstk%d_Tag" endstk_no
	eval set endstk_number \$EndStk${endstk_no}(number)
	if {$endstk_number == 1} {
	    set EndStk${endstk_no}(suit) empty
	}
	incr EndStk${endstk_no}(number) -1
	eval set endstk_number \$EndStk${endstk_no}(number)
    } elseif {[string match playstk?_Tag $WorkStk(stack)]} {
	# update the playstack size
	scan $WorkStk(stack) "playstk%d_Tag" playstk_no
	incr PlayStk${playstk_no}(size) [expr -1 * $WorkStk(size)]
    }

    # do we want to reset the working stack size here? what about undo? [bug]
    # yes, for double clicking cases where the events are somewhat confusing
    set WorkStk(size) 0
}


##########################################################
# Slide the cards on the working stack to a new location #
##########################################################

proc SlideWorkStack {new_coord old_coord} {

    global Var Flag

    set pixels_per_move 1

    set newx [lindex $new_coord 0]
    set newy [lindex $new_coord 1]
    set oldx [lindex $old_coord 0]
    set oldy [lindex $old_coord 1]
    set distancex [expr $newx - $oldx]
    set distancey [expr $newy - $oldy]

    if {$Var(debug)} {Stderr "oldx $oldx oldy $oldy newx $newx newy $newy distancex $distancex distancey $distancey" }

    set x [expr double($oldx)]
    set y [expr double($oldy)]
    set ratio [expr double($Var(speed))/$Var(speed_multiplier)]
    if {$ratio <.2} {set ratio .2}

    if {[expr abs($distancex) > abs($distancey)]} {
	set steps [expr int( abs($distancex)/$ratio)]
    } else {
	set steps [expr int( abs($distancey)/$ratio)]
    }

    if {$steps < 1} { 	# move in a single steps to the new location
	.canvas move workstk_Tag $distancex $distancey
	return
    }

    ### S.A. doesn't trust tcl to not set up a new working stack while
    ### this SlideWorkStack is moseying along, so i'll set up a semaphore
    set Flag(slidingstack) 1

    if {$distancex != 0 || $distancey != 0} {

	if {[expr abs($distancex) > abs($distancey)]} {	;# move along x-axis

	    set slope [expr double($distancey) / $distancex]
	    set x_offset [expr {($distancex > 0 ? 1 : -1)} * \
			  ($ratio * $pixels_per_move)]
	    if {$distancey != 0} {
		set y_offset [expr {($distancey > 0 ? 1 : -1)} * \
			      (abs($x_offset) * abs($slope))]
	    } else { set y_offset 0 }

	    if {$Var(debug)} {Stderr "steps $steps slope $slope x_offset $x_offset y_offset $y_offset" }

	    for {set move 0} {$move < $steps} {incr move} {
		set x_prime [expr $x + $x_offset]
		set y_prime [expr $y + $y_offset]
		set x_move [expr int(round($x_prime) - round($x))]
		set y_move [expr int(round($y_prime) - round($y))]
		set x $x_prime
		set y $y_prime

		.canvas move workstk_Tag $x_move $y_move
		update idletasks
	    }

	} else {	;# move along y-axis

	    set slope [expr double($distancex) / $distancey]
	    set y_offset [expr {($distancey > 0 ? 1 : -1)} * \
			  ($ratio * $pixels_per_move)]
	    if {$distancex != 0} {
		set x_offset [expr {($distancex > 0 ? 1 : -1)} * \
			      (abs($y_offset) * abs($slope))]
	    } else { set x_offset 0 }

	    if {$Var(debug)} {Stderr "steps $steps slope $slope x_offset $x_offset y_offset $y_offset" }

	    for {set move 0} {$move < $steps} {incr move} {
		set x_prime [expr $x + $x_offset]
		set y_prime [expr $y + $y_offset]
		set x_move [expr int(round($x_prime) - round($x))]
		set y_move [expr int(round($y_prime) - round($y))]
		set x $x_prime
		set y $y_prime

		.canvas move workstk_Tag $x_move $y_move
		update idletasks
	    }
	}

	# finally, make sure we get to the exact new location
	.canvas move workstk_Tag [expr $newx - round($x)] \
	    [expr $newy - round($y)]
    }
    ### release semaphore
    set Flag(slidingstack) 0
}

####################################
# Check for rectangle intersection #
####################################

proc StackOverlap {coord1 coord2} {

    # find the stack on the left
    set x1 [lindex $coord1 0]
    set x2 [lindex $coord2 0]
    if {$x1 < $x2} {
	set left 1
	set right 2
    } else {
	set right 1
	set left 2
    }
    # if right edge of left stack is less than left edge of right stack, no go
    if {[eval lindex \$coord${left} 2] < [eval lindex \$coord${right} 0]} {
	return 0
    }

    # now we know the stacks overlap vertically, need to check horizontally

    # find the stack on the top
    set y1 [lindex $coord1 1]
    set y2 [lindex $coord2 1]
    if {$y1 < $y2} {
	set top 1
	set bottom 2
    } else {
	set top 2
	set bottom 1
    }
    # if bottom edge of top stack is less than top edge of bottom stack, no go
    if {[eval lindex \$coord${top} 3] < [eval lindex \$coord${bottom} 1]} {
	return 0
    }

    # if we get this far, the stacks overlap
    return 1
}

###################################
# Push a move onto the undo stack #
###################################

proc PushUndoStack {item origin destination {info {}}} {

    # note that to undo, the item will go from destination to origin
    global UndoStk Var

    ### if card is from drawleft-> info is the number of cards flipped
    ### ie. flipping 3 cards make 3 pushes to the undo stack with infos: 1 2 3
    ### else, info is current_item's coords

    if {$Var(debug)} {Stderr "Undo_info: $info" }

    incr UndoStk(top)
    set UndoStk($UndoStk(top)) [list $item $origin $destination $info]
}

###############
# Undo a move #
###############

proc Undo {} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global Var Flag Card UndoStk WorkStk LastFlipOffset

    if {$UndoStk(top) == 0} {
	return
    }
    incr Var(score) -10 ;# you better believe it, Undo costs 10 points

    # double check to make sure that both destination and origin are tags [bug]

    ### hack by S.A to fix this bug:
    ### (move a card, click but don't drag a card, press undo - weird things)
    .canvas dtag workstk_Tag workstk_Tag

    set top $UndoStk(top)
    set undo_cmd $UndoStk($top)
    incr UndoStk(top) -1
    set WorkStk(0) [lindex $undo_cmd 0]
    .canvas addtag workstk_Tag withtag $WorkStk(0)
    set origin [lindex $undo_cmd 1]
    set destination [lindex $undo_cmd 2]
    set info [lindex $undo_cmd 3]
    set WorkStk(stack) $destination
    set WorkStk(size) 1

    if {[string match MoveLeft $origin]} {	;# unflip the drawleft stack
	# invoke MoveRight for each card on the drawleft stack
	# yes, this is ugly but it's the easiest way to do it, for now ...
	set drawleft_size [llength [.canvas find withtag drawleft_Tag]]
	for {set card 0} {$card < $drawleft_size} {incr card} {
	    ### hack by S.A. to allow undo to work after DrawStack flips
	    ### 'no' stops MoveRight from pushing these moves
	    ### onto the undo stack!!!
	    MoveRight 0 1 no
	}
    } elseif {[string match drawleft_Tag $origin]} {
	set flip_coord [.canvas coord flip_Tag]
	# flip one or more cards over
	MoveWorkStack LeftStk MoveSlide

	### hack by S.A. to undo to the RightStk a little cleaner (see Tricky)
	### when we're unflipping the stack , the cards are not offset
	set LastFlipOffset 0

	### info indicates how many cards flipped
	if {[lindex $info 0] > 1} {

	    ### hack by S.A. is to change penalty for undoing
	    ### flipping the stack from -30 (-10*Var(flip)) to -10
	    incr Var(score) 10

	    Undo
	}
    } elseif {[string match drawright_Tag $origin]} {
	MoveWorkStack RightStk MoveSlide $info
    } elseif {[string match endstk?_Tag $origin]} {
	scan $origin "endstk%d_Tag" endstk_no
	MoveWorkStack EndStk${endstk_no} MoveSlide
    } elseif {[string match playstk?_Tag $origin]} {
	if {[string match $origin $destination]} {
	    # same playstack so simply flip the card facedown
	    set item $WorkStk(0)
	    set coord [.canvas coord $item]
	    DisplayCard $item FaceDown [lindex $coord 0] [lindex $coord 1] \
		[list $destination down_Tag]
	    if {$Flag(autofinish)} {	;# disable autofinish if  enabled ...
		set Flag(autofinish) 0
		pack forget .button.finish
	    }
	} else {			;# fill up the working stack if needed
	    if {[string match playstk?_Tag $destination]} {
		set current_item $WorkStk(0)
		# look in the destination, _not_ the origin, playstack
		scan $destination "playstk%d_Tag" playstk_no
		eval set bound \$PlayStk${playstk_no}(size)
		for {set index 0} {$index < $bound} {incr index} {
		    eval set item \$PlayStk${playstk_no}($index)
		    if {$item == $current_item} {
			set WorkStk(size) [expr $bound - $index]
			incr index	;# first item already assigned above
			break
		    }
		}
		# now get all the cards that are on top of the "current" item
		for {set stk_index 1} {$index < $bound} {incr stk_index} {
		    eval set item \$PlayStk${playstk_no}($index)
		    set WorkStk($stk_index) $item
		    .canvas addtag workstk_Tag withtag $item
		    incr index
		}
	    }
	    scan $origin "playstk%d_Tag" playstk_no
	    MoveWorkStack PlayStk${playstk_no} MoveSlide
	}
    } else {
	Stderr "Error Undo> unknown original stack \($origin\)"
	return
    }

    # just to be on the safe side ...
    set WorkStk(size) 0
}

### Score procedures ######################

proc ScoreEndStk {} {
    global Var WorkStk

    if {![string compare drawright_Tag $WorkStk(stack)]} {
	incr Var(score) 6
    } else {
	incr Var(score) 3
    }
}

proc ScorePlayStk {} {
    global Var WorkStk

    if {![string compare drawright_Tag $WorkStk(stack)]} {
	incr Var(score) 3
    } elseif {[string match endstk?_Tag $WorkStk(stack)]} {
	incr Var(score) -8
    } else {
	incr Var(score) -1 ;# moving between playstacks
    }
}

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

proc DebugWorkStack {where} {
	global WorkStk Card

	Stderr "\[$where\]"
	Stderr "\tWorkStk(size) is $WorkStk(size)"
	Stderr "\tWorkStk(stack) is $WorkStk(stack)"
	for {set i 0} {$i < $WorkStk(size)} {incr i} {
	    set item $WorkStk($i)
	    Stderr "\tWorkStk($i) is $Card($item)"
	}
}

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

proc Stderr {message} {
    puts stderr $message
}

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

proc RunningWindows {} {
    # returns 1 if it looks like windows
    global tcl_platform
    return [regexp -nocase "win" $tcl_platform(os)] 
}

#############################################################################
# Automatically finish the game once all the cards have been turned face up #
#############################################################################

proc AutoFinish {} {

    global PlayStk0 PlayStk1 PlayStk2 PlayStk3 PlayStk4 PlayStk5 PlayStk6
    global EndStk0 EndStk1 EndStk2 EndStk3
    global Card UndoStk Var

    # if this is the last face down card on all the playstacks, autofinish
    # there still may be some face down cards on the drawright stack however
    # [this is not really necessary as the button will not be packed when
    # autofinish is disabled; however, just in case ...]
    set down_size [llength [.canvas find withtag down_Tag]]
    set drawleft_size [llength [.canvas find withtag drawleft_Tag]]
    set drawright_size [llength [.canvas find withtag drawright_Tag]]
    if {$down_size != $drawleft_size} {	;# nice try!
	return
    }

    # change the cursor to a watch
    .button config -cursor watch
    update

    # find out the current card number of each endstack
    set orphan_list {}
    foreach stk {0 1 2 3} {
	eval set suit \$EndStk${stk}(suit)
	if {![string match empty $suit]} {
	    eval set number \$EndStk${stk}(number)
	    set ${suit}(number) $number
	    set ${suit}(stack) EndStk${stk}
	    lappend suit_list $suit
	} else {	;# mark this endstack as unassigned
	    lappend orphan_list $stk
	}
    }

    # the section below will be difficult to debug ... [bug]

    # assigned any orphan suit if needed
    if {[string length $orphan_list] > 0} {
	set index 0
	foreach suit {h s d c} {
	    if {![info exists ${suit}(number)]} {
		set ${suit}(number) 0
		set orphan_endstk [lindex $orphan_list $index]
		set ${suit}(stack) EndStk${orphan_endstk}
		incr index
	    }
	}
    }

    ### Calculate final score
    # Can't really update score as we go along with AutoFinish
    # as due to program logic, the last score doesn't get tallied till late

    # Score += (3 * cards_face_up_on_playstk + 6 * remainder_not_on_endstk)

    set num_endstk [expr $h(number) + $d(number) + $s(number) + $c(number)]
    set playcard [expr 52 - $num_endstk]
    set L1 [.canvas find withtag up_Tag]
    set L2 [.canvas find withtag drawright_Tag]
    set num_fuop [expr [llength $L1] - [llength $L2] - $num_endstk]

    incr Var(score) [expr 3*$num_fuop + 6*(52 - $num_endstk-$num_fuop)]

    if {$Var(debug)} {
	Stderr "final up_Tag: $L1"
	Stderr "final drawright_Tag: $L2"
	Stderr "$num_fuop cards num face up on playstk"
    }

    # once an empty stack, always an empty stack
    set empty_stack 0
    foreach stk {0 1 2 3 4 5 6} {
	if {[set PlayStk${stk}(size)] == 0} { incr empty_stack }
    }

    # cycle through the playstacks and drawstacks until all the cards have
    # been moved up to the endstacks; there are other ways to do this, and
    # this probably is not the optimal way ...

    while {$playcard > 0} {

	set found_top 0
	set found_bottom init
	set topbottom 1
	set top 1
	if {$empty_stack < 7} {
	    set bottom 1
	} else { set bottom 0}

	# first scan through the playstacks and drawright stack
	while {$topbottom == 1} {

	    # move as many of the cards on the drawright stack as possible
	    while {$top == 1} {
		# move a card from the drawleft stack over if needed
		if {$drawright_size == 0} {
		    if {$drawleft_size == 0} {	;# no card left on drawstacks
			break;		# get out of "top" loop
		    } else {
			MoveRight
			update idletasks
			incr drawright_size
			incr drawleft_size -1
		    }
		}
		# this _has_ to be the topmost card on the drawright stack
		#set item [.canvas find closest $drawright_x $drawright_y]
		set drawright_list [.canvas find withtag drawright_Tag]
		set item [lindex $drawright_list \
			  [expr [llength $drawright_list] - 1]]		
		set card $Card($item)
		scan $card "%c%d" card_suit card_number
		set card_suit [format "%c" $card_suit]
		eval set suit_number \$${card_suit}(number)
		eval set endstk \$${card_suit}(stack)

		if {[ClearCard $item $card_number $suit_number \
		     drawright_Tag $endstk]} {
		    incr ${card_suit}(number)
		    incr drawright_size -1
		    set found_top 1
		    incr playcard -1
		} else {
		    break;		# get out of "top" loop
		}
	    }

	    # stop if we can't find anything at the top and this is not the
	    # first iteration of the loop, ie. we have to go into the bottom
	    # loop at least once ...
	    if {$found_top == 0 && $found_bottom != "init"} {
		break;			# get out of "topbottom" loop
	    }

	    set found_bottom 0
	    while {$bottom == 1} {

		set bottom 0
		foreach stk {0 1 2 3 4 5 6} {

		    eval set stk_size \$PlayStk${stk}(size)
		    if {$stk_size > 0} {
			set top_index [expr $stk_size - 1]
			eval set item \$PlayStk${stk}($top_index)
			set card $Card($item)
			scan $card "%c%d" card_suit card_number
			set card_suit [format "%c" $card_suit]
			eval set suit_number \$${card_suit}(number)
			eval set endstk \$${card_suit}(stack)

			if {[ClearCard $item $card_number $suit_number \
			     playstk${stk}_Tag $endstk]} {
				 incr ${card_suit}(number)
				 incr playcard -1
				 set found_bottom 1
				 set bottom 1
				 if {$stk_size == 1} {
				     incr empty_stack
				 }
			     }
		    }
		}
	    }

	    # stop if we can't find anything at the bottom
	    if {$found_bottom == 0} {
		break;			# get out of topbottom loop
	    }
	}

	# now flip over a card from the drawleft stack, move all the cards
	# from the drawright stack over if needed
	if {$drawleft_size > 0} {
	    MoveRight
	    update idletasks
	    incr drawright_size
	    incr drawleft_size -1
	} else {	;# flip over all the drawright stack cards first
	    if {$drawright_size > 1} {
		MoveLeft
		update idletasks
		MoveRight
		update idletasks
		set temp drawleft_size
		set drawleft_size [expr $drawright_size - 1]
		set drawright_size 1
	    }
	}
    }

    # change the cursor back to a normal pointer
    .button config -cursor left_ptr

    # don't invoke EndGame here since it is done automatically when all
    # the cards have been moved up to the endstacks (see MoveWorkStack)
}

#######################################################################
# Do something graphically related to reward the player for finishing #
#######################################################################

proc EndGame {} {

    global Var UndoStk WorkStk Image

    # don't let the user do something strange while the endgame is running ...
    set UndoStk(top) 0
    set WorkStk(size) 0

    .canvas itemconfigure bg_picture -state hidden

    pack forget .button.undo .button.finish .button.options

    set beginstk [.canvas coord playspot0_Tag]
    set endstk [.canvas coord playspot6_Tag]
    set xdistance [expr [lindex $endstk 0] - [lindex $beginstk 0]]
    # note that we divide by 12, not 13, since the last card is positioned
    # on the coordinates of the last playstack, ie. playspot6
    set x_offset [expr round([expr $xdistance / 12])]
    set ydistance [expr $Var(canvas_height) - [lindex $beginstk 1] - \
				$Var(card.padheight) - 20 ]
    # we divide by 3 here since the bottom stack must be fully visible ...
    set y_offset [expr $ydistance / 3]
    set x [expr round([lindex $beginstk 0])]
    set y [expr round([lindex $beginstk 1])]
    foreach s {0 1 2 3} {
	# layout each suit on the canvas
	.canvas raise endstk${s}_Tag all
	set card_list [.canvas find withtag endstk${s}_Tag]
	# the find returns the bottom most card first (eg. the Ace)
	for {set card [expr [llength $card_list] - 1]} \
	    {$card >= 0} \
	    {incr card -1} {
	    set card_no [lindex $card_list $card]
	    .canvas raise $card_no endstk${s}_Tag
	    .canvas coord $card_no $x $y
	    update idletasks
	    incr x $x_offset
	}
	set x [expr round([lindex $beginstk 0])]
	incr y [expr round(floor($y_offset))]
    }

    # display the cardback bitmaps at the end ... (do we want this??????)
    after 1500
    .canvas itemconfig up_Tag -image $Image(cardback)
    update idletasks

    # we may have to remove all bindings or tags so that the player won't
    # attempt to move the cards around after the endgame has concluded ...
    .canvas dtag up_Tag up_Tag
}

####################################################
# Move a card to the endstack while autofinish'ing #
####################################################

proc ClearCard {item card_number suit_number fromstk_Tag endstk} {

    global WorkStk Var

    if {$suit_number == [expr $card_number - 1]} {
	set WorkStk(size) 1
	set WorkStk(0) $item
	set WorkStk(stack) $fromstk_Tag
	.canvas addtag workstk_Tag withtag $item

	eval MoveWorkStack $endstk MoveSlide

	update idletasks
	return 1
    } else {
	return 0
    }
}

###################
# S.A's gui stuff #
###################

proc DrawBackgroundPicture {} {
	global Var

	# create image "bg_image" to get it's height and width
	# is there may be an easier way to do this (?)
	set picture $Var(picture_directory)/$Var(bg_picture)
	image create bitmap bg_image -file $picture

        .canvas create bitmap \
            [expr ( $Var(canvas_width) - [image width bg_image] ) / 2] \
            [expr $Var(canvas_height) - [image height bg_image] - 10] \
            -bitmap  @$picture -anchor nw -tags bg_picture
	CheckBackgroundPicture
}

proc CheckBackgroundPicture {} {
        global Var

	if {$Var(showpicture) == "yes"} {
           .canvas itemconfig bg_picture -state normal
        } else {
           .canvas itemconfig bg_picture -state hidden
        }
}

######################
# The Options Window #
######################

proc ChangeOptions {} {
    if {[winfo exists .b]} {
	ShowOptions
    } else {
        InitOptions
    }
}

proc ShowOptions {} {
    wm deiconify .b
    update
    raise .b
    grab set .b
}

proc WithdrawOptions {} {
    wm withdraw .b
    grab release .b
}

proc InitOptions {} {
    global Var

    catch {destroy .b}
    toplevel .b
    wm title .b "Options"
    wm iconname	.b "TkSol Options"
    wm transient .b .
    grab set .b

    ### try to place the options window nicely

    scan [wm geometry .] "%dx%d+%d+%d" a b c d
    set x [expr $c + $a - 240]
    set y [expr $d + 30]
    if {[expr $x + 332] > [winfo screenwidth .]} {
	set x [expr [winfo screenwidth .] - 332]
    }
    if {[expr $y + 492] > [winfo screenheight .]} {
        set y [expr [winfo screenheight .] - 492]
    }
    wm geometry .b 315x474+$x+$y
    wm resizable .b 0 0

    set label_width 20
    set entry_width 12
    set scale_length 150

    frame .b.button -relief raise -bd 2 -back  $Var(canvas_color)
    frame .b.flip 
    frame .b.speed
    frame .b.showpicture
    frame .b.entry

    # Option Window Buttons
    eval button .b.button.close $Var(button_options) -text "close" \
	{ -command {WithdrawOptions} } 

    eval button .b.button.save $Var(button_options)  -text "save" \
	{ -command {
    	    ### catch opening the file for writing
    	    if {[catch {set fid [open ~/.tksolrc w]}] != 0} {
		    Stderr {tksol: error writing to "~/.tksolrc"}
	    } else {
		foreach i { bg_picture canvas_color flip cardback_fg \
		    showpicture speed cardback } {
		    puts $fid "set Var($i) $Var($i)"
            	}
		close $fid }
	    }
	}

    pack .b.button -side top -fill x
    pack .b.button.save -side left
    pack .b.button.close -side left

    # customize the flip frame
    pack .b.flip -side top -fill x -padx 2 -pady 2
    label .b.flip.label -width $label_width -anchor center -text "Flip How Many"
    scale .b.flip.scale -from 1 -to 5 -orient horiz -length $scale_length \
	-showvalue False -sliderlength 20 -tickinterval 1 \
	-command { set Var(flip) }
    .b.flip.scale set $Var(flip)
    pack .b.flip.label -side left -padx 2 -pady 2
    pack .b.flip.scale -side left -padx 2 -pady 2

    # customize the speed frame
    pack .b.speed -side top -fill x -padx 2 -pady 2
    label .b.speed.label -width $label_width \
	-anchor center -text "Card Speed (Slow-Fast)"
    scale .b.speed.scale -from 1 -to 100 -orient horiz -length $scale_length \
	-showvalue False -sliderlength 20 -command {set Var(speed)}
    .b.speed.scale set $Var(speed)
    pack .b.speed.label -side left -padx 2 -pady 2
    pack .b.speed.scale -side left -padx 2 -pady 2

    # customize the showpicture frame
    pack .b.showpicture -side top -fill x -padx 2 -pady 2
    label .b.showpicture.label -width $label_width \
	-anchor center -text "Show Picture"
    pack .b.showpicture.label -side left -padx 2 -pady 2

    ### added this extra frame to get the yes/no buttons in the middle
    frame .b.showpicture.radio
    pack .b.showpicture.radio

    foreach toggle {yes no} {
	radiobutton .b.showpicture.radio.$toggle -text $toggle \
	-variable Var(showpicture) -value $toggle -command {CheckBackgroundPicture}
    }
    .b.showpicture.radio.$Var(showpicture) select
    pack .b.showpicture.radio.yes .b.showpicture.radio.no -side left -padx 2 -pady 2

    ########################
    # Colour entry widgets #
    ########################

    pack .b.entry -side top -fill x -padx 2 -pady 2
    foreach frame {card canvas} {
	frame .b.entry.$frame
	label .b.entry.$frame.l -width $label_width -anchor center
	entry .b.entry.$frame.e -width $entry_width \
		-relief sunken -justify center
        button .b.entry.$frame.b -pady .7 -text Choose -relief flat \
	  -command "Choose.$frame.Colour" -pady .7 -activebackground lavender

	pack .b.entry.$frame -side top -fill x -pady 2
	pack .b.entry.$frame.l -side left -pady 2
	pack .b.entry.$frame.e -side left -pady 2 -padx 6
	pack .b.entry.$frame.b -side right -padx 5
	bind .b.entry.$frame.e <Return> "Set.$frame.Colour"
    }
    .b.entry.card.l config -text "Card colour"
    .b.entry.card.e insert 0 "$Var(cardback_fg)"
    .b.entry.card.e icursor end

    .b.entry.canvas.l config -text "Canvas colour"
    .b.entry.canvas.e insert 0 "$Var(canvas_color)"
    .b.entry.canvas.e icursor end

    ###############################
    # Bitmap and Picture canvases #
    ###############################

    frame .b.bitmap -bd 7 -back $Var(canvas_color)
    frame .b.picture -bd 7 -back $Var(canvas_color)

    canvas .b.bitmap.canvas 
    scrollbar .b.bitmap.scroll -orient horizontal \
	-command ".b.bitmap.canvas xview" -relief groove -width 12 \
	-elementborderwidth 1

    canvas .b.picture.canvas 
    scrollbar .b.picture.scroll -orient horizontal \
	-command ".b.picture.canvas xview" -relief groove -width 12 \
	-elementborderwidth 1

    pack .b.bitmap -ipady 10 -ipadx 10 -fill both
    pack .b.picture -ipady 10 -ipadx 10 -fill both

    pack .b.bitmap.canvas -fill both -padx 5
    pack .b.bitmap.scroll -side bottom -fill x

    pack .b.picture.canvas -fill both -padx 5
    pack .b.picture.scroll -side bottom -fill x

    .b.bitmap.canvas bind bitmap_Tag <ButtonPress-1> {
	LoadNewBitmap [file tail [lindex [.b.bitmap.canvas gettags current] 0]]
    }

    ### Changing the background picture
    .b.picture.canvas bind picture_Tag <ButtonPress-1> {

        set Var(bg_picture) \
	[file tail [lindex [.b.picture.canvas gettags current] 1]]

	set Var(showpicture) yes

	### easier just to destroy and remake just to get the right geometry
        image delete bg_image
	.canvas delete bg_picture

        ### draw new picture
	DrawBackgroundPicture
        .canvas lower bg_picture all
    }

    DisplayCardbacks
    DisplayPictures
}

###############################
# Colour Selection Procedures #
###############################

proc Choose.card.Colour {} {
	global Var

	set choice [tk_chooseColor -parent .b \
	  -title "Card colour" -initialcolor $Var(cardback_fg)]
	if {"$choice"!=""} {
		.b.entry.card.e delete 0 end
		.b.entry.card.e insert 0 $choice
		Set.card.Colour
	}
}

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

proc Choose.canvas.Colour {} {
	global Var

	set choice [tk_chooseColor -parent .b \
	   -title "Background colour" -initialcolor $Var(canvas_color)]
	if {"$choice"!=""} {
		.b.entry.canvas.e delete 0 end
		.b.entry.canvas.e insert 0 $choice
		Set.canvas.Colour
	}
}

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

proc Set.card.Colour {} {
	global Var Image
	set colour [.b.entry.card.e get]

	# (Do we have to change "up_Tag"s ?)
	# also change the options-menu card bitmap colour

	if {[TestColour $colour]} {
		foreach i "cardback [glob $Var(cardbacks_dir)/*.xbm]" {
		    $Image($i) configure -foreground $colour
		}
		set Var(cardback_fg) $colour
	} else bell
}

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

proc Set.canvas.Colour {} {
	global Var Image
	set colour [.b.entry.canvas.e get]

	if {[TestColour $colour]} {
    		set Var(canvas_color) $colour
		$Image(placeholder) configure -foreground $colour
    		foreach i {.button.score .canvas .button .b.button .b.bitmap \
			.b.picture .b.bitmap.canvas .b.picture.canvas } {
			$i configure -back $colour
    		}
	} else bell
}

#####################
# Display Cardbacks #
#####################
proc DisplayCardbacks {} {

    global Var Image

    # bitmap_list is currently a huge list of "dir/card.xbm"
    set bitmap_list [glob $Var(cardbacks_dir)/*.xbm]
    set len [llength $bitmap_list]

    set spacing 15
    set x_offset 0
    set x_incr [expr $Var(card.width) + $spacing]
    set canvas_height [expr $Var(card.height) + 10]

    .b.bitmap.canvas configure -height $canvas_height \
       -back $Var(canvas_color) \
       -scrollregion "0 0 [expr $len * $x_incr - $spacing] $canvas_height" \
       -xscrollcommand ".b.bitmap.scroll set" -relief flat

    # create an image for every card_back, and a canvas item
    foreach bitmap $bitmap_list {
	set Image($bitmap) [image create bitmap -file $bitmap \
	    -maskfile $Var(maskfile) \
	     -background $Var(cardback_bg) -foreground $Var(cardback_fg)]
	.b.bitmap.canvas create image $x_offset 10 \
	    -image $Image($bitmap) -anchor nw \
	    -tags [list $bitmap bitmap_Tag]
	incr x_offset $x_incr
    }
}

####################
# Display Pictures #
####################

proc DisplayPictures {}  {

    global Var

    set spacing 15
    set x_offset 0

    # mini pictures are of size x_incr*x_incr (72*72)
    # and are made this size by "generate_mini_pictures"
    set x_incr [expr $Var(card.width)]
    set picture_list [glob $Var(picture_directory)/mini/*.xbm]
    set len [llength $picture_list]
    set canvas_height $x_incr
    set bitmap_height [expr $canvas_height - 1]

    .b.picture.canvas configure -height $canvas_height \
	-back $Var(canvas_color) \
	-scrollregion [list 0 0 [expr $len * $x_incr ] $canvas_height] \
	-xscrollcommand ".b.picture.scroll set" -relief sunken

    foreach bitmap $picture_list {
	eval .b.picture.canvas create bitmap $x_offset 0 \
	    -bitmap @$bitmap -fore black -anchor nw \
	    -tags {[list picture_Tag $bitmap]}

	# place a little outline around each mini picture
	# .b.picture.canvas create rectangle $x_offset 0 \
	# [expr $x_offset + $x_incr] $bitmap_height -width 1 -outline grey70

	incr x_offset $x_incr
    }
}

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

proc LoadNewBitmap {bitmap} {
	                
    global Var Image
       
    $Image(cardback) configure -file $Var(cardbacks_dir)/$bitmap
    set Var(cardback) $bitmap
    update idletasks
}

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

proc TestColour {c} {
	# Check colour is valid and has no spaces (bungs up when 'saved')
	# Order of these two tests is important
	# - dont know how to do this except for configuring something unseen
	if {![regexp " " $c] && \
	    ![catch {.button.score config -highlightcolor $c}]} {
	    return 1
        } else {
	    return 0
	}
}

############
# BINDINGS #
############

proc BindKeys {} {

    # single click on drawleft stack flip the card over to drawright
    ### the break stops FlipUp being triggered
    .canvas bind drawleft_Tag <ButtonPress-1> {MoveRightMany; break}

    # single click on flip move all the cards from drawright over
    .canvas bind flip_Tag <ButtonPress-1> "MoveLeft"

    # single click on a facedown card on top of a stack flip it
    .canvas bind down_Tag <ButtonPress-1> "FlipUp"

    # press of button-1 on a faceup card setup the current working stack
    .canvas bind up_Tag <Control-ButtonPress-1> "SetupWorkStack %x %y 1"
    .canvas bind up_Tag <ButtonPress-1> "SetupWorkStack %x %y"

    # motion drags the current working stack around
    .canvas bind up_Tag <B1-Motion> "DragWorkStack %x %y"

    # release of button-1 moves the working stack to a new location (maybe)
    .canvas bind up_Tag <ButtonRelease-1> "ProcessWorkStack %x %y"

    # double click on an up card attempts to move it to the end stack
    .canvas bind up_Tag <Double-ButtonPress-1> "ClearWorkStack"

    # middle button now acts as a double click
    .canvas bind up_Tag <ButtonPress-2> "SetupWorkStack %x %y ; ClearWorkStack"

    ### Using 'bind all' quits when typing 'aqua..' in the colour widgets %-|
    bind .canvas <KeyPress-q> {destroy .}
    focus .canvas
}

########
# MAIN #
########

Init		;# defaults and read in user customization

CreateCanvas	;# create the canvas and bitmaps

NewGame

BindKeys	;# setup key bindings and party time ...
