boxcl/boxcl.tcl

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

set scriptpath [ file normalize [ info script ] ]
set appdir [ file dirname $scriptpath ]
# check if we're running from a starpack
if [string match *app-boxcl $appdir] {
  set appdir [ file normalize [ file join $appdir ".." ".." ".." ] ]
}
set leveldir [ file join $appdir "levelsets" ]

# 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 {} {
  global leveldir
  set types {
    {{Plain text levelset} {.txt} TEXT}
    {{Sokoban YASC levelset} {.sok} TEXT}
  }
  return [tk_getOpenFile -initialdir $leveldir -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}