Customizable (background, snake and food color) Snake game on Tcl/Tk

snake.tcl

#!/usr/bin/env tclsh

# Author: limafresh <https://github.com/limafresh>
# License: CC0 <https://creativecommons.org/publicdomain/zero/1.0/>

package require Tk

proc move_snake {} {
	global snake snake_direction food score level snake_size width height game_over snake_color bg_color

	set head [lindex $snake 0]
	set head_x [lindex $head 0]
	set head_y [lindex $head 1]

	# Direction of the snake
	if {$snake_direction eq "Right"} {
		set head_x [expr {$head_x + $snake_size}]
	} elseif {$snake_direction eq "Left"} {
		set head_x [expr {$head_x - $snake_size}]
	} elseif {$snake_direction eq "Up"} {
		set head_y [expr {$head_y - $snake_size}]
	} elseif {$snake_direction eq "Down"} {
		set head_y [expr {$head_y + $snake_size}]
	}

	# If snake touches the edge
	if {$head_x < 0 || $head_x >= $width || $head_y < 0 || $head_y >= $height} {
		set game_over 1
		return
	}

	# Set new head
	set new_head [list $head_x $head_y]

	# If snake touches itself
	if {[lsearch -exact $snake $new_head] != -1} {
		set game_over 1
		return
	}

	# If snake touches food
	if {$new_head eq $food} {
		for {set i 0} {$i < $level} {incr i} {
			set snake [linsert $snake 0 $new_head]
		}
		.canvas delete food
		set score [expr {$score + 1 * $level}]
		wm title . "Score: $score"
		create_food
	} else {
		set snake [linsert [lrange $snake 0 end-1] 0 $new_head]
	}

	# Update snake
	.canvas delete snake
	foreach segment $snake {
		set x [lindex $segment 0]
		set y [lindex $segment 1]
		.canvas create rectangle $x $y [expr {$x + $snake_size}] [expr {$y + $snake_size}] -fill $snake_color -outline $bg_color -tags snake
	}
}

proc game_loop {} {
	global game_over score is_pause speed

	if {$game_over} {
		.menu_bar entryconfigure 1 -state normal
		.settings_menu entryconfigure "Level" -state normal
		.menu_bar entryconfigure 4 -state disabled
		tk_messageBox -message "Game over. Score: $score" -title "Game over" -icon info -type ok
		return
	}

	if {$is_pause} {
		return
	}

	move_snake

	after $speed game_loop
}

proc create_food {} {
	global food food_color bg_color snake_size width height snake

	while {1} {
		set food_x [expr {int(rand() * ((($width - $snake_size) / $snake_size) + 1)) * $snake_size}]
		set food_y [expr {int(rand() * ((($height - $snake_size) / $snake_size) + 1)) * $snake_size}]
		if {[lsearch -exact $snake [list $food_x $food_y]] == -1} {
			break
		}
	}

	set food [list $food_x $food_y]
	set food_x [lindex $food 0]
	set food_y [lindex $food 1]

	.canvas create rectangle $food_x $food_y [expr {$food_x + $snake_size}] [expr {$food_y + $snake_size}] -fill $food_color -outline $bg_color -tags food
}

proc new_game {} {
	global game_over snake snake_direction food score is_pause speed

	if {!$game_over} {
		return
	}

	.canvas delete all
	.menu_bar entryconfigure 1 -state disabled
	.settings_menu entryconfigure "Level" -state disabled
	.menu_bar entryconfigure 4 -state normal

	set snake {{100 100}}
	set snake_direction "Right"
	set food ""
	set score 1
	set game_over 0
	set is_pause 0

	wm title . "Score: $score"

	create_food
	game_loop
}

proc pause {} {
	global game_over is_pause speed

	if {$game_over} {
		return
	}
	if {!$is_pause} {
		set is_pause 1
		.menu_bar entryconfigure 4 -label "Continue"
	} elseif {$is_pause} {
		set is_pause 0
		after $speed game_loop
		.menu_bar entryconfigure 4 -label "Pause"
	}
}

proc change_level {level_item} {
	global level speed

	set level $level_item
	set speed [expr {25 * [expr {9 - $level}]}]

}

proc change_snake_color {} {
	global snake_color

	set color_code [tk_chooseColor -title "Choose snake color"]
	if {$color_code ne ""} {
		set snake_color $color_code
		.canvas itemconfigure snake -fill $snake_color
	}
}

proc change_food_color {} {
	global food_color

	set color_code [tk_chooseColor -title "Choose food color"]
	if {$color_code ne ""} {
		set food_color $color_code
		.canvas itemconfigure food -fill $food_color
	}
}

proc change_bg_color {} {
	global bg_color

	set color_code [tk_chooseColor -title "Choose background color"]
	if {$color_code ne ""} {
		set bg_color $color_code
		.canvas configure -bg $bg_color
		.canvas itemconfigure snake -outline $bg_color
		.canvas itemconfigure food -outline $bg_color
	}
}

proc about {} {
	set message_text "Control the snake with the arrow keys and collect food.
The higher the level, the faster the snake moves and the more points.

Hotkeys: Enter - new game, Ctrl+P - pause/continue.

Author: limafresh <https://github.com/limafresh>"
	tk_messageBox -message $message_text -title "About Snake game" -icon info -type ok
}

proc change_direction {key} {
	global snake_direction

	if {$key eq "Left" && $snake_direction ne "Right"} {
		set snake_direction "Left"
	} elseif {$key eq "Right" && $snake_direction ne "Left"} {
		set snake_direction "Right"
	} elseif {$key eq "Up" && $snake_direction ne "Down"} {
		set snake_direction "Up"
	} elseif {$key eq "Down" && $snake_direction ne "Up"} {
		set snake_direction "Down"
	}
}

# Declaring variables
set width 400
set height 400
set snake_color "chartreuse"
set food_color "orange red"
set bg_color "black"
set speed 200
set level 1
set game_over 1
set is_pause 1

set snake_size 20
set snake {{100 100}}
set snake_direction "Right"
set food ""
set score 1

# Creating a GUI
wm resizable . 0 0

menu .menu_bar

.menu_bar add command -label "Restart" -command new_game

menu .settings_menu -tearoff 0
.menu_bar add cascade -label "Settings" -menu .settings_menu
menu .level_menu -tearoff 0
.settings_menu add cascade -label "Level" -menu .level_menu
set levels {1 2 3 4 5 6 7 8}
foreach level_item $levels {
	.level_menu add command -label $level_item -command [list change_level $level_item]
}
.settings_menu add command -label "Snake color" -command change_snake_color
.settings_menu add command -label "Food color" -command change_food_color
.settings_menu add command -label "Background color" -command change_bg_color
.settings_menu add separator
.settings_menu add command -label "About" -command about

.menu_bar add command -label "Pause" -command pause

. configure -menu .menu_bar

canvas .canvas -width $width -height $height -bg $bg_color
pack .canvas

bind . <KeyPress> {change_direction %K}
bind . <Control-p> pause
bind . <Return> new_game

wm protocol . WM_DELETE_WINDOW {exit}

# Launching the game
new_game

vwait forever