#!/usr/dist/bin/wishx -f

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

set rcsid(dontspaceRules.tcl) {$Id: dontspaceRules.tcl,v 2.16 1997/03/26 17:46:26 johnh Exp $}



proc main {} {
	global game table tk_version argv

	source "$game(sourcedir)/table.tcl"
	source "$game(sourcedir)/score.tcl"
	source "$game(sourcedir)/help.tcl"
	source "$game(sourcedir)/dontspaceMenus.tcl"

	if {$tk_version < 4.0} {
		bind . <Any-Enter> {focus [focus default]}
	}
	mkTableDefaults
	if {[winfo screenheight .] < 600} {
		set table(gutter) 10
		set table(stackedCardOffset) 20
	}

	set game(numTableColumns) 8
	set game(zeroBasedList) {0 1 2 3 4 5 6 7 8 9 10 11 12}
	set game(tableList) [lrange $game(zeroBasedList) \
			0 [expr $game(numTableColumns)-1]]

	set game(foundationList) {0 1 2 3}
	set game(spaceList) {0 1 2 3}

	set game(scoreMethod) official
	set game(randomSeed) {}
	set game(presetRandomSeed) {}

	set cardWidth $game(numTableColumns)
	if { $cardWidth < 9 } { set cardWidth 9 }
	# Largest table is
	set tableWidth  [expr $cardWidth*$table(cardWidth)+$cardWidth*$table(gutter) ]
	# Longest possible chain of cards: 7 card start w/a king on the bottom
	# + 13 cards down from the king.  This configuration is extremely
	# unlikely and makes the table *way* too big for normal play.
	# As a compromise we allow 15 stacked cards.
	set tableHeight [expr 2*$table(cardHeight)+3.5*$table(gutter)+14*$table(stackedCardOffset) ]

	set game(tableW) [mkTable $tableWidth $tableHeight gamePreActionProc]
	set game(menuW) [mkMenus]
	mkMenuBindings -default $game(tableW)

	pack $game(menuW) -side top -fill x
	pack $game(tableW) -side bottom -fill x
	update idletasks

	# fixed stuff
	mkUnchangingItems

	# Score stuff
	mkScore $game(tableW) "dontspace" \
		[expr $table(gutter)+4*($table(cardWidth)+$table(gutter))] \
		$table(gutter) game(scoreMethod)

	# a game
	if {[llength $argv] <= 0} {
		mkNewGame
	} else {
		set seed [lindex $argv 0]
		# puts "Old game key $seed."
		mkOldGame $seed
	}
}

proc mkUnchangingItems {} {
	global game table

	set w $game(tableW)
	set game(status) building

	mkDeck
	mkBindings $w

	# spaces
	foreach i $game(spaceList) {
		set game(spaceId,$i) [createItemBitmap \
			[expr $table(gutter)+$i*($table(cardWidth)+$table(gutter))] \
			$table(gutter) "space"]
	}

	# foundation
	foreach i $game(foundationList) {
		set game(foundationId,$i) [createItemBitmap \
			[expr $table(gutter)+(5+$i)*($table(cardWidth)+$table(gutter))] \
			$table(gutter) "space"]
	}

	# table
	set offset 0
	if { $game(numTableColumns) <= 8 } { set offset 0.5 }
	foreach i $game(tableList) {
		set game(tableId,$i) [createItemBitmap \
			[expr $table(gutter)+($i+$offset)*($table(cardWidth)+$table(gutter))] \
			[expr 2.5*$table(gutter)+$table(cardHeight)] "space"]
	}

	# Make the notice text.
	set game(noticeId) [$game(tableW) create text \
			    [expr 4*($table(cardWidth)+$table(gutter))] \
			    [expr 3.5*($table(cardHeight)+$table(gutter))] \
			    -anchor c -font $table(font) ]
	tableRegisterDumbItem $game(noticeId)
	setNoticeText "\n\n\n\n\n\n\n\n\n\nPlease wait, starting game..."
	set game(initialNoticeText) "\n\n\n\n\n\n\n\n\n\nCheck the ``Help'' menu\nin the upper-right\ncorner for game rules.\nClick on a card to start the game."
	# Start the decay daemon.
	set game(scoreDecayDelay) 15000
	decayScore $game(scoreDecayDelay)

	update idletasks
}

