#/usr/bin/wish  
#   KidStampPad
#   GPL (C)2002-2005 @yak.net : <strick>

catch { package require Tk }

set FONT 9x15bold
set FONT -adobe-courier-bold-r-normal--34-240-100-100-m-200-iso8859-1
set FONT -adobe-courier-bold-r-normal--34-*-*-*-*-*-iso8859-1
set FONT {courier 50 bold}

#shortcuts
proc 0 x {lindex $x 0}
proc 1 x {lindex $x 1}
proc 2 x {lindex $x 2}
proc 3 x {lindex $x 3}
proc 4 x {lindex $x 4}
proc 5 x {lindex $x 5}
proc end x {lindex $x end}
proc + {x y} {expr { $x + $y } }
proc - {x y} {expr { $x - $y } }
proc * {x y} {expr { $x * $y } }
proc / {x y} {expr { $x / $y } }
proc % {x y} {expr { $x % $y } }
proc avg {x y} {expr { ($x + $y) / 2 } }
interp alias {} sm {} string match
interp alias {} eq {} string equal
interp alias {} sc {} string compare
interp alias {} ie {} info exists

set B1 0
set Color blue
proc nextColor {} {
	switch -exact $::Color {
		blue { set ::Color green }
		green { set ::Color yellow }
		yellow { set ::Color orange }
		orange { set ::Color red }
		red { set ::Color violet }
		violet { set ::Color blue }
	}
}

proc height {} { .c cget -height }
proc width {} { .c cget -width }
proc color {} { set ::Color }

proc new_tria {radius x y} {
	set id [.c create polygon [
		expr {$x}] [ expr {$y-$radius}] [
		expr {$x-$radius}] [ expr {$y+$radius/2}] [
		expr {$x+$radius}] [ expr {$y+$radius/2}
		] -width 2 -outline [color] -fill [color] -tags {visible node tria} ]
	set ::ColorOf($id) [color]
}

proc new_rect {radius x y} {
	set id [.c create rectangle [
		expr {$x-$radius}] [ expr {$y-$radius}] [
		expr {$x+$radius}] [ expr {$y+$radius}
		] -width 2 -outline [color] -fill [color] -tags {visible node rect}]
	set ::ColorOf($id) [color]
}

proc new_circ {radius x y} {
	set id [.c create oval [
		expr {$x-$radius}] [ expr {$y-$radius}] [
		expr {$x+$radius}] [ expr {$y+$radius} 
		] -width 2 -outline [color] -fill [color] -tags {visible node circ}]
	set ::ColorOf($id) [color]
}

proc delete_rubber {} {
	.c delete rubber
}
proc init_rubber {x y} {
	delete_rubber
	.c create line $x $y $x $y -width 4 -fill white -tags {rubber}
}
proc init_rubber_marqee {x y} {
	delete_rubber
	.c create line $x $y $x $y -dash . -width 4 -fill white -tags {rubber marqeeN}
	.c create line $x $y $x $y -dash . -width 4 -fill white -tags {rubber marqeeE}
	.c create line $x $y $x $y -dash . -width 4 -fill white -tags {rubber marqeeS}
	.c create line $x $y $x $y -dash . -width 4 -fill white -tags {rubber marqeeW}
}
proc start_line {x y} {
	set ::Action "new_line $x $y"
	init_rubber $x $y
}
proc start_marqee {x y} {
	set ::Action "new_marqee $x $y"
	init_rubber_marqee $x $y
}
proc new_line {fromx fromy x y} {
	# instantiate a line segment
	set id [.c create line $fromx $fromy $x $y -width 4 -fill [color] -tags {visible node line}]
	set ::Action "new_line $x $y"
	set ::ColorOf($id) [color]
	init_rubber $x $y
	return $id
}
proc new_gang {avgx avgy x y} {
	foreach id [.c find withtag (gang&&node) ] {
	  set oldxy [.c coords $id]
	  set newx [+ $x [- [0 $oldxy] $avgx]]
	  set newy [+ $y [- [1 $oldxy] $avgy]]
	  set fill [end [.c itemconfig $id -fill]]

	  switch -exact [.c type $id] {
	    text {
		set text [end [.c itemconfig $id -text]]
		set nid [.c create text $newx $newy -font $::FONT -text $text -fill $fill -tags {visible node text}]
		set ::ColorOf($nid) $fill
	    }
	    rectangle {
		set newx2 [+ $x [- [2 $oldxy] $avgx]]
		set newy2 [+ $y [- [3 $oldxy] $avgy]]

		set nid [.c create rectangle $newx $newy $newx2 $newy2 -width 2 -outline $fill -fill $fill -tags {visible node rect}]

		set ::ColorOf($nid) $fill
	    }
	    polygon {
		set newx2 [+ $x [- [2 $oldxy] $avgx]]
		set newy2 [+ $y [- [3 $oldxy] $avgy]]
		set newx3 [+ $x [- [4 $oldxy] $avgx]]
		set newy3 [+ $y [- [5 $oldxy] $avgy]]

		set nid [.c create polygon $newx $newy $newx2 $newy2 $newx3 $newy3 -width 2 -outline $fill -fill $fill -tags {visible node tria}]

		set ::ColorOf($nid) $fill
	    }
	    oval {
		set newx2 [+ $x [- [2 $oldxy] $avgx]]
		set newy2 [+ $y [- [3 $oldxy] $avgy]]

		set nid [.c create oval $newx $newy $newx2 $newy2 -width 2 -outline $fill -fill $fill -tags {visible node circ}]

		set ::ColorOf($nid) $fill
	    }
	    line {
		set newx2 [+ $x [- [2 $oldxy] $avgx]]
		set newy2 [+ $y [- [3 $oldxy] $avgy]]

		set nid [.c create line $newx $newy $newx2 $newy2 -width 4 -fill $fill -tags {visible node line}]

		set ::ColorOf($nid) $fill
	    }
	  }

	}
}

