# Random Dot Stereogram
package require Tk

canvas .c
pack .c
update

set width [winfo width .]
set height [winfo height .]

# The strip width effects the interocular distance.
set vstrip 40
# initialize picture to size of root window and depth of 0
proc new_pic { } {
    global width height pic xpos ypos
    set pic {}
    set xpos 0
    set ypos 0
    for {set y 0} {$y<$height} {incr y} {
        set row {}
        for {set x 0} {$x<$width} {incr x} {
            lappend row 0
        }
        lappend pic ${row}
    }
}
# set a rectangle in pic to depth
proc rectangle { x0 y0 x1 y1 depth } {
    global pic
    for {set y $y0} {$y<$y1} {incr y} {
        for {set x $x0} {$x<$x1} {incr x} {
            lset pic $y $x $depth
        }
    }
}
# draw a stepped pyramid in pic
proc draw_pyramid { steps depth } {
    global width height
    set offset 50
    set base [expr {$height-2*$offset}]
    set step [expr {$base/($steps*2)}]
    for {set i 1} {$i<=$steps} {incr i} {
        set offset [expr {$offset+$step}]
        set x0 $offset
        set x1 [expr {$width-$offset}]
        set y0 $offset
        set y1 [expr {$height-$offset}]
        #puts "rectangle $x0 $y0 $x1 $y1 [expr {$i*$depth}]"
        rectangle $x0 $y0 $x1 $y1 [expr {$i*$depth}]
    }   
}
# Initialize buffer with a vertical strip of random bits.
# Width of the strip is vstrip.
proc init_buffer { } {
    global width height buffer vstrip
    for {set y 0} {$y<$height} {incr y} {
        set row {}
        for {set x 0} {$x<$vstrip} {incr x} {
            lappend row [expr {round(rand())}]
        }
        lappend buffer ${row}
    }   
}
# Create a random dot stereogram
proc stereogram {  } {
    global width height pic buffer vstrip
    for {set col 0} {$col<$width} {incr col $vstrip} {
        do_one_strip $col
    }
}
# process one vertical strip of the stereogram
proc do_one_strip { offset } {
    global width height pic buffer vstrip
    set buf_y 0
    for {set pic_y 0;set buf_y 0} {$pic_y<$height} {incr pic_y;incr buf_y} {
        for {set pic_x ${offset}; set buf_x [expr {$vstrip+$offset}]} \
            {$pic_x<[expr {$offset+$vstrip}]} \
            {incr pic_x;incr buf_x} \
        {
            set depth [lindex $pic $pic_y $pic_x]
            if { $depth > 0 } {
                lset buffer $buf_y $buf_x [lindex $buffer $buf_y [expr {${buf_x}-${vstrip}+${depth}}]]
            } else {
                lset buffer $buf_y $buf_x [lindex $buffer $buf_y [expr {${buf_x}-${vstrip}}]]
            }
        }
    }
}
# Output the stereogram to the canvas
proc render { buffer } {
    set y 0
    foreach row ${buffer} {
        set x 0
        foreach bit ${row} {
            if { $bit > 0 } {
                .c create rectangle $x $y $x $y -outline white
            } else {
                .c create rectangle $x $y $x $y -outline black
            }
            incr x
        }
        incr y
    }
}
# run the program
new_pic
draw_pyramid 4 3
init_buffer
stereogram
render ${buffer}