proc setNoticeText {text} {
	global game
	$game(tableW) itemconf $game(noticeId) -text $text
	$game(tableW) raise $game(noticeId)
}

proc decayScore {delay} {
	global game
	if { $game(status) == "running" } {
		incrScore -2
	}
	after $delay "decayScore $delay"
}

proc mkNewGame {} {
	global deck game

	set game(status) dealing

	set w $game(tableW)

	# Get a unique random number.
	if { $game(presetRandomSeed) != {} } {
		set game(randomSeed) $game(presetRandomSeed)
		set randomNotice " (for game ``$game(presetRandomSeed)'')"
		set game(presetRandomSeed) {}
	} else {
		set game(randomSeed) [mkRandomSeed]
		set randomNotice ""
	}
	setRandomSeed $game(randomSeed)
	shuffleDeck

	mkNewScore
	setScoreMessage "Good\nluck!"
	setNoticeText "\n\n\n\n\n\n\n\n\n\nDealing cards${randomNotice}..."
	set game(cardsToPlay) 52
	set game(moveCount) 0

	initSpaceAvailability
	# spaces
	foreach i $game(spaceList) {
		setCard $w $game(spaceId,$i) -default -type place \
			-location space -sublocation $i \
			-dragTargetAcceptGlob {??} \
			-dragTargetAcceptProc singleOnlyAcceptProc \
			-adoptChildProc spaceAdoptChild \
			-orphanChildProc spaceOrphanChild
		makeSpaceAvailable $w $game(spaceId,$i)
	}

	# foundation
	foreach i $game(foundationList) {
		setCard $w $game(foundationId,$i) -default -type place \
			-location foundation -sublocation $i \
			-dragTargetAcceptGlob {a?} \
			-dragTargetAcceptProc singleOnlyAcceptProc \
			-adoptChildProc foundationAdoptChild
		set game(foundationTopId,$i) $game(foundationId,$i)
	}

	# table
	foreach i $game(tableList) {
		setCard $w $game(tableId,$i) -default -type place \
			-location table -sublocation $i \
			-dragTargetAcceptGlob {??} \
			-dragTargetAcceptProc tableSpaceAcceptProc \
			-adoptChildProc tableAdoptChild \
			-orphanChildProc tableSpaceOrphanChild
		makeSpaceAvailable $w $game(tableId,$i)
	}

	# deal the cards
	dirtyTableDragability disable
	foreach column $game(tableList) {
		set lastCard($column) $game(tableId,$column)
	}
	set column -1
	foreach id $deck {
		set column [expr ($column+1)%$game(numTableColumns)]
		if {$column == 0} { update idletasks }

		setCard $w $id \
			-default \
			-side face \
			-doubleClickProc cardDoubleClick \
			-numChildren 0

		# place the card on the table
		playCardOnCard $w $id {} $lastCard($column)

		set lastCard($column) $id
	}

	# Recompute time to win.
	set game(status) thinking
	set game(dragableCards) ""
	set game(cardsLeftToDrag) 52

	dirtyTableDragability enable
	dirtyTableDragability all
	fixTableDragability $w
	enablePatternDoubleClicking $w {a?}

	setNoticeText $game(initialNoticeText)
	set game(initialNoticeText) ""

	set game(status) beginable
}

proc dirtyTableDragability {which} {
	global game
	switch -exact $which {
	"disable" { set game(dragability) 0 }
	"enable" { set game(dragability) 1 }
	"all" {
		foreach column $game(tableList) {
			set game(columnDragabilityDirty,$column) 1
		}
	}
	"count" {
		set game(countDirty) 1
		}
	default {
		set game(columnDragabilityDirty,$which) 1
	}
	}
}