proc restore_gang_color {} {
	foreach id [.c find withtag gang] {
	    if {[ie ::ColorOf($id)]} {
		.c itemconfig $id -fill $::ColorOf($id)
	    }
	}
}
proc paint_gang_white {} {
	.c itemconfig gang -fill white
}
	
proc new_marqee {fromx fromy x y} {
	# instantiate a copy
	restore_gang_color
	set ::Action "new_gang [avg $fromx $x] [avg $fromy $y]"
}

proc new_text {x y} {
	set id [.c create text $x $y -font $::FONT -text $::Text -fill [color] -tags {visible node text}]
	set ::ColorOf($id) [color]
	return $id
}

# create canvas; pack at toplevel; focus keyboard on it
set max [wm maxsize .]
canvas .c -width [0 $max] -height [1 $max]
pack .c
focus .c

# Lefthand Edge Shape Masters
set y 100
foreach {rad} {15 20 25 30  } {

	# master circle
	set id [.c create oval 10 $y [+ 10 [* 2 $rad]] [+ $y [* 2 $rad]] -fill black -tags { master mcirc} ]
	.c bind $id <Any-Enter> "set ::Action \"new_circ $rad\" ; .c raise circ "
	incr y [+ 10 [* 2 $rad]]
}
foreach {rad} {15 20 25 30 } {
	# master rectangle
	set id [.c create rectangle 10 $y [+ 10 [* 2 $rad]] [+ $y [* 2 $rad]] -fill black -tags { master mrect} ]
	.c bind $id <Any-Enter> " set ::Action \"new_rect $rad\" ; .c raise rect "
	incr y [+ 10 [* 2 $rad]]
}
foreach {rad} {15 20 25 30 } {
	# master triangle
	set id [.c create polygon [+ 10 $rad] $y 10 [+ $y [* 2 $rad]] [+ 10 [* 2 $rad]] [+ $y [* 2 $rad]] -fill black -tags { master mtria} ]
	.c bind $id <Any-Enter> " set ::Action \"new_tria $rad\" ; .c raise tria "

	incr y [+ 10 [* 2 $rad]]
}
#master inkpen
#.c create line 100 0 0 100 -width 10 -fill black -tags {master inkpen}
for {set i 0} {$i<100} {incr i 8} {
	.c create oval [- 100 $i] [+ $i 0]  [- 106 $i] [+ $i 6]  -outline black -fill black -tags {master inkpen}
}
.c bind inkpen <Any-Enter> { set ::Action inkpen ; .c raise ink ; .c itemconfigure inkpen -fill [color] -outline [color] }
.c bind inkpen <Button-1> { set ::Action inkpen ; .c raise ink ; .c itemconfigure inkpen -fill [color] -outline [color] }

proc master_reset {} {
	.c dtag gang
	.c configure -cursor arrow

	.c itemconfigure master -state normal
	.c itemconfigure magic -state normal
	.c itemconfigure visible -state normal
	.c itemconfigure upper -state hidden 

	.c itemconfigure master -fill black
	.c itemconfigure white -fill white
	.c itemconfigure brown -fill brown
	delete_rubber
}
.c bind master <Any-Enter> {
	master_reset
	.c itemconfigure current -fill [color]
}
.c create line [- [width] 60] 700 [- [width] 10] 720 -width 6 -fill black -tags {master mline}
.c bind mline <Any-Enter> { set ::Action "start_line" }
.c create rectangle [- [width] 60] 750 [- [width] 10] 770 -outline white -width 6 -fill black -tags {master mmarqee}
.c bind mmarqee <Any-Enter> { set ::Action "start_marqee" }

