# tcl3dDouble.tcl
#
# A Tcl3D widget demo with two windows, one single buffered and the
# other double buffered.
#
# This is a version of the original Togl double demo written entirely in Tcl
# with the help of the Tcl3D package.
#
# Copyright (C) 1996 Brian Paul and Ben Bederson (Original C/Tcl version)
# Copyright (C) 2005-2024 Paul Obermeier (Tcl3D version)
# See the LICENSE file for copyright details.
#
# Original sources available at: http://sourceforge.net/projects/togl/

package require tcl3d

# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
    tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
    exit
}

# Print info message into widget a the bottom of the window.
proc PrintInfo { msg } {
    if { [winfo exists .fr.info] } {
        .fr.info configure -text $msg
    }
}

proc CreateCallback { toglwin } {
    set ::FontBase [$toglwin loadbitmapfont]
}

proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    set w [$toglwin width]
    set h [$toglwin height]

    set aspect [expr double ($w) / double ($h)]

    glViewport 0 0 $w $h

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glFrustum [expr -1.0 * $aspect] $aspect -1.0 1.0 1.0 10.0

    set ::CornerX  [expr -1.0 * $aspect]
    set ::CornerY  -1.0
    set ::CornerZ  -1.1

    glMatrixMode GL_MODELVIEW
}

proc PrintString {s} {
    set len [string length $s]
    if { $len > 0 } {
        glListBase $::FontBase
        set sa [tcl3dVectorFromString GLubyte $s]
        glCallLists $len GL_UNSIGNED_BYTE $sa
        $sa delete
    }
}

proc DisplayCallback { toglwin } {
    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]

    # Viewport command is not really needed, but has been inserted for
    # Mac OSX. Presentation framework (Tk) does not send a reshape event,
    # when switching from one demo to another.
    glViewport 0 0 [$toglwin width] [$toglwin height]

    glLoadIdentity
    glTranslatef 0.0 0.0 -3.0
    glRotatef $::xAngle 1.0 0.0 0.0
    glRotatef $::yAngle 0.0 1.0 0.0
    glRotatef 0.0       0.0 0.0 1.0

    glEnable GL_DEPTH_TEST

    if { ! [info exists ::cubeList] } {
        set ::cubeList [glGenLists 1]
        glNewList $::cubeList GL_COMPILE

        glBegin GL_QUADS
            glColor3f 0.0 0.7 0.1
            glVertex3f -1.0  1.0 1.0
            glVertex3f  1.0  1.0 1.0
            glVertex3f  1.0 -1.0 1.0
            glVertex3f -1.0 -1.0 1.0

            glColor3f 0.9 1.0 0.0
            glVertex3f -1.0 1.0 -1.0
            glVertex3f 1.0 1.0 -1.0
            glVertex3f 1.0 -1.0 -1.0
            glVertex3f -1.0 -1.0 -1.0

            glColor3f 0.2 0.2 1.0
            glVertex3f -1.0 1.0 1.0
            glVertex3f 1.0 1.0 1.0
            glVertex3f 1.0 1.0 -1.0
            glVertex3f -1.0 1.0 -1.0

            glColor3f 0.7 0.0 0.1
            glVertex3f -1.0 -1.0 1.0
            glVertex3f 1.0 -1.0 1.0
            glVertex3f 1.0 -1.0 -1.0
            glVertex3f -1.0 -1.0 -1.0
        glEnd

        glEndList

    }
    glCallList $::cubeList

    glDisable GL_DEPTH_TEST
    glLoadIdentity
    glColor3f 1.0 1.0 1.0
    glRasterPos3f $::CornerX $::CornerY $::CornerZ
    set ident [lindex [$toglwin configure -ident] end]
    if { [string compare $ident "Single"] == 0 } {
        PrintString "Single buffered"
    } else {
        PrintString "Double buffered"
    }
    $toglwin swapbuffers
}

proc SetRotX { wid val } {
    set ::xAngle $val

    if { $::xAngle < 0.0 } {
        set ::xAngle [expr $::xAngle + 360.0]
    } elseif { $::xAngle > 360.0 } {
        set ::xAngle [expr $::xAngle - 360.0]
    }

    $wid postredisplay
}

