Posted to tcl by hardkorebob at Fri Aug 07 18:01:40 GMT 2026view raw

  1. # plugins/snake.tcl ? classic Snake game inside a buffer
  2. #
  3. # :eval snake ? start or switch to the game
  4. # Arrow keys ? change direction
  5. # Escape ? quit
  6.  
  7. namespace eval Snake {
  8. variable buffer_name "*snake*"
  9. variable container ""
  10. variable canvas ""
  11. variable direction "right"
  12. variable snake {} ;# list of {x y} head first
  13. variable food {}
  14. variable score 0
  15. variable interval 150 ;# ms between moves
  16. variable after_id ""
  17. variable game_over 0
  18. }
  19.  
  20. # ----------------------------------------------------------------------
  21. # Public command
  22. # ----------------------------------------------------------------------
  23. proc snake {} {
  24. set bufname $::Snake::buffer_name
  25. if {$bufname ni $Core::buffer_list} {
  26. Core::SwitchToBuffer $bufname
  27. Snake::SetupUI
  28. } else {
  29. Core::SwitchToBuffer $bufname
  30. }
  31. }
  32. Core::PluginAddCommand snake
  33. # optional keybinding (uncomment if desired)
  34. # Core::PluginBindKey CoreText <Control-x>s { snake; break }
  35.  
  36. # ----------------------------------------------------------------------
  37. # Build the game UI inside the buffer's container
  38. # ----------------------------------------------------------------------
  39. proc Snake::SetupUI {} {
  40. variable container
  41. variable canvas
  42.  
  43. set wid [dict get $Core::buffer_widget $::Snake::buffer_name]
  44. set container ".workspace.$wid"
  45. if {![winfo exists $container]} return
  46. set ::Snake::container $container
  47.  
  48. # Remove old content
  49. foreach child [winfo children $container] {
  50. pack forget $child
  51. }
  52. catch { destroy $container.game }
  53.  
  54. frame $container.game -bg "#1e1e1e"
  55. pack $container.game -fill both -expand true
  56.  
  57. set canvas [canvas $container.game.canvas -bg "#111111" -highlightthickness 0]
  58. pack $canvas -fill both -expand true
  59.  
  60. # Bind arrow keys to direction changes
  61. foreach key {Up Down Left Right} {
  62. bind $canvas <Key-$key> [list Snake::SetDirection [string tolower $key]]
  63. }
  64. bind $canvas <Escape> [list Snake::Quit]
  65.  
  66. # Start the game
  67. Snake::NewGame
  68. focus $canvas
  69. }
  70.  
  71. # ----------------------------------------------------------------------
  72. # Initialise / reset game state
  73. # ----------------------------------------------------------------------
  74. proc Snake::NewGame {} {
  75. variable snake
  76. variable food
  77. variable score
  78. variable direction
  79. variable game_over
  80. variable after_id
  81.  
  82. # Cancel any existing game loop
  83. if {$after_id ne ""} { after cancel $after_id; set after_id "" }
  84.  
  85. set direction "right"
  86. set score 0
  87. set game_over 0
  88.  
  89. # Initial snake in the middle of the canvas
  90. set center_x 20
  91. set center_y 15
  92. set snake [list [list $center_x $center_y] \
  93. [list [expr {$center_x - 1}] $center_y] \
  94. [list [expr {$center_x - 2}] $center_y]]
  95.  
  96. Snake::PlaceFood
  97. Snake::Draw
  98. Snake::StartLoop
  99. }
  100.  
  101. # ----------------------------------------------------------------------
  102. # Place food at a random cell not occupied by the snake
  103. # ----------------------------------------------------------------------
  104. proc Snake::PlaceFood {} {
  105. variable snake
  106. variable food
  107. variable canvas
  108.  
  109. set w [expr {[winfo width $canvas] / 20}]
  110. set h [expr {[winfo height $canvas] / 20}]
  111. if {$w < 1 || $h < 1} { set w 30; set h 20 } ;# fallback
  112.  
  113. while 1 {
  114. set fx [expr {int(rand() * $w)}]
  115. set fy [expr {int(rand() * $h)}]
  116. set occupied 0
  117. foreach seg $snake {
  118. if {[lindex $seg 0] == $fx && [lindex $seg 1] == $fy} {
  119. set occupied 1
  120. break
  121. }
  122. }
  123. if {!$occupied} break
  124. }
  125. set food [list $fx $fy]
  126. }
  127.  
  128. # ----------------------------------------------------------------------
  129. # Redraw the canvas
  130. # ----------------------------------------------------------------------
  131. proc Snake::Draw {} {
  132. variable canvas
  133. variable snake
  134. variable food
  135. variable score
  136.  
  137. $canvas delete all
  138. set cellSize 20
  139.  
  140. # Draw food
  141. if {[llength $food] == 2} {
  142. set fx [expr {[lindex $food 0] * $cellSize}]
  143. set fy [expr {[lindex $food 1] * $cellSize}]
  144. $canvas create rectangle $fx $fy [expr {$fx + $cellSize}] [expr {$fy + $cellSize}] \
  145. -fill red -outline ""
  146. }
  147.  
  148. # Draw snake
  149. foreach seg $snake {
  150. set x [expr {[lindex $seg 0] * $cellSize}]
  151. set y [expr {[lindex $seg 1] * $cellSize}]
  152. $canvas create rectangle $x $y [expr {$x + $cellSize - 1}] [expr {$y + $cellSize - 1}] \
  153. -fill #00ff00 -outline ""
  154. }
  155.  
  156. # Score
  157. $canvas create text 5 5 -text "Score: $score" -fill white -anchor nw -font {Courier 12 bold}
  158. }
  159.  
  160. # ----------------------------------------------------------------------
  161. # Game loop
  162. # ----------------------------------------------------------------------
  163. proc Snake::StartLoop {} {
  164. variable after_id
  165. variable interval
  166. set after_id [after $interval Snake::Move]
  167. }
  168.  
  169. proc Snake::Move {} {
  170. variable game_over
  171. if {$game_over} return
  172.  
  173. variable direction
  174. variable snake
  175. variable food
  176. variable score
  177. variable canvas
  178.  
  179. # Determine new head position
  180. set head [lindex $snake 0]
  181. set x [lindex $head 0]
  182. set y [lindex $head 1]
  183. switch $direction {
  184. "up" { incr y -1 }
  185. "down" { incr y 1 }
  186. "left" { incr x -1 }
  187. "right" { incr x 1 }
  188. }
  189.  
  190. # Check collision with walls
  191. set gridW [expr {[winfo width $canvas] / 20}]
  192. set gridH [expr {[winfo height $canvas] / 20}]
  193. if {$gridW < 1} { set gridW 30 }; if {$gridH < 1} { set gridH 20 }
  194. if {$x < 0 || $x >= $gridW || $y < 0 || $y >= $gridH} {
  195. Snake::GameOver
  196. return
  197. }
  198.  
  199. # Check collision with self
  200. foreach seg $snake {
  201. if {[lindex $seg 0] == $x && [lindex $seg 1] == $y} {
  202. Snake::GameOver
  203. return
  204. }
  205. }
  206.  
  207. # Add new head
  208. set snake [linsert $snake 0 [list $x $y]]
  209.  
  210. # Check food
  211. if {[llength $food] == 2 && [lindex $food 0] == $x && [lindex $food 1] == $y} {
  212. incr score
  213. Snake::PlaceFood
  214. # Do not remove tail -> grow
  215. } else {
  216. # Remove tail
  217. set snake [lrange $snake 0 end-1]
  218. }
  219.  
  220. Snake::Draw
  221. Snake::StartLoop
  222. }
  223.  
  224. # ----------------------------------------------------------------------
  225. # Change direction (ignore opposite direction to avoid self-collision)
  226. # ----------------------------------------------------------------------
  227. proc Snake::SetDirection {newdir} {
  228. variable direction
  229. set opposite [dict get {up down down up left right right left} $newdir]
  230. if {$newdir ne $opposite || [llength $::Snake::snake] == 1} {
  231. set direction $newdir
  232. }
  233. }
  234.  
  235. # ----------------------------------------------------------------------
  236. # Game over ? show message, stop loop, allow restart
  237. # ----------------------------------------------------------------------
  238. proc Snake::GameOver {} {
  239. variable game_over
  240. variable after_id
  241. set game_over 1
  242. if {$after_id ne ""} { after cancel $after_id; set after_id "" }
  243.  
  244. Snake::Draw ;# to show final state
  245. # Display "Game Over" overlay
  246. $::Snake::canvas create text [expr {[winfo width $::Snake::canvas] / 2}] \
  247. [expr {[winfo height $::Snake::canvas] / 2}] \
  248. -text "GAME OVER\nScore: $::Snake::score\nPress any arrow key to restart" \
  249. -fill white -font {Courier 14 bold} -justify center
  250.  
  251. # Bind any arrow key to restart
  252. foreach key {Up Down Left Right} {
  253. bind $::Snake::canvas <Key-$key> [list Snake::NewGame]
  254. }
  255. }
  256.  
  257. # ----------------------------------------------------------------------
  258. # Quit the game and kill its buffer
  259. # ----------------------------------------------------------------------
  260. proc Snake::Quit {} {
  261. variable after_id
  262. if {$after_id ne ""} { after cancel $after_id; set after_id "" }
  263. Core::KillBuffer $::Snake::buffer_name
  264. }
  265.  
  266. # ----------------------------------------------------------------------
  267. # Cleanup hooks (always return empty to allow killing)
  268. # ----------------------------------------------------------------------
  269. proc Snake::OnKillBuffer {bufname} {
  270. if {$bufname eq $::Snake::buffer_name} {
  271. variable after_id
  272. if {$after_id ne ""} { after cancel $after_id; set after_id "" }
  273. set ::Snake::game_over 1
  274. set ::Snake::container ""
  275. }
  276. return ""
  277. }
  278. Core::PluginAddHook kill-buffer-hook Snake::OnKillBuffer
  279.  
  280. proc Snake::OnSwitchBuffer {bufname} {
  281. if {$bufname eq $::Snake::buffer_name} {
  282. after idle Snake::SetupUI
  283. }
  284. }
  285. Core::PluginAddHook switch-buffer-hook Snake::OnSwitchBuffer
  286.  
  287. # ----------------------------------------------------------------------
  288. # Reload safety
  289. # ----------------------------------------------------------------------
  290. proc Snake::Init {} {
  291. if {$::Snake::buffer_name in $::Core::buffer_list} {
  292. Snake::SetupUI
  293. }
  294. }
  295. Snake::Init

Add a comment

Please note that this site uses the meta tags nofollow,noindex for all pages that contain comments.
Items are closed for new comments after 1 week