[Keith Vetter] 2016-03-25 - I've been wasting too much time playing the app 1010! on my smart phone so I decided to write my own version of it. [1010! screenshot2] ---- [Jeff Smith] 2019-05-03 : Below is an online demo using [CloudTk] <> <> ---- ====== ##+########################################################################## # # 1010!.tcl -- plays the game 1010!, placing tiles and clearing filled rows # and columns. # by Keith Vetter 2016-03-22 # package require Tk set S(title) "1010!" set S(n) 10 set S(box) 40 set S(margin,outside) [expr {$S(box) * 2 / 3}] set S(margin,between) 2 set S(corner,radius) [expr {$S(box) / 6}] set S(preview,scaling) .7 set S(explode,delay) 30 set GAME(state) over set GAME(score) 0 set GAME(difficulty) easy set GAME(score) 0 set GAME(time,duration) "00:00" set CLR(empty) gray90 set CLR(box1) #7d8ed4 set CLR(box2) #98dc55 set CLR(box3) #4dd5b1 set CLR(line2) #ffc63e set CLR(line3) #ed954b set CLR(line4) #dd6555 set CLR(line5) #dd6555 set CLR(el2) #59cb86 set CLR(el3) #63bbe1 set CLR(box23) yellow set CLR(t) green set CLR(T) green set CLR(z) green set CLR(h) cyan set CLR(w) magenta # How to draw the different pieces set P(box1) {. } set P(box2) {. r d l} set P(box3) {. r r d l l d r r} set P(line2,h) {. r} set P(line2,v) {. d} set P(line3,h) {. r r} set P(line3,v) {. d d} set P(line4,h) {. r r r} set P(line4,v) {. d d d} set P(line5,h) {. r r r r} set P(line5,v) {. d d d d} set P(el2,a) {r d l} set P(el2,b) {. d r} set P(el2,c) {. r L d} set P(el2,d) {. r d} set P(el3,a) {R r d d l l} set P(el3,b) {. d d r r} set P(el3,c) {. r r L L d d} set P(el3,d) {. r r d d} set S(pieces,easy) [array names P] # https://image.apkpure.com/118/92de3b3ceef9c6/air.com.mapacarta.puzle1010-screen-2=x355.jpg set P(box23,v) {. r d l d r} set P(box23,h) {. r r d l l} set P(t,n) {r L d r r} set P(t,e) {. d r L d} set P(t,s) {. r r L d} set P(t,w) {r d l R d} set P(z,ne) {r d l d} set P(z,wn) {. r d r} set P(z,nw) {. d r d} set P(z,en) {r r D l l} set S(pieces,moderate) [concat $S(pieces,easy) [array names P]] set P(T,n) {r d d l R r} set P(T,e) {. d r r L L d} set P(T,s) {. r r L d d} set P(T,w) {R r d l l R R d} set P(h,v) {. R r d l l d R r} set P(h,h) {. r r D l L d r r} set P(w,a) {R r d l L d r r} set P(w,b) {. d r d l R r} set P(w,c) {. r r D l l d} set P(w,d) {. r r d l D r} set S(pieces,hard) [concat $S(pieces,moderate) [array names P]] proc DoDisplay {} { global S ComputeSizes wm title . $S(title) wm resizable . 0 0 canvas .c -width $S(canvas,width) -height $S(canvas,height) -bd 0 -highlightthickness 0 \ -bg white pack .c -side top -fill both -expand 1 DoDisplayBanner DrawConfigButton DrawEmptyBoard ClockTick } proc DoDisplayBanner {} { global S GAME set y [expr {$S(banner,height) / 2}] Logo1010 $S(margin,outside) $y 10 .c create text [expr {$S(canvas,width) / 2}] $y -anchor c -font {Times 48 bold} \ -tag score -fill magenta -text $GAME(score) .c create text [expr {$S(canvas,width) - $S(margin,outside)}] $y -anchor e \ -font {Times 32 bold} -tag time -fill magenta -text $GAME(time,duration) foreach var {score time,duration} { foreach tr [trace info variable GAME($var)] { trace remove variable GAME($var) {*}$tr } trace add variable GAME($var) write UpdateBannerTrace } } proc UpdateBannerTrace {var1 var2 op} { if {$var2 eq "score"} { .c itemconfig score -text $::GAME(score) } elseif {$var2 eq "time,duration"} { .c itemconfig time -text $::GAME(time,duration) } } proc About {} { set msg "$::S(title)\n\nby Keith Vetter\nMarch, 2016" set details "Simply try to fit pieces into the grid, be aware some" append details " pieces like to make a mess. Complete vertical or horizontal lines" append details " to clear blocks. Complete a line either vertically or horizontally" append details " and they disappear. Can't fit any more blocks in? Game over.." append details "\n\nThe harder levels have more complex blocks." tk_messageBox -title "About $::S(title)" -message $msg -detail $details -parent . } proc ComputeSizes {} { global S set S(banner,height) [expr {10 + [font metric {Times 48 bold} -linespace]}] set S(tableau,size) [expr {$S(n) * $S(box) + ($S(n) - 1) * $S(margin,between)}] set S(tableau,top) $S(banner,height) set S(tableau2,height) [expr {$S(tableau,size) + $S(margin,outside)}] set S(preview,top) [expr {$S(tableau,top) + $S(tableau,size) + $S(margin,outside)}] set S(preview,size) [expr {round((5 * $S(box) + 4 * $S(margin,between)) * $S(preview,scaling))}] set S(canvas,width) [expr {$S(tableau,size) + 2 * $S(margin,outside)}] set S(canvas,height) [expr {$S(preview,top) + $S(preview,size) + $S(margin,outside)}] } proc BoxToXY {row col {shrink 0}} { global S set x0 [expr {$S(margin,outside) + $col * ($S(box) + $S(margin,between))}] set y0 [expr {$S(tableau,top) + $row * ($S(box) + $S(margin,between))}] set x1 [expr {$x0 + $S(box)}] set y1 [expr {$y0 + $S(box)}] set x0 [expr {$x0 + $shrink}] set y0 [expr {$y0 + $shrink}] set x1 [expr {$x1 - $shrink}] set y1 [expr {$y1 - $shrink}] return [list $x0 $y0 $x1 $y1] } proc BoxToXYMiddle {row col} { lassign [BoxToXY $row $col] x0 y0 x1 y1 return [list [expr {($x0 + $x1)/2}] [expr {($y0 + $y1) / 2}]] } proc XYToBox {x y} { global S set col [expr {round(($x - $S(margin,outside)) / 1.0 / ($S(box) + $S(margin,between)))}] set row [expr {round(($y - $S(tableau,top)) / 1.0 / ($S(box) + $S(margin,between)))}] return [list $row $col] } proc StockPilesToXY {col} { global S set x [expr {round($S(margin,outside) + $S(tableau,size)/6. + $col * $S(tableau,size) / 3.)}] set y [expr {round($S(preview,top) + $S(preview,size)/2.)}] return [list $x $y] } proc DrawConfigButton {} { global S set x1 [expr {$S(canvas,width) - 5}] set y1 [expr {$S(canvas,height) - 5}] set x0 [expr {$x1 - 8}] set y0 [expr {$y1 - 20}] .c create rect $x0 $y0 $x1 $y1 -tag config -fill sandybrown -width 0 set id [.c create rect $x0 $y0 $x1 $y1 -tag config -fill sandybrown -width 0] .c move $id -10 0 set id [.c create rect [.c bbox config] -tag config -fill white -outline white] .c lower $id .c bind config <1> ConfigDialog } proc DrawEmptyBoard {} { global S CLR .c delete rect tile for {set row 0} {$row < $S(n)} {incr row} { for {set col 0} {$col < $S(n)} {incr col} { DrawRect .c $row $col $CLR(empty) rect } } } proc DrawRect {W row col clr tag} { # Polygon seem to always have a outline width of 1 set xy [BoxToXY $row $col 1] roundRect $W {*}$xy $::S(corner,radius) -fill $clr -outline $clr -tag $tag -width 0 } proc roundRect { w x0 y0 x3 y3 radius args } { set r [winfo pixels $w $radius] set d [expr { 2 * $r }] # Make sure that the radius of the curve is less than 3/8 # size of the box! set maxr 0.75 if { $d > $maxr * ( $x3 - $x0 ) } { set d [expr { $maxr * ( $x3 - $x0 ) }] } if { $d > $maxr * ( $y3 - $y0 ) } { set d [expr { $maxr * ( $y3 - $y0 ) }] } set x1 [expr { $x0 + $d }] set x2 [expr { $x3 - $d }] set y1 [expr { $y0 + $d }] set y2 [expr { $y3 - $d }] set cmd [list $w create polygon] lappend cmd $x0 $y0 $x1 $y0 $x2 $y0 lappend cmd $x3 $y0 $x3 $y1 $x3 $y2 lappend cmd $x3 $y3 $x2 $y3 $x1 $y3 lappend cmd $x0 $y3 $x0 $y2 $x0 $y1 lappend cmd -smooth 1 return [eval $cmd $args] } proc DrawTile {who {tag a} {W .c}} { global P CLR $W delete $tag set type [lindex [split $who ","] 0] set m [TileToMatrix $who] for {set row 0} {$row < 5} {incr row} { for {set col 0} {$col < 5} {incr col} { if {[dict get $m $row,$col]} { DrawRect $W $row $col $CLR($type) [list $tag tile] } } } } proc TileToMatrix {who} { # Converts tile described by P($who) or PP($who) into a 5x5 matrix global P PP set m [dict create] for {set row 0} {$row < 5} {incr row} { for {set col 0} {$col < 5} {incr col} { set m [dict set m $row,$col 0] } } set row 0 set col 0 set directions [expr {[info exists P($who)] ? $P($who) : $PP($who)}] foreach dir $directions { if {$dir eq "."} { ; } elseif {$dir eq "r"} { incr col } elseif {$dir eq "d"} { incr row } elseif {$dir eq "l"} { incr col -1 } elseif {$dir eq "R"} { incr col continue } elseif {$dir eq "L"} { incr col -1 continue } elseif {$dir eq "D"} { incr row continue } else { error "bad dir: $dir" } set m [dict set m $row,$col 1] } return $m } proc PlaceTileAtXY {tag xy anchor {W .c}} { lassign $xy x y lassign [$W bbox $tag] x0 y0 x1 y1 if {$anchor eq "nw"} { set dx [expr {$x - $x0}] set dy [expr {$y - $y0}] $W move $tag $dx $dy } elseif {$anchor eq "c"} { set xc [expr {($x0 + $x1) / 2}] set yc [expr {($y0 + $y1) / 2}] set dx [expr {$x - $xc}] set dy [expr {$y - $yc}] $W move $tag $dx $dy } else { error "unknown anchor '$anchor'" } } proc PlaceTileOnBoard {tag row col} { set xy [BoxToXY $row $col] PlaceTileAtXY $tag $xy nw } proc PlaceTileOnStockPile {tag col} { set xy [StockPilesToXY $col] PlaceTileAtXY $tag $xy c } proc NewTileOnStockPile {who tag col} { global NEW set NEW($tag,who) $who set NEW($tag,col) $col DrawTile $who $tag AddMoveBindings $tag $tag PlaceTileOnStockPile $tag $col DrawBackgroundTile $tag } proc RandomPiece {} { global S GAME # set all [array names P] set all $S(pieces,$GAME(difficulty)) set idx [expr {int(rand() * [llength $all])}] return [lindex $all $idx] } proc RefreshPiles {{force 0}} { global NEW GAME if {! $force} { foreach arr [array names NEW *,done] { if {$NEW($arr) == 0} return } } DeleteBackgroundTiles ThreeNewPieces {*}$GAME(preview) } proc ThreeNewPieces {args} { global NEW S GAME set args [MakePilesFit {*}$args [RandomPiece] [RandomPiece] [RandomPiece]] for {set i 0} {$i < 3} {incr i} { set tag newTile$i set NEW($i) $tag set NEW($tag,who) [lindex $args $i] set NEW($tag,col) $i set NEW($tag,done) 0 NewTileOnStockPile $NEW($tag,who) $tag $NEW($tag,col) ScaleUpDown .c $tag c $S(preview,scaling) } set GAME(preview) [MakePilesFit [RandomPiece] [RandomPiece] [RandomPiece]] Preview maybe } proc MakePilesFit {left middle right args} { # avoid two adjacent line5,h since they overlap visually if {$middle ne "line5,h"} { return [list $left $middle $right] } if {$left ne "line5,h"} { return [list $middle $left $right] } if {$right ne "line5,h"} { return [list $left $right $middle] } return [MakePilesFit $left [RandomPiece] $right] } proc DrawBackgroundTile {tag} { # Create hidden box around tile for better bind target set xy [.c bbox $tag] set id [.c create rect $xy -fill white -outline white -tag launch] .c lower $id AddMoveBindings $id $tag } proc DeleteBackgroundTiles {} { .c delete launch } ################################################################ proc MouseMove {action tag x y} { global S NEW GAME if {$GAME(state) eq "starting"} { set GAME(time,start) [clock seconds] set GAME(state) "playing" } if {$GAME(state) ne "playing"} return if {$NEW($tag,done)} return if {$action eq "down"} { set S(mouse,x) $x set S(mouse,y) $y .c raise $tag ScaleUpDown .c $tag c [expr {1 / $S(preview,scaling)}] } elseif {$action eq "move"} { set dx [expr {$x - $S(mouse,x)}] set dy [expr {$y - $S(mouse,y)}] set S(mouse,x) $x set S(mouse,y) $y .c move $tag $dx $dy } elseif {$action eq "up"} { lassign [.c bbox $tag] x0 y0 x1 y1 lassign [XYToBox $x0 $y0] row col if {[IsRoomAvailableAt $tag $row $col]} { DoMove $tag $row $col } else { PlaceTileOnStockPile $tag $NEW($tag,col) ScaleUpDown .c $tag c $S(preview,scaling) } } } proc AddMoveBindings {targetTag pieceTag} { .c bind $targetTag <1> [list MouseMove down $pieceTag %x %y] .c bind $targetTag [list MouseMove move $pieceTag %x %y] .c bind $targetTag [list MouseMove up $pieceTag %x %y] } proc RemoveTagAndBindings {tag} { .c dtag $tag } proc DoMove {tag row col} { global NEW PlaceTileOnBoard $tag $row $col RemoveTagAndBindings $tag MarkBoard $tag $row $col set NEW($tag,done) 1 set countRows [ClearRows $row $col] BonusScore $countRows RefreshPiles if {[CanMove] eq {}} { GameOver } } proc GameOver {} { global GAME set GAME(state) over ::ttk::frame .over -borderwidth 5 -relief ridge -pad 3m ::ttk::label .over.msg -text "Game Over" -font "Times 48 bold" ::ttk::button .over.new -text "New Game" -command NewGame pack .over.msg .over.new -side top place .over -in .c -relx .5 -rely .3 -anchor c } proc NewGame {} { global S GAME BRD set BRD [dict create] for {set row 0} {$row < $S(n)} {incr row} { for {set col 0} {$col < $S(n)} {incr col} { dict set BRD $row,$col 0 } } set GAME(state) starting set GAME(score) 0 set GAME(preview) [list [RandomPiece] [RandomPiece] [RandomPiece]] set GAME(time,start) [clock seconds] set GAME(time,duration) "00:00" destroy .over .c delete tile ThreeNewPieces } proc CanMove {{listAll 0}} { global NEW S set all {} foreach pile {0 1 2} { set tag $NEW($pile) if {$NEW($tag,done)} continue for {set row 0} {$row < $S(n)} {incr row} { for {set col 0} {$col < $S(n)} {incr col} { if {[IsRoomAvailableAt $tag $row $col]} { lappend all [list $pile $row $col] if {! $listAll} { return $all } } } } } return $all } proc IsRoomAvailableAt {tag row col} { global NEW BRD S if {$row < 0 || $row >= $S(n) || $col < 0 || $col >= $S(n)} { return false } set m [TileToMatrix $NEW($tag,who)] dict for {pos value} $m { if {$value == 0} continue lassign [split $pos ","] dRow dCol set row1 [expr {$row + $dRow}] set col1 [expr {$col + $dCol}] if {$row1 < 0 || $row1 >= $S(n) || $col1 < 0 || $col1 >= $S(n)} { return false } if {[dict get $BRD $row1,$col1]} { return false } } return true } proc MarkBoard {tag row col} { global NEW BRD GAME set m [TileToMatrix $NEW($tag,who)] dict for {pos value} $m { if {$value == 0} continue lassign [split $pos ","] dRow dCol set row1 [expr {$row + $dRow}] set col1 [expr {$col + $dCol}] dict set BRD $row1,$col1 1 incr GAME(score) } } proc BonusScore {countRows} { global GAME array set BONUSES {0 0 1 10 2 30 3 60 4 100 5 150 6 210} incr GAME(score) $BONUSES($countRows) } proc ClearRows {row col} { lassign [FindFullRows $row $col] countRows all foreach pos $all { lassign $pos row col distance ClearCell $row $col $distance } return $countRows } proc ClearCell {row col distance} { global BRD if {[dict get $BRD $row,$col]} { dict set BRD $row,$col 0 lassign [BoxToXYMiddle $row $col] x y set id [.c find closest $x $y] ExplodeCell $id $distance 4 } } proc ExplodeCell {tag delay state} { global S if {$delay} { set when [expr {$S(explode,delay) * $delay}] after $when ExplodeCell $tag 0 $state } elseif {$state <= 0} { .c delete $tag } else { ScaleUpDown .c $tag c .5 after $S(explode,delay) ExplodeCell $tag 0 [incr state -1] } } proc FindFullRows {row0 col0} { global BRD S set allCellsToClear {} set countRows 0 for {set row 0} {$row < $S(n)} {incr row} { set full {} for {set col 0} {$col < $S(n)} {incr col} { if {[dict get $BRD $row,$col] == 0} { set full {} break } lappend full [list $row $col [XYDistance $row0 $col0 $row $col]] } if {$full ne {}} { lappend allCellsToClear {*}$full incr countRows } } for {set col 0} {$col < $S(n)} {incr col} { set full {} for {set row 0} {$row < $S(n)} {incr row} { if {[dict get $BRD $row,$col] == 0} { set full {} break } lappend full [list $row $col [XYDistance $row0 $col0 $row $col]] } if {$full ne {}} { lappend allCellsToClear {*}$full incr countRows } } return [list $countRows [lsort -unique $allCellsToClear]] } proc XYDistance {row0 col0 row1 col1} { return [expr {max(abs($row0 - $row1), abs($col0 - $col1))}] } proc ScaleUpDown {W tag anchor amt} { lassign [$W bbox $tag] x0 y0 x1 y1 if {$anchor eq "c"} { set x [expr {($x0 + $x1)/2}] set y [expr {($y0 + $y1)/2}] } elseif {$anchor eq "nw"} { set x $x0 set y $y0 } elseif {$anchor eq "ne"} { set x $x1 set y $y0 } $W scale $tag $x $y $amt $amt # Try to avoid getting "dust"--stray pixels on the screen left # over after the item is deleted. May be due to round error. set cleanXY {} foreach xy [$W coords $tag] { lappend cleanXY [expr {round($xy)}] } $W coords $tag $cleanXY } ################################################################ proc ConfigDialog {} { if {[winfo exists .config]} return toplevel .config wm title .config "$::S(title) Configure" ::ttk::frame .config.all -padding {3m 2m 3m 0} pack .config.all -fill both -expand 1 set ::GAME(dialog,difficulty) $::GAME(difficulty) ::ttk::labelframe .config.d -text "Difficulty" foreach txt {easy moderate hard} { set title [string totitle $txt] ::ttk::radiobutton .config.d.$txt -text $title -variable ::GAME(dialog,difficulty) \ -value $txt grid .config.d.$txt -sticky w } ::ttk::frame .config.misc ::ttk::button .config.misc.about -text About -command About ::ttk::button .config.misc.preview -text Preview -command {Preview toggle} ::ttk::button .config.misc.cheat -text "New Blocks" -command {RefreshPiles 1} grid .config.misc.about -sticky w grid .config.misc.preview -sticky w grid .config.misc.cheat -sticky w ::ttk::frame .config.buttons ::ttk::button .config.ok -text "Ok" -command {ConfigDialogDone ok} ::ttk::button .config.cancel -text "Cancel" -command {ConfigDialogDone cancel} grid .config.ok .config.cancel -in .config.buttons grid columnconfigure .config.buttons {0 1} -weight 1 grid .config.d .config.misc -in .config.all -sticky wn grid config .config.d -padx {0 3m} grid .config.buttons - -in .config.all -sticky we -pady 5m PlaceWindow .config . right } proc ConfigDialogDone {how} { destroy .config if {$how eq "ok"} { set ::GAME(difficulty) $::GAME(dialog,difficulty) NewGame } } proc Preview {action} { global S GAME if {$action eq "toggle"} { set action [expr {[winfo exists .preview] ? "hide" : "show"}] } if {$action eq "hide"} { destroy .preview return } set width [expr {2 * $S(margin,outside) + 3 * $S(preview,size) + 2 * $S(margin,outside)}] set height [expr {2 * $S(margin,outside) + $S(preview,size)}] if {! [winfo exists .preview]} { if {$action ne "show"} return toplevel .preview wm title .preview "$S(title) Preview" wm transient .preview . wm protocol .preview {set ::S(preview,geom) [wm geom .preview]} canvas .preview.c -width $width -height $height -bd 0 -highlightthickness 0 pack .preview.c PlaceWindow .preview .config bottom } .preview.c delete all foreach col {0 1 2} { set who [lindex $GAME(preview) $col] if {$who eq ""} continue set x [expr {$width * (2 * $col + 1) / 6}] set y [expr {$height / 2}] set tag preview$col DrawTile $who $tag .preview.c ScaleUpDown .preview.c $tag c $S(preview,scaling) PlaceTileAtXY $tag [list $x $y] c .preview.c } } proc ClockTick {} { global GAME if {$GAME(state) eq "playing"} { set duration [expr {[clock seconds] - $GAME(time,start)}] set GAME(time,duration) [PrettyDuration $duration] } after 1000 ClockTick } proc PrettyDuration {sec} { if {$sec < 3600} { set time [clock format $sec -gmt 1 -format %M:%S] } elseif {$sec < 3600 * 24} { set time [clock format $sec -gmt 1 -format %H:%M:%S] } else { set days [expr {$sec / (3600*24)}] set sec [expr {$sec % (3600*24)}] if {$days == 1} { set time "1 day [clock format $sec -gmt 1 -format %H:%M:%S]" } else { set time "$days days [clock format $sec -gmt 1 -format %H:%M:%S]" } } return $time } proc AutoPlaceOne {strategy} { global S NEW GAME if {$GAME(state) ni {"starting" "playing"}} return set all [CanMove 1] if {$strategy eq "random"} { set move [lindex $all [expr {int(rand() * [llength $all])}]] } elseif {$strategy eq "first"} { set move [lindex $all 0] } elseif {$strategy eq "alternate"} { set move [lindex $all [expr {rand() > .5 ? "end" : 0}]] } lassign $move who row col set tag $::NEW($who) ScaleUpDown .c $tag c [expr {1 / $::S(preview,scaling)}] DoMove $tag $row $col } proc Robot {strategy} { global S NEW GAME if {$GAME(state) ni {"starting" "playing"}} return AutoPlaceOne $strategy after 200 Robot $strategy } proc Logo1010 {x y sz} { set interLetter 2 set intraLetter 1 set y0 [expr {$y - $sz -$sz/2 - $intraLetter}] .c delete logo set clrs {red sandybrown sandybrown sandybrown green blue blue blue cyan} for {set col 0} {$col < 9} {incr col} { set clr [lindex $clrs $col] set newLetter [expr {$col > 0 && $clr != [lindex $clrs $col-1]}] if {$newLetter} { incr x $interLetter } set x1 $x set x2 [expr {$x + $sz}] for {set row 0} {$row < 3} {incr row} { if {$row == 1 && ($col == 2 || $col == 6)} continue set y1 [expr {$y0 + $row * ($sz + $intraLetter)}] set y2 [expr {$y1 + $sz}] if {$row == 1 && $col == 8} { incr y1 -1 } .c create rect $x1 $y1 $x2 $y2 -fill $clr -width 0 -tag logo } incr x $sz incr x $intraLetter } } proc PlaceWindow {who parent where} { if {! [winfo exists $parent] || ! [winfo exists $who]} return set n [scan [wm geom $parent] %dx%d%d%d width height x y] if {$n != 4} return if {$width == 1} { update puts "geom2: [wm geom $parent]" } if {$where eq "right"} { incr x $width incr x 5 } elseif {$where eq "bottom"} { incr y $height incr y 30 } else return wm geom $who +$x+$y } ################################################################ DoDisplay NewGame return ====== <>Games | Application