Mine

Die x-te Implementierung der wohl stabilsten Software unter Windows:

---

#!/usr/bin/wish

package require Tk
bind [winfo class .] <Destroy> exit

# debug
proc -- args #
proc echo args {puts $args}
proc aloud args {
  puts $args
  uplevel $args
}
namespace path "::tcl::mathop ::tcl::mathfunc"


# mine, 30 cols 16 rows 99 mines

# here to customize
# lassign "30 16 99" cols rows mines
# lassign "8 8 8" cols rows mines

switch [lindex $argv 0] {
  child {
    lassign {8 8 10} cols rows mines
  }
  teenie {
    lassign {16 16 40} cols rows mines
  }
  custom {
    lassign $argv - cols rows mines
    if {$cols eq ""} then {
      set cols 16
    }
    if {$rows eq ""} then {
      set rows $cols
    }
    if {$mines eq ""} then {
      set mines [int [sqrt [* $cols $rows 4]]]
    }
  }
  default {
    # lassign {8 8 10} cols rows mines
    lassign {30 16 99} cols rows mines
  }
}

pack [canvas .c\
        -width [- [* 25 $cols] 2]\
        -height [- [* 25 $rows] 2]\
        -background grey70]\
  -expand yes -fill both

wm title . Minesweeper

wm resizable . no no

#
# game states
#

variable pressed false
variable init true

set bombChar \u2688
set flagChar \u2691
set flagCharHollow \u2690


proc tile {col row {canvas .c}} {
  #
  # draw a tile
  # make tile responsive
  #
  global bombChar flagChar
  set w 25
  set h 3
  set x [* $col $w]
  set y [* $row $w]
  set tags "col$col row$row"
  $canvas create text [+ $x 12] [+ $y 12]\
    -text ""\
    -anchor center\
    -font "Helvetica 16 bold"\
    -tags "$tags text"
  $canvas create polygon\
    [+ $x 1] [+ $y 1] [+ $x $w -1] [+ $y 1] [+ $x 1] [+ $y $w -1]\
    -fill grey85 -tags "$tags topleft"
  $canvas create polygon\
    [+ $x 1] [+ $y $w -1] [+ $x $w -1] [+ $y $w -1] [+ $x $w -1] [+ $y 1]\
    -fill grey15 -tags "$tags bottomright"
  $canvas create rectangle [+ $x $h] [+ $y $h] [+ $x $w -$h] [+ $y $w -$h]\
    -fill grey70 -tags "$tags surface" -outline ""
  $canvas create text [+ $x 11] [+ $y 11]\
    -text ""\
    -anchor center\
    -font "Helvetica 16 bold"\
    -fill white\
    -tags "$tags flag"
  #
  $canvas bind col$col&&row$row&&surface <1> "press $col $row"
  $canvas bind col$col&&row$row&&surface <3> "flag $col $row"
  $canvas bind col$col&&row$row&&flag <3> "flag $col $row"
  $canvas bind col$col&&row$row&&surface\
    <Leave> "release $col $row"
  $canvas bind col$col&&row$row&&surface\
    <ButtonRelease> "
    if {\$pressed} then {
      if {\$init} then {
        init $col $row
      } else {
        check $col $row
      }
      setTitle
    }
    release $col $row
  "
}

proc flag {col row {canvas .c}} {
  #
  # set or unset flag
  #
  global flagChar
  if {[$canvas itemcget col$col&&row$row&&flag -text] eq $flagChar} then {
    $canvas itemconfigure col$col&&row$row&&flag -text ""
  } else {
    $canvas itemconfigure col$col&&row$row&&flag -text $flagChar
  }
  setTitle
}

proc unflaggedMines {{canvas .c}} {
  #
  # $mines minus number of flags
  #
  global rows cols mines
  set result $mines
  for {set i 0} {$i < $cols} {incr i} {
    for {set j 0} {$j < $rows} {incr j} {
      if {[$canvas itemcget col$i&&row$j&&flag -text] ne ""} then {
        incr result -1
      }
    }
  }
  set result
}

