uniquename 2013aug17For those who will never have the time/opportunity/whatever to run the code below, here are a couple of images that show the nice appearance of this GUI --- and how just switching the black disks with the white disks can make the lines (appear to?) bulge inward rather than outward.
2017-09-29: Online demo at [1]
#!/bin/sh -*- tab-width: 8; -*-
# The next line is executed by /bin/sh, but not tcl \
exec wish $0 ${1+"$@"}
##+#############################################################
#
# bulging.tcl -- whizzlet demonstrating the bulging line illusion
# by Keith Vetter
#
package require Tk
set G \#848484
set L \#C4C4C4
set B \#040404
set W \#FEFEFE
set S(m) 30 ;# Margin
set S(r) 10 ;# Circle radius
set S(colors) "GLWB" ;# Coloring scheme
proc DoDisplay {} {
wm title . "Bulging Line Illusion"
pack [frame .bottom] -side bottom -fill x
canvas .c -width 400 -height 400 -bd 2 -relief raised -bg \#C0DEC4
pack .c -side top -fill both -expand 1
scale .size -from 5 -to 15 -orient horizontal -showvalue 0 \
-variable S(r) -label "Circle Size" -command DrawCircles
radiobutton .c1 -text "GLWB" -variable S(colors) -value "GLWB" \
-command Colorize
radiobutton .c2 -text "GLBW" -variable S(colors) -value "GLBW" \
-command Colorize
pack .size -side left -in .bottom
pack .c2 .c1 -side right -in .bottom
image create photo ::img::blank -width 1 -height 1
button .about -image ::img::blank -highlightthickness 0 -command About
place .about -in .bottom -relx 1 -rely 0 -anchor ne
bind all <Alt-c> [list console show]
bind .c <Configure> DrawBoard
update
}
proc DrawBoard {} {
global S
.c delete c0 c1 c2 c3
set S(w) [expr {([winfo width .c] - 2*$S(m)) / 9.0}]
set S(h) [expr {([winfo height .c] - 2*$S(m)) / 9.0}]
.size config -to [expr {int(($S(w) < $S(h) ? $S(w) : $S(h))/2)}]
for {set row 0} {$row < 9} {incr row} {
for {set col 0} {$col < 9} {incr col} {
set xy [GetXY $row $col]
.c create rect $xy -tag "c[expr {($row + $col) % 2}]" -outline {}
}
}
DrawCircles
for {set row 1} {$row < 9} {incr row} {
foreach {x1 y1} [GetXY $row 1] break
foreach {x2 y2} [GetXY $row 8] break
.c create line $x1 $y1 $x2 $y2 -tag {c1 line}
}
for {set col 1} {$col < 9} {incr col} {
foreach {x1 y1} [GetXY 1 $col] break
foreach {x2 y2} [GetXY 8 $col] break
.c create line $x1 $y1 $x2 $y2 -tag {c1 line}
}
Colorize
}
# Colorize -- sets the correct color for every item on the canvas
proc Colorize {} {
foreach id {0 1 2 3} {
set color [set ::[string index $::S(colors) $id]]
.c itemconfig c$id -fill $color
catch {.c itemconfig c$id -outline $color}
}
}
proc DrawCircles {args} {
global S
if {! [info exists S(w)]} return
set id1 {3 2 3 2 2 3 2 3 2 3 2 3 3 2 3 2} ;# Color each gets
set id2 {2 3 2 3 3 2 3 2 3 2 3 2 2 3 2 3}
set ids [concat $id1 $id1 $id2 $id2]
.c delete circle
for {set row 1} {$row < 9} {incr row} {
for {set col 1} {$col < 9} {incr col} {
foreach {x y} [GetXY $row $col] break
set xy [Box $x $y $S(r)]
set id [lindex $ids 0] ; set ids [lrange $ids 1 end]
.c create oval $xy -tag [list c$id circle]
}
}
Colorize
.c raise line
}
proc Box {x y r} {
return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
}
proc GetXY {row col} {
global S
set x1 [expr {$S(m) + $col * $S(w)}]
set y1 [expr {$S(m) + $row * $S(h)}]
set x2 [expr {$x1 + $S(w)}]
set y2 [expr {$y1 + $S(h)}]
return [list $x1 $y1 $x2 $y2]
}
proc About {} {
set msg "Bulging Line Illusion\nby Keith Vetter, February 2003\n\n"
append msg "A whizzlet for visualizing the Bulging Line Illusion.\n\n"
append msg "The Bulging Line Illusion was invented by Japanese artist\n"
append msg "Akiyoshi Kitaoka. So named because for some distributions of\n"
append msg "colors, e.g. GLWB, the lines appear to bulge. For other\n"
append msg "distributions they appear to bend inwards.\n\n"
append msg "(G is gray, L is light gray, B is black and W is white.)\n"
tk_messageBox -title "About Bulging Line Illusion" -message $msg
}
DoDisplay