#! /usr/local/bin/wish

package require safesock

set VERSION    1.2                  ;# What server version to talk to?
set FONT       {Helvetica -14}      ;# Font for text
set HOSTNAME   $embed_args(host)    ;# Default host
set PORTNUMBER $embed_args(port)    ;# Default port

# Window size is 300x321, at least on my workstation...

# ----------------------------------------------------------------------

### COLOUR UTILITIES ###

proc rgb2col {r g b} {format "#%0.4x%0.4x%0.4x" $r $g $b}
proc darken {colour {pr 0.9} {pg 0.9} {pb 0.9} {w .}} {
    foreach {r g b} [winfo rgb $w $colour] {break}
    rgb2col [expr {int($r*$pr)}] [expr {int($g*$pg)}] [expr {int($b*$pb)}]
}
proc lighten {colour {pr 0.9} {pg 0.9} {pb 0.9} {w .}} {
    foreach {r g b} [winfo rgb $w $colour] {break}
    set r [expr {int($r/$pr)}]
    set g [expr {int($g/$pg)}]
    set b [expr {int($b/$pb)}]
    rgb2col [expr {$r>0xffff?0xffff:$r}] \
	    [expr {$g>0xffff?0xffff:$g}] \
	    [expr {$b>0xffff?0xffff:$b}]
}
proc scaleDistance {d col args} {
    if {[llength $args]} {
	foreach {r2 g2 b2  r3 g3 b3} $args {break}
    } else {
	foreach {r2 g2 b2} [winfo rgb .c [.c cget -background]] {break}
	foreach {r3 g3 b3} [winfo rgb .c [.c itemcget floor -fill]] {break}
    }
    foreach {r1 g1 b1} [winfo rgb .c $col] {break}
    rgb2col [expr {int(($r1*$d+$r2+$r3)/($d+2))}] \
	    [expr {int(($g1*$d+$g2+$g3)/($d+2))}] \
	    [expr {int(($b1*$d+$b2+$b3)/($d+2))}]
}

# ----------------------------------------------------------------------

### LCD NUMBER DISPLAY ENGINE ###

# The shapes of individual elements of a digit
array set lcdshape {
    a {3.0 5 5.2 3 7.0 5 6.0 15 3.8 17 2.0 15}
    b {6.3 2 8.5 0 18.5 0 20.3 2 18.1 4 8.1 4}
    c {19.0 5 21.2 3 23.0 5 22.0 15 19.8 17 18.0 15}
    d {17.4 21 19.6 19 21.4 21 20.4 31 18.2 33 16.4 31}
    e {3.1 34 5.3 32 15.3 32 17.1 34 14.9 36 4.9 36}
    f {1.4 21 3.6 19 5.4 21 4.4 31 2.2 33 0.4 31}
    g {4.7 18 6.9 16 16.9 16 18.7 18 16.5 20 6.5 20}
}
# Which elements are turned on for a given digit?
array set llcd {
    0 {a b c d e f}
    1 {c d}
    2 {b c e f g}
    3 {b c d e g}
    4 {a c d g}
    5 {a b d e g}
    6 {a b d e f g}
    7 {b c d}
    8 {a b c d e f g}
    9 {a b c d e g}
    - {g}
    { } {}
}
# Which elements are turned off for a given digit?
array set ulcd {
    0 {g}
    1 {a b e f g}
    2 {a d}
    3 {a f}
    4 {b e f}
    5 {c f}
    6 {c}
    7 {a e f g}
    8 {}
    9 {f}
    - {a b c d e f}
    { } {a b c d e f g}
}

