Written by [mg%|%Mike Griffiths%|%], with the most recent code update on
2005-08-29.  On 2006-09-11, Steven Naaus noted his derived version at
http://tkgames.sourceforge.net/index.html#ss2.3, noting some bug fixes, an
updated "Rules" widget, a slightly different look and feel, and a redo feature.

[MG] April 27th 2004 - Ever since I started learning Tcl, I avoided the [[canvas]] widget like the plague; when I first started, it looked far more complicated than other things, and I just never got around to learning. But then it turned out to be the only way to do something I needed, so I learned, and sorely regret not doing so before; I've been missing a lot. So, to practice my skills with the widget a little -- and after seeing [Jeff Godfrey]'s cardgame, [Once in a Lifetime], which looked (deceptively:) easy once I read the code (reading it is always easier than writing it, alas...;) -- I decided to code a version of [Microsoft] XP's Spider Solitaire game. A few of the routines are taken, more or less directly, from Once in a Lifetime, as are the card images (originally from [scat], and [http://tcl.tk/starkits/patience.kit] before that, according to Jeff's page). Although it got easier as I went on, I was kind of lost at the start, and would've been totally so if not for Jeff Godfrey's code as an example, so thanks very much :)

With nearly all the features of Microsoft's Spider Solitaire (apart from sound effects, as I couldn't be bothered finding decent .wav files, decent animation (what's there is poor), and the ability to save games (quite easily added, but for when I've not been spending 7 hours straight on it), it's quite complete. 
It has rules/help, but they're terrible - I'm no good with help-files at the best of times.

There's also a hidden cheat which lets you see what all the cards are (and toggles it off again). 
Though, given that the code's not compiled, it's not all that hidden, I guess... :)

(Apr 27th - Fix added to 'Restart Game' option.. and several others, mostly in the way suitable moves are checked for. Also added an option to turn the console on, while debugging the errors.)

Apr 28th - Fixed a bug with undoing, where a tag was being added where it shouldn't (always) have been.

Apr 28th - Edited the generateGoodMoves procedure. Previously, it wouldn't recognise moving (for example) the 7 of Hearts onto the 8 of Spades. Now, as long as there isn't an 8 of Hearts available (which is obviously a better move), it will do.

Apr 28th - Updated so that when a column has more than 12 cards face-up, the (vertical) spacing between each card in that column is smaller. That stops the problem with the last cards in a column disappearing behind the scoreboard, or blocking out the new cards to be dealt. Also fixed a bug which appeared if you clicked to deal a new row quickly, which made it try to deal more rows than there actually were.

Apr 28th - Yet another bug, this one seems to have been introduced during a previous 'fix' (or so I call them:). The procedure checkForWins has now been simplified down a lot to make it quicker; now, as long as [[getTopCards ''$column'']] returns a list 13-long, there's a complete line there, and we clean it off.

Apr 30th - a few more minor bug fixes/improvements. Still not fixed the bug found by [LES] a couple of days back, though; hopefully that'll happen soon.

May 17th - Changed the way the Show Good Move feature works, since the old style looked a little crude, IMHO. The code for the old way's still in there; the $animatetype variable set near the start (which should be 1 for the new, 0 for the old) controls which is used. Also fixed a 'bug' in the same feature that allowed it to show multiple moves at once, thus making it totally unusable. Now it refuses to show a second, while the first is still playing (win XP's version queues them, but this was a heck of a lot easier:) The bug reported by LES mentioned previously is also fixed, now.

May 17th - Another fix; now you can only deal one row at a time, too, whereas before clicking on the new decks rapidly and repeatedly started dealing several times at once.

May 18th - fixed the bug found by KBK (see below code). Changed to version 2.0, and will now make a conscious effort to change the version number every time the code changes, since I hadn't been :P

May 21st - now when you select a new difficulty, the default button is different; if you're currently playing with 1 or 4 suits, the default button is 2 suits. If you're playing with 2 suits, the default button is 1.

June 11th - Several new fixes, mostly stopping you picking up cards when you shouldn't (like while you're dealing a new row). Also, a change to the scoring - you now get 100 points when you clear a stack/suit, the same as in MS Win XP's version. The help has also been updating w/the scoring changes. Generally less buggy, hopefully :) It also now works in Tcl/Tk 8.3, as well as 8.4, by supplying a (very crude) version of "[lset]" and "[lsearch] -all", as well as checking which order the arguments for [trace] should be in.