proc fixTableDragability {w} {
	global game

	if { !$game(dragability) } { return }

	# This is kind of slow so make sure the user has something to look at.
	update idletasks

	# First build up a list of each table.
	foreach column $game(tableList) {
		if { $game(columnDragabilityDirty,$column) } {
			fixTableColumnDragability $w $column
			set game(columnDragabilityDirty,$column) 0
		}
	}
	# Now enable the correct cards to correct for a count failure.
	if { $game(movableChildCount) > $game(oldMovableChildCount) } {
		changeChildCountDragability $w -atag [lrange $game(zeroBasedList) $game(oldMovableChildCount) $game(movableChildCount)]
	} elseif { $game(movableChildCount) < $game(oldMovableChildCount) } {
		changeChildCountDragability $w -dtag [lrange $game(zeroBasedList) [expr $game(movableChildCount)+1] $game(oldMovableChildCount)]
	}
	set game(oldMovableChildCount) $game(movableChildCount)
	set game(countDirty) 0
}

proc changeChildCountDragability {w action list} {
	foreach i $list {
		foreach id [$w find withtag "${i}child"] {
			# puts "$id $action dragableCard"
			setCard $w $id $action dragableCard
		}
	}
}

proc fixTableColumnDragability {w column} {
	global game

	set columnCards [figureColumnCards $game(tableW) $game(tableId,$column)]
	set seq [lreverse [leftmostGoodSubsequence $w $columnCards]]
	set i 0
	foreach id $seq {
		set oldI [getCard $w $id -numChildren]
		setCard $w $id \
			-dtag "${oldI}child" \
			-atag "${i}child" \
			-numChildren $i
		if { $i <= $game(movableChildCount) } {
			setCard $w $id \
				-atag dragableCard
			addCardToDragableList $id
		} else {
			setCard $w $id \
				-dtag dragableCard
		}
		incr i
	}
}

proc figureColumnCards {w id} {
	set l {}
	# Intentionally skip the first card, it's the table card.
	set id [getCard $w $id -child]
	while {$id != {}} {
		lappend l $id
		set id [getCard $w $id -child]
	}
	return $l
}

proc leftmostGoodSubsequence {w seq} {
	set seql [llength $seq]
	if { $seql <= 1 } {
		return $seq
	} else {
		set car [lindex $seq 0]
		set cadr [lindex $seq 1]
		set cdr [lrange $seq 1 end]
		set goodsubseq [leftmostGoodSubsequence $w $cdr]
		if { $cdr == $goodsubseq && \
			[string match [globNextLowerOtherColor \
						[getCard $w $car -subtype]] \
					[getCard $w $cadr -subtype]]} {
			return $seq
		} else {
			return $goodsubseq
		}
	}
}


proc fixCardDoubleClickability {w id} {
	# Adjust double-clickablility.
	if { [foundationAccepts $w $id] != {} } {
		setCard $w $id \
			-atag doubleClickableCard
	}
}


proc enablePatternDoubleClicking {w pattern} {
	if { $pattern == {a?} } {
		foreach vs {ac ad ah as} {
			enableVsDoubleClicking $w $vs
		}
	} elseif { [string match {x?} $pattern] == 0 } {
		enableVsDoubleClicking $w $pattern
	}
}

proc enableVsDoubleClicking {w vs} {
	set id [rememberCard $vs]
	if { [getCard $w $id -child] == {} } {
		setCard $w $id \
			-atag doubleClickableCard
	}
}

proc singleOnlyAcceptProc {w target src srcFriends} {
	# debugLog "singleOnlyAcceptProc $w $target $src $srcFriends"
	if { [llength $srcFriends] != 0 } {
		return 0
	} else {
		return 1
	}
}

proc tableSpaceAcceptProc {w target src srcFriends} {
	# debugLog "tableSpaceAcceptProc $w $target $src $srcFriends"
	if {[dangerousMove $w $target $src $srcFriends]} {
		return 0
	} else {
		return 1
	}
}

