dontspace/dontspace-1.2/table.tcl

#!/usr/local/bin/wish8.6 -f

######################################################################
#
# table.tcl
#
# Copyright (C) 1993,1994 by John Heidemann <johnh@ficus.cs.ucla.edu>
# All rights reserved.  See the main klondike file for a full copyright
# notice.
#
# $Id: table.tcl,v 2.16 1997/03/26 17:47:29 johnh Exp $
#
######################################################################

#
# generic card table routines
#
set rcsid(table.tcl) {$Id: table.tcl,v 2.16 1997/03/26 17:47:29 johnh Exp $}


proc mkTableDefaults {} {
	global table tk_version

	if {$tk_version < 4.0} {
		set table(colormodel) [tk colormodel .]
	} else {
		set table(colormodel) "color"
		if {[winfo depth .] < 8} {
			set table(colormodel) monochrome
		}
	}
	set table(font) -*-Helvetica-Medium-R-*-140-*
	if { $table(colormodel) == "monochrome" } {
		set table(fg) Black
		set table(bg) White
	} else {
		set table(fg) Black
		set table(bg) #ffe4c4
	}

	set table(font) -*-Helvetica-Medium-R-*-140-*

	set table(cardWidth) 54
	set table(cardHeight) 69
	# If necessary
	# we will trim these values a little shorter in dontspace
	# to make the window fit a 640x480 display.
	set table(gutter) 12
	set table(stackedCardOffset) 25
}

proc tableBell {} {
	global tk_version
	if {$tk_version < 4.0} {
		puts -nonewline "\a"
	} else {
		bell
	}

}

proc mkCardDefaults {} {
	global table

	# cards
	# (see reface card for card colors)

	set table(cardWidth) 52
	set table(cardHeight) 67
	# cardSpace -- reasonable amount of space between card bitmaps
	set table(cardSpace) 8
	# cardOverlap -- required overlap when dropping cards
	set table(cardOverlap) 4
	# padValue -- a good value for random padding (around text)
	set table(padValue) 10

	# coords of a place off the screen
	set table(hiddenX) -1000
	set table(hiddenY) -1000
}

#
# init stuff
#
# table(preActionProc) = called before any action (used to start game)
#
proc mkTable {width height preActionProc} {
	global table tk_version

	set table(width) $width
	set table(height) $height
	set table(preActionProc) $preActionProc
	set table(id) ".c"

	mkCardDefaults

	# random constants
	set table(values) "a 2 3 4 5 6 7 8 9 t j q k"
	set table(suits) "c d h s"
	set table(cvalues) "xa23456789tjqkx"
	set table(csuits) "xcdhsx"
	set table(otherColorSuits,c) "dh"
	set table(otherColorSuits,d) "cs"
	set table(otherColorSuits,h) "cs"
	set table(otherColorSuits,s) "dh"

	canvas $table(id) -relief raised \
		-width $table(width) -height $table(height) \
		-background $table(bg)
	if {$tk_version >= 4.0} {
		focus $table(id)
		$table(id) configure -takefocus 1
	}

	return $table(id)
}


#
# card bitmap backgrounds
#
proc setBackBitmap {} {
	global table
	if { [info exists table(backFace)] } {
		set oldBackFace $table(backFace)
	} else {
		set oldBackFace "xxx"
	}
	set table(backFace) "back_$table(backChoice)"
	#
	# Fix any cards with the old back.
	#
	if {[catch {$table(id) configure}] == 0} {
		foreach i [$table(id) find withtag card] {
			set itemBitmap [lindex [$table(id) itemconfigure $i -bitmap] 4]
			if { [regexp $oldBackFace $itemBitmap] } {
				refaceItem $i $table(id) $table(backFace)
			}
		}
	}
}