July 6th 04 - UPDATED: Some major changes to the code, hopefully completely removing every last bug (famous last words). Tested (albeit briefly) on WinXP, there appears to be absolutely no point at which you can pick up a card when you shouldn't be able to, put a card in the wrong place, etc. Just don't quote me on that :) Should still work with Tcl/Tk 8.3+ . If anyone uses this newer version and finds a bug, please let me know. :)

July 9th 04 - Changed 'Restart Game' to F5, as the F4 binding was getting confused with Alf+F4 on Windows.

July 15th - Added some animation when dealing a new row, and clearing a complete column/stack, with the code from the extremely long-titled [Move an item on a Canvas Widget in a Straight Line (animated)]

July 16th - Updated the canvas-animation code so that it actually works ;)

Anyways, enough rambling. Here's the code (written and tested only on Win XP Home)...

'''LES''': Tested on Windows 98 SE. Impressive!

[HJG] 2005-07-29 Tweaked the logic for detecting 'game in progress', 
and changed the positions of extra-cards & discard-pile. 
But I could not find how to adjust them when the window is resized, like the score-box does.

[MG] The score box isn't actually a canvas item. IIRC, it's a label widget which is [place]d halfway across the canvas widget.

And just a quick note: Please don't comment out things if you haven't looked to make sure you know what you're doing. Someone made a change and commented out the ''set app(author) "Mike Griffiths"'' line, thus breaking the 'About' dialog. Presumably this was someone who wanted to point out that they'd made some changes to the code - there's a "credits" section in the help. Please feel free to add your name into it, but don't make unthoughtout changes elsewhere and break it for everyone. Thank you.

[HJG] 2005-08-29 Factored out the card-images to [card_img].

======
#!/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

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)   "michael_j_griffiths@hotmail.com"

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

f { $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
======

[Stefan Vogel] 27 Apr 04  Cool game. I'm astonished every time what can be done in a few lines of Tcl.

[Eric Amundsen] 27 Apr 04  The game can be played with 1 of 3 diffictulties.  The easiest (default) is 1 suit, check the menus for higher difficulties and therefore more suits.  Nice game!!

[MG] Apr 28th 2004 - What Eric said :) Glad you like the game, I'm hoping to add Freecell and Hearts, soon; I think I've become addicted to card-games on Tcl/Tk's [[canvas]] widget now :) Although, to be honest, after a year of playing with Tcl and downloading the code from this Wiki, I've stopped being astonished, or even slightly suprised, at all the things Tcl can do (and how easily it does them).

'''LES''' - bug: the '''D''' key binding invokes ''dealRows'' instead of ''dealRow''.

[MG] - Could've sworn I'd fixed that before. Definitely done it this time, though :) Thanks :)

'''LES''' - bug: press F2 to start a new game. As soon as the cards begin to be laid out, press F3 and select any option. Even "Cancel" will do. Just watch.

[MG] - I don't see the bug when I click 'Cancel', but I do for everything else. Right now, I have no idea what to do about it, but it's been a long day; I'll try and fix it tomorrow. Thanks for pointing it out :)

[KBK] - bug (2004-05-06): If I have, say, the ten of Spades stacked atop the Knave of Hearts, the program will allow you to move them both.  Normally, the rules for Spider allow you to move a stack of multiple cards only when they're all of a single suit.

[MG] - It certainly doesn't do that ''all'' of the time (and you're quite right, shouldn't do it at all). I'll have to have a dig through the code for that one.

[MG] May 17th - Fixed the latest bug that LES reported, finally. Will get to work on [KBK]'s later tonight :) ''Update'' OK, I thought I'd addressed this problem before, and looking at the code I really can't see how that could still happen. Is it possible you weren't using the most up-to-date version when you had that problem, KBK? If not, something's probably seriously wrong somewhere. . .

[KBK] copied the code off this page again and tried it in "4 Suits" mode.  No trouble moving a stack
of cards of different suits as long as the numbers are in sequence.  It's not supposed to allow that.

[MG] May 18th - Ah, that's why I hadn't seen the error; I'm not good enough to play with 4 suits ;) It's been fixed, now, by adding a couple more calls to the 'clearBindings' proc.