proc spaceAdoptChild {w target src srcFriends closure} {
	# debugLog "spaceAdoptChild $w $target $src $srcFriends"
	global game

	if { [llength $srcFriends] != 0} {
		error "spaceAdoptChild: child with friends"
	}
	# Disable the space.
	setCard $w $target \
		-dragTargetAcceptGlob {} \
		-child $src
                                                                                      	# Move the child.
	moveCardOnCard $w $src $target
	# Make the child outlineable and dragable.
	setCard $w $src \
		-location space \
		-sublocation [getCard $w $target -sublocation] \
		-parent $target \
		-orphanChildProc spaceOrphanChild \
		-atag dragableCard
	addCardToDragableList $src

	# All dragability must change.
	makeSpaceUnavailable $w $target
	dirtyTableDragability count
	fixTableDragability $w

	checkForWin
}

proc spaceOrphanChild {w target src srcFriends closure} {
	# debugLog "spaceOrphanChild $w $target $src $srcFriends"
	global game

	# Enable the space.
	setCard $w $target \
		-dragTargetAcceptGlob {??} \
		-child {}
	# All dragability must change.
	makeSpaceAvailable $w $target
	dirtyTableDragability count
}

proc foundationAdoptChild {w target src srcFriends closure} {
	global game

	# debugLog "foundationAdoptChild $w $target $src $srcFriends $closure"
	if { [llength $srcFriends] != 0} {
		error "foundationAdoptChild: child with friends"
	}
	# Disable the foundation.
	setCard $w $target \
		-dragTargetAcceptGlob {} \
		-child $src
	# Move the child.
	# debugLogPause "foundationAdoptChild: moveCardOnCard $w $src $target"
	moveCardOnCard $w $src $target

	# Make the child accept the next card and otherwise unusable.
	set vs [getCard $w $src -subtype]
	set v [string index $vs 0]
	set s [string index $vs 1]
	set newV [figureNextValue $v 1]
	set column [getCard $w $target -sublocation]
	# debugLogPause "foundationAdoptChild: setCard (colmn: $column)"
	setCard $w $src \
		-location foundation \
		-sublocation $column \
		-dragTargetAcceptGlob "$newV$s" \
		-adoptChildProc foundationAdoptChild \
		-childOffsetProc samePlaceChildOffsetProc \
		-dtag dragableCard \
		-dtag doubleClickableCard
	unhilightCard $src $w {} {}
	# Indicate the new top.
	set game(foundationTopId,$column) $src

	# Score the points
	incrScore 10

	# Change dragability, possibly making more cards double clickable.
	fixTableDragability $w
	# debugLogPause "foundationAdoptChild: enablePatternDoubleClicking"
	enablePatternDoubleClicking $w "$newV$s"

	# Finally, check for win.
	incr game(cardsToPlay) -1
	checkForWin
}

# Return foundation id that will accept this card or nil.
proc foundationAccepts {w id} {
	global game

	set vs [getCard $w $id -subtype]

	foreach i $game(foundationList) {
		set targetId $game(foundationTopId,$i)
		set targetGlob [getCard $w $targetId -dragTargetAcceptGlob]
		if { [string match $targetGlob $vs] } {
			return $targetId
		}
	}
	return {}
}

proc tableAdoptChild {w target src srcFriends closure} {
	global game

	# debugLog "tableAdoptChild $w $target $src $srcFriends"
	if { [llength $srcFriends] != 0} {
		moveMultipleCards $w $target $src $srcFriends $closure
		return
		# error "tableAdoptChild: child with friends $srcFriends: [llength $srcFriends]"
	}
	# Disable the table, but give it children
	setCard $w $target \
		-dragTargetAcceptGlob {} \
		-dragFindFriendsClosure $src \
		-dtag doubleClickableCard \
		-dtag dragableCard \
		-child $src
	set column [getCard $w $target -sublocation]
	# Move the child.
	moveCardOnCard $w $src $target
	# Make the child accept the next card.
	setCard $w $src \
		-location table \
		-sublocation $column \
		-parent $target \
		-dragTargetAcceptGlob [globNextLowerOtherColor [getCard $w $src -subtype]] \
		-adoptChildProc tableAdoptChild \
		-childOffsetProc offsetChildOffsetProc \
		-orphanChildProc tableCardOrphanChild \
		-atag dragableCard
	addCardToDragableList $src
	# Adjust dragability.
	if { [getCard $w $target -parent] == {} } {
		makeSpaceUnavailable $w $target
	}
	dirtyTableDragability $column
	fixTableDragability $w

	checkForWin
}

