74 lines
1.8 KiB
Tcl
74 lines
1.8 KiB
Tcl
package require Tcl 8.5
|
|
package require Tk
|
|
package require struct::queue
|
|
|
|
proc floodFill {img colour point} {
|
|
set new [colour2rgb $colour]
|
|
set old [getPixel $img $point]
|
|
struct::queue Q
|
|
Q put $point
|
|
while {[Q size] > 0} {
|
|
set p [Q get]
|
|
if {[getPixel $img $p] eq $old} {
|
|
set w [findBorder $img $p $old west]
|
|
set e [findBorder $img $p $old east]
|
|
drawLine $img $new $w $e
|
|
set q $w
|
|
while {[x $q] <= [x $e]} {
|
|
set n [neighbour $q north]
|
|
if {[getPixel $img $n] eq $old} {Q put $n}
|
|
set s [neighbour $q south]
|
|
if {[getPixel $img $s] eq $old} {Q put $s}
|
|
set q [neighbour $q east]
|
|
}
|
|
}
|
|
}
|
|
Q destroy
|
|
}
|
|
|
|
proc findBorder {img p colour dir} {
|
|
set lookahead [neighbour $p $dir]
|
|
while {[getPixel $img $lookahead] eq $colour} {
|
|
set p $lookahead
|
|
set lookahead [neighbour $p $dir]
|
|
}
|
|
return $p
|
|
}
|
|
|
|
proc x p {lindex $p 0}
|
|
proc y p {lindex $p 1}
|
|
|
|
proc neighbour {p dir} {
|
|
lassign $p x y
|
|
switch -exact -- $dir {
|
|
west {return [list [incr x -1] $y]}
|
|
east {return [list [incr x] $y]}
|
|
north {return [list $x [incr y -1]]}
|
|
south {return [list $x [incr y]]}
|
|
}
|
|
}
|
|
|
|
proc colour2rgb {color_name} {
|
|
foreach part [winfo rgb . $color_name] {
|
|
append colour [format %02x [expr {$part >> 8}]]
|
|
}
|
|
return #$colour
|
|
}
|
|
|
|
set img [newImage 70 50]
|
|
fill $img white
|
|
|
|
drawLine $img blue {0 0} {0 25}
|
|
drawLine $img blue {0 25} {35 25}
|
|
drawLine $img blue {35 25} {35 0}
|
|
drawLine $img blue {35 0} {0 0}
|
|
floodFill $img yellow {3 3}
|
|
|
|
drawCircle $img black {35 25} 24
|
|
drawCircle $img black {35 25} 10
|
|
floodFill $img orange {34 5}
|
|
floodFill $img red {36 5}
|
|
|
|
toplevel .flood
|
|
label .flood.l -image $img
|
|
pack .flood.l
|