#!/bin/sh # Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \ exec wish $0 ${1+"$@"}
# Spider Solitaire, based on the card-game shipped with Windows XP # Mike Griffiths, April 25th 2004 # Some code, and the card images, taken from Jeff Godrey's # "Once in a Lifetime", at http://wiki.tcl.tk/11193
# History: # 2005-07-28 "set y 470" - to prevent collisions with long stacks of cards, # moved 'extra cards' and discard-pile to align with score-box. # 2005-07-29 "set data(playing) 1" - corrected Status for 'game in progress', # to allow bypassing confirmations (new game, quit program). # 2005-08-29 moved cards to card_img.tcl
package require Tk
set app(name) "Mike's Spider Solitaire" set app(version) "3.5" set app(date) "Aug 29th 2004" set app(author) "Mike Griffiths" set app(email) "[email protected]"
set data(cheating) 0 set data(playing) 0 set data(suits) 1 set data(moves) 0 set data(clears) 0 set data(score) 500 set data(undo) {} set data(goodmoves) {} set data(newdecks) {} set data(drag,bad) 0 set data(showingmove) 0 set animatetype 1 set data(dealing) 1 set data(alldeals) 0 set data(numnewgames) 0
for {set i 1} {$i <= 10} {incr i} {
set data(col$i) [expr {10 + (78 * ($i - 1))}]
set data(col$i,cards) {}
}proc chkExit {} {
global app data
if { !$data(playing) || [tk_messageBox -icon question -title $app(name) -type yesno \
-message "Do you really want to exit?"] == "yes" } {
exit;
}};# chkExit
proc move {c item tox toy {time 25} {steps 1}} {
scan [$c coords $item] "%s %s" origx origy
set diffx [expr {abs($origx-$tox)}]
set diffy [expr {abs($origy-$toy)}]
if { $diffx > $diffy } {
set stepy [expr {$steps*1}]
if { [expr { round(ceil($diffx + $diffy))}] == "0" } {
set stepx 0
} else {
set stepx [expr {$steps*(double($diffx) / $diffy)}]
}
} else {
set stepx [expr {$steps*1}]
if { [expr {round(ceil($diffx+$diffy))}] == "0" } {
set stepy 0
} else {
set stepy [expr {$steps*(double($diffy) / $diffx)}]
}
}
set dirx ">" ; set diry ">"
if { $origx > $tox } {
set stepx [expr {$stepx*-1}] ; set dirx "<"
}
if { $origy > $toy } {
set stepy [expr {$stepy*-1}] ; set diry "<"
}
while {1} {
scan [$c coords $item] "%s %s" nowx nowy
if { $stepx == 0 && $stepy == 0} {return;}
if { [expr {round(ceil($nowx-$tox))}] == 0 } {
set stepx 0
} elseif " [expr {$nowx+$stepx}] $dirx $tox " {
set stepx [expr {$tox-$nowx}]
}
if { [expr {round(ceil($nowy-$toy))}] == 0 } {
set stepy 0
} elseif " [expr {$nowy+$stepy}] $diry $toy " {
set stepy [expr {$toy-$nowy}]
}
$c move $item $stepx $stepy
update idletasks
after $time
}};# move
proc main {} {
global app data
menu .m -tearoff 0
. configure -menu .m
menu .m.file -tearoff 0
menu .m.help -tearoff 0
.m add cascade -label "File" -menu .m.file -underline 0
.m add command -label "Deal!" -command {dealRow} -underline 0
.m add cascade -label "Help" -menu .m.help -underline 0
.m.file add command -label "New Game" -command newGame \
-accelerator "F2" -underline 0
.m.file add command -label "Restart This Game" -command "newGame 1" \
-accelerator "F5" -underline 0
.m.file add separator
.m.file add command -label "Undo" -command undoMove \
-accelerator "Cntrl+Z" -underline 0
.m.file add command -label "Deal New Row" -command dealRow \
-accelerator "D" -underline 0
.m.file add command -label "Show An Available Move" \
-command showGoodMoves -accelerator M -underline 18
.m.file add separator
.m.file add command -label "Difficulty..." -command setDiff \
-accelerator "F3" -underline 0
.m.file add separator
.m.file add command -label "Exit" -command chkExit -underline 1
.m.help add command -label "Rules" -command showRules -underline 0 -accelerator "F1"
.m.help add separator
.m.help add command -label "About..." -command aboutSS -underline 0
.m.help add separator
.m.help add command -label "Show Console" -command {console show} -underline 0
canvas .c -bg darkgreen -borderwidth 0 -highlightthickness 0
.c bind card <ButtonPress-3> {set ::data(belowCard) [.c find above \
[set ::data(raiseCard) [.c find closest %x %y]]] ; .c raise $::data(raiseCard)}
.c bind card <ButtonRelease-3> {.c lower $::data(raiseCard) $::data(belowCard)}
.c bind topcard <ButtonPress-1> [list dragStart %x %y]
.c bind topcard <B1-Motion> [list dragging %x %y]
.c bind topcard <ButtonRelease-1> [list dragEnd %x %y]
.c bind newdeck <ButtonPress-1> "dealRow"
bind . <Control-Alt-c> cheat
bind . <F1> {showRules}
bind . <F2> {newGame}
bind . <F3> {setDiff}
bind . <F5> {newGame 1}
bind . <KeyPress-m> {showGoodMoves}
bind . <Control-z> {undoMove}
pack .c -expand 1 -fill both
#wm geometry . 800x550
wm geometry . 800x600
wm title . "$app(name) Version $app(version)"
wm protocol . WM_DELETE_WINDOW chkExit
catch {wm iconbitmap . -default ./16.ico}
#catch {wm state . zoomed}
frame .c.f -height 100 -width 200 -bg #000088880000 \
-highlightthickness 2 -highlightbackground black \
-highlightcolor black
place .c.f -in .c -relx .5 -rely 1 -x -100 -y -125
label .c.f.l -text "Score: < Not Playing >\nMoves: < Not Playing>" \
-foreground white -font [list Arial 10 bold] -bg #000088880000
place .c.f.l -in .c.f -relx .5 -rely .5 \
-x -[expr {[winfo reqwidth .c.f.l]/2}] -y -[expr {[winfo reqheight .c.f.l]/2}]
bind .c.f <ButtonPress-1> {showGoodMoves}
bind .c.f.l <ButtonPress-1> {showGoodMoves}
if { [package vsatisfies $::tk_version 8.4] } {
trace add variable data(score) write setBoard
trace add variable data(moves) write setBoard
trace add variable data(undo) write chkUndos
interp alias {} lsearchall {} lsearch -all
} else {
trace variable data(score) w setBoard
trace variable data(moves) w setBoard
trace variable data(undo) w chkUndos
proc lset {var at with} {
upvar $var upd
set upd [lreplace $upd $at $at $with]
};# lset
proc lsearchall {args} {
set ret {}
if { [llength $args] > 2 } {
set op [lindex $args 0]
set list [lindex $args 1]
set find [lindex $args 2]
} else {
set op "-glob"
set list [lindex $args 0]
set find [lindex $args 1]
}
for { set i 0 } { $i<[llength $list] } {incr i} {
if { [lsearch $op [list [list "[lindex $list $i]"]] [list $find]] != "-1" } {
lappend ret $i
}
}
return $ret;
};# lsearchall
}
focus -force .c
if { [info commands console] == "" } {
proc console {{args ""}} {
tk_messageBox -icon info -title $app(name) \
-message "The Console is not available on this Operating System."
}
}
for {set i 1} {$i <= 10} {incr i} {
makeTray $i
}
dealRow 10 -1 0 0};# main
proc aboutSS {} {
global app
set text "$app(name) is a version of the 'Spider Solitaire' game shipped with MS Windows XP, written in Tcl/Tk. It was last updated on $app(date), and is at version $app(version).\n\nCode by $app(author) (email: $app(email)), with some code (and card images) taken from the game 'Once in a Lifetime', by Jeff Godrey."
tk_messageBox -icon info -title "About $app(name) Version $app(version)" \
-message $text};# aboutSS
proc showRules {} {
global app
set w .rules
if { [winfo exists $w] } {
wm deiconify $w
raise $w
focus $w
return;
}
toplevel $w
wm title $w "$app(name) - Rules"
frame $w.f
text $w.f.t -wrap word
scrollbar $w.f.sb
$w.f.t configure -yscrollcommand "$w.f.sb set"
$w.f.sb configure -command "$w.f.t yview"
$w.f.t tag configure head -font {{} 20 bold} -justify center
$w.f.t tag configure sub -font {{} 16 italic} -justify center
$w.f.t insert end "$app(name)\n" head
$w.f.t insert end "Version $app(version) - Rules\n\n" sub
$w.f.t insert end "$app(name)'s rules are almost identical to those of Spider Solitaire, shipped with MS Windows XP. There are ten columns of cards, made up of either 1, 2, or 4 different suits (this can be changed in File->Difficulty). The aim of the game is to remove all the cards from the ten stacks at the top in as few moves as possible.\n\nTo remove cards from the ten stacks, move the cards from one column to another until you line up a suit of cards in order from king to ace (this is a 'stack'). When you line up a complete suit, those cards are removed. You can only move a card if it has no cards below it, or the cards below it form a 'stack' (for example, you can move a 5 of Hearts only if there are no cards below it, or the card below it is the 4 of Hearts. The same applies again; there must be no cards on the 4, or it must be a 3 of Hearts, etc.) When a stack is lined up of a complete suit, it is removed from the table.\n\nYou can stack a card onto one of another suit, as long as its value is one higher (six of Spades on a seven of Hearts, etc). However, the higher card is frozen in place then, because the stack below it doesn't match suit.\n\nIf there are no moves available, click on the extra cards in the bottom-right once; this will deal a new row. You can see if there are any available moves by clicking the Score Card (the box in the bottom-center of the screen, showing the score and number of moves.). When all the cards are removed, the game has been won.\n\nSCORING:\nYou start the game with 500 points. Every time you move a card (or undo), you lose one point. Dealing a row does not cost any points. You gain 100 points for every stack you successfully clear.\n\nUNDO:\nYou can undo your last move (by selecting 'Undo' in the File menu or pressing Control+Z), as long as your last move was not dealing a new row or removing a stack.\n\nDIFFICULTUES:\nThere are three difficulties (you can change which you're using by pressing F3, or via the File menu); the difficulties are Easy (1 suit), Medium (2 suits), or Hard (4 suits).\n\nCREDITS:\nWritten by $app(author) ($app(email)), with some code by Jeff Godfrey's \"Once in a Lifetime\" card-game, which can be found at: http://wiki.tcl.tk/11193"
$w.f.t configure -state disabled
pack $w.f -side top -expand 1 -fill both
pack $w.f.t -side left -expand 1 -fill both
pack $w.f.sb -side right -fill y
frame $w.f2
pack $w.f2 -side top -pady 8
button $w.f2.b -text "Close" -command "wm withdraw $w" -width 9
pack $w.f2.b
wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
focus $w.f.t};# showRules
proc setBoard {args} {
global data
.c.f.l configure -text "Score: $data(score)\nMoves: $data(moves)"
place .c.f.l -in .c.f -relx .5 -rely .5 \
-x -[expr {[winfo reqwidth .c.f.l]/2}] -y -[expr {[winfo reqheight .c.f.l]/2}]};# setBoard
proc makeTray {col} {
global data
# Make a 'tray' for each stack of cards. This is a totally invisible
# rectangle on the canvas, just so we can tell when we're hovering over
# an area of cards.
set x1 $data(col$col)
set x2 [expr $x1+[image width ::img::back]]
.c create rectangle $x1 10 $x2 800 -outline {} -fill {} -tags "tray.$col immortal"};# makeTray
proc cheat {} {
global data
if { !$data(cheating) } {
foreach x [.c find withtag backcard] {
.c itemconfigure $x -image ::img::$data(card,$x)
}
set data(cheating) 1
} else {
foreach x [.c find withtag backcard] {
.c itemconfigure $x -image ::img::back
}
set data(cheating) 0
}};# cheat
proc shuffleList { list } {
set n [llength $list]
for { set i 1 } { $i < $n } { incr i } {
set j [expr { int( rand() * $n ) }]
set temp [lindex $list $i]
lset list $i [lindex $list $j]
lset list $j $temp
}
return $list;};# shuffleList
proc clearBindings {{rtag 1}} {
# --- remove the bindings from all cards
if { $rtag } {
foreach id [.c find withtag topcard] {
.c dtag $id topcard
}
}
.c bind topcard <ButtonPress-1> {}
.c bind newdeck <ButtonPress-1> {}
.m.file entryconfigure "Deal New Row" -state disabled
.m entryconfigure "Deal!" -state disabled};# clearBindings
proc updateBindings {{clear 1}} {
global data
if { $clear } {
clearBindings
}
# --- add bindings to only the top cards
foreach card [getTopCards] {
.c addtag topcard withtag $card
}
if { [info exists data(newdecks)] } {
foreach x $data(newdecks) {
.c raise $x
}
}
.c bind topcard <ButtonPress-1> [list dragStart %x %y]
.c bind newdeck <ButtonPress-1> "dealRow"
resetDealOptions};# updateBindings
proc generateGoodMoves {} {
global data
# Work out which cards (if any) can still be moved.
set data(goodmoves) {}
for {set i 1} {$i <= 10} {incr i} {
if { [set temp [lindex [getTopCards $i] 0]] != "" } {
lappend fullList [cardInfo $temp]
} else {
lappend fullList [list 0 X]
}
}
for {set i 1} {$i <= 10} {incr i} {
set top(i) [lindex [getTopCards $i] end]
if { $top(i) == "" } {continue;}
scan [cardInfo $top(i)] "%d %s" top(v) top(s)
incr top(v)
set search [lsearchall $fullList [list $top(v) $top(s)]]
if { $search != "-1" && $search != "" } {
foreach x $search {
incr x
lappend data(goodmoves) [list $i $x]
}
} else {
set search [lsearchall -glob $fullList [list $top(v) ?]]
if { $search != "" && $search != "-1" } {
foreach x $search {
incr x
lappend data(goodmoves) [list $i $x]
}
}
}
}};# generateGoodMoves
if { $animatetype } {
proc showGoodMoves {} {
global data
if { $data(goodmoves) == "" || $data(showingmove) || $data(dealing) } {
bell -displayof .
return;
}
set data(showingmove) 1
set timer 300
set thismove [lindex $data(goodmoves) 0]
set data(goodmoves) [lrange $data(goodmoves) 1 end]
lappend data(goodmoves) $thismove
set card0 [getTopCards [lindex $thismove 0]]
set card1 [lindex [getTopCards [lindex $thismove 1]] 0]
set img1 [.c itemcget $card1 -image]
foreach x $card0 {
set img0($x) [.c itemcget $x -image]
.c itemconfigure $x -image ::img::anim
}
update
after $timer
.c itemconfigure $card1 -image ::img::anim
update
after $timer
foreach x $card0 {
.c itemconfigure $x -image $img0($x)
}
update
after $timer
.c itemconfigure $card1 -image $img1
update
set data(showingmove) 0
};# showGoodMoves (animatetype 1)} else {
proc showGoodMoves {} {
global data
if { $data(goodmoves) == "" || $data(showingmove) || $data(dealing) } {
bell -displayof .
return;
}
set data(showingmove) 1
set timer 75
set thismove [lindex $data(goodmoves) 0]
set data(goodmoves) [lrange $data(goodmoves) 1 end]
lappend data(goodmoves) $thismove
.c itemconfigure "tray.[lindex $thismove 0]" -fill white
update
after $timer
.c itemconfigure "tray.[lindex $thismove 0]" -fill black
update
after $timer
.c itemconfigure "tray.[lindex $thismove 0]" -fill white
.c itemconfigure "tray.[lindex $thismove 1]" -fill black
update
after $timer
.c itemconfigure "tray.[lindex $thismove 0]" -fill {}
.c itemconfigure "tray.[lindex $thismove 1]" -fill white
update
after $timer
.c itemconfigure "tray.[lindex $thismove 1]" -fill black
update
after $timer
.c itemconfigure "tray.[lindex $thismove 1]" -fill {}
update
after $timer
set data(showingmove) 0
};# showGoodMoves (animatetype 0)} ;# animatetype
proc checkForWins {} {
global data app
set work 0
# if there're any complete sets of cards, get rid of them.
foreach x {1 2 3 4 5 6 7 8 9 10} {
if { [llength [getTopCards $x]] == "13" } {
clearWinCol $x
return 1;
}
}
if { $data(clears) == "8" } {
set ans [tk_messageBox -icon question -title $app(name) -type yesno \
-message "Congratulations, you won! Do you want to play again?"]
if { $ans == "yes" } {
clearGame
newGame
}
set data(playing) 0
}
return 0;};# checkForWins
proc clearWinCol {col} {
global data
# Column $col has a winning row; remove it
set list [lrange $data(col$col,cards) end-11 end]
set top [lindex $data(col$col,cards) end-12]
set data(col$col,cards) [lrange $data(col$col,cards) 0 end-13]
set data(undo) {}
set x [expr {25+(12*$data(clears))}]#set y 420
set y [expr {[winfo y .c.f]+0}] ;# 420 --> 470
foreach i [revList $list] {
#.c coords $i $x $y
move .c $i $x $y 1 15
.c raise $i
update
after 18
}
.c dtag $top topcard
#.c coords $top $x $y
move .c $top $x $y 1 15
foreach i $list {
.c delete $i
}
set last [lindex [getTopCards $col] 0]
if { $last != "" } {
.c itemconfigure $last -image ::img::$data(card,$last)
.c dtag $last backcard
}
incr data(clears)
putCol $col 0
after 10
incr data(score) 100};# clearWinCol
proc whereIs {id} {
global data
foreach x {1 2 3 4 5 6 7 8 9 10} {
if { [lsearch $data(col$x,cards) $id] != "-1" } {
return $x;
}
}};# whereIs
proc putCol {col {bind 1}} {
global data
set i [llength $data(col$col,cards)]
foreach x $data(col$col,cards) {
.c coords $x $data(col$col) [colHeight $col $i]
.c raise $x
incr i -1
}
if { $bind } {
generateGoodMoves
updateBindings
}};# putCol
proc putCard {card col {undo 0}} {
global data
if { $undo != "1" && $undo != "0" } {
info default [info level 0] undo undo
}
set x [whereIs [lindex $card 0]]
set num [llength $card]
set data(col$x,cards) [lrange $data(col$x,cards) 0 end-$num]
set last [lindex $data(col$x,cards) end]
if { !$undo } {
if { $last != "" && [lsearch [.c gettags $last] backcard] != "-1" } {
set bws 1
} else {
set bws 0
}
lappend data(undo) [list $card $x $bws]
}
if { $last != ""} {
.c itemconfigure $last -image ::img::$data(card,$last)
.c dtag $last backcard
}
foreach x $card {
lappend data(col$col,cards) $x
}
incr data(moves)
putCol $col
if { !$undo } {
while { [checkForWins] } {
continue;
}
}
generateGoodMoves
updateBindings};# putCard
proc revList {list} {
set ret {}
foreach x $list {
set ret [linsert $ret 0 $x]
}
return $ret;};# revList
proc getTopCards {{cols "1 2 3 4 5 6 7 8 9 10"}} {
global data
set ret {}
foreach x $cols {
set list [set data(col$x,cards)]
if { [llength $list] > 0 } {
lappend ret [lindex $list end]
while { 1 } {
set end [cardInfo [lindex $list end]]
set endm [cardInfo [lindex $list end-1]]
if { [lsearch [.c gettags [lindex $list end-1]] "backcard"] != "-1" } {
set hidden 1
} else {
set hidden 0
}
if { [lindex $end 1] == [lindex $endm 1] && \
[expr [lindex $end 0]+1] == [lindex $endm 0] && !$hidden } {
set list [lrange $list 0 end-1]
lappend ret [lindex $list end]
} else {
break;
}
}
}
}
return $ret;};# getTopCards
proc setDiff {} {
global app data
set def [lindex {-> 1 0 -> 1} $data(suits)]
set ans [tk_dialog .suits $app(name) \
"How many suits do you want to play with?" \
question $def {1 Suit} {2 Suits} {4 Suits} Cancel]
if { $ans == "-1" || $ans == "3" } {
return;
}
clearGame
set data(suits) [lindex "1 2 4" $ans]
newGame};# setDiff
proc clearGame {} {
global data
set delList [setdiff [.c find all] [.c find withtag immortal]]
foreach x $delList {
.c delete $x
}
for {set i 0} {$i<=10} {incr i} {
set data(col$i,cards) {}
}
set data(playing) 0
set data(moves) 0
set data(score) 500
set data(undo) {}
set data(clears) 0
set data(cheating) 0
set data(newdecks) {}};# clearGame
proc newGame {{restart 0}} {
global data app
if { $data(playing) } {
if { $restart } {
set msg "Restart game?"
} else {
set msg "Start a new game?"
}
set ans [tk_messageBox -icon question -title $app(name) \
-message $msg -type yesno]
if { $ans == "no" } {return;}
}
clearGame#set data(playing) 1
if { !$restart } {
set data(allcards) {}
set list [list {} {h h h h h h h h} {h h h h s s s s} {} {h h s s c c d d}]
foreach i [lindex $list $data(suits)] {
foreach x {a 2 3 4 5 6 7 8 9 t j q k} {
lappend data(allcards) "$x$i"
}
}
set data(deck) [shuffleList $data(allcards)]
set data(rdeck) $data(deck)
} else {
set data(deck) $data(rdeck)
}
set data(dealing) 1
set numnewgames [incr data(numnewgames)]
set moves {{dealRow 10 -1 0 0} {dealRow 10 0 0 0} {dealRow 10 0 0 0} {dealRow 10 0 0 0} {dealRow 10 0 0 0} {dealRow 4 0 0 0} {dealRow 10 1 0 0} {addDecks 5}}
foreach x $moves {
if { $numnewgames == $data(numnewgames) } {
eval $x;
} else {
return;
}
}
set data(dealing) 0};# newGame
proc addDecks {num} {
global data
set data(newdecks) {}
set x 720
set y [expr {[winfo y .c.f] -0}] ;# 420 --> 470
for {set i 1} {$i <= $num} {incr i} {
set x [expr {$x-12}]
set id [.c create image $x $y -image ::img::back -tags newdeck -anchor nw]
lappend data(newdecks) $id
update idletasks
after 95
}
resetDealOptions};# addDecks
proc dealRow {{num 10} {show 1} {clear 1} {remove 1}} {
global data app
set thisdealtime [incr data(alldeals)]
set data(dealtime) $thisdealtime
clearBindings
if { $show != "-1" && [llength $data(deck)] == "0" } {
updateBindings 0
return;
}
if { $clear } {
set inplay 0
for {set i 1} {$i<=10} {incr i} {
incr inplay [llength $data(col$i,cards)]
}
if { $inplay >= 10 } {
for {set i 1} {$i<=10} {incr i} {
if { [getTopCards $i] == "" } {
tk_messageBox -icon error -title $app(name) \
-message "You can't deal a new row while there are empty columns."
updateBindings 0
return;
}
}
}
}
set speed 40
if { $show == "-1" } {
# we're showing the markers...
for {set i 1} {$i <= $num} {incr i} {
if { $thisdealtime != $data(dealtime) } {
updateBindings 0
return;
}
.c create image $data(col$i) 10 -image ::img::marker \
-anchor nw -tags [list marker col$i immortal]
}
updateBindings 0
return;
} else {
for {set i 1} {$i <= $num} {incr i} {
if { $thisdealtime != $data(dealtime) } {
updateBindings 0
return;
}
set card [lindex $data(deck) 0]
set data(deck) [lrange $data(deck) 1 end]
if { $show == "0" } {
set img ::img::back
set tags [list card backcard]
} else {
set img ::img::$card
set tags [list card]
}
set y [colHeight $i]
set decks [lindex $data(newdecks) end]
if { $decks == "" } {
set sx $data(col$i) ; set sy $y
} else {
scan [.c coords [lindex $data(newdecks) end]] "%s %s" sx sy
}
set id [.c create image $sx $sy \
-image $img -anchor nw -tags $tags]
set data(card,$id) $card
lappend data(col$i,cards) $id
move .c $id $data(col$i) $y 1 15
putCol $i 0
update
if { $i != $num } {
after $speed
}
}
}
if { $remove } {
set img [lindex $data(newdecks) end]
set data(newdecks) [lrange $data(newdecks) 0 end-1]
.c delete $img
}
set data(undo) {}
while { [checkForWins] } {
continue;
}
generateGoodMoves
resetDealOptions
updateBindings};# dealRow
proc resetDealOptions {} {
global data
if { $data(newdecks) == "" } {
bind . <KeyPress-d> {}
set state disabled
} else {
bind . <KeyPress-d> {dealRow}
set state normal
}
.m entryconfigure "Deal!" -state $state
.m.file entryconfigure "Deal New Row" -state $state};# resetDealOptions
proc chkUndos {args} {
global data
if { [llength $data(undo)] } {
.m.file entryconfigure "Undo" -state normal
} else {
.m.file entryconfigure "Undo" -state disabled
}};# chkUndos
proc undoMove {} {
global data
if { [llength $data(undo)] } {
set do [lindex $data(undo) end]
set data(undo) [lrange $data(undo) 0 end-1]
set col [lindex $do 1]
set coltop [getTopCards $col]
if { [lindex $do 2] == "1" } {
.c itemconfigure $coltop -image ::img::back
.c addtag backcard withtag $coltop
}
.c dtag $coltop topcard
putCard [lindex $do 0] $col 1
} else {
bell -displayof .
}};# undoMove
proc colHeight {col {num 0}} {
global data
set pad 10 ; set ext0 10 ; set ext1 25
set all [setdiff $data(col$col,cards) [.c find withtag backcard]]
if { [llength $all] > 12 } {
set ext1 [expr {$ext1-(([llength $all]-12)*1)}]
}
foreach x [lrange $data(col$col,cards) 0 end-$num] {
if { [lsearch [.c gettags $x] "backcard"] != "-1" } {
incr pad $ext0
} else {
incr pad $ext1
}
}
return $pad;};# colHeight
proc cardInfo {card} {
global data
if { $card == "" } {return;}
if { [string is integer -strict $card] } {
set card $data(card,$card)
}
foreach {value suit} [split $card ""] {break}
if {$value == "t"} {set value 10}
if {$value == "j"} {set value 11}
if {$value == "q"} {set value 12}
if {$value == "k"} {set value 13}
if {$value == "a"} {set value 1}
return [list $value $suit];};# cardInfo
proc dragStart {x y} {
global data
clearBindings 0
set id [.c find closest $x $y]
set data(drag,topcard) $id
set col [whereIs $id]
if { $col == "" || $data(drag,bad) } {
set data(drag,bad) 1
return;
}
set data(drag,homecol) $col
if { [getTopCards $col] != $id } {
set cardList [lrange $data(col$col,cards) [lsearch $data(col$col,cards) $id] end]
} else {
set cardList $id
}
set data(drag,allcards) $cardList
set data(drag,orgCoords) [.c coords $id]
set data(drag,xLoc) $x
set data(drag,yLoc) $y
foreach i $cardList {
.c raise $i
}};# dragStart
proc dragging {x y} {
global data
if { $data(drag,bad) } {
return;
}
if { ![info exists data(drag,allcards)] } {
set data(drag,bad) 1
return;
}
set cards $data(drag,allcards)
foreach id $cards {
.c move $id [expr {$x - $data(drag,xLoc)}] [expr {$y - $data(drag,yLoc)}]
}
set data(drag,xLoc) $x
set data(drag,yLoc) $y};# dragging
proc dragEnd {x y} {
global data
set data(playing) 1
if { $data(drag,bad) || ![info exists data(drag,allcards)] } {
catch {putCol $data(drag,homecol)}
set data(drag,bad) 0
updateBindings
return;
}
set ids $data(drag,allcards)
set topInfo [cardInfo [lindex $ids 0]]
set bb1 [.c bbox [lindex $ids 0]]
set bb2 [.c bbox [lindex $ids end]]
if { [catch {eval .c find overlapping [lindex $bb1 0] [lindex $bb1 1] [lindex $bb2 2] [lindex $bb2 3]} tagList] } {
putCol $data(drag,homecol)
updateBindings
return;
}
foreach x $tagList {
if { [.c type $x] == "rectangle" } {
lappend trays $x
} elseif { [.c type $x] == "image" } {
lappend cards $x
}
}
if { [setdiff $cards $ids] == "" || ![info exists trays] } {
putCol $data(drag,homecol)
updateBindings
return;
# we only have the card(s) we're moving, and the tray
}
set 2nd {}
foreach x $trays {
set x [string range [file extension [lindex [.c gettags $x] 0]] 1 end]
set top [cardInfo [lindex [getTopCards $x] 0]]
set topC [getTopCards $x]
if { [lindex $top 0] == [expr [lindex $topInfo 0]+1] || $topC == "" } {
if { ([lindex $top 1] == [lindex $topInfo 1]) || $topC == "" } {
# Same suit (or blank column). Put it here.
putCard $ids $x
incr data(score) -1
# Refresh spacing on the original column
putCol $data(drag,homecol)
updateBindings
return;
} else {
# Another suit. This is second-best.
lappend 2nd $x
}
}
}
if { [llength $2nd] > 0 } {
# OK, since there's none of the same suit, stick 'em in the first
# available slot w/another suit. Then refresh original column's spacing
putCard $ids [lindex $2nd 0]
incr data(score) -1
putCol $data(drag,homecol)
} else {
# Bad move. Put them back.
putCol $data(drag,homecol)
}
updateBindings};# dragEnd
proc setinter {arg1 arg2} {
set list ""
foreach x $arg1 {
if { [lsearch -exact $arg2 $x] != "-1" } {
lappend list $x
}
}
return [lsort -unique $list];};# setinter
proc setdiff {arg1 arg2} {
set list ""
foreach x $arg1 {
if { [lsearch -exact $arg2 $x] == "-1" } {
lappend list $x
}
}
return [lsort -unique $list];};# setdiff
source card_img.tcl
# Alternatives for the last card on each of the 8 stacks: # Light "grass" green: image create photo ::img::marker -width 71 -height 96 ::img::marker put #000088880000 -to 0 0 70 95 ;# light green, as in score-box #::img::marker put #0000cccc0000 -to 0 0 70 95 ;# lighter green
main newGame