proc tableSpaceOrphanChild {w target src srcFriends closure} {
	global game

	# debugLog "tableSpaceOrphanChild $w $target $src $srcFriends $closure"
	# Enable the table.
	setCard $w $target \
		-dragTargetAcceptGlob {??}
	tableOrphanChild $w $target $src $srcFriends $closure
	# All dragability must change.
	makeSpaceAvailable $w $target
	dirtyTableDragability count
}

proc tableCardOrphanChild {w target src srcFriends closure} {
	# Enable the table.
	setCard $w $target \
		-dragTargetAcceptGlob [globNextLowerOtherColor [getCard $w $target -subtype]] \
		-atag dragableCard
	addCardToDragableList $target
	tableOrphanChild $w $target $src $srcFriends $closure
	# Some dragability must change.
	dirtyTableDragability [getCard $w $target -sublocation]
	# And double-clickability.
	fixCardDoubleClickability $w $target
}

proc tableOrphanChild {w target src srcFriends closure} {
	# debugLog "tableOrphanChild $w $target $src $srcFriends $closure"
	# The target no longer has a friend.
	setCard $w $target \
		-dragFindFriendsClosure {} \
		-child {}
	# Undo stuff to the child.
	set childNumChildren [getCard $w $src -numChildren]
	setCard $w $src \
		-location {} \
		-parent {} \
		-dragTargetAcceptGlob {} \
		-adoptChildProc error \
		-childOffsetProc error \
		-dtag dragableCard \
		-dtag ${childNumChildren}child
	# And any friends.
	foreach id $srcFriends {
		set childNumChildren [getCard $w $src -numChildren]
		setCard $w $src \
			-dtag ${childNumChildren}child
	}
}

proc cardDoubleClick {itemId w x y closure} {
	# debugLog "cardDoubleClick $itemId $w $x $y $closure"
	set target [foundationAccepts $w $itemId]
	if { $target == {} } {
		error "cardDoubleClick: double-click on card with no viable destination."
	}
	playCardOnCard $w $itemId {} $target
}


proc gamePreActionProc {action} {
	global game
	if { $action != "dragPress" } { return }
	if { $game(status) == "beginable" } {
		beginGame
	}
}

proc beginGame {} {
	global game

	if { $game(status) != "beginable" } { return }

	set game(status) running
	setScoreMessage ""
	setNoticeText ""

	# Remember when we started for the possible winning bonus.
	set game(startTime) [getclock]
	set game(pauseTime) 0

	beginGameChangeMenus
}

proc endGame {how} {
	global game

	if { $game(status) == "paused" } { unpauseGame }
	if { $game(status) != "running" } { return }

	set game(status) stopped
	set game(endTime) [getclock]
	set timeDelta [expr $game(endTime)-$game(startTime)]
	if { $how == "win" } {
		set bonusDelta [expr ([getScore]-$game(moveCount))*10]
		setScoreMessage "You\nwon!"
	} else {
		set bonusDelta 0
		setScoreMessage "Game\nover."
		
	}
	# Can't loose in bonus.
	if { $bonusDelta < 0 } { set bonusDelta 0 }
	# To track potential bonus bugs, squirrel away these values.
	set game(timeDelta) $timeDelta
	set game(bonusDelta) $bonusDelta
	incrScore $bonusDelta
	set timeMinutes [format "%d" [expr int($timeDelta/60)]]
	set timeSeconds [expr $timeDelta % 60]
	setNoticeText "Time: $timeMinutes:$timeSeconds\nMoves: $game(moveCount)\nBonus: $bonusDelta\nGame seed (for replay): $game(randomSeed)"

	registerNewScore
	if { $game(scoreMethod) == "unofficial" } {
		set game(scoreMethod) official
	}
	endGameChangeMenus
}