proc chooseCardBackground {} {
	global table

	#
	# get our choices
	#
	set choices ""
	# Note:  wish-4.1 under linux seems to have a bug
	# with the glob failing.  If so, take our
	# known good cases.
	if [catch {
		set possibleChoices [glob [string trimleft "$table(bitmapdir)/c_back_*.xbm" "@"]]
	}] {
		set possibleChoices "c_back_crane.xbm c_back_pagoda.xbm c_back_plain.xbm"
	}
	foreach i $possibleChoices {
		regexp {c_back_(.*)\.xbm$} $i trash token
		lappend choices $token
	}
	if { $choices == "" } {
		return -errorinfo "No background bitmap found."
	}
	set table(backChoices) $choices

	#
	# randomly pick one
	#
	set table(backChoice) [lindex $choices [random [llength $choices]]]
	setBackBitmap
}
chooseCardBackground


#
# table stuff
#


proc refaceItem {itemId w face} {
	global table items
	# puts "refaceItem $itemId $w $face"
	switch -glob $face {
		[a23456789tjqk][cs] {
			set items($itemId,normFg) Black
			set items($itemId,normBg) White
			if { $table(colormodel) == "monochrome" } {
				set items($itemId,highFg) White
				set items($itemId,highBg) Black
			} else {
				set items($itemId,highFg) Black
				set items($itemId,highBg) Gray70
			}
		}
		[a23456789tjqk][dh] {
			set items($itemId,normFg) Red
			set items($itemId,normBg) White
			if { $table(colormodel) == "monochrome" } {
				set items($itemId,highFg) White
				set items($itemId,highBg) Black
			} else {
				set items($itemId,highFg) "#a00000"
				set items($itemId,highBg) Gray70
			}
		}
		back_*		    {
			set items($itemId,normFg) Black
			set items($itemId,normBg) White
			if { $table(colormodel) == "monochrome" } {
				set items($itemId,highFg) White
				set items($itemId,highBg) Black
			} else {
				set items($itemId,highFg) Black
				set items($itemId,highBg) Gray70
			}
		}
		space		    -
		warnspace	    {
			set items($itemId,normFg) $table(fg)
			set items($itemId,normBg) $table(bg)
			if { $table(colormodel) == "monochrome" } {
				set items($itemId,highFg) $table(bg)
				set items($itemId,highBg) $table(fg)
			} else {
				set items($itemId,highFg) Black
				set items($itemId,highBg) Gray70
			}
		}
		default		    { puts "refaceItem: unkown face $face\n" }
	}
	$w itemconfigure $itemId \
		-bitmap "$table(bitmapdir)/c_$face.xbm" \
		-foreground $items($itemId,normFg) \
		-background $items($itemId,normBg)

}

proc createItemBitmap {x y face} {
	global table
	set c $table(id)
	set itemId [ $c create bitmap $x $y -anchor nw]
	refaceItem $itemId $c $face
	# Remember the cards so we can change bitmaps as required.
	$c addtag card withtag $itemId
	# $c addtag debug withtag $itemId
	return $itemId
}


#
# null procs
#
proc recursiveFindFriendsProc {itemId w x y closure} {
	global items
	if { $closure == {} } {
		return {}
	} else {
		return [linsert [recursiveFindFriendsProc $closure $w $x $y $items($closure,dragFindFriendsClosure)] 0 $closure]
	}
}
proc defaultDragTargetAcceptProc {w target src srcFriends} { return 1 }

proc defaultClickProc {item w x y closure} {}

#
# dropableCard
#
proc defaultDragTargetEnterProc {item w x y targetId} {
	global items
	$w itemconfig $targetId \
		-foreground $items($targetId,highFg) \
		-background $items($targetId,highBg)
	}
proc defaultDragTargetLeaveProc {item w x y targetId} {
	global items
	$w itemconfig $targetId \
		-foreground $items($targetId,normFg) \
		-background $items($targetId,normBg)
}

proc whereDroppedDragProc {itemId w x y src target} {
}

proc originalPlaceDragProc {itemId w x y src target} {
	global table
	# debugLog "originalPlaceDragProc $itemId $w $x $y $src $target"
	if { $target == "" } {
		#
		# Put the card back where it started.
		# This is a little trickey since we could be dragging a
		# stack, so we compute the relative distance and
		# move selected.
		#
		set oldCoords [$w coords $itemId]
		moveAllRelatively $w $src \
			[lindex $oldCoords 0] [lindex $oldCoords 1] \
			$table(dragInitialX) $table(dragInitialY)
	} else {
		error "defaultDragAbortProc: called with target $target"
	}
}