# master letters
for {set i 1} {$i < 27} {incr i} {
	# uppercase across top of screen
	.c create text [expr {100+ $i*40}] 40 \
		-font $::FONT -text [format %c [expr 64+$i]] -fill black -tags {master mtext}
	# lowercase across bottom of screen
	.c create text [expr {100+ $i*40}] [- [height] 40] \
		-font $::FONT -text [format %c [expr 96+$i]] -fill black -tags {master mtext}
}
# master numbers
for {set i 0} {$i < 10} {incr i} {
	# numbers down right side
	.c create text [- [width] 30] [+ 50 [* $i 50]] \
		-font $::FONT -text [format %c [expr 48+$i]] -fill black -tags {master mtext}
}
# bind all master text characters
.c bind mtext <Any-Enter> {
	set ::Action new_text
	set ::Text [end [ .c itemconfigure current -text ] ]
	.c raise text
}

# erasers
.c create line [- [width] 60] 600 [- [width] 10] 650 -width 6 -fill white -tags {white magic eraser1}
.c create line [- [width] 60] 650 [- [width] 10] 600 -width 6 -fill white -tags {white magic eraser1}
.c bind eraser1 <Any-Enter> {
	master_reset
	.c itemconfigure eraser1 -fill red
	set ::Action "magic_eraser1"
	.c configure -cursor iron_cross
}

# magic ladder
.c create polygon 30 [- [height] 60]   60 [- [height] 30]  30 [- [height] 1]  1 [- [height] 30] \
 		-fill brown -tags {magic brown ladder}
.c bind ladder <Any-Enter> {
	master_reset
	.c itemconfigure ladder -fill white
	.c itemconfigure visible -state hidden 
	.c itemconfigure master -state hidden 
	.c itemconfigure magic -state hidden 
	.c itemconfigure ladder -state normal 
	.c itemconfigure upper -state normal 

	set ::Action "magic_ladder"
	set ::Action "none"
}

.c create text 100 100 -anchor nw -font $::FONT -text "clear" -fill black -tags {upper u_clear}
.c bind u_clear <Any-Enter> {
	master_reset
	.c delete node
	.c itemconfig life -state hidden
	set ::Action "none"
}
.c create text 200 200 -anchor nw -font $::FONT -text "tic-tac-toe" -fill black -tags {upper u_tictactoe}
.c bind u_tictactoe <Any-Enter> {
	master_reset
	set x3 [- [width] 100]
	set x1 [/ [+ 100 [+ 100 $x3]] 3]
	set x2 [/ [+ 100 [+ $x3 $x3]] 3]
	set y3 [- [height] 100]
	set y1 [/ [+ 100 [+ 100 $y3]] 3]
	set y2 [/ [+ 100 [+ $y3 $y3]] 3]
	set ::ColorOf([.c create line 100 $y1 $x3 $y1 -width 4 -fill black -tags {visible node line}]) black
	set ::ColorOf([.c create line 100 $y2 $x3 $y2 -width 4 -fill black -tags {visible node line}]) black
	set ::ColorOf([.c create line $x1 100 $x1 $y3 -width 4 -fill black -tags {visible node line}]) black
	set ::ColorOf([.c create line $x2 100 $x2 $y3 -width 4 -fill black -tags {visible node line}]) black

	set ::Action "none"
}

set LIFESIZE 20
set LIFETIME 1000
.c create text 300 300 -anchor nw -font $::FONT -text "life" -fill black -tags {upper u_life}
if 1 {
	set x3 [- [width] 100]
	set y3 [- [height] 100]

	set LIFESIZE 20
	for {set i 0} {$i<$LIFESIZE} {incr i} {
	  for {set j 0} {$j<$LIFESIZE} {incr j} {
	    set x [expr {100+ $i*([width]-200)/$LIFESIZE }]
	    set y [expr {100+ $j*([height]-200)/$LIFESIZE }]
	    set nid [.c create oval [- $x 10] [- $y 10] [+ $x 10] [+ $y 10] -fill white -tags {circ life} -state hidden ]
	    set ::ColorOf($nid) white
	    set Life($i,$j) $nid
	  }
	}
}
.c bind u_life <Any-Enter> {
	master_reset

	set LIFESIZE 20
	for {set i 0} {$i<$LIFESIZE} {incr i} {
	  for {set j 0} {$j<$LIFESIZE} {incr j} {
	    .c itemconf $Life($i,$j) -state [expr {rand()<0.7 ? "hidden" : "normal" }]
	  }
	}

	set ::Action "none"
}
proc life-step {} {
	set hide {}
	set norm {}
	for {set i 0} {$i<$::LIFESIZE} {incr i} {
	  for {set j 0} {$j<$::LIFESIZE} {incr j} {
		set nei 0
		foreach {f g} {-1 -1 -1 0 -1 1   0 -1 0 1  1 -1 1 0 1 1} {
			set x [+ $i $f]
			set y [+ $j $g]
			if { $x>=0 && $x<$::LIFESIZE && $y>=0 && $y<$::LIFESIZE } {
				if {"normal" == [end [.c itemconfig $::Life($x,$y) -state]]} { incr nei }
			}
		}
		if {"normal" == [end [.c itemconfig $::Life($i,$j) -state]]} {
			if { $nei!=2 && $nei!=3 } { lappend hide $::Life($i,$j) }
		} else {
			if { $nei==3 } { lappend norm $::Life($i,$j) }
		}
	  }
	}
	foreach id $hide { .c itemconfig $id -state hidden }
	foreach id $norm { .c itemconfig $id -state normal }

	after $::LIFETIME life-step
}
after $::LIFETIME life-step



