#!/usr/bin/wish
# tcLines is a clone of well-known game Color Lines
# Copyright Ihar Viarheichyk 2002

set maxLine 5
set toAdd 3
set colors {blue cyan red green yellow brown magenta}
set scorefile ~/.tclines
set topscore 0

proc Cell {x} {lindex [eval $::board find overlapping [$::board bbox $x]] 0}

proc Coord {tag} {
     foreach k {x y} v [$::board coords $tag] {set $k [expr int($v/$::cSize)]}
     list $x $y
}

# Select active ball
proc SelectBall {} {
	if {[llength [$::board find withtag target]]} return
	if {[llength [$::board find withtag active]]} { Unscale active }
	$::board dtag active
	$::board addtag active withtag current
	Scale active
	$::board itemconfigure free -activefill white
}

# 'Heartbeating' of active ball
proc Scale {tag {s 0}} {
	set p [expr {($s<4)?1/1.4:1.4}]
	foreach {x1 y1 x2 y2} [$::board coords $tag] break
	$::board scale $tag [expr ($x2+$x1)/2] [expr ($y2+$y1)/2] $p $p
	set ::phase [after 100 [list Scale $tag [expr ($s+1)%8]]]
}

# Disable 'heartbeating'
proc Unscale {tag} {
	after cancel $::phase
	$::board coords $tag [$::board coords [Cell $tag]]
}

# Select new target cell
proc SelectTarget {} {
	if {[llength [$::board find withtag active||target]]!=1} return
	Unscale active
	$::board addtag target withtag current
	set way [FindWay [Cell active] [$::board find withtag target]]
	$::board dtag passed
	if {[llength $way]} {
		$::board itemconfigure cell\
			-activefill [$::board itemcget cell -fill]
		$::board dtag target free
		$::board addtag free withtag [Cell active]
		MoveBall $way
	} else { $::board dtag target }
}

# Move ball to target, drawing it's track in different color
proc MoveBall {way} {
	$::board coords active [$::board coord [lindex $way 0]]
	if {[llength $way]==1} {
		$::board itemconfigure cell -fill gray80
		NextMove [FindLines active]
	} else {
		$::board itemconfigure [lindex $way 0] -fill LightGreen
		after 40 [list MoveBall [lrange $way 1 end]]
	}	
}

# Find a way from selected ball to target cell. Note, that this is not 
# shortest way, because it is too expensive. Trick with sorting by distance on 
# every iteration is used instead
proc FindWay {tag target} {
	$::board addtag passed withtag $tag
	if {$tag==$target} {return [list $target]}
	set neighbours [$::board find withtag "neighbour$tag&&free&&!passed"]
	foreach n [lsort -command "Sorter $target" $neighbours] {
		set res [FindWay $n $target]
		if {[llength $res]} {return [concat $n $res]}
	}
	list
}

proc Sorter {t n1 n2} { expr {[Distance $n1 $t]-[Distance $n2 $t]} }

# Calculate distance between cells (in moves)
proc Distance {n1 n2} {
	foreach {x1 y1} [Coord $n1] break
	foreach {x2 y2} [Coord $n2] break
	expr { abs($x2-$x1)+abs($y2-$y1) }
}

# Add new ball to the board
proc NewBall {} {
	# Find free cells and finish game if less than two free cells found
	set free [$::board find withtag free]
	# Get random free cell and random color (for prediction)
	set take [lindex $free [expr {int(rand()*[llength $free])}]]
	set color [lindex $::predict 0]
	set ::predict [lrange $::predict 1 end]
	lappend ::predict [lindex $::colors [expr {int(rand()*[llength $::colors])}]]
	# Remove tag 'free' from selected cell
	$::board dtag $take free
	# Draw the ball on selected cell with predicted color
	set shape [$::board create oval [$::board coords $take]\
		-outline black -fill $color -tags "ball color:$color"]
	if {[llength $free]<2} GameOver else {set shape}
}

# Performs next move
proc NextMove {{flag 1}} {
	# Deletes target and selected ball tags
	$::board dtag target
	$::board dtag active
	set ::previous $::saved
	# Add new balls if needed (no balls disappeared on previous move)
	if {$flag} {for {set x 0} {$x<$::toAdd} {incr x} {FindLines [NewBall]}}
	# Save information for posssible rollback
	foreach {b f} [list [list] [list]] break
	foreach item [$::board find withtag ball] {
		lappend b [$::board coords $item]\
		    [$::board gettags $item] [$::board itemcget $item -fill]
	}
	set i 0
	# Show prediction
	foreach col $::predict {.fr.next itemconfigure [incr i] -fill $col}
	foreach item [$::board find withtag free] {lappend f $item }
	set ::saved [list $b $f $::score]
}

# Rollback last move
proc Rollback {} {
	if {![llength $::previous]} return
	after cancel $::phase
	$::board delete ball
	foreach {coords tags color} [lindex $::previous 0] {
		$::board create oval $coords -tags "$tags" -fill $color
	}
	foreach x [lindex $::previous 1] {$::board addtag free withtag $x}
	set ::score [lindex $::previous 2]
	set ::saved $::previous
	foreach x {current active target} {$::board dtag $x }
}

# Find list of neighbours in given (with x and y increments) direction
proc FindChunk {map x y dx dy} {
	set res [list]
	while {[lsearch $map "$x,$y:*"]!=-1} {
		incr x [expr -$dx]
		incr y [expr -$dy]
	}
	while {[set pos [lsearch $map "[incr x $dx],[incr y $dy]:*"]]!=-1} {
		lappend res [lindex [split [lindex $map $pos] :] 1]
	}
	set res
}

