Ticket #122: stereo.tcl

#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" "$@"

# $Id: stereo.tcl,v 1.10 2009/02/07 07:04:50 gregcouch Exp $

# Togl - a Tk OpenGL widget
# Copyright (C) 1996  Brian Paul and Ben Bederson
# Copyright (C) 2006-2009  Greg Couch
# See the LICENSE file for copyright details.

# add parent directory to path to find Togl's pkgIndex in current directory
if { [file exists pkgIndex.tcl] } {
    set auto_path [linsert $auto_path 0 ..]
}
# following load also loads Tk and Togl packages
load [file dirname [info script]]/stereo[info sharedlibextension]

# create ::stereo namespace
namespace eval ::stereo {
}

variable stereo::mode none
proc stereo::setup {} {
        grid rowconfigure . 0 -weight 1 -minsize 200p
        grid columnconfigure . 1 -weight 1 -minsize 200p
        labelframe .c -text "Stereo mode:"
        grid .c -padx 2 -pady 2 -ipadx 2 -ipady 1
        # add "nvidia" to list below when it works
        foreach {b} {none native sgioldstyle anaglyph cross-eye wall-eye DTI "left eye" "right eye" } {
                set name [string map {- _ " " _} $b]
                radiobutton .c.b$name -text "$b" -command "::stereo::makeGraphics {$b}" -variable stereo::mode -value "$b"
                pack .c.b$name -padx 2 -pady 1 -anchor w
        }
        scale .sx -label {X Axis} -from 0 -to 360 -command {::stereo::setAngle x} -orient horizontal
        grid .sx -columnspan 2 -sticky ew
        scale .sy -label {Y Axis} -from 0 -to 360 -command {::stereo::setAngle y} -orient horizontal
        grid .sy -columnspan 2 -sticky ew
        if {[string first IRIX $::tcl_platform(os)] != -1} {
                label .irix -justify left -wraplength 250p -text "Use /usr/gfx/setmon or /usr/bin/X11/xsetmon to change video mode for native stereo (eg., 1024x768_120s) or sgioldstyle stereo (eg., str_bot) and back."
                grid .irix -sticky new -columnspan 2
        }
        button .quit -text Close -command exit
        grid .quit -sticky se -columnspan 2 -padx 2 -pady 2
        frame .f -relief groove -borderwidth 2 -bg black
        grid .f -row 0 -column 1 -sticky news
        bind . <Key-Escape> {exit}
        label .f.error -wraplength 100p -bg black -fg white
        ::stereo::makeGraphics $stereo::mode
}

set stereo::count 0
set stereo::oldname ""
proc stereo::makeGraphics {mode} {
        incr stereo::count
        set name .f.gr$stereo::count
        set width 200
        set height 200
        if { "$mode" == "nvidia" } {
                set mode "nvidia consumer stereo"
                set name ".gr$stereo::count"
                foreach s [grid slaves .] {
                        grid forget $s
                }
                wm attributes . -fullscreen 1
                set width [winfo screenwidth .]
                set height [winfo screenheight .]
        }
        if { [catch { togl $name -width $width -height $height -rgba true -stereo "$mode" -double true -depth true -sharelist main -create create_cb -display display_cb -reshape reshape_cb -eyeseparation 0.05 -convergence 2.0 } error] } {
                pack forget $stereo::oldname
                .f.error configure -text "$error\n\nMake another choice from the stereo modes on the left."
                pack .f.error -expand 1 -fill both
        } else {
                pack forget .f.error
                $name configure -ident main
                if { "$stereo::oldname" != "" } {
                        destroy $stereo::oldname
                }
                set stereo::oldname $name
                pack $name -expand 1 -fill both
                bind $name <B1-Motion> {
                        ::stereo::motion_event %W \
                                [lindex [%W config -width] 4] \
                                [lindex [%W config -height] 4] %x %y
                }
        }
}

# This is called when mouse button 1 is pressed and moved
proc stereo::motion_event { widget width height x y } {
    setXrot $widget [expr 360.0 * $y / $height]
    setYrot $widget [expr 360.0 * ($width - $x) / $width]

#    .sx set [expr 360.0 * $y / $height]
#    .sy set [expr 360.0 * ($width - $x) / $width]

    .sx set [getXrot]
    .sy set [getYrot]
}

# This is called when a slider is changed.
proc stereo::setAngle {axis value} {
    global xAngle yAngle zAngle

    # catch because .f.gr might be a label instead of a Togl widget
    catch {
            switch -exact $axis {
                x {setXrot .f.gr $value}
                y {setYrot .f.gr $value}
            }
    }
}

if { [info script] == $argv0 } {
        ::stereo::setup
}