proc SetRotY { wid val } {
    set ::yAngle $val

    if { $::yAngle < 0.0 } {
        set ::yAngle [expr $::yAngle + 360.0]
    } elseif { $::yAngle > 360.0 } {
        set ::yAngle [expr $::yAngle - 360.0]
    }

    $wid postredisplay
}

proc Cleanup {} {
    # Destroy the display list and it's associated variable.
    # Needed when running the demo in the presentation framework.
    if { [info exists ::cubeList] } {
        glDeleteLists $::cubeList 1
        unset ::cubeList
    }
}

proc CreateWindows {} {
    wm title . "Tcl3D demo: Single vs Double Buffering"

    # Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
    frame .fr
    pack .fr -expand 1 -fill both

    frame .fr.f1

    # create first Togl widget
    togl .fr.f1.o1 -width 400 -height 400 -rgba true \
                -double false -depth true -ident Single \
                -createcommand  CreateCallback \
                -displaycommand DisplayCallback \
                -reshapecommand ReshapeCallback

    # create second Togl widget, share display lists with first widget
    togl .fr.f1.o2 -width 400 -height 400 -rgba true \
                -double true -depth true -ident Double -sharelist Single \
                -createcommand  CreateCallback \
                -displaycommand DisplayCallback \
                -reshapecommand ReshapeCallback

    frame  .fr.x
    label  .fr.x.l -text "X Axis"
    scale  .fr.x.s -from 0 -to 360 -command {SetAngle x} -orient horizontal -variable ::xAngle

    frame  .fr.y
    label  .fr.y.l -text "Y Axis"
    scale  .fr.y.s -from 0 -to 360 -command {SetAngle y} -orient horizontal -variable ::yAngle

    label  .fr.info

    bind .fr.f1.o1 <B1-Motion> {
        MotionEvent [lindex [%W config -width] 4] \
                    [lindex [%W config -height] 4] \
                    %x %y
    }

    bind .fr.f1.o2 <B1-Motion> {
        MotionEvent [lindex [%W config -width] 4] \
                    [lindex [%W config -height] 4] \
                    %x %y
    }
    bind . <Key-Escape> "exit"

    grid .fr.f1   -row 0 -column 0 -sticky news
    grid .fr.x    -row 1 -column 0 -sticky news
    grid .fr.y    -row 2 -column 0 -sticky news
    grid .fr.info -row 3 -column 0 -sticky news
    grid rowconfigure .fr 0 -weight 1
    grid columnconfigure .fr 0 -weight 1

    pack .fr.f1.o1 -side left -padx 2 -pady 2 -fill both -expand true
    pack .fr.f1.o2 -side left -padx 2 -pady 2 -fill both -expand true

    pack .fr.x.l -side left
    pack .fr.x.s -side left -fill x -expand true
    pack .fr.y.l -side left
    pack .fr.y.s -side left -fill x -expand true
}

# This is called when mouse button 1 is pressed and moved in either of
# the OpenGL windows.
proc MotionEvent { width height x y } {
    SetRotX .fr.f1.o1 [expr 360.0 * $y / $height]
    SetRotX .fr.f1.o2 [expr 360.0 * $y / $height]
    SetRotY .fr.f1.o1 [expr 360.0 * ($width - $x) / $width]
    SetRotY .fr.f1.o2 [expr 360.0 * ($width - $x) / $width]

    .fr.x.s set $::xAngle
    .fr.y.s set $::yAngle
}

# This is called when a slider is changed.
proc SetAngle {axis value} {
    global xAngle yAngle

    switch -exact $axis {
        x {SetRotX .fr.f1.o1 $value
           SetRotX .fr.f1.o2 $value
        }
        y {SetRotY .fr.f1.o1 $value
           SetRotY .fr.f1.o2 $value
        }
    }
}

set xAngle 33.0
set yAngle 45.0

CreateWindows

PrintInfo [tcl3dOglGetInfoString]