# Displays a decimal number using LCD digits in the top-left of the canvas
proc showLCD {number {width 5} {colours {#ff8080 #ff0000 #404040 #303030}}} {
    global llcd ulcd lcdshape
    set lcdoffset 0
    .c delete lcd
    foreach {onRim onFill offRim offFill} $colours {break}
    foreach glyph [split [format %${width}d $number] {}] {
	foreach symbol $llcd($glyph) {
	    .c move [eval .c create polygon $lcdshape($symbol) -tags lcd \
		    -outline $onRim -fill $onFill] $lcdoffset 0
	}
	foreach symbol $ulcd($glyph) {
	    .c move [eval .c create polygon $lcdshape($symbol) -tags lcd \
		    -outline $offRim -fill $offFill] $lcdoffset 0
	}
	incr lcdoffset 22
    }
}

# ----------------------------------------------------------------------

### WALL DISPLAY ENGINE ###

pack [canvas .c -width 300 -height 300 -background skyblue \
	-highlightthickness 0] -side top
pack [entry .e] -side top -fill x

.c create rectangle 0 60 300 300 -outline {} -fill forestgreen -tags floor
proc makeWalls {} {
    global walls fill offset
    foreach {tag col x1 y1 x2 y2 x3 y3 x4 y4 off} {
	L8  1	24  53    60  53    60  89    24  89  {7 -6}
	ll8 1	60  53    96  53    96  89    60  89  {7 -4}
	l8  1	96  53   132  53   132  89    96  89  {7 -2}
	m8  1  132  53   168  53   168  89   132  89  {7  0}
	r8  1  168  53   204  53   204  89   168  89  {7  2}
	rr8 1  204  53   240  53   240  89   204  89  {7  4}
	R8  1  240  53   276  53   276  89   240  89  {7  6}

	LL7 2  -24  50    24  53    24  89   -24 100  {6 -7}
	L7  2	24  50    60  53    60  89    24 100  {6 -5}
	ll7 2	74  50    96  53    96  89    74 100  {6 -3}
	l7  2  125  50   131  52   131  90   125 100  {6 -1}
	RR7 2  326  50   276  53   276  89   326 100  {6  7}
	R7  2  276  50   240  53   240  89   276 100  {6  5}
	rr7 2  226  50   204  53   204  89   226 100  {6  3}
	r7  2  175  50   169  52   169  90   175 100  {6  1}

	L6  3  -10  50    24  50    24 100   -10 100  {5 -6}
	ll6 3	24  50    74  50    74 100    24 100  {5 -4}
	l6  3	74  50   125  50   125 100    74 100  {5 -2}
	m6  3  125  50   175  50   175 100   125 100  {5  0}
	r6  3  175  50   226  50   226 100   175 100  {5  2}
	rr6 3  226  50   276  50   276 100   226 100  {5  4}
	R6  3  276  50   310  50   310 100   276 100  {5  6}

	L5  4  -60  43    24  50    24 100   -60 127  {4 -5}
	ll5 4	24  43    74  50    74 100    24 127  {4 -3}
	l5  4  108  43   124  49   124 101   108 127  {4 -1}
	R5  4  360  43   276  50   276 100   360 127  {4  5}
	rr5 4  276  43   226  50   226 100   276 127  {4  3}
	r5  4  192  43   176  49   176 101   192 127  {4  1}

	ll4 5  -60  43    24  43    24 127   -60 127  {3 -4}
	l4  5	24  43   108  43   108 127    24 127  {3 -2}
	m4  5  108  43   192  43   192 127   108 127  {3  0}
	r4  5  192  43   276  43   276 127   192 127  {3  2}
	rr4 5  276  43   360  43   360 127   276 127  {3  4}

	ll3 6 -228  10    24  43    24 127  -228 260  {2 -3}
	l3  6   24  10   107  42   107 128    24 260  {2 -1}
	rr3 6  528  10   276  43   276 127   528 260  {2  3}
	r3  6  276  10   193  42   193 128   276 260  {2  1}

	l2  7 -228  10    24  10    24 260   -10 260  {1 -2}
	m2  7   24  10   276  10   276 260    24 260  {1  0}
	r2  7  276  10   528  10   528 260   276 260  {1  2}

	l1  8  -10  -3    24  10    24 260   -10 314  {0 -1}
	r1  8  310  -3   276  10   276 260   310 314  {0  1}
    } {
	set fill($tag) [scaleDistance [expr {$col*2-1}] [darken darkgreen]]
	.c create polygon $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4 \
		-outline {} -fill $fill($tag) -tag [list $tag wall]
	lappend walls $tag
	set offset($tag) $off
    }
}

proc showWalls {wlist} {
    global walls fill
    .c itemconfigure wall -outline {} -fill {}
    foreach wall $wlist {
	.c itemconfigure $wall -outline $fill($wall) -fill $fill($wall)
    }
}

proc makeAvatars {} {
    global colourscale
    foreach {tag below scale dx posn tailoff} {
	al1 l1  1.05 -200  {0 -2}  5.5
	am1 {}  1.05    0  {0 0}   5.5
	ar1 r1  1.05  200  {0 2}   5.5

	aL2 ll3 0.55 -252  {2 -4}  4
	al2 l3  0.55 -126  {2 -2}  4
	am2 m2  0.55    0  {2 0}   4
	ar2 r3  0.55  126  {2 2}   4
	aR2 rr3 0.55  252  {2 4}   4

	Al3 L5  0.22 -177  {4 -6}  2.5
	aL3 ll5 0.22 -118  {4 -4}  2.5
	al3 l5  0.22  -59  {4 -2}  2.5
	am3 m4  0.22    0  {4 0}   2.5
	ar3 r5  0.22   59  {4 2}   2.5
	aR3 rr5 0.22  118  {4 4}   2.5
	Ar3 R5  0.22  177  {4 6}   2.5

	AL4 LL7 0.14 -158  {6 -8}  1
	Al4 L7  0.14 -119  {6 -6}  1
	aL4 ll7 0.14  -79  {6 -4}  1
	al4 l7  0.14  -40  {6 -2}  1
	am4 m6  0.14    0  {6 0}   1
	ar4 r7  0.14   40  {6 2}   1
	aR4 rr7 0.14   79  {6 4}   1
	Ar4 R7  0.14  119  {6 6}   1
	AR4 RR7 0.14  158  {6 8}   1
    } {
	set cid [.c create oval \
		100 280  200 320 \
		-outline white  -fill red  -width 0  -tags [list c$tag dots]]
	set id [.c create polygon \
		150 300  100 100  150 75  125 50  175 50  150 75 200 100 \
		-tags [list $tag avatar]  -outline white  -fill red  -width 0]
	.c scale $cid 150 60 $scale $scale
	.c move $cid $dx 0
	.c scale $id 150 60 $scale $scale
	.c move $id $dx 0
	if {[string length $below]} {
	    .c lower $id $below
	    .c lower $cid $id
	}
	# posn is really ignored here, as it is only needed on the server;
	# it is kept for commonality of data with standalone version...
	set colourscale(c$tag) $tailoff
    }
    .c itemconfigure avatar -outline {} -fill {}
    .c itemconfigure dots -outline {} -fill {}
}

proc showAvatars {avs} {
    .c itemconfigure avatar -fill {} -outline {}
    foreach {av col} $avs {
	.c itemconfigure $av -fill $col -outline white
    }
}
proc showDots {dots} {
    #COMPILER HACK
    set r2 [set g2 [set b2 [set r3 [set g3 [set b3 [set t [set c {}]]]]]]]

    global colourscale
    foreach {r2 g2 b2} [winfo rgb .c [.c cget -background]] {break}
    foreach {r3 g3 b3} [winfo rgb .c [.c itemcget floor -fill]] {break}
    foreach {t c} $dots {
	if {[string length $c]} {
	    # Rescale colour according to distance
	    .c itemconfigure $t -fill [scaleDistance $colourscale($t) $c \
		    $r2 $g2 $b2  $r3 $g3 $b3] ;# Saved calculations!
	} else {
	    .c itemconfigure $t -fill {}
	}
    }
}

proc makeMsgArea {} {
    global msgs FONT

    .c create text 150 299 -anchor s -font $FONT -fill white -tag seeking
    foreach {? y1 ? y2} [.c bbox seeking] {break}
    set dy [expr {$y2-$y1+1}]
    set y [expr {299-$dy}]
    foreach i {0 1 2 3 4 5 6 7} {
	.c create text 150 $y -anchor s -font $FONT -tag msg$i
	set msgs($i) [list -fill white -text {}]
	set y [expr {$y-$dy}]
    }
}
proc addMsg {colour message} {
    global msgs removeId
    foreach i {7 6 5 4 3 2 1} ii {6 5 4 3 2 1 0} {
	set msgs($i) $msgs($ii)
    }
    set msgs(0) [list -fill $colour -text $message]
    foreach i {0 1 2 3 4 5 6 7} {
	eval .c itemconfigure msg$i $msgs($i)
    }
    after cancel $removeId
    set removeId [after 15000 removeMsg]
}
proc removeMsg {} {
    global removeId msgs
    foreach i {7 6 5 4 3 2 1 0} {
	set m $msgs($i)
	if {[string length [lindex $m 3]]} {
	    set msgs($i) [lreplace $m 3 3 {}]
	    eval .c itemconfigure msg$i $msgs($i)
	    set removeId [after 7500 removeMsg]
	    return
	}
    }
}
set removeId N*O*N*E*X*I*S*T*A*N*T*T*I*M*E*R*E*V*E*N*T

makeWalls
makeAvatars
makeMsgArea

# ----------------------------------------------------------------------

### MOVE AROUND MAZE ###

proc makeCompass {} {
    global FONT
    set darkblue [darken blue 0.7 0.7 0.7]
    .c create oval 255 5 295 35 -width 2 \
	    -fill [darken yellow 0.7 0.7 0.7] \
	    -outline $darkblue
    .c create line 0 0 0 0 -fill [lighten blue 0.7 0.7 0.7] -tags compass \
	    -arrow last -width 4 -capstyle round
    set fb "$FONT bold"
    set s [expr {([font metrics $fb -linespace]-1)/2}]
    foreach {x y t} {275 5 N    275 35 S    255 20 W    295 20 E} {
	.c create oval \
		[expr {$x-$s}] [expr {$y-$s}] [expr {$x+$s}] [expr {$y+$s}] \
		-fill $darkblue
	.c create text $x $y -anchor center -text $t -font $fb \
		-fill [lighten red 0.7 0.7 0.7] -tags compasstext
    }
    .c raise compass
    .c raise compasstext
}
makeCompass
proc showCompass {dir} {
    switch $dir {
	s {.c coords compass 275 15 275 30}
	n {.c coords compass 275 25 275 10}
	w {.c coords compass 265 20 290 20}
	e {.c coords compass 285 20 260 20}
    }
}

bind .e <Left>  {left;break}
bind .e <Right> {right;break}
bind .e <Up>    {forward;break}
bind .e <Down>  {backward;break}
bind .e <Escape> {.e delete 0 end}
bind .e <Return> {
    if {[string length [.e get]]} {
	broadcast [.e get]
	.e delete 0 end
    }
}

focus .e

# ----------------------------------------------------------------------

### NETWORK HANDLERS ###

## Incoming Messages
# display {wall wall ...} {avtype avcol avtype avcol ...} direction
# ouch newScore
# bump newScore
# target colour
# message colour messageString
# colour colour
# vanished colour

## Outgoing Messages
# forward
# backward
# left
# right
# broadcast messageString

proc forward {} {
    global socket
    if {[string length $socket]} {
	puts $socket "forward"
    }
}
proc backward {} {
    global socket
    if {[string length $socket]} {
	puts $socket "backward"
    }
}
proc left {} {
    global socket
    if {[string length $socket]} {
	puts $socket "left"
    }
}
proc right {} {
    global socket
    if {[string length $socket]} {
	puts $socket "right"
    }
}
proc broadcast {message} {
    global socket
    set message [lindex [split [string trim $message] "\n"] 0]
    if {[string length $socket]} {
	puts $socket [list "broadcast" $message]
    }
}
proc printConsole {message} {
    global socket
    if {[string length $socket]} {
	foreach line [split $message "\n"] {
	    puts $socket [list "printConsole" $line]
	}
    }
}

proc MSG_display {arg} {
    foreach {walls avs dir dots} $arg {break}
    # Update our display with walls $walls, avatars $avs, direction $dir,
    # and dot colouring $dots
    showWalls   $walls
    showDots    $dots
    showAvatars $avs
    showCompass $dir
}
proc MSG_ouch {arg} {
    set score [lindex $arg 0]
    # We hit something we shouldn't

    global fill
    .c configure -background     [darken [.c cget -background] 0.8 0.8 0.9]
    .c itemconfigure floor -fill [darken [.c itemcget floor -fill] 0.8 0.9 0.8]
    foreach {wall colour} [array get fill] {
	set fill($wall) [darken $colour]
    }
    catch {bell}
    showLCD $score
}
proc MSG_bump {arg} {
    set score [lindex $arg 0]
    # We hit something we should

    global fill
    .c configure -background [ \
	    lighten [.c cget -background] 0.8 0.8 0.9]
    .c itemconfigure floor -fill [ \
	    lighten [.c itemcget floor -fill] 0.8 0.9 0.8]
    foreach {wall colour} [array get fill] {
	set fill($wall) [lighten $colour]
    }
    showLCD $score
}
proc MSG_target {arg} {
    set col [lindex $arg 0]
    # We are seeking avatar $col

    if {[string length $col]} {
	.c itemconfigure seeking -text "You are seeking the $col being"
    } else {
	.c itemconfigure seeking -text "There is no-one to seek right now"
    }
}
proc MSG_message {arg} {
    foreach {col msg} $arg {break}
    # Avatar $col has sent message $msg

    #puts stdout "message $col $msg"
    addMsg $col $msg
}
proc MSG_colour {arg} {
    set col [lindex $arg 0]
    # Our colour is $col

    .c itemconfigure seeking -fill $col
    showLCD 0
}
proc MSG_vanished {arg} {
    set col [lindex $arg 0]
    # Avatar $col has vanished from the server

    ## DO NOTHING ABOUT THIS ONE FOR NOW...
    #puts stdout "vanished $col"
}
proc MSG_version {arg} {
    set ver [lindex $arg 0]
    global VERSION socket
    # Use [package vsatisfies] instead??
    if {[string compare $ver $VERSION]} {
	catch {close $socket}
	catch {
	    tk_messageBox -message "mismatched versions: $ver and $VERSION"
	}
	set socket {}
	return
    }
}

proc rcvMsg {} {
    global socket
    if {[gets $socket line] < 0} {
	close $socket
	set socket {}
	return
    }
    #puts stdout $line
    if {[catch {
	regsub -all {[^a-z]} [lindex $line 0] {} cmd
	set arg [lrange $line 1 end]
	MSG_$cmd $arg
    } msg]} {
	printConsole $::errorInfo
	bgerror $msg
    }
}

set socket [socket $HOSTNAME $PORTNUMBER]
fconfigure $socket -buffering line
fileevent $socket readable rcvMsg
proc nukeKids {args} {
    eval destroy [winfo children .]
}
proc bgerror {msg} {
    global socket
    close $socket
    set socket {}
}
trace variable socket w nukeKids