# Find 5-in-line balls, starting with ball passed as tag 
proc FindLines {tag} {
	# Get coordinates and color of start ball
	set tags [$::board gettags $tag]
	foreach {x y} [Coord $tag] break
	set color [lindex $tags [lsearch -glob $tags color:*]]
	# Find all balls of same color, save their coordinates and tags 
	set map [list]
	foreach n [$::board find withtag $color] {
		foreach {nx ny} [Coord $n] break
		lappend map "$nx,$ny:$n"
	}
	# For all balls of same color perform search of neigbours in different
	# directions and select direction having maximal number of neighbours.
	set max [list]
	foreach {dx dy} {1 0 0 1 1 1 -1 1} {
		set res [FindChunk $map $x $y $dx $dy]
		if {[llength $res]>[llength $max]} { set max $res }
	}
	# If number of neighbours is more or equal than limit, delete them
	set len [llength $max]
	if {$len>=$::maxLine} {
		# Recalculate score
		set ::score [expr {$::score+$len*($len-$::maxLine+1)}]
		foreach n $max { 
			$::board addtag free withtag [Cell $n]
			$::board delete $n
		}
	}
	# Return 0 if balls were disappeared, 1 otherwise. This is needed for 
	# NextMove procedure, which should not add new balls in first case
	expr {$len<$::maxLine}
}

# Initialize new game
proc NewGame {} {
	#Reset score
	set ::score 0
	# Reset information for last move rollback
	foreach {::previous ::saved} [list [list] [list]] break
	# Set first moves
	set ::predict [list]
	for {set i 0} {$i<$::toAdd} {incr i} {
		lappend ::predict [lindex $::colors [expr {int(rand()*[llength $::colors])}]]
	}
	# Delete all balls, if any
	$::board delete ball
	# Mark all cells as free
	$::board addtag free withtag cell
	NextMove
}

# Game over: write top score if needed
proc GameOver {} {
	if {$::score>$::topscore} {
	   set ::topscore $::score
	   if {![info exists ::embed_args]} {
		   catch { set f [open $::scorefile w]
			   puts $f $::topscore
			   close $f
			 }
	   }	 
	}
	set answer [tk_messageBox -type yesno -title {Game over}\
	            -message {Another game?} -default yes -parent .]
	if {$answer=={yes}} {after idle NewGame} else {destroy .}
}

# Just the 'About' message box
proc About {} {
	tk_messageBox -default ok -title "About tcLines" -message\
	   "tcLines is a clone of well-known game Color Lines\nAuthor: Igor Vergeichik"
}

# Draw the board, menu, score labels and prediction label
proc Board {w} {
	global cSize
	if {![info exists ::embed_args]} {
		catch { 
			set f [open $::scorefile r]
			gets $f ::topscore
			close $f
		}
		wm title . tcLines
		wm resizable . 0 0
		menu .main -type menubar -tearoff no
		menu .main.game -tearoff no 
		.main add cascade -menu .main.game -label Game -underline 0
		.main add command -label "About" -command About -underline 0
		.main.game add command -label "New" -command NewGame -underline 0
		.main.game add command -label "Back" -command Rollback -underline 0
		.main.game add separator
		.main.game add command -label "Exit" -command {destroy .} -underline 0
		. configure -menu .main
	} else {
		pack [frame .control]
		pack [button .control.new -text {New Game} -command NewGame]\
		     [button .control.back -text Back -command Rollback]\
			-side left
	}
	frame .fr -height 50 
	label .fr.score -textvariable score -relief sunken -bd 1 -width 5
	label .fr.topscore -textvariable topscore -relief sunken -bd 1 -width 5
	canvas .fr.next -width [expr 3*$cSize+4] -height $cSize -relief sunken -bd 1
	pack .fr.score .fr.next .fr.topscore -padx 4 -side left
	set ::board [canvas .c -width [expr $w*$cSize] -height [expr $w*$cSize]]
	# Bind mouse click handlers for selection ball and target
	$::board bind ball <1> SelectBall
	$::board bind free <1> SelectTarget
	# Create cells (rectangles) with corresponging tag.
	for {set i 0} {$i<[expr $w*$w]} {incr i} {
		$::board create rectangle\
		   [expr {$i%$w*$cSize+1}] [expr {$i/$w*$cSize+1}]\
		   [expr {($i%$w+1)*$cSize-1}] [expr {($i/$w+1)*$cSize-1}]\
		   -outline [option get . gridColor Color]\
		   -fill [option get . cellColor Color] -tags cell 
	}
	# Create prediction balls with corresponding tags
	for {set i 0} {$i<$::toAdd} {incr i} {
	    .fr.next create oval [expr $i*$cSize+3] 3\
	    	[expr ($i+1)*$cSize] [expr $cSize] -tags "pred pred:$i" 
	}
	# Find 4-neighbours of each item and add corresponging tags.
	# This allows simplify procedure of finding way to target
	foreach tag [$::board find withtag cell] {
		foreach {x y} [$::board coords $tag] break
		foreach {sx sy} {-1/2 0 +3/2 0 0 -1/2 0 +3/2} {
		    foreach v {x y} {set d$v [expr [set $v]+[set s$v]*$cSize]}
		    $::board addtag "neighbour$tag" withtag\
			[$::board find overlapping $dx $dy $dx $dy]
		}
	}
	pack .fr 
	pack $::board -padx 2 -pady 2
	NewGame
}
# Set default options for colors, cell size, fonts etc. User can redefine them
# in ~/.Xdefaults (Unix) file
foreach {opt val} { 
	*fr.Label.foreground gray40 *fr.Label.font {Courier 18 bold}
	*cellSize 32	*cellColor gray80	*gridColor gray60
	*board 9 *control.Button.relief groove
	} { option add $opt $val widgetDefault}

set cSize [option get . cellSize CellSize]
Board [option get . board Board]