proc onCardPlaceDragProc {itemId w x y src target} {
	global table items
	if { $target != {} } {
		# unhiligth other card by calling leave proc
		defaultDragTargetLeaveProc $itemId $w $x $y $target
		moveCardOnCard $w $itemId $target selected
	} else {
		error "defaultDragAbortProc: called with target $target"
	}
}

proc samePlaceChildOffsetProc {} {
	return [list 0 0]
}
proc offsetChildOffsetProc {} {
	global table
	return [list 0 $table(stackedCardOffset)]
}


#
# map from id's to cards
#
proc memorizeCard {id vs} {
	global cards
	set cards($vs) $id
}

proc rememberCard {vs} {
	global cards
	return $cards($vs)
}


#
# deck stuff
#

proc getCard {w id param} {
	global items
	return $items($id,[string trim $param "-"])
}

proc setCard {w id args} {
	global items
	# puts "$id: $args"
	while { [llength $args] } {
		set a [lindex $args 0]
		set args [lreplace $args 0 0]
		if { $a != "-default" } {
			if { [llength $args] == 0 } {
				error "setCard: argument $a without parameter"
			}
			set b [lindex $args 0]
			set args [lreplace $args 0 0]

			switch -exact -- $a {
			"-atag" {
				$w addtag $b withtag $id
				# Make sure that double clicking is allowed
				# before clicking for dragging.
				set tags [lindex [$w itemconf $id -tags] 4]
				set doubleI [lsearch -exact $tags "doubleClickableCard"]
				set dragableI [lsearch -exact $tags "dragableCard"]
				if { $dragableI < $doubleI } {
					# Redo dragableCard tag to make it last.
					$w dtag $id dragableCard
					$w addtag dragableCard withtag $id
				}
			}
			"-dtag" { $w dtag $id $b }
			default {
				set a [string trim $a "-"]
				set items($id,$a) $b
				}
			}
			switch  -exact -- $a {
			"side" {
				if { $b == "back" } {
					set face $table(backFace)
				} else {
					set face $items($id,subtype)
				}
				refaceItem $id $w $face
				}
			"subtype" {
				memorizeCard $id $b
				}
			}
		} else { # -default
			# kill tags
			$w itemconf $id -tags card

			set items($id,type) card
					# values: card, place
			if { [info exists items($id,subtype)] == 0 } {
				set items($id,subtype) ""
					# for cards: value/suit
			}
			set items($id,location) hidden
					# values: hidden, deck, pile,
					# tableau, foundation
			set items($id,sublocation) ""
					# values
			set items($id,side) back
					# values: face, back
			set items($id,parent) {}
			set items($id,child) {}

			# items(id,normFg), items(id,normBg)
			# items(id,highFg), items(id,highBg)

			set items($id,childOffsetProc) samePlaceChildOffsetProc
					# returns xy list of where
					# a child should be placed

			set items($id,dragableCardPress) defaultDragableCardPress
			set items($id,dragableCardMove) defaultDragableCardMove
			set items($id,dragableCardRelease) defaultDragableCardRelease
			set items($id,dragFindFriendsProc) recursiveFindFriendsProc
			set items($id,dragFindFriendsClosure) {}
					# return a list of friends to be drug
			set items($id,dragTargetEnterProc) \
						defaultDragTargetEnterProc
					# when dropAccepting, called if a
					# valid target is over us
			set items($id,dragTargetLeaveProc) \
						defaultDragTargetLeaveProc
					# when dropAccepting, called if a
					# valid target was over us but left
			set items($id,dragTargetAcceptGlob) ""
					# globbing of cards that we take
			set items($id,dragTargetAcceptProc) \
						defaultDragTargetAcceptProc
					# second check after Accepts
			set items($id,dragCommitProc) onCardPlaceDragProc
					# Called when drag is released.

			set items($id,clickProc) defaultClickProc
					# Called when clicked on.
			set items($id,clickClosure) {}
					# passed to clickProc
			set items($id,doubleClickProc) defaultClickProc
					# Called when clicked on.
			set items($id,doubleClickClosure) {}
					# passed to doubleClickProc

			set items($id,orphanChildProc) error
			set items($id,orphanChildClosure) {}

			set items($id,adoptChildProc) error
			set items($id,adoptChildClosure) {}
		}
	}
}

