#!/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} {
        lassign [GetXY $row 1] x1 y1
        lassign [GetXY $row 8] x2 y2
        .c create line $x1 $y1 $x2 $y2 -tag {c1 line}
    }
    for {set col 1} {$col < 9} {incr col} {
        lassign [GetXY 1 $col] x1 y1
        lassign [GetXY 8 $col] x2 y2
        .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} {
            lassign [GetXY $row $col] x y
            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