Initial upload
This commit is contained in:
Luxferre
@@ -0,0 +1,584 @@
|
||||
#!/usr/bin/env tclsh
|
||||
# BOXcl: a simple and self-contained Sokoban clone that can load any custom levelset
|
||||
# Depends upon Tcllib and Tk
|
||||
# Compatible with *plaintext* levels downloaded from https://www.sourcecode.se/sokoban/levels.php
|
||||
# Press h or F1 to get in-game help
|
||||
# Controls: WASD or arrow keys to move, u to undo, r to restart,
|
||||
# Ctrl+N / Ctrl+P to switch levels in the set, Ctrl+O to open a new set, Ctrl+Q to quit
|
||||
# Created by Luxferre in 2024, released into public domain
|
||||
|
||||
package require textutil
|
||||
package require Tk
|
||||
|
||||
# hardcoded tile sizes
|
||||
set tilew 64
|
||||
set tileh 64
|
||||
|
||||
# check if the line contains only valid Sokoban format characters
|
||||
proc islevelline {line} {
|
||||
return [regexp {^[ #pPbB._*$+@-]+$} $line]
|
||||
}
|
||||
|
||||
# convert a level data line into the internal format
|
||||
proc levelconvert {datalist} {
|
||||
set convdata ""
|
||||
foreach dataline $datalist {
|
||||
set outlist ""
|
||||
foreach chr [split $dataline ""] {
|
||||
switch $chr {
|
||||
{#} {lappend outlist 8}
|
||||
p -
|
||||
@ {lappend outlist 2}
|
||||
P -
|
||||
+ {lappend outlist 3}
|
||||
b -
|
||||
$ {lappend outlist 4}
|
||||
B -
|
||||
* {lappend outlist 5}
|
||||
. {lappend outlist 1}
|
||||
" " -
|
||||
"-" -
|
||||
_ {lappend outlist 0}
|
||||
default {}
|
||||
}
|
||||
}
|
||||
lappend convdata $outlist
|
||||
}
|
||||
return $convdata
|
||||
}
|
||||
|
||||
# load and parse a levelset file
|
||||
proc loadlevels {fname} {
|
||||
set fp [open $fname r]
|
||||
fconfigure $fp -encoding utf-8 -translation auto
|
||||
set fdata [read $fp]
|
||||
close $fp
|
||||
set levelblocks [::textutil::splitx $fdata {\n\n}]
|
||||
set levelsettitle ""
|
||||
set levelsetauthor ""
|
||||
set outlevels ""
|
||||
foreach lblock $levelblocks {
|
||||
set leveldata ""
|
||||
set leveltitle ""
|
||||
foreach line [split $lblock "\n"] {
|
||||
set line [string trimright $line]
|
||||
if {[islevelline $line]} { # the line contains valid level characters
|
||||
lappend leveldata $line
|
||||
} else {
|
||||
if {[regexp {^Title:(.*)$} $line _ title]} {
|
||||
set leveltitle [string trim $title]
|
||||
} elseif {[regexp {^Author:(.*)$} $line _ author]} {
|
||||
set levelsettitle $leveltitle
|
||||
set leveltitle ""
|
||||
set levelsetauthor [string trim $author]
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$leveldata ne ""} {
|
||||
set lobj ""
|
||||
dict set lobj settitle $levelsettitle
|
||||
dict set lobj author $levelsetauthor
|
||||
dict set lobj title $leveltitle
|
||||
dict set lobj data [levelconvert $leveldata]
|
||||
lappend outlevels $lobj
|
||||
}
|
||||
}
|
||||
return $outlevels
|
||||
}
|
||||
|
||||
# render the level state
|
||||
proc renderfield {leveldata} {
|
||||
global tilew tileh fieldw
|
||||
global tile_0 tile_1 tile_2 tile_3 tile_4 tile_5 tile_8
|
||||
.c delete anytile
|
||||
set rownum 0
|
||||
foreach line $leveldata {
|
||||
set tiley [expr {$rownum * $tileh}]
|
||||
for {set colnum 0} {$colnum < $fieldw} {incr colnum} {
|
||||
set colval [lindex $line $colnum]
|
||||
if {$colval eq ""} {set colval 0}
|
||||
set curtile "tile_$colval"
|
||||
set tilex [expr {$colnum * $tilew}]
|
||||
.c create image $tilex $tiley -image $curtile -anchor nw -tag anytile
|
||||
}
|
||||
incr rownum
|
||||
}
|
||||
}
|
||||
|
||||
# move logic
|
||||
# dir: 0 up, 1 left, 2 down, 3 right
|
||||
# return 1 if won
|
||||
proc domove {dir} {
|
||||
global leveldata fieldw fieldh pushcount
|
||||
# detect horizontal and vertical direction factors
|
||||
if {$dir % 2} {
|
||||
set hd [expr {$dir - 2}]
|
||||
set vd 0
|
||||
} else {
|
||||
set vd [expr {$dir - 1}]
|
||||
set hd 0
|
||||
}
|
||||
# find the player position into cx and cy
|
||||
for {set cy 0; set outbreak 0} {($outbreak < 1) && ($cy < $fieldh)} {incr cy} {
|
||||
for {set cx 0} {($outbreak < 1) && ($cx < $fieldw)} {incr cx} {
|
||||
if {[lindex $leveldata $cy $cx] & 2} { # found it
|
||||
set outbreak 1
|
||||
incr cx -1
|
||||
incr cy -1
|
||||
}
|
||||
}
|
||||
}
|
||||
# calculate the new target player position
|
||||
set tx [expr {$cx + $hd}]
|
||||
set ty [expr {$cy + $vd}]
|
||||
# start by checking if it is within the field boundaries
|
||||
if {($tx >= 0) && ($tx < $fieldw) && ($ty >= 0) && ($ty < $fieldh)} {
|
||||
# get the target object value
|
||||
set tov [lindex $leveldata $ty $tx]
|
||||
if {$tov < 6} { # we're not pushing a wall
|
||||
if {$tov & 4} { # we've hit a box
|
||||
# get next-to-target positions
|
||||
set ntx [expr {$tx + $hd}]
|
||||
set nty [expr {$ty + $vd}]
|
||||
# calculate the condition under which we can push
|
||||
if {($ntx >= 0) && ($ntx < $fieldw) && ($nty >= 0) && ($nty < $fieldh)} {
|
||||
set ntov [lindex $leveldata $nty $ntx]
|
||||
if {$ntov < 4} { # now we can push
|
||||
# remove the box from the target field
|
||||
lset leveldata $ty $tx [expr {$tov & 11}]
|
||||
# push the box further
|
||||
lset leveldata $nty $ntx [expr {$ntov | 4}]
|
||||
# increment the push counter
|
||||
incr pushcount
|
||||
} else {return 0}
|
||||
} else { # otherwise don't perform the move
|
||||
return 0
|
||||
}
|
||||
}
|
||||
# now, remove player from the current field
|
||||
lset leveldata $cy $cx [expr {[lindex $leveldata $cy $cx] & 13}]
|
||||
# add player to the target field
|
||||
lset leveldata $ty $tx [expr {[lindex $leveldata $ty $tx] | 2}]
|
||||
# check for victory by counting boxes not on goals
|
||||
set bcount 0
|
||||
for {set cy 0} {$cy < $fieldh} {incr cy} {
|
||||
for {set cx 0} {$cx < $fieldw} {incr cx} {
|
||||
if {int([lindex $leveldata $cy $cx]) == 4} { # non-goal box
|
||||
incr bcount
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$bcount > 0} {return 0} else {return 1}
|
||||
}
|
||||
}
|
||||
return 0
|
||||
}
|
||||
|
||||
# perform a move and render it
|
||||
proc rendermove {dir} {
|
||||
global leveldata pushcount undobuffer
|
||||
lappend undobuffer $leveldata
|
||||
set res [domove $dir]
|
||||
# remove the last undobuffer entry if the field is the same
|
||||
if {[lindex $undobuffer end] eq $leveldata} {
|
||||
set undobuffer [lreplace $undobuffer end end]
|
||||
}
|
||||
renderfield $leveldata
|
||||
# check for victory flag
|
||||
if {$res eq 1} {
|
||||
tk_messageBox -title {Victory!} -type ok -message "Level complete!\nPushes: $pushcount"
|
||||
nextlevel 1
|
||||
}
|
||||
}
|
||||
|
||||
# undo the last move and render the result
|
||||
# Tcl 8.6 compatible (no lpop)
|
||||
proc renderundo {} {
|
||||
global leveldata undobuffer
|
||||
if {[llength $undobuffer] > 0} {
|
||||
set leveldata [lindex $undobuffer end]
|
||||
set undobuffer [lreplace $undobuffer end end]
|
||||
renderfield $leveldata
|
||||
}
|
||||
}
|
||||
|
||||
# start a loaded level
|
||||
proc startlevel {level} {
|
||||
global tilew tileh fieldw fieldh leveldata pushcount
|
||||
global undobuffer
|
||||
set undobuffer ""
|
||||
set leveltitle [dict get $level title]
|
||||
set leveldata [dict get $level data]
|
||||
set settitle [dict get $level settitle]
|
||||
set pushcount 0
|
||||
# determine field width and field height (in tiles)
|
||||
set fieldh [llength $leveldata]
|
||||
set fieldw 0
|
||||
foreach l $leveldata {
|
||||
set lw [llength $l]
|
||||
if {$lw > $fieldw} {set fieldw $lw}
|
||||
}
|
||||
# align level data
|
||||
set idx 0
|
||||
foreach l $leveldata {
|
||||
set lw [llength $l]
|
||||
if {$lw < $fieldw} {
|
||||
set diff [expr {$fieldw - $lw}]
|
||||
for {set i 0} {$i < $diff} {incr i} {
|
||||
lset leveldata $idx end+1 0
|
||||
}
|
||||
}
|
||||
incr idx
|
||||
}
|
||||
|
||||
.c configure -width [expr {$fieldw * $tilew}] -height [expr {$fieldh * $tileh}]
|
||||
wm title . "BOXcl - $settitle - $leveltitle"
|
||||
renderfield $leveldata
|
||||
}
|
||||
|
||||
# move to the next level in the set
|
||||
proc nextlevel {natural} {
|
||||
global sublevel levels levelcount
|
||||
incr sublevel
|
||||
if {$sublevel == $levelcount} {
|
||||
if {$natural eq 1} {
|
||||
tk_messageBox -title {All clear!} -type ok -message "Congratulations!\nYou have beaten the last level in the set!"
|
||||
exit 0
|
||||
} else {
|
||||
set sublevel 0
|
||||
startlevel [lindex $levels $sublevel]
|
||||
}
|
||||
} else {
|
||||
startlevel [lindex $levels $sublevel]
|
||||
}
|
||||
}
|
||||
|
||||
# move to the previous level in the set
|
||||
proc prevlevel {} {
|
||||
global sublevel levels levelcount
|
||||
incr sublevel -1
|
||||
if {$sublevel == -1} {
|
||||
set sublevel [expr {$levelcount - 1}]
|
||||
}
|
||||
startlevel [lindex $levels $sublevel]
|
||||
}
|
||||
|
||||
# open a levelsetfile
|
||||
proc openlevel {} {
|
||||
set types {
|
||||
{{Plain text levelset} {.txt} TEXT}
|
||||
{{Sokoban YASC levelset} {.sok} TEXT}
|
||||
}
|
||||
return [tk_getOpenFile -filetypes $types -title {Choose a Sokoban levelset file}]
|
||||
}
|
||||
|
||||
# define the tiles
|
||||
|
||||
set imgdata(wall) {
|
||||
iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAAAAACPAi4CAAADQ0lEQVRYw8VX23bqIBDtD9mLra1a
|
||||
q9Vj6wq5nIRkBcKa//+OQ4AQGIjV+nDmpXZDdsjMZjPc3d8YdzcTzB4eTbzIeFvJeHtxQiELF1n0
|
||||
U+b6mfvZ3Wy+lLH9k6ggDICTxIlUADQukBAOAH+Pu5V87sEQHMZRgNSbnpQAxEcKgE7++X63BHtn
|
||||
VLAEBYSIXtNpZQjW7iC7iICqv3tD4C4g6To0O4UQgVb9+DYEX85gDpD70ylA4SM1gNCJWmsCl1xm
|
||||
mHtZzGUVRIkYh0mbnuD1I7dRgwoaIIza4BoRtfy9f+wJPuGKEGzgapmA05MkeF5TKtRYlZvFk7xo
|
||||
9VvybPgSvZbO/by0VQR9DkjPUARyK3DuUILTr4EgyYbSjgwCKVhWOFDEpyVIWqxX+cIiQNBLku1I
|
||||
QAHLjWJBSOQsAdpDSRNZQYuQ3UjAIzlA00mHdyo5WgK5Z6HyBjlGSNMLMIuXUevNWUOmdAAN8UTe
|
||||
S6OxkmyMkBZbxpkKPgrOIN05RIpSfcLifVxlqcZrp6KkjSOisJvJ241SLCh3JIqY9EQIypgnhojx
|
||||
mAjBhZ5IpwnYjQQELvLEJjmTg9ATQ0SQCYK0i3liiBiJaU/cXOCJIcJL+Xt7vSf6YaQ8/EuxJ0Iz
|
||||
emLBFFLnQ0KyvBZ2M1G0l4xL+ju8Z6j9U9YSSPfADljYVDuHFkKSw2goXeCJHL0uhjiWVgeeeLWp
|
||||
/saVHU9soAxOgfBc4AjZWwKZdJEhUwbwkSrwzdxWQRueI3lSqaqXiNGvVTkcrnklzCFuo/Od0EE6
|
||||
i3CjxNfdYLP1MEs0hdZ9SesphNPK7IWXJeo+/H6kiiLGZCJ+wACXo4khk34g9XqjIyXdrabKbyRI
|
||||
Y51xiLSTBDTodVgMMaJTBM9L1Ei5Z7Lq/2OIrqw21d3YRDJ77g4BU4iS5NH3RKtT7p3h3mOj4MVg
|
||||
qn0OSjXX3UwUkAIN4npEwT1PRP4RbzR9TWam0Twqs6iClupnQzGOdJjwxB/7xNNaE2x+22geDEH/
|
||||
DU2k0SwDpEELeDcEq5O8HYaNJgsQ/2DZLo2tS4beFMugCmVgs84Sjpvlh+rW+6vv03wu77P4futf
|
||||
edUdeLwWz9VT8ur732/v/wB3P44Wbg6kBQAAAC10RVh0U29mdHdhcmUAYnkuYmxvb2RkeS5jcnlw
|
||||
dG8uaW1hZ2UuUE5HMjRFbmNvZGVyqAZ/7gAAAABJRU5ErkJggg==
|
||||
}
|
||||
|
||||
set imgdata(boxongoal) {
|
||||
iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAQAAAAAYLlVAAACy0lEQVRo3sWZvW7bMBDHObWZmqKR
|
||||
KAcGmjiI69RorEqWfYEQoFq7d+/SvY+QpXseoY+ixXsfoUMfIQ9wHSgpTnj8kklGt9Ew/z+Rx9Px
|
||||
jrHh4Xlyl7RJm7Qcw1jSJu3Jr3c/Xl+y5w/Pw8kqUKo9+en3pz9Pg9npI8LD8bfh7cVQhue4wGVw
|
||||
u8BJh8BzxhhjWcuR4yleRRAXdtWtRNIO759FlBcImdiKnKX3HDnOosovcYnnYg3umfB++f1LrLHA
|
||||
mrAKgRgttCOlNP+i3wSx/xQjYIUNYTd4S4xWmhEg5xeuyMSxo5dp5QUAFLNPzQBLhIMBQDk3CVBa
|
||||
ILgAALGqWoCa+AuMBpDn2mJtAmiMCLYAhTTPJ2xsAEwIdgBAHOzKFkCPYANAyTcuADoEMwAt7wig
|
||||
RjABqOSdASg3AiOAbvOcASoyLugA9O47AqAhED4rAUwHeBQAhbAlAcwhbCRAYxWgV2TY8QRgRlCF
|
||||
HW8ADW41COqw4xFA7WK6sOMVoCG/bvqw4xngOcKcSGbBkCEcCLCPoJcPBtBgZSUfEOAGcwv5oAC3
|
||||
Vhl0QIC1JD/HWbwVqCT5y25DoviAfO5ne/4Q/BTo5YPHASoY58rTEO1boPpSegbQpRv0l9IrADjn
|
||||
A+ATACwyomvL0DQCACxzwjJMTijLXyuz4tJ/VkylG7p7Qen3XlCQ2Y7+ZlT6uxmpki33uyGMAVDn
|
||||
emNux+AKIE+xPrA+AC4AYSokYAsQrka0sgHwWSWjTkQdt05YEq4cuVJaulVKQ9SKN2MBQlfLe4C/
|
||||
HLli8X0B0AhduV40LD5Ii7/BDea4IazANTGaG0ZWZMMi3bHkjiPH9y/Xsjk6E02rRVT5vmn16iNj
|
||||
3Sa8RNsu3T1pXE7wIgrEvO8aPgw95JOhdZsFbNsKmwzN26F1yxhjb78kf6I2r/+9+Sp10I/O0t8i
|
||||
KoS1dJf+ZMe96n+qpZFsvgDj+QAAAC10RVh0U29mdHdhcmUAYnkuYmxvb2RkeS5jcnlwdG8uaW1h
|
||||
Z2UuUE5HMjRFbmNvZGVyqAZ/7gAAAABJRU5ErkJggg==
|
||||
}
|
||||
|
||||
set imgdata(box) {
|
||||
iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAQAAAAAYLlVAAACvklEQVRo3sWZW07jMBSGs4PRPFaC
|
||||
OFGFeBlRiqhGFaqAKpoEGoGRIp4isYRZQpfAEmYpWcIsgSWwhH8enKYdfHwLtonfXNX/F9vn5FyS
|
||||
ZHjyWbplHetYlyHMYB3r0m36MmHJxyefhZOlUfLZgXz68v/Pp8HGyR7h/fhxeHsxleMMS6yCjwtM
|
||||
e4R+F8Tmn+AqgrgYV/1OsG54/zyivEDIxa7PkvQ1Q4bzqPIrrHCGDBnS1/4A5Pev0KBEQ4wanJgt
|
||||
tTOVtP5ydwji/ClGjg1aYjzhmZjdaGY4ub64iokwO3qbCi8AXLH6qRlgBf5pAK5cmwSoLBBcAGT5
|
||||
tR6gIf7CRwPIaz2gMQG0RgRbAHk3b9DaAJgQ7AA4YdgbWwA9gg0AJd+6AOgQzAC0vCOAGsEEoJJ3
|
||||
BmhRkgh6AN3hOQNsSL+gA9Bf3xEAlDH9UgKYDHgUAIXwSAKYXdhIgNbKQRek2/EEYEZQuR1vAC0e
|
||||
NAhqt+MRQH3FdG7HK0BLft30bsczwEeEBeYGt+Md4BBBLx8MoEVtJR8Q4AmFhXxQgGcixFxbRole
|
||||
AO4l+QXm8XagluQv+wOJcgdku58f3IfgVqCXD+4HKGdcKK0h2rdA9aX0DKALN+gvpVcA7hwPcJ8A
|
||||
3CIiurVI7kcCcMuYsAoTE8ryt8qouPIfFVPhhi4vqPzmBRUZ7egzo8pfZqQKttxzQz4GQB3rjcmO
|
||||
uSuAvMT9J+sD3AUgTIWE2wL4qhGVpGtqYlbJKIto4tYJKUOOXCmt3CqlIWrF9ViA0NXyHoC9ZcgU
|
||||
m+8LgEboy/WiYfFTSjNq1ChQE6PEHTFbGGbWqoZFus2Q4cfXtWwmTDStllHld02rCfv6tt2+cTnF
|
||||
RRSIxU7+fegh71u3ecC2rRjToXk7tG6TJEmOrtnfqM3rt6NrqYM+Yekf4RVCd87T39+/7VT/AZaV
|
||||
3OsTnXjsAAAALXRFWHRTb2Z0d2FyZQBieS5ibG9vZGR5LmNyeXB0by5pbWFnZS5QTkcyNEVuY29k
|
||||
ZXKoBn/uAAAAAElFTkSuQmCC
|
||||
}
|
||||
|
||||
set imgdata(player) {
|
||||
iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJ
|
||||
bWFnZVJlYWR5ccllPAAAAyZpVFh0WE1MOmNvbS5hZG9iZS54bXAAAAAAADw/eHBhY2tldCBiZWdp
|
||||
bj0i77u/IiBpZD0iVzVNME1wQ2VoaUh6cmVTek5UY3prYzlkIj8+IDx4OnhtcG1ldGEgeG1sbnM6
|
||||
eD0iYWRvYmU6bnM6bWV0YS8iIHg6eG1wdGs9IkFkb2JlIFhNUCBDb3JlIDUuNi1jMTM4IDc5LjE1
|
||||
OTgyNCwgMjAxNi8wOS8xNC0wMTowOTowMSAgICAgICAgIj4gPHJkZjpSREYgeG1sbnM6cmRmPSJo
|
||||
dHRwOi8vd3d3LnczLm9yZy8xOTk5LzAyLzIyLXJkZi1zeW50YXgtbnMjIj4gPHJkZjpEZXNjcmlw
|
||||
dGlvbiByZGY6YWJvdXQ9IiIgeG1sbnM6eG1wPSJodHRwOi8vbnMuYWRvYmUuY29tL3hhcC8xLjAv
|
||||
IiB4bWxuczp4bXBNTT0iaHR0cDovL25zLmFkb2JlLmNvbS94YXAvMS4wL21tLyIgeG1sbnM6c3RS
|
||||
ZWY9Imh0dHA6Ly9ucy5hZG9iZS5jb20veGFwLzEuMC9zVHlwZS9SZXNvdXJjZVJlZiMiIHhtcDpD
|
||||
cmVhdG9yVG9vbD0iQWRvYmUgUGhvdG9zaG9wIENDIDIwMTcgKFdpbmRvd3MpIiB4bXBNTTpJbnN0
|
||||
YW5jZUlEPSJ4bXAuaWlkOjJCQzQyNTY5RTI1NTExRTZCNUJFOEM2QkJDQzA1OUQ1IiB4bXBNTTpE
|
||||
b2N1bWVudElEPSJ4bXAuZGlkOjJCQzcyN0ZCRTI1NTExRTZCNUJFOEM2QkJDQzA1OUQ1Ij4gPHht
|
||||
cE1NOkRlcml2ZWRGcm9tIHN0UmVmOmluc3RhbmNlSUQ9InhtcC5paWQ6MkJDNDI1NjdFMjU1MTFF
|
||||
NkI1QkU4QzZCQkNDMDU5RDUiIHN0UmVmOmRvY3VtZW50SUQ9InhtcC5kaWQ6MkJDNDI1NjhFMjU1
|
||||
MTFFNkI1QkU4QzZCQkNDMDU5RDUiLz4gPC9yZGY6RGVzY3JpcHRpb24+IDwvcmRmOlJERj4gPC94
|
||||
OnhtcG1ldGE+IDw/eHBhY2tldCBlbmQ9InIiPz6SouJPAAAGb0lEQVR42u1ba08cVRjmH/gT/GrV
|
||||
eMnCXgoK4SKwu7VooGBdKTbQLWJDEFtrbcVG+SJorY02tqRUrbYlqYSEYiLWfkESDZe2Rog2FNGm
|
||||
GtFSjPiBtHmdZzpnPDtzdvfsMmfY4k7yJJudc973eZ9z5p1zmZNDRDn/Z+RkBcgKkBUgK0DSQpJX
|
||||
NOx9sHlDoHB72N/B4fxK0BwKHGC2okHfRtiX5aNcgG2lnruaQ/4t20P+Xp1sOEBuQBdH8wnf4LAq
|
||||
AqA1NBKzPLGGukeprqmEKl7dYKLgYA35D9emDd5WdUsZReqLYsXQOICLqwJAeT7o8O6gHuhDJyJ0
|
||||
z8BWpbi/b4spDHybYmicXBGgJbj+buYUgYOQ6qATiQEhGB9wUy6A/uxpzqraKlYtcCvAxXgcetUL
|
||||
YCQ7N7q7LMCFJUflAmiOFhqfzM+Y4BnYY+CGALqjdEjmnW2h3RM9NHxtnL6Zn44B/sO9NSsAgru6
|
||||
NE/Jrqkbc1R1vmNtCYCAFpeXSPaCUKmKkLECFH+xM6Xg+Z6AR+aOF+CzuRFK90LdO16AdFqfXaib
|
||||
8QKsG2qkdZ83xeC+r5qV4N7haKwvzfeqCfDAWFtGIStAVgCXBcj78rmMCR5c3BMgFJiEo00vBjNG
|
||||
AHC5vSYQmHRjNtghWqb6Y/wjop8GXMOHr2+zL5eFAgf4JTLHBWBrAVb0de9wNXgAggvXC0P+WSUC
|
||||
sOC7Wmto8INdNHx8r+6wM7qRlqZOx5D7eeQIvd1WqwO/0w2St/PD8CHb/cH3d+ocwAWcwI1fGHFM
|
||||
ALYGuO/ZSrpw9i2aPndIxyv1FcIAQZi1CH6nK4CMHTQA4wNu4MjWCB0U4Hbig9LMGWBteQZrt0xX
|
||||
ABk74MBzYj0TnJ0TwCDAOwJWQtwpAQArL7P8agmAbsnq4LeozG9jx2nu6yM6rn17jG7O9KdlB/WU
|
||||
C8A2QKyPwPLlM3GT1ws1RTpEOeLGpU9spCFIPDvwLUqC+iMwLX4EwNk5AYx3vzUJwnmqr65zvXtt
|
||||
wTPgXqpvDV4APgmCs6OvQZYId20uNXsCWlKW6IWBLrNrftrVYgserzF2H2Vl7f71/Umz5cGNHxE6
|
||||
KoC+ERoO9PNJCe9hGZLovqlugI6eekPKNhsLcOhno0HHR4IwrD8ORm+QfcdjvJCqAHj2UxFAz1OW
|
||||
rXNlm6NGb4ibma1giUyFAKa4bm6O8t8CyCQtJD+0FD+yiweUQVmZyRV8811f+eao/gVIOLAAh5uf
|
||||
L6fSnghF3ovQTZdngvr7X/P50skWnQO4GCIsgKPK2eAsC56fj3/cWUt/tj0lxDsD7bT14v60gLrx
|
||||
7MInz4GJoGw2GA37WuGgqbqAHh7ZYVuUeLN7E/0aLrBhMlJMAUH5ZEAd1BXZhC9reXACN3AEV+en
|
||||
w8Zzjy7HO2atVTHxMrX3PEOXqwuFIlQNRqWDR1lR8LANH/DF/PL1wI3fJnd2IGQkG9b6rZc6afGK
|
||||
fSh8fewYzUefELbcSGMZRU80CHsE/sM9lBHVhU3YtvoDB3BhvYBfG1QiAAs+WYISBbESJEu0TAR1
|
||||
AhiDH6h8dSb5HMBpAZL5AyezB6gYCrNh8P6+dqnXVLxAfgnm04/lfvquzBsD/Id76QoAgBsbE6hI
|
||||
gh2y4//lkaPCIBDkeEleQqCMqC5sSg+LNa7KXoOH99QnJfJ37z5bADMVgaTBM6CstT5sJvMLbspe
|
||||
g5hoyIz/b02dpt/rg7ZuPyEZPICy1scBNm9NJc495gqSMSlyVAD+A8lE4/TrexpsrXex1CsdPAPq
|
||||
WO3Atsw+AZsTKNsYwYRFtCL8z6lOG+krlf91/VENZ7SEd7TcJwTujXIioK7VHnyIVobZRIv/WNJx
|
||||
AYxesMBEwMrN5NBBmh56lxa7W4XJa+oxnx7Ma/m5VOn1JJ0NogzKog7qimzCF3zCNzhws8wFfkao
|
||||
ZDqM2Rb/lbjH40kJT5f5zESl5xUNLMHiXqr2Yr4a52aCriyIrEQAfvWGJdiVCCA6N6D0vAB7FB4v
|
||||
9EqTLVmfS01Bv+3LbmOdQf//EV+utL3qYq/wG2F3BODODNRrCQxCFAVyKeCNJenN9VB5QZ5Jlm1j
|
||||
W+3xO891pT69DuxZg4Z9+IJP016cYzTKj8zoZ3iMniALNkgRXfG+PUiAhURniFw7NMXODcUTA10U
|
||||
gSc632Ozxw5NiQPvFy2CKhMge24wK0BWgKwAaxX/AvBZf/1O5gkeAAAAAElFTkSuQmCC
|
||||
}
|
||||
|
||||
set imgdata(floor) {
|
||||
iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAIAAAAlC+aJAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJ
|
||||
bWFnZVJlYWR5ccllPAAAAyZpVFh0WE1MOmNvbS5hZG9iZS54bXAAAAAAADw/eHBhY2tldCBiZWdp
|
||||
bj0i77u/IiBpZD0iVzVNME1wQ2VoaUh6cmVTek5UY3prYzlkIj8+IDx4OnhtcG1ldGEgeG1sbnM6
|
||||
eD0iYWRvYmU6bnM6bWV0YS8iIHg6eG1wdGs9IkFkb2JlIFhNUCBDb3JlIDUuNi1jMTM4IDc5LjE1
|
||||
OTgyNCwgMjAxNi8wOS8xNC0wMTowOTowMSAgICAgICAgIj4gPHJkZjpSREYgeG1sbnM6cmRmPSJo
|
||||
dHRwOi8vd3d3LnczLm9yZy8xOTk5LzAyLzIyLXJkZi1zeW50YXgtbnMjIj4gPHJkZjpEZXNjcmlw
|
||||
dGlvbiByZGY6YWJvdXQ9IiIgeG1sbnM6eG1wPSJodHRwOi8vbnMuYWRvYmUuY29tL3hhcC8xLjAv
|
||||
IiB4bWxuczp4bXBNTT0iaHR0cDovL25zLmFkb2JlLmNvbS94YXAvMS4wL21tLyIgeG1sbnM6c3RS
|
||||
ZWY9Imh0dHA6Ly9ucy5hZG9iZS5jb20veGFwLzEuMC9zVHlwZS9SZXNvdXJjZVJlZiMiIHhtcDpD
|
||||
cmVhdG9yVG9vbD0iQWRvYmUgUGhvdG9zaG9wIENDIDIwMTcgKFdpbmRvd3MpIiB4bXBNTTpJbnN0
|
||||
YW5jZUlEPSJ4bXAuaWlkOjJCRThGOUE2RTI1NTExRTZCNUJFOEM2QkJDQzA1OUQ1IiB4bXBNTTpE
|
||||
b2N1bWVudElEPSJ4bXAuZGlkOjJCRThGOUE3RTI1NTExRTZCNUJFOEM2QkJDQzA1OUQ1Ij4gPHht
|
||||
cE1NOkRlcml2ZWRGcm9tIHN0UmVmOmluc3RhbmNlSUQ9InhtcC5paWQ6MkJFOEY5QTRFMjU1MTFF
|
||||
NkI1QkU4QzZCQkNDMDU5RDUiIHN0UmVmOmRvY3VtZW50SUQ9InhtcC5kaWQ6MkJFOEY5QTVFMjU1
|
||||
MTFFNkI1QkU4QzZCQkNDMDU5RDUiLz4gPC9yZGY6RGVzY3JpcHRpb24+IDwvcmRmOlJERj4gPC94
|
||||
OnhtcG1ldGE+IDw/eHBhY2tldCBlbmQ9InIiPz4wOW0fAAAE4UlEQVRo3rVa2XbbQAjlp2MnttOm
|
||||
y2NtWfKapenpnxZ5YoJnYYBRz6F9yLEkLgOXbeDu1ybI6nD6+f43lW8vv+/WXfjNfLN9PJynkoft
|
||||
jr6+6PfKp5a7Iz2FAvhvttmillntg3x/fScMq/1pKgCz6zsRienBxbBnANadrP3nObg+VjTkcAgv
|
||||
RBgOo8w3/QcAjfZB0McmPAT0xvC2+25wPE6HAErtg9xvh0kiAT2efMB3pOEA0fo2AGMwfJitb3ce
|
||||
ciHHS1CBxXBAlWwAUIgEHvpdu/a+VwUdnp7fPAAoEkzcF2mPxsPPfzk9B59EQZ2UL1ntjoG+8PGm
|
||||
E7CGIIVd+DAJIkEmVHIR/obIF8F7AMyu7MEw9Pqo/Xp+LeWZEYN4Dqg9sSe9DfBhvfaLnAdfeKkX
|
||||
7EcZN7J9fA6XgC750kX72HYIG+Zd36i9nI/wfORShQThleKBe04kEEJKfvWPtz9IFIL2nE8IBid7
|
||||
dDyTjTg9LK9Ri//j35EJgmD4fQAIoAXtU7+3ivKcOcWhuugzcr2ExoKIldLwIu1HBx0OAp3LEmjb
|
||||
yhDVRAHcwx6PZ7T3jVMSZyV0yT1E6V0mglZmG4gZat0hv1J+kQ3AC3qNCMHGnef2kUquhGqkyzky
|
||||
ImYfBjx5h+1jAFkM1US7Kpx7iBk8oiCcwiMMLdrHAFIMFLVyYZjJCcm5ERsGn8QkilJiZ32VBXK9
|
||||
UXXBqMELlUUpK3MMkptZakSQHUNTrHMA1W8LOdXXoEG19JXfuGRQNf5WrGq8Uw/QtK0lIiLbVwtJ
|
||||
JQalCbQAKFVlCzVKAlbtS77k6y1B2f5xLfHvc1ZfuIcUEQX7ZgWgp5fwDW62Fu2zNpoYQErwpiSt
|
||||
HTCyVOBwRVCOINtHCRq2wMJkGgBVtvYdt8ZY1kkH+Eo03zxQWRSaPBMcrj/hiLdUmesxQKL9oKmK
|
||||
p3WhbGuhDGhwN1mTUFClpFVwNFRtHzXXjXnH1FQIY6IYQMnveTmN74oOeiomnYtTDxkDpPM6mdHQ
|
||||
Wvx7jvLLwRlCWwIlvpd5hvytsZpIjxTbtKfnN5SxzWe65a25P4G7LqcSAH/swxD1k9gr86EODa5v
|
||||
QuJ64PjFAB70U06h3nYsbCLGK01c+JK3OBtt6SrIiiYMqe0rC9IyBmivEYgDNGUMnm0UtdXRsowh
|
||||
BuDwZv3KcZVMJTTayxigvUTLjFVyzJ2m+eq0tLRsLwLwlWhZIufMjapnyHrdmZZDpQEwWLdd+tGi
|
||||
e9CrWVQXY8Baos29u4/qxqkkChpVY1DunfIt0WVJapWwC6wAUGJYep3HtLPJXtaoA6iOddu1d8Qx
|
||||
/+hssx3BrDsQlqel7W+15TdhiOofzQrn8Ximv4OwYsi2FLL2mEloDaqMELRlFQPXMFpGQrRkLqjV
|
||||
hwVtOqurZnENTc27XsDAdUtXqZD9nVXkAlbTspTu7XG/zy6CQbMqrNhPvChh2Gcmt/d4fJbyBsgs
|
||||
W6dzdfJWjjzGywqH02j420grcW4TAGvpYd2NmwGYXMh3bc6Noe5CpiBu6eU1MZ0VKYitFNS416hy
|
||||
6811m+FAmSdPo9a6oH0WhPhNe2KuIU/DI4CF8eLMVIP1Uk4sWYe3o7yXgLTKxWOi0VJ6gWc13Uw3
|
||||
LUmWtUt/n49cbtWMxVzEwVFK5/fW/+v1e+W1htT3/gHO9EIyge+NWAAAAABJRU5ErkJggg==
|
||||
}
|
||||
|
||||
set imgdata(goal) {
|
||||
iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAIAAAAlC+aJAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJ
|
||||
bWFnZVJlYWR5ccllPAAAAyZpVFh0WE1MOmNvbS5hZG9iZS54bXAAAAAAADw/eHBhY2tldCBiZWdp
|
||||
bj0i77u/IiBpZD0iVzVNME1wQ2VoaUh6cmVTek5UY3prYzlkIj8+IDx4OnhtcG1ldGEgeG1sbnM6
|
||||
eD0iYWRvYmU6bnM6bWV0YS8iIHg6eG1wdGs9IkFkb2JlIFhNUCBDb3JlIDUuNi1jMTM4IDc5LjE1
|
||||
OTgyNCwgMjAxNi8wOS8xNC0wMTowOTowMSAgICAgICAgIj4gPHJkZjpSREYgeG1sbnM6cmRmPSJo
|
||||
dHRwOi8vd3d3LnczLm9yZy8xOTk5LzAyLzIyLXJkZi1zeW50YXgtbnMjIj4gPHJkZjpEZXNjcmlw
|
||||
dGlvbiByZGY6YWJvdXQ9IiIgeG1sbnM6eG1wPSJodHRwOi8vbnMuYWRvYmUuY29tL3hhcC8xLjAv
|
||||
IiB4bWxuczp4bXBNTT0iaHR0cDovL25zLmFkb2JlLmNvbS94YXAvMS4wL21tLyIgeG1sbnM6c3RS
|
||||
ZWY9Imh0dHA6Ly9ucy5hZG9iZS5jb20veGFwLzEuMC9zVHlwZS9SZXNvdXJjZVJlZiMiIHhtcDpD
|
||||
cmVhdG9yVG9vbD0iQWRvYmUgUGhvdG9zaG9wIENDIDIwMTcgKFdpbmRvd3MpIiB4bXBNTTpJbnN0
|
||||
YW5jZUlEPSJ4bXAuaWlkOjJCRkVFQTNFRTI1NTExRTZCNUJFOEM2QkJDQzA1OUQ1IiB4bXBNTTpE
|
||||
b2N1bWVudElEPSJ4bXAuZGlkOjJCRkVFQTNGRTI1NTExRTZCNUJFOEM2QkJDQzA1OUQ1Ij4gPHht
|
||||
cE1NOkRlcml2ZWRGcm9tIHN0UmVmOmluc3RhbmNlSUQ9InhtcC5paWQ6MkJGRUVBM0NFMjU1MTFF
|
||||
NkI1QkU4QzZCQkNDMDU5RDUiIHN0UmVmOmRvY3VtZW50SUQ9InhtcC5kaWQ6MkJGRUVBM0RFMjU1
|
||||
MTFFNkI1QkU4QzZCQkNDMDU5RDUiLz4gPC9yZGY6RGVzY3JpcHRpb24+IDwvcmRmOlJERj4gPC94
|
||||
OnhtcG1ldGE+IDw/eHBhY2tldCBlbmQ9InIiPz6L30xAAAAFYUlEQVRo3s1a224jNwzVtxbFAkWL
|
||||
olsgmcRxNnHcXBatPbbja2zHm2Tb7+yZ0ObKunA4mrF3ASYvHkk8FEUeUjIn//RJ2pPZX88vvnSe
|
||||
1ie9nL7J+oPLybwpOR888uqt4Vg56uJxyqMgBn+n/QG0DGpPcrN8Zgzt8awpAKe7OYGk0sDWaGwB
|
||||
6OWy9t/2IWmxqCFHE5oQMBKMkvWHWwAa7UngYw1uAryRZjvLRwnDeRNMTN27L2/3r19JPn/9Tyma
|
||||
tfWz3X15hdxuCh/+NF34GwjrBwDcvbzp1zgoAEe6qw1PcpYPW6MJtDUx7a/mT3/cPfx6fQP56SRT
|
||||
isb19bPR6lADymwxrDcciK4XKxfA7eaVvsMY/TJ6ALTvaTNDpa1lZ08Uvj7NFi6A+5fC3XE+0taQ
|
||||
AfCxS54cM0C9znIbD88GIxfAw9u/+OKXy6vGASBP0apX82Xy5FCsONkvb5wEMJvBAWcAtEf2GHwE
|
||||
h+MPWrvg7QiishBbOePSpgcFDk05AcvZme7j/WdbH9Lw29K93GT5UABgrxHTXs5HCBcyVWEBPPrS
|
||||
xgCRABCVoHgkAED8Oh8+Ctqz4DOGwW5DbEWTK9lGNjXyASAYQJABtwDYT4IAoP3pLmsmi73PmmRP
|
||||
W4psjf8+AMYGY5n245Sjkg8AJ4S1Lxx0NHGYjF4obMsStJQAAGIIB2EIHOIdYfQZi+0hSu+StXd4
|
||||
cgUAhAGRJBiFaO1SQq8RPmyy8+wPGasAEIZYGNXQ2joYLqfz8MfvR1kLgGmWPaCU67Yj+05nBltE
|
||||
klnO7WCQta8LgE+tIBzp93KCt28Xu2hBPokkColFZzmMVgAAF6xU4L0f92hWtjFIbrZfH9cCgPUq
|
||||
ASitzTnixcR32loASks+jn12lijFkEUyY7DrUReAEIjY9kGnT8AQNEEDAIJEjZNAVe1jvhRz1wYA
|
||||
OFrCTpnFL5KbFE4IjnXNKgCQwwutYZutjvY+p9IEDF9MpQDvumx1zwnwESsVJLiiUbYgg+SsqR4j
|
||||
OySISTMASqN12nZrjKXv8koASilaWj9QSQoreaZJcP0GW7wxZq7HYDztRxpW3KwLBUsL5YE2yUVW
|
||||
IyGohNIqYrQptT0X1xre0khGs5cuNZOR/d6m05jL2eimImkmdj1kDIaqYQ0vZ2vZ6ykZaJ106djR
|
||||
BRCL93KcYX+rySb8LUWZdr1YQYoy39ItbM3xzNjjfTKnoQDYkDQMTj2JWrm72rgN00hjCysS+HQA
|
||||
dtSCG1S+5NqPeLGOS+dpXd4bTQZgW7ESBt/2QsPrsABsFqChMdh659TK2h8DgO0M8tFve12JUu2P
|
||||
AsBvq4Qit5/mS7ulRwIQDOR25IbqgWDdy+3Loe8GoF1W9yQ0eo8KIEu9+yi9cToGAOW9U7gker8k
|
||||
/Z4ALlKdp9KdzaEA1Ndef46DAE77A+xhcc1qX576AIIkp7Tkr4TB4T8aAJfTOf9q7CuGYHfaoeOy
|
||||
9mCpdAcKUZ4Q2FLG4AOwfzX2JXOstVi8bRmOoZPfq9sLLKHt0oSpLB8KGFQACAP9/HN2zgN+63SV
|
||||
Nb7AqDUlS+zd3p8Pf7MyUEwCULxWeX+c9Xv3tvHHHnbhkjw5FIN6UDIKgF47IcUc5LnNsO5zGyhG
|
||||
r1WiAG5Wm4M+eCIMNR88OT5mnNvm68WSvsPB+tBqNwuAMFSdE2pAme0zwH3zu4eYtrizXP+Yj/5u
|
||||
N4EYZRztmQzfrJ5/HADd9YYiuP9kygivLKKdptq9IMRc/T2xw1zsNFwAaFV8ONNUYz2WE2PWsctR
|
||||
u5YwPsvFNnFryX/A026up+tTErmLuMdievmWzDlFqpPS7XfrB31+L/cPBd/7HwDmw8MEUb41AAAA
|
||||
AElFTkSuQmCC
|
||||
}
|
||||
|
||||
# load the tiles
|
||||
|
||||
# load the player tile separately
|
||||
image create photo tile_player -data $imgdata(player)
|
||||
# floor is coded as 0
|
||||
image create photo tile_0 -data $imgdata(floor)
|
||||
# goal is coded as 1
|
||||
image create photo tile_1 -data $imgdata(goal)
|
||||
# player on the floor is coded as 2
|
||||
image create photo tile_2
|
||||
tile_2 copy tile_0
|
||||
tile_2 copy tile_player
|
||||
# player on the goal is coded as 3
|
||||
image create photo tile_3
|
||||
tile_3 copy tile_1
|
||||
tile_3 copy tile_player
|
||||
# box is coded as 4
|
||||
image create photo tile_box -data $imgdata(box)
|
||||
image create photo tile_4
|
||||
tile_4 copy tile_0
|
||||
tile_4 copy tile_box
|
||||
# box on goal is coded as 5
|
||||
image create photo tile_goalbox -data $imgdata(boxongoal)
|
||||
image create photo tile_5
|
||||
tile_5 copy tile_1
|
||||
tile_5 copy tile_goalbox
|
||||
# wall is coded as 8
|
||||
image create photo tile_8 -data $imgdata(wall)
|
||||
|
||||
# create the UI and canvas
|
||||
|
||||
canvas .c
|
||||
grid .c -column 0 -row 0
|
||||
grid rowconfigure . 0 -weight 1
|
||||
grid columnconfigure . 0 -weight 1
|
||||
|
||||
wm title . "BOXcl"
|
||||
|
||||
# define the help message
|
||||
|
||||
set helpmsg {Welcome to BOXcl!
|
||||
|
||||
Controls:
|
||||
|
||||
Move: WASD or arrow keys
|
||||
Undo: u
|
||||
Restart: r
|
||||
Open a levelset: Ctrl+O
|
||||
Next level in the set: Ctrl+N
|
||||
Previous level in the set: Ctrl+P
|
||||
Quit: Ctrl+Q
|
||||
This help: h or F1
|
||||
|
||||
You can also pass the levelset as the command line parameter to the boxcl.tcl script.
|
||||
|
||||
Created by Luxferre in 2024
|
||||
Released into public domain
|
||||
}
|
||||
|
||||
# entry point
|
||||
|
||||
set levelsetfile ""
|
||||
if {$argc > 0} { # get the level set file name
|
||||
set levelsetfile [lindex $argv 0]
|
||||
} else { # open the file dialog
|
||||
set levelsetfile [openlevel]
|
||||
}
|
||||
set sublevel 0
|
||||
if {$argc > 1} { # get the optional level number
|
||||
set sublevel [expr {int([lindex $argv 1]) - 1}]
|
||||
if {$sublevel < 0} {
|
||||
puts "Invalid level number!"
|
||||
exit 1
|
||||
}
|
||||
}
|
||||
if {$levelsetfile eq ""} {
|
||||
tk_messageBox -type ok -title "Missing levelset" -icon error -message "Please open a levelset file to start the game!"
|
||||
exit 1
|
||||
}
|
||||
|
||||
set levels [loadlevels $levelsetfile]
|
||||
set levelcount [llength $levels]
|
||||
startlevel [lindex $levels $sublevel]
|
||||
|
||||
# bind keys to move logic
|
||||
|
||||
bind . <Key> {
|
||||
switch "%K" {
|
||||
r {startlevel [lindex $levels $sublevel]}
|
||||
u -
|
||||
BackSpace {renderundo}
|
||||
w -
|
||||
Up {rendermove 0}
|
||||
a -
|
||||
Left {rendermove 1}
|
||||
s -
|
||||
Down {rendermove 2}
|
||||
d -
|
||||
Right {rendermove 3}
|
||||
h -
|
||||
F1 {
|
||||
tk_messageBox -type ok -icon question -title "BOXcl help" -message $helpmsg
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
bind . <Control-n> {nextlevel 0}
|
||||
bind . <Control-p> {prevlevel}
|
||||
bind . <Control-o> {
|
||||
set levelsetfile [openlevel]
|
||||
if {$levelsetfile ne ""} {
|
||||
set sublevel 0
|
||||
set levels [loadlevels $levelsetfile]
|
||||
set levelcount [llength $levels]
|
||||
startlevel [lindex $levels $sublevel]
|
||||
}
|
||||
}
|
||||
bind . <Control-q> {exit}
|
||||
Reference in New Issue
Block a user