Intro edit

keyboardzombie.com

http://tkgames.sourceforge.net/index.html#ss2.3

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

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

Program edit

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

Comments edit

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References