proc tableRegisterDumbItem {id} {
	global items
	set items($id,dragTargetAcceptGlob) {}
}

proc mkDeck {} {
	global table items deck

	#
	# Create each new card on the deck
	# and add it to items.
	# Initially cards are instantiated off-screen.
	#
	#
	# Additionally, cards ids are listed in the deck list.
	#

	foreach v $table(values) {
		foreach s $table(suits) {
			# create the card
			set id [createItemBitmap $table(hiddenX) $table(hiddenY) $table(backFace)]
			lappend deck $id
			setCard $table(id) $id -default -type card -subtype $v$s
		}
	}
}


proc shuffleDeck {} {
	global deck
	# Put the deck in a cannonical order so we
	# can regenerate it with the same sequenece
	# of random numbers.
	set oldCards [lsort -integer $deck]
	set newCards ""
	while { [llength $oldCards] > 0 } {
		# tclX
		set i [random [llength $oldCards]]
		lappend newCards [lindex $oldCards $i]
		set oldCards [lreplace $oldCards $i $i]
	}
	set deck $newCards
}


#
# bindings
#
proc mkBindings {w} {
	global table items

	#
	# card clicking
	#
	$w bind clickableCard <ButtonRelease-1> {
		global table

		$table(preActionProc) click

		set itemId [%W find withtag current]
		# NEEDSWORK: Check to make sure release is still on card.
		$items($itemId,clickProc) $itemId %W %x %y $items($itemId,clickClosure)
	}
	$w bind clickableCard <Enter> { enterHilightCard [%W find withtag current] %W %x %y }
	$w bind clickableCard <Leave> { leaveUnhilightCard [%W find withtag current] %W %x %y }

	#
	# double clicking
	#
	$w bind doubleClickableCard <Double-ButtonRelease-1> {
		global table

		$table(preActionProc) doubleClick
		set table(dragging) 0

		set itemId [%W find withtag current]
		# NEEDSWORK: Check to make sure release is still on card.
		$items($itemId,doubleClickProc) $itemId %W %x %y $items($itemId,clickClosure)
	}
	# johnh: xxx
	$w bind doubleClickableCard <ButtonRelease-3> {
		global table

		$table(preActionProc) doubleClick

		set itemId [%W find withtag current]
		# NEEDSWORK: Check to make sure release is still on card.
		$items($itemId,doubleClickProc) $itemId %W %x %y $items($itemId,clickClosure)
	}
	$w bind doubleClickableCard <Enter> { enterHilightCard [%W find withtag current] %W %x %y }
	$w bind doubleClickableCard <Leave> { leaveUnhilightCard [%W find withtag current] %W %x %y }

	#
	# dragableCard
	#
	$w bind dragableCard <ButtonPress-1> {
		set id [%W find withtag current]
		$items($id,dragableCardPress) $id %W %x %y
	}
	$w bind dragableCard <B1-Motion> {
		set id [%W find withtag current]
		$items($id,dragableCardMove) $id %W %x %y
	}
	$w bind dragableCard <ButtonRelease-1> {
		set id [%W find withtag current]
		$items($id,dragableCardRelease) $id %W %x %y
	}
	$w bind dragableCard <Enter> { enterHilightCard [%W find withtag current] %W %x %y }
	$w bind dragableCard <Leave> { leaveUnhilightCard [%W find withtag current] %W %x %y }

	#
	# outlineableCard
	#
	$w bind outlineableCard <Enter> { enterHilightCard [%W find withtag current] %W %x %y }
	$w bind outlineableCard <Leave> { leaveUnhilightCard [%W find withtag current] %W %x %y }

	# this is for debugging
	$w bind card <ButtonPress-2> { debugCard [%W find withtag current] %W %x %y}

	#
	# untouched stuff
	#
	$w bind untouchedCard <ButtonPress-1> { beginGame current %W %x %y }
	#
	$w bind pauseItems <ButtonRelease-1> { unpauseGame }

	#
	# Keyboard events
	#
	bind $w <Control-KeyPress> { # do nothing }
	bind $w <Meta-KeyPress> { # do nothing }
#	bind $w <KeyPress> { keyPress "%A" %W }
	resetKeyState
}

proc debugCard {id w x y } {
	global items
	puts -nonewline "dubugCard $id: "
	foreach i {location sublocation parent child} {
		puts -nonewline "$i=$items($id,$i) "
	}
	puts ""
}


#
# keyPress
#
# Keypresses are managed by modes
#	submode: any-(special,suit,value)->(any,value,suit)
#		value-(suit)->any
#		suit-(value)->any
#	source---target
#
#
proc keyPress {asc w} {
	global table

	if { "$asc" == "" } { return }
	set asc [string tolower $asc]
	switch -exact -- $table(keySubState) {
	"any" {
		switch -glob -- "$asc" {
		[cdhs] {
			set table(keySuit) $asc
			set newSubState suit
		}
		[a23456789tjqk] {
			set table(keyValue) $asc
			set newSubState value
		}
		[\ ] {
			set newSubState triple
		}
		[\n] {
			set newSubState double
		}
		default {
			set newSubState error
		}
		}
	}
	"value" {
		switch -glob -- $asc {
		[cdhs] {
			set table(keySuit) $asc
			set newSubState complete
		}
		[\b] {
			set newSubState any
		}
		default {
			set newSubState error
		}
		}
	}
	"suit" {
		switch -glob -- $asc {
		[a23456789tjqk] {
			set table(keyValue) $asc
			set newSubState complete
		}
		[\b] {
			set newSubState any
		}
		default {
			set newSubState error
		}
		}
	}
	}
	#
	# Handle larger state transitions.
	#
	switch -exact -- $table(keyState) {
	"any" {
		switch -exact -- $newSubState {
			"double" {
				set newState any
				set newSubState any
			}
			"triple" {
				set newState any
				set newSubState any
			}
			"complete" {
				set newState card
				set newSubState any
			}
			"error" {
				set newState error
				set newSubState any
			}
			default {
				set newState $table(keyState)
			}
		}
	}
	"card" {
		switch -exact -- $newSubState {
			"double" {
				set newState double
				set newSubState any
			}
			"triple" {
				set newState triple
				set newSubState any
			}
			"complete" {
				set newState move
				set newSubState any
			}
			"error" {
				set newState error
				set newSubState any
			}
			default {
				set newState $table(keyState)
			}
		}
	}
	default {
		set newState any
		set newSubState any
	}
	}
	#
	# Take the action.
	#
	if { $table(keyState) == "card" && $newState != "card"} {
		# Unhilight the card.
		unhilightCard $table(keyFirstId) $w "" ""
	}
	switch -exact -- $newState {
	"double" {
		set newState any
	}
	"triple" {
		set newState any
	}
	"card" {
		# Check to make sure it's a card with actions.
		set id [rememberCard "$table(keyValue)$table(keySuit)"]
		set table(keyFirstId) $id
		set goodCard 0
		foreach i [lindex [$w itemconf $id -tags] 4] {
			switch -exact -- $i {
			"clickableCard" -
			"doubleClickableCard" -
			"dragableCard" {
				set goodCard 1
				break
			}
			}
		}
		if { $goodCard } {
			# Hilight the selected card.
			hilightCard $table(keyFirstId) $w "" ""
		} else {
			set newState any
		}
	}
	"move" {
#		if { [cardHasTag $w $table(keyFirstId) dragableCard] } {
#			set newId [rememberCard "$table(keyValue)$table(keySuit)"]
#		}
		set newState any
	}
	"error" {
		tableBell
		set newState any
	}
	}
	#
	# Commit the action.
	#
	set table(keyState) $newState
	set table(keySubState) $newSubState
}

proc resetKeyState {} {
	global table

	set table(keySubState) any
	set table(keyState) any
	set table(keySuit) "x"
	set table(keyValue) "x"
	set table(keyFirstId) "x"
}


#
# outlineableCard
#
proc enterHilightCard {itemId w x y} {
	global game
	# Avoid hilighting cards that will be obscured by other cards.
	if { $game(status) == "dealing" } { return }
	hilightCard $itemId $w $x $y
}
proc leaveUnhilightCard {itemId w x y} {
	global table

	if { $table(keyFirstId) == $itemId } { return }
	# A bug was happening where sometimes we'd get a null itemId
	# when redealing the tableau.  It's not consistently repeatable.
	# Avoid the problem
	if { $itemId == "" } { return }
	unhilightCard $itemId $w $x $y
}

proc hilightCard {itemId w x y} {
	global table items
	# puts "hilightCard $itemId $w $x $y"
	if { [llength $itemId] != 1 } { error "hilightCard: called with list of items." }
	$table(preActionProc) outlineEnter
	$w itemconfig $itemId \
		-foreground $items($itemId,highFg) \
		-background $items($itemId,highBg)
}
proc unhilightCard {itemId w x y} {
	global table items

	if { [llength $itemId] < 1 } { error "unhilightCard: called with empty items." }
	if { [llength $itemId] > 1 } { error "unhilightCard: called with list of items." }
	$table(preActionProc) outlineLeave
	$w itemconfig $itemId \
		-foreground $items($itemId,normFg) \
		-background $items($itemId,normBg)
}
proc checkHilighting {w x y} {
	# Items come back to front, so reverse them.
	set ids [lreverse [$w find overlapping $x $y $x $y]]
	foreach id $ids {
		set tags [lindex [$w itemconfig $id -tags] 4]
		if { ([lsearch -exact $tags outlineableCard] != -1) ||
			([lsearch -exact $tags dragableCard] != -1)} {
			hilightCard $id $w $x $y
			return
		}
	}
}

#
# dragableCard
#
proc defaultDragableCardPress {itemId w x y} {
	global table items

	$table(preActionProc) dragPress
	set table(dragging) 1

	unhilightCard $itemId $w $x $y

	$w dtag selected
	$w addtag selected withtag $itemId
	set friends [$items($itemId,dragFindFriendsProc) $itemId $w $x $y $items($itemId,dragFindFriendsClosure)]
	set table(dragFriends) $friends
	# NEEDSWORK: Tk3.2 bug.  We shouldn't have to loop here, but
	# it seems that "$w addtag selected withtag $friends"
	# just adds one of the list.
	foreach i $friends {
		$w addtag selected withtag $i
	}
	$w raise selected
	set table(dragLastX) $x
	set table(dragLastY) $y
	set table(dragLastHit) {}
	set startXY [lrange [$w bbox $itemId] 0 1]
	set table(dragInitialX) [lindex $startXY 0]
	set table(dragInitialY) [lindex $startXY 1]
}
proc defaultDragableCardMove {itemId w x y} {
	global table items
	# debugLog "defaultDragableCardMove $itemId $w $x $y"
	$w move selected [expr $x-$table(dragLastX)] [expr $y-$table(dragLastY)]
	set table(dragLastX) $x
	set table(dragLastY) $y

	set hit [checkForDropableHit $itemId $w]
	if { $hit != $table(dragLastHit) } {
		if { $table(dragLastHit) != {} } {
			$items($table(dragLastHit),dragTargetLeaveProc) $itemId $w $x $y $table(dragLastHit)
		}
		if { $hit != {} } {
			$items($hit,dragTargetEnterProc) $itemId $w $x $y $hit
		}
		set table(dragLastHit) $hit
	}
}

proc checkForDropableHit { itemId w } {
	global table items

	#
	# Check for hit over possible dropableCard.
	#
	set bbox [$w bbox $itemId]
	set bbox_t [expr [lindex $bbox 0]+$table(cardOverlap)]
	set bbox_l [expr [lindex $bbox 1]+$table(cardOverlap)]
	set bbox_b [expr [lindex $bbox 2]-$table(cardOverlap)]
	set bbox_r [expr [lindex $bbox 3]-$table(cardOverlap)]
	set hits [$w find overlapping $bbox_t $bbox_l $bbox_b $bbox_r]
	#
	# Go through the list of hits
	# (in reverse order---we assume the list is sorted back-to-front).
	# Quit if we get a good hit.
	#
	foreach hit [lreverse $hits] {
		#
		# Now check to see if we're over a dropableCard.
		# (Sigh, there doesn't seem any way to query the tags
		# of an object.)
		#
		if { ([string match $items($hit,dragTargetAcceptGlob) $items($itemId,subtype)] == 0) } { continue }
		if { [$items($hit,dragTargetAcceptProc) $w $hit $itemId $table(dragFriends)] } {
			# puts stderr "$itemId: $items($itemId,cardVS),$table(selectedCount) matches $hit: $table($hit,dropAccepts) of $hits"
			return $hit;
		}
	}
	return {}
}

proc defaultDragableCardRelease {itemId w x y} {
	global items table
	# debugLog "defaultDragableCardRelease $itemId $w $x $y"
	# Dropping the card somewhere?
	if { $table(dragLastHit) != {} } {
		# yes
		$items($table(dragLastHit),dragTargetLeaveProc) $itemId $w $x $y $table(dragLastHit)
		playCardOnCard $w $itemId $table(dragFriends) $table(dragLastHit)
	} elseif { $table(dragging) != 0 } {
		# no, send it home
		originalPlaceDragProc $itemId $w $x $y selected {}
	}
	# Redo the hilighting.
	checkHilighting $w $x $y
}


#
# playCardOnCard
#
proc playCardOnCard {w top topFriends newBottom} {
	global items
	#
	# debugLog "playCardOnCard $w $top $topFriends $newBottom"
	set oldBottom $items($top,parent)
	if { $oldBottom != {} } {
		$items($oldBottom,orphanChildProc) $w $oldBottom $top $topFriends $items($oldBottom,orphanChildClosure)
	}
	# 2. Connect top to bottom.
	$items($newBottom,adoptChildProc) $w $newBottom $top $topFriends $items($newBottom,adoptChildClosure)
}

#
# Unconditional position card on another card.
#
proc moveCardOnCard {w top bottom args} {
	global items

	# debugLog "moveCardOnCard $w $top $bottom $args"
	if {[llength $args] == 0} {
		set topTag $top
	} else {
		set topTag [lindex $args 0]
	}

	set oldCoords [$w coords $top]
	set bottomCoords [$w bbox $bottom]
	set bottomOffset [$items($bottom,childOffsetProc)]
	moveAllRelatively $w $topTag \
		[lindex $oldCoords 0] [lindex $oldCoords 1] \
		[expr [lindex $bottomCoords 0]+[lindex $bottomOffset 0]] \
		[expr [lindex $bottomCoords 1]+[lindex $bottomOffset 1]]

	$w raise $top
}


proc moveAllRelatively { w items oldX oldY newX newY } {
	# debugLog "moveAllRelatively $w $items $oldX $oldY $newX $newY"
	$w move $items [expr $newX-$oldX] [expr $newY-$oldY]
}


proc figureNextValue {oldValue inc} {
	global table
	return [string index $table(cvalues) \
			[expr [string first $oldValue $table(cvalues)]+$inc]]
}

proc globNextLowerOtherColor {vs} {
	global table

	set v [string index $vs 0]
	set s [string index $vs 1]

	return "[figureNextValue $v -1]\[$table(otherColorSuits,$s)\]"
}

proc lreverse {lin} {
	set lout {}
	for {set i [expr [llength $lin]-1]} { $i >= 0 } {incr i -1} {
		lappend lout [lindex $lin $i]
	}
	return $lout
}

proc obscureTable {} {
	global table
	set w $table(id)
	$w create rectangle 0 0 $table(width) $table(height) \
		-fill $table(bg) -tag pauseItems
	$w create text [expr $table(width)/2] [expr $table(height)/2] \
			-anchor center -fill $table(fg) \
			-text "Game paused.\nClick to continue." \
			-tag pauseItems
}

proc unobscureTable {} {
	global table
	$table(id) delete pauseItems
}