[BMA] May 21st - Seems to work fine under Mac OS X 2.8 ""Jaguar" and Daniel Steffen's Wish. ''[MG] - Great! Good to hear I've finally managed to write something that works cross-platform ;) Thanks :)''

[DKF] July 7: Candidate for tclapps?

[MG] July 7th - *checks the [tclapps] page* If you (or whoever manages/maintains it) wants to add this, please feel free to do so.

[LV] We've had problems in the past with accusations about adding code.
It just works out better if a) the auther adds a [EULA] and if the author
contacts a sf.net project leader and works with them to contribute a 
piece of code.

[MG] Feb 18 2005 - Sorry to have taken so long to get back to this, since your comment, [LV]. Would that be a sf.net project leader for [tcllib], and do you happen to know who the best person would be?

[HZe] Mar 6 2005 - Great Game! The only thing: I don't like the last card on each of the 8 stacks (the white card with the red X), I prefer to use a light green solid card. So, I've just replaced the ::img::marker definition by this one:

======
image create photo ::img::marker -format gif -data {
    R0lGODlhRwBgAKECAABkAACIAP///////ywAAAAARwBgAAACXIyPqcvtD6Oc
    tNqLs968+w+G4kiW5omm6sq27gvH8kzX9o3n+s73/g8MCofEovGITCqXzKbz
    CY1Kp9Sq9YrNarfcrvcLDovH5LL5jE6r1+y2+w2Py+f0uv2OFxUAADs=
}
======

[MG] March 6 2005 - Glad you like it :) Yeah, I never liked that red X too much, either, but I never got around to changing it. Looking at your replacement one just made me think - you could also use something like this, which is slightly smaller (in terms of file-size) and lets you change the color by just editing the script.

======
image create photo ::img::marker -width 71 -height 96
::img::marker put #0000cccc0000 -to 0 0 70 95
======

Jesse June 12 2005 - Hi, cool game, I have been playing it a few times a day for about a month on Puppy Linux... took me a while to notice that it has a bug in it that can let you cheat a bit. The bug is where you want to move card X but you click your mouse 1 pixel above that card, the mouse grabs the card Y (card beneath X) and the ones down the screen from it, and you can move the cards to a position valid for card Y to land in. 
i.e. you can move stack of { 8h , Kh } onto 9h so you have stack of 9h 8h Kh. Happy bug fixing :)

[MG] June 12 2005 - Hey Jesse, thanks for your comments. I'd noticed the bug before in passing (that sometimes it picked up a card too many), but had realised exactly what it was or how easily replicatable it was - I'll have to look into reworking the bindings when I get the time, to fix a few other things which are slightly clumsy. Thanks for pointing it out :)

[HJG] 2005-07-25 Small change, so the game does not start maximized.
I also noticed that the final score is updated just after you press the ok-button.

[MG] 2005 July 26 - That is indeed a bug, and one I've been meaning to fix for a while. IIRC, it's just because of where the code which updates the score is placed in relation to the code which checks for the game being won. There are several bugs still in need of fixing (like the one Jesse mentioned before), and really it needs a re-write to just get them all out. One of those projects for when I get a few hours to spare, unless someone beats me to it...

[HJG] I also noticed that proc generateGoodMoves does not consider moving cards into empty columns,
or splitting a stack in order to get a complete suit.

[MG] Moving cards into empty columns is left out deliberately, because you can always move cards from any column into any empty column, and I considered it unnecessary to have it point it out (it would also make checking all the available moves take a lot longer). As for breaking apart a "working" stack, to put it onto another for a complete suit... With a little more code that could be done, but I think that takes it into "playing the game for you", instead of hints, so I never did it.

[HJG] When all the "extra" cards have been dealt then "no more hints" means "game lost". 
But sometimes there is still a chance to win by splitting a stack in order to get a complete suit,
which might lead to another free column, etc.
Thus, players using the hints to check if there is still a chance might give up prematurely...

----
'''[Geraldine] - 2011-04-01 00:34:38'''


How can I win at Spider Solitaire.RE scoring???? You get one Point for a game played ...and one point for a win???
If you loose a game,you get one score for game played and nothing for a win(because you lost??)So how can you possibly get 
ahead???

<<categories>> Games | Application | Tcl/Tk Games