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

# TkSol

# Version 1.0   (02/18/94) (c) 1993 by Bao Trinh.
# Version 1.8.4 (24/12/04) (c) 2005 by Steven A. (stevenaaus@yahoo.com)
# released under the GPL

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

proc Init {} {

	global argv Var WorkStk

	option add *highlightThickness 0

	set Var(version)	1.8.4
	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
	set Var(showstack)   yes		;# flag to show lower cards on DrawRight
	
	if {![RunningWindows]} {
		set Var(cardback)	default	;# bitmap of face down card
		set Var(bg_picture)	default ;# background picture
		set Var(font)		{6x13}
	} else {				;# windows can't handle links
		set Var(cardback)	x.xbm
		set Var(bg_picture)	kittyt.xbm
		set Var(font)           {MS 8}
	}

	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	;# padded width of card
	set Var(card.padheight)	100	;# padded height of card
	set Var(card.width)		72	;# actual width
	set Var(card.height)	99	;# actual height

	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)		13
	set Var(button.foreground)		White
	set Var(button.background)		DeepSkyBlue1
	set Var(button.activeForeground)	White		;# RosyBrown1
	set Var(button.activeBackground)	DeepSkyBlue2	;# DeepSkyBlue1

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

	set WorkStk(size) 0

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

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

	# (courtesy of ical) ### modified by S.A.

	while {[llength $argv] != 0} {

	set arg [lindex $argv 0]
	set argv [lrange $argv 1 end]	;# remove the processed argv

 	case $arg in {
		"-flip" {
			GetVar flip 1 5
		}
		"-speed" {
			GetVar speed 1 100
		}
		"-spacing" {
			GetVar stack_spacing 1 20
		}
		"-back" {
			GetVar canvas_color
   		}
		"-black" {
			GetVar card.blackForeground
		}
		"-red" {
			GetVar card.redForeground
		}
		"-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
		}
	}
	}
}

# read in an arg from the command line (testing for lower/upper bounds)
proc GetVar {whichvar {lower {}} {upper {}}} {

	global Var argv

	set tmp [lindex $argv 0]
	if { $tmp == "" } {
		Stderr "tksol: Wrong number of args"
		exit 1
	}
	set argv [lrange $argv 1 end]

	if { "$upper" != "" } {
		if { $tmp > $upper } { set tmp $upper }
		if { $tmp < $lower } { set tmp $lower }
	}

	set Var($whichvar) $tmp
}


#################
# 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"
	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 -font $Var(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.about $Var(button_options) \
		-text "about"	-command "About"
	eval button .button.quit	$Var(button_options) \
		-text "quit"	{-command { destroy . }}
	eval button .button.finish	$Var(button_options) \
		-text "finish"	-command "AutoFinish"

	### score
	label .button.score -width 4 -font $Var(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.about .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
	pack .button.about -after .button.options -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 end]
	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} {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
		if {$Var(showstack)} {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 (not implemented):
	# 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

	} ;# WorkStk(size) == 1

	# 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
	}
	} ;# foreach

	# 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) || $WorkStk(size)==0 } {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
		}
	}
}

##############################################################
# 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 right 2 ; set left 1
	} 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 it
	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 end]
		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 .button.about

	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 + 512] > [winfo screenheight .]} {
		set y [expr [winfo screenheight .] - 512]
	}
	wm geometry .b 315x494+$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.showstack
	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 showstack 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

	##############
	# card speed #
	##############
	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 h -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

	##############
	# flip scale #
	##############
	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

	##########################
	# showpicture, showstack #
	##########################

	foreach \
		i {showstack showpicture} \
		j {{Show Flipped Cards} {Show Picture}} \
		k {{} CheckBackgroundPicture} {

		pack .b.$i -side top -fill x -padx 2 -pady 2
		label .b.$i.label -width $label_width -anchor center -text $j
		pack .b.$i.label -side left -padx 2 -pady 2

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

		foreach toggle {yes no} {
			radiobutton .b.$i.radio.$toggle -text $toggle \
			-variable Var($i) -value $toggle -command "$k"
		}
		.b.$i.radio.$Var($i) select
		pack .b.$i.radio.yes .b.$i.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]]
	}

	#################################
	# Change 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
	}
}
#########
# About #
#########
proc About {} {
	global Var

	toplevel .a
	wm title .a	"About"
	wm iconname	.a "TkSol Info"
	wm transient .a .
	grab set .a

	frame .a.frame -bg $Var(canvas_color)
	label .a.frame.message -relief sunken -bd 20 -borderwidth 0  \
	-fg gray40 -text " TkSol
-----
version $Var(version)

(c) 1993 Bao Trinh
(c) 2005 Steven A.

released under the GPL

stevenaaus@yahoo.com
"
	
	eval {button .a.frame.quit -text "ok" -command {destroy .a}} $Var(button_options) -width 7

	scan [wm geometry .] "%dx%d+%d+%d" a b c d
	set x [expr $c + $a/2 - 80]
	set y [expr $d + $b/2 - 180]
	wm geometry .a +$x+$y
	wm resizable .a 0 0

	pack .a.frame -fill both
	pack .a.frame.message -side top -padx 3 -pady 3
	pack .a.frame.quit -padx 2 -pady 1
}

############
# 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
CreateCanvas
NewGame
BindKeys