proc blink {widget args} {
  lassign [info level 0] blink
  if {$widget eq "info"} then {
    #
    # info
    #
    set result {}
    foreach event [after info] {
      set info [after info $event]
      if {[lindex $info end] eq "timer" &&
          [lindex $info 0 0] eq $blink} then {
        lassign $info cmd
        lassign $cmd blink widget
        if {[winfo exists $widget]} then {
          set line [list $blink $widget]
          set opts [lrange $cmd 2 end]
          if {[winfo class $widget] in {Text Canvas}} then {
            lappend line -tag [dict get $opts -tag]
          } 
          lappend line -att [dict get $opts -att]
          lappend result $line
        }
      }
    }
    lsort $result
  } elseif {$widget eq "stop"} then {
    #
    # stop all after-events
    #
    foreach event [after info] {
      set info [after info $event]
      if {[lindex $info end] eq "timer" &&
          [lindex $info 0 0] eq $blink} then {
        after cancel $event
      }
    }
  } elseif {[winfo exists $widget]} then {
    if {$args eq "stop"} then {
      $blink $widget -action stop
    } else {
      set class [winfo class $widget]
      #
      # prepare
      #
      set item {
        -step 0
        -red0 0
        -green0 0
        -blue0 0
        -tag blink
        -red1 65535
        -green1 65535
        -blue1 65535
        -interval 25
        -action continue
      }
      #
      # set default target attributes
      #
      switch -exact -- $class {
        Text {
          dict set item -att -foreground
        }
        Canvas {
          dict set item -att -fill
        }
        default {
          dict set item -att -fg
        }
      }
      #
      # customize by command line
      #
      dict for {key val} $args {
        dict set item $key $val
      }
      #
      # translate named colors if given
      #
      if {[dict exists $item -color0]} then {
        lassign [winfo rgb . [dict get $item -color0]] r g b
        dict set item -red0 $r
        dict set item -green0 $g
        dict set item -blue0 $b
        dict unset item -color0
      }
      if {[dict exists $item -color1]} then {
        lassign [winfo rgb . [dict get $item -color1]] r g b
        dict set item -red1 $r
        dict set item -green1 $g
        dict set item -blue1 $b
        dict unset item -color1
      }
      #
      if {[dict get $item -action] eq "continue"} then {
        #
        # calculate increasement of color
        #
        dict incr item -step
        if {[dict get $item -step] >= 100} then {
          dict set item -step 0
        }
        set pi [expr {
          atan2(0,-1)
        }]
        set factor [expr {
          (cos($pi * 2 * [dict get $item -step] / 100) + 1) / 2
        }]
        #
        # generate hexadecimal color string
        #
        set rrrrggggbbbb #
        #
        set red0 [dict get $item -red0]
        set red1 [dict get $item -red1]
        set red [expr {$red0+int(($red1-$red0)*$factor)}]
        append rrrrggggbbbb [format %04x $red]
        #
        set green0 [dict get $item -green0]
        set green1 [dict get $item -green1]
        set green [expr {$green0+int(($green1-$green0)*$factor)}]
        append rrrrggggbbbb [format %04x $green]
        #
        set blue0 [dict get $item -blue0]
        set blue1 [dict get $item -blue1]
        set blue [expr {$blue0+int(($blue1-$blue0)*$factor)}]
        append rrrrggggbbbb [format %04x $blue]
        #
        set tag [dict get $item -tag]
        set att [dict get $item -att]
        switch -exact -- $class {
          Canvas {
            $widget itemconfigure $tag $att $rrrrggggbbbb
          }
          Text {
            $widget tag configure $tag $att $rrrrggggbbbb
          }
          default {
            $widget configure $att $rrrrggggbbbb
          }
        }
        #
        # repeat
        #
        set interval [dict get $item -interval]
        after $interval [list blink $widget {*}$item]
        #
      } else {
        #
        # stop blinking of $widget
        #
        foreach event [after info] {
          set info [after info $event]
          set line [lindex $info 0]
          lassign $line proc arg 
          if {$proc eq $blink && $arg eq $widget} then {
            after cancel $event
          }
        }
      }
    }
  }
}

proc setTitle {{canvas .c}} {
  #
  # game status on window title
  #
  global flagChar cols rows
  if {[wm title .] ne "Autschn!"} then {
    global mines
    set top [winfo toplevel $canvas]
    set freeTiles [- [llength [$canvas find withtag surface]] $mines]
    if {$freeTiles == 0} then {
      wm title $top Success!
      bind . <Enter> ""
      bind . <Leave> ""
      $canvas itemconfigure flag -text $flagChar
      for {set i 0} {$i < $cols} {incr i} {
        for {set j 0} {$j < $rows} {incr j} {
          $canvas bind col$i&&row$j&&surface <1> ""
          $canvas bind col$i&&row$j&&surface <3> ""
          $canvas bind col$i&&row$j&&flag <3> ""
          $canvas bind col$i&&row$j&&surface <Leave> ""
          $canvas bind col$i&&row$j&&surface <ButtonRelease> ""
        }
      }
      blink $canvas -tag flag -color0 yellow -color1 white
    } else {
      wm title $top "$freeTiles tiles, [unflaggedMines] flags"
    }
  }
}

bind . <Enter> setTitle
bind . <Leave> {
  wm title . Mine
}

proc press {col row {canvas .c}} {
  #
  # visual response: pressed tile "sunken"
  #
  if {[$canvas itemcget row$row&&col$col&&flag -text] eq ""} then {
    variable pressed true
    $canvas itemconfigure col$col&&row$row&&topleft -fill grey15
    $canvas itemconfigure col$col&&row$row&&bottomright -fill grey85
    $canvas itemconfigure col$col&&row$row&&surface -fill grey65
  }
}

proc release {col row {canvas .c}} {
  #
  # visual response: pressed tile "raised"
  #
  variable pressed false
  $canvas itemconfigure col$col&&row$row&&topleft -fill grey85
  $canvas itemconfigure col$col&&row$row&&bottomright -fill grey15
  $canvas itemconfigure col$col&&row$row&&surface -fill grey70
}