# clicking on masters
foreach BUTTON {1 2 3} {
  .c bind master <Button-$BUTTON> { nextColor ; .c itemconfigure current -fill [color] }
}

# bind instance nodes
.c bind node x { .c delete current }
.c bind node <Any-Enter> {
	if {[sm magic_eraser* $::Action ]} {
		foreach id [ .c find withtag current ] {
			catch { unset ::ColorOf($id) }
			.c delete $id
		}
	} else {
		.c itemconfigure current -fill white 
	}
}
.c bind node <Any-Leave> { .c itemconfigure current -fill [color] }
.c bind node <Any-Leave> { 
	set id [.c find withtag current]
	.c itemconfigure $id -fill $::ColorOf($id)
}
foreach BUTTON {1 2 3} {
  .c bind node <Button-$BUTTON> { set curx %x ; set cury %y }
  .c bind node <B$BUTTON-Motion> {
	set id [.c find withtag current]
	.c move $id [- %x $curx] [- %y $cury]
	.c raise $id
	set curx %x ; set cury %y
  }
}

# type 'q' 'u' 'i' 't' in order, to quit
set quit x
bind .c q { set quit q }
bind .c u { set quit [expr { $quit=="q" ? "u" : "x" }]}
bind .c i { set quit [expr { $quit=="u" ? "i" : "x" }]}
bind .c t { 
	set quit [expr { $quit=="i" ? "t" : "x" }]
	if { $quit=="t" } { destroy . }
}
# or just hit ESC to quit
bind .c <Escape> { destroy . }

proc end_line {newx newy} {
	set a [.c coords $::this]
	.c coords $::this [0 $a] [1 $a] $newx $newy
}

bind .c <Button-1> { 
  set ::B1 1
  switch -glob $::Action {
    new_line* {
	eval $::Action %x %y
    }
    new_marqee* {
	eval $::Action %x %y
    }
    start_line { 
	eval $::Action %x %y
    }
    start_marqee { 
	eval $::Action %x %y
    }
    new_* {
	set o [.c find withtag current]
	if {![llength $o]} { eval $::Action %x %y }
    }
  }
  set curx %x
  set cury %y
}
bind .c <B1-ButtonRelease> {
  set ::B1 0
  switch -glob $::Action {
	new_marqee* {
		eval $::Action %x %y
	}

  }
}
if 0 {
bind .c <B1-Motion> {
  switch -glob $::Action {
	new_marqee* {
		restore_gang_color
		.c dtag gang

		.c addtag gang overlapping [1 $::Action] [2 $::Action] %x %y
		paint_gang_white

		eval $::Action %x %y
	}
	inkpen {
	    set id [.c create oval [- %x 3] [- %y 3] [+ %x 3] [+ %y 3] \
		-fill [color] -tags {visible node ink}]
	    set ::ColorOf($id) [color]
	}

  }
}
}
bind .c <Motion> {
  switch -glob $::Action {
    new_line* {
	.c coords rubber [1 $::Action] [2 $::Action] %x %y
    }
    new_marqee* {
	.c coords marqeeN [1 $::Action] [2 $::Action] %x [2 $::Action]
	.c coords marqeeE %x [2 $::Action] %x %y
	.c coords marqeeS [1 $::Action] %y %x %y
	.c coords marqeeW [1 $::Action] [2 $::Action] [1 $::Action] %y
	
		restore_gang_color
		.c dtag gang

		.c addtag gang overlapping [1 $::Action] [2 $::Action] %x %y
		paint_gang_white


    }
	inkpen { if $::B1 {
	    set id [.c create oval [- %x 3] [- %y 3] [+ %x 3] [+ %y 3] \
		-outline [color] -fill [color] -tags {visible node ink}]
	    set ::ColorOf($id) [color]
	} }
  }
}

master_reset
set ::Action "start_line"

wm title . "KidStampPad"

#END $Header: /home/beamer/kid_stamp_pad/RCS/kid_stamp_pad.tcl,v 1.11 2004/12/19 04:41:47 beamer Exp beamer $