proc addCardToDragableList {id} {
	global game

	if { $game(status) == "building" || $game(status) == "dealing" } { return }
	if { [lsearch -exact $game(dragableCards) $id] == -1 } {
		lappend game(dragableCards) $id
		incr game(cardsLeftToDrag) -1
		setScoreMessage "To go: $game(cardsLeftToDrag)"
	}
}


proc checkForWin {} {
	global game

	if { $game(status) != "running" } { return }
	incr game(moveCount)
	if { ($game(cardsLeftToDrag) <= 0 && $game(scoreMethod) != "non-scoring")
			|| ($game(cardsToPlay) <= 0)} {
		endGame win
	}
}


#
######################################################################
#
# Code to automatically move card stacks around.
#
# External interfaces are marked proc's and
# the variables game(movableChildCount)
#
#

proc dangerousMove {w target src srcFriends} {
	global game

	# Check to make sure we're not moving to a space
	# with too many cards.
	if { [lsearch -exact $game(freeSpaces) $target] != -1} {
		if { [llength $srcFriends] >= $game(movableChildCount) } {
			# Too many things.  Abort.
			return 1
		}
	}
	return 0
}

# external
proc moveMultipleCards {w target src srcFriends closure} {
	# Sigh.  This would be more elegant if it were recursive.
	global game

	if {[dangerousMove $w $target $src $srcFriends]} {
		error "moveMultipleCards: dangerousMove"
	}

	set spaces $game(freeSpaces)
	set srcFriendsLen [llength $srcFriends]

	if { $srcFriendsLen  > [llength $spaces] } {
		error "moveMultipleCarsd: out of spaces"
	}

	dirtyTableDragability disable

	# Move the friends to the spaces temporarily.
	for {set i [expr $srcFriendsLen-1]; set j 0} \
				{ $i >= 0 } {incr i -1; incr j} {
		set tmpTarget [lindex $spaces $j]
		if { $tmpTarget == $target } {
			incr j
			set tmpTarget [lindex $spaces $j]
		}
		if { $tmpTarget == {} } {
			error "moveMultipleCards: out of spaces (in-process)"
		}
		playCardOnCard $w [lindex $srcFriends $i] {} $tmpTarget
		update idletasks
	}

	# Move the src to its final resting place.
	# (We don't do the whole move because half of it is already done.)
	tableAdoptChild $w $target $src {} $closure
	update idletasks

	# Move the friends under the src.
	set nextTarget $src
	for {set i 0} { $i < $srcFriendsLen } {incr i} {
		set nextSrc [lindex $srcFriends $i]
		playCardOnCard $w $nextSrc {} $nextTarget
		set nextTarget $nextSrc
		update idletasks
	}

	# Dropability.
	dirtyTableDragability enable
	dirtyTableDragability [getCard $w $target -sublocation]
	fixTableDragability $w
}

# external
proc makeSpaceAvailable {w id} {
	global game

	lappend game(freeSpaces) $id
	set game(freeSpaces) [lsort -integer $game(freeSpaces)]
	incr game(movableChildCount)
}

# external
proc makeSpaceUnavailable {w id} {
	global game
	set i [lsearch -exact $game(freeSpaces) $id]
	if { $i == -1 } { error "makeSpaceUnavailable: missing id <$id>" }
	set game(freeSpaces) [lreplace $game(freeSpaces) $i $i]
	incr game(movableChildCount) -1
}

# external
proc initSpaceAvailability {} {
	global game
	set game(movableChildCount) 0
	set game(freeSpaces) {}
	set game(oldMovableChildCount) 0
}