proc takeNfromList {n liste} {
  #
  # take n different elements from list (none twice!)
  #
  if {$n > 0} then {
    set i [expr {int(rand()*[llength $liste])}]
    list [lindex $liste $i] {*}[takeNfromList [- $n 1] [lreplace $liste $i $i]]
  }
}

proc init {col row {canvas .c}} {
  #
  # On first pressed tile,
  # init game such that this tile has no mine!
  # (Some kind of humanity ...)
  #
  global rows cols mines
  global bombChar
  variable init
  if {$init} then {
    set init false
    # hide 99 mines everywhere, but not at $col $row
    # first, collect fields
    for {set i 0} {$i < $cols} {incr i} {
      for {set j 0} {$j < $rows} {incr j} {
        if {$col != $i && $row != $j} then {
          lappend fields "$i $j"
        }
      }
    }
    # hide $mines mines
    set mineIndices [takeNfromList $mines $fields]
    foreach idx $mineIndices {
      lassign $idx x y
      $canvas itemconfigure col$x&&row$y&&text -text $bombChar
    }
    # write num of neighboured mines
    for {set i 0} {$i < $cols} {incr i} {
      for {set j 0} {$j < $rows} {incr j} {
        set tags col$i&&row$j&&text
        if {[$canvas itemcget $tags -text] ne $bombChar} then {
          set count 0
          foreach di {-1 0 1} {
            foreach dj {-1 0 1} {
              if {[$canvas itemcget col[+ $i $di]&&row[+ $j $dj]&&text -text] eq
                $bombChar} then {
                incr count
              }
            }
          }
          if {$count > 0} then {
            $canvas itemconfigure col$i&&row$j&&text\
              -text $count\
              -fill [lindex {black
                            blue4
                            green4
                            red4
                            grey25
                            blue4
                            green4
                            red4
                            grey25} $count]
          }
        }
      }
    }
    check $col $row
  }
}

proc check {col row {canvas .c}} {
  #
  # Check pressed tile on mine
  #
  global bombChar rows cols mines
  if {[$canvas itemcget col$col&&row$row&&flag -text] eq ""} then {
    if {[$canvas itemcget col$col&&row$row&&text -text] eq $bombChar} then {
      #
      # hit a mine, finish game:
      #
      bumm $col $row $canvas
    } elseif {[$canvas find withtag row$row&&col$col&&surface] ne ""} then {
      #
      # remove mine, unhide number of neighboured mines
      #
      $canvas delete row$row&&col$col&&!text
      if {[$canvas itemcget col$col&&row$row&&text -text] eq ""} then {
        #
        # if zero neighboured mines, check neighboured tiles too
        #
        check [- $col 1] [- $row 1] $canvas
        check [- $col 1]    $row    $canvas
        check [- $col 1] [+ $row 1] $canvas
        #
        check    $col    [- $row 1] $canvas
        check    $col    [+ $row 1] $canvas
        #
        check [+ $col 1] [- $row 1] $canvas
        check [+ $col 1]    $row    $canvas
        check [+ $col 1] [+ $row 1] $canvas
      }
    }
  }
}

proc bumm {col row {canvas .c}} {
  #
  # mine hit, game over
  #
  global rows cols flagCharHollow bombChar
  wm title [winfo toplevel $canvas] Autschn!
  bind . <Enter> ""
  bind . <Leave> ""
  for {set i 0} {$i < $cols} {incr i} {
    for {set j 0} {$j < $rows} {incr j} {
      $canvas bind col$i&&row$j&&surface <1> ""
      $canvas bind col$i&&row$j&&surface <3> ""
      $canvas bind col$i&&row$j&&flag <3> ""
      $canvas bind col$i&&row$j&&surface <Leave> ""
      $canvas bind col$i&&row$j&&surface <ButtonRelease> ""
      if {$i == $col && $j == $row} then {
        # hit the mine, sorry ...
        $canvas delete col$i&&row$j&&!text
        # $canvas itemconfigure col$i&&row$j&&text -fill red
        blink $canvas -tag col$i&&row$j&&text\
          -color0 yellow -color1 red -interval 10
      } elseif {[$canvas itemcget col$i&&row$j&&flag -text] ne ""} then {
        # flag set
        if {[$canvas itemcget col$i&&row$j&&text -text] ne $bombChar} then {
          # but no mine under it
          $canvas itemconfigure col$i&&row$j&&flag\
            -text $flagCharHollow\
            -font "Helvetica 16 bold overstrike"\
            -fill red
        }
      } elseif {[$canvas itemcget col$i&&row$j&&text -text] eq $bombChar} then {
        $canvas delete col$i&&row$j&&!text
      }
    }
  }
}

apply {
  {cols rows} {
    .c del all
    for {set i 0} {$i < $cols} {incr i} {
      for {set j 0} {$j < $rows} {incr j} {
        tile $i $j
      }
    }
  }
} $cols $rows

---

14.3.2022

<< | Heimatseite | Verzeichnis | Stichworte | Autor | >>