# projectionModes.tcl
#
# A Tcl3D widget demo with two windows, one rendered as a single image with
# projection set by gluPerspective, the other one rendered row by row with
# the projection set by numRows * glFrustum calls.
#
# Copyright (C) 2013-2026 Paul Obermeier
# See www.tcl3d.org for the Tcl3D extension.

package require tcl3d

set gDemo(winWidth)  300
set gDemo(winHeight) 150

set gDemo(near)  1.0
set gDemo(far)  10.0

set gDemo(fovX) 60.0
set gDemo(fovY) [expr {$gDemo(fovX) * $gDemo(winHeight) / $gDemo(winWidth)}]

set gDemo(numRows) 10

set gDemo(useTcl3dProcs) 0
set gDemo(printProjMat)  0

set gDemo(saveImgs) 0

set gDemo(xAngle) 0.0
set gDemo(yAngle) 0.0
set gDemo(zAngle) 0.0

# Determine the directory of this script
set gDemo(scriptDir) [file dirname [info script]]

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

# 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 tcl3dMatListPrint { mat { msg "" } { precisionString "%6.3f" } } {
    if { $msg ne "" } {
        puts "$msg"
    }
    for { set i 0 } { $i < 4 } { incr i } {
        for { set j 0 } { $j < 4 } { incr j } {
            puts -nonewline [format "$precisionString " [lindex $mat [expr 4*$j + $i]]]
        }
        puts ""
    }
}

proc SetMousePos { x y } {
    global gDemo

    set gDemo(cx) $x
    set gDemo(cy) $y
}

proc SetRotX { wid val } {
    global gDemo

    set gDemo(xAngle) [expr {$gDemo(xAngle) + $val}]
    $wid postredisplay
}

proc SetRotY { wid val } {
    global gDemo

    set gDemo(yAngle) [expr {$gDemo(yAngle) + $val}]
    $wid postredisplay
}

proc HandleRot { wid x y } {
    global gDemo

    SetRotY $wid [expr {180 * (double($x - $gDemo(cx)) / [winfo width $wid])}]
    SetRotX $wid [expr {180 * (double($y - $gDemo(cy)) / [winfo height $wid])}]

    set gDemo(cx) $x
    set gDemo(cy) $y
}

proc MotionEvent { wid x y } {
    global gDemo

    HandleRot $gDemo(togl,Native)  $x $y
    HandleRot $gDemo(togl,Frustum) $x $y
    HandleRot $gDemo(togl,OSG)     $x $y
    HandleRot $gDemo(togl,Offset)  $x $y
    HandleRot $gDemo(togl,Row)     $x $y
}

proc SaveImg { type imgVec w h } {
    global gDemo

    set fileName [format "%s-%dx%d.png" $type $w $h]
    set filePath [file join $gDemo(scriptDir) $fileName]
    # Create a name on the file system, if running from within a Starpack.
    set imgName [tcl3dGenExtName $filePath]
    set ph [image create photo -width $w -height $h]
    tcl3dVectorToPhoto $imgVec $ph $w $h 3
    set fmt [string range [file extension $fileName] 1 end]
    $ph write $fileName -format $fmt
    image delete $ph
}

proc DrawCube {} {
    global gDemo

    glLoadIdentity
    glTranslatef 0.0 0.0 -5.0
    glRotatef $gDemo(xAngle) 1.0 0.0 0.0
    glRotatef $gDemo(yAngle) 0.0 1.0 0.0
    glRotatef $gDemo(zAngle) 0.0 0.0 1.0

    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
}

proc CallGluPerspective { fovX fovY near far } {
    set aspect [expr {$fovX / $fovY}]
    glLoadIdentity
    gluPerspective $fovY $aspect $near $far
}

proc CallFrustumPerspective { fovX fovY near far } {
    set aspect [expr {$fovX / $fovY}]
    set fovYRad [tcl3dDegToRad $fovY]
    set fovXRad [tcl3dDegToRad $fovX]

    set top    [expr {$near * tan(0.5 * $fovYRad) }]
    set bottom [expr { -1.0 * $top }]
    set left   [expr { $bottom * $aspect }]
    set right  [expr { $top * $aspect }]

    glLoadIdentity
    glFrustum $left $right $bottom $top $near $far
}

proc CallOSGPerspective { fovX fovY near far } {
    set aspect [expr {$fovX / $fovY}]
    set fovYRad [tcl3dDegToRad $fovY]

    set right  [expr {$near * $aspect * tan(0.5 * $fovYRad) }]
    set left   [expr { -1.0 * $right }]
    set top    [expr {$near * tan(0.5 * $fovYRad) }]
    set bottom [expr { -1.0 * $top }]

    glLoadIdentity
    glFrustum $left $right $bottom $top $near $far
}

proc CallPerspectiveWithOffset { fovX fovY near far winWidth winHeight subWidth subHeight offX offY } {
    set aspect [expr {$fovX / $fovY}]
    set fovY [tcl3dDegToRad $fovY]

    set nTanFovX [expr {$near * $aspect * tan($fovY * 0.5) }]
    set nTanFovY [expr {$near * tan($fovY * 0.5) }]

    set left  [expr {-1.0 * $nTanFovX * (1.0 - (2.0 * $offX / $winWidth))}]
    set right [expr {$nTanFovX * (((2.0 * ($offX + $subWidth)) / $winWidth) - 1.0)}]

    set bottom [expr {-1.0 * $nTanFovY * (1.0 - (2.0 * $offY / $winHeight))}]
    set top    [expr {$nTanFovY * (((2.0 * ($offY + $subHeight)) / $winHeight) - 1.0)}]

    glLoadIdentity
    glFrustum $left $right $bottom $top $near $far
}

# This procedure calls the C impementation of Tcl3D.
proc CallTcl3dPerspective { fovX fovY near far } {
    set aspect [expr {$fovX / $fovY}]
    set projMat [tcl3dVector GLfloat 16]
    tcl3dPerspective $fovY $aspect $near $far $projMat
    set projMatAsList [tcl3dVectorToList $projMat 16]
    glLoadMatrixf $projMatAsList
    $projMat delete
}

# This procedure calls the C impementation of Tcl3D.
proc CallTcl3dPerspectiveWithOffset { fovX fovY near far winWidth winHeight \
                                      subWidth subHeight offX offY } {
    set projMat [tcl3dVector GLfloat 16]
    tcl3dPerspectiveWithOffset $fovX $fovY $near $far $winWidth $winHeight \
                               $subWidth $subHeight $offX $offY $projMat
    set projMatAsList [tcl3dVectorToList $projMat 16]
    glLoadMatrixf $projMatAsList
    $projMat delete
}

proc CreateCallback { toglwin } {
    set ident [lindex [$toglwin configure -ident] end]
    # puts "CreateCallback $ident"

    glEnable GL_DEPTH_TEST
}

proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    global gDemo

    set ident [lindex [$toglwin configure -ident] end]
    # puts "ReshapeCallback $ident"

    set gDemo($ident,winWidth)  [$toglwin width]
    set gDemo($ident,winHeight) [$toglwin height]

    glViewport 0 0 $w $h

    glMatrixMode GL_PROJECTION
    switch -- $ident {
        "Native" {
            if { $gDemo(useTcl3dProcs) } {
                CallTcl3dPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
            } else {
                CallGluPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
            }
        }
        "Frustum" {
            CallFrustumPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
        }
        "OSG" {
            CallOSGPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
        }
        "Offset" {
            if { $gDemo(useTcl3dProcs) } {
                CallTcl3dPerspectiveWithOffset $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far) \
                                               $w $h $w $h 0 0
            } else {
                CallPerspectiveWithOffset $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far) \
                                          $w $h $w $h 0 0
            }
        }
        "Row" {
            ; # Do nothing in Reshape. Everything is done in DisplayCallback.
        }
    }
    if { $gDemo(printProjMat) } {
        set mat [tcl3dOglGetFloatState GL_PROJECTION_MATRIX 16]
        tcl3dMatListPrint $mat "Projection matrix $ident:"
    }

    glMatrixMode GL_MODELVIEW
}

proc DisplayCallback { toglwin } {
    global gDemo

    set ident [lindex [$toglwin configure -ident] end]
    # puts "DisplayCallback $ident"

    set w [$toglwin width]
    set h [$toglwin height]

    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]

    DrawCube

    if { $gDemo(saveImgs) } {
        set imgVec [tcl3dVector GLubyte [expr {$w * $h * 3}]]
        glReadPixels 0 0 $w $h $::GL_RGB $::GL_UNSIGNED_BYTE $imgVec
        SaveImg $ident $imgVec $w $h
        $imgVec delete
    }

    $toglwin swapbuffers
}

proc DisplayCallbackRow { toglwin } {
    global gDemo

    set ident [lindex [$toglwin configure -ident] end]
    # puts "DisplayCallback $ident"

    set w [$toglwin width]
    set h [$toglwin height]
    set iw $gDemo(Native,winWidth)
    set ih $gDemo(Native,winHeight)

    if { $gDemo(saveImgs) } {
        set imgVec [tcl3dVector GLubyte [expr $iw * $ih * 3]]
        set rowVec [tcl3dVector GLubyte [expr $w  * $h  * 3]]
    }

    for { set row 0 } { $row < $ih } { incr row $h } {
        glMatrixMode GL_PROJECTION
        CallPerspectiveWithOffset  \
            $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far) \
            $iw $ih $w $h 0 $row
        if { $gDemo(printProjMat) } {
            set mat [tcl3dOglGetFloatState GL_PROJECTION_MATRIX 16]
            tcl3dMatListPrint $mat "Projection matrix $ident:"
        }

        glMatrixMode GL_MODELVIEW
        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]

        DrawCube

        if { $gDemo(saveImgs) } {
            glReadPixels 0 0 $w $h $::GL_RGB $::GL_UNSIGNED_BYTE $rowVec
            set off [expr {$row * $w * 3}]
            tcl3dVectorCopy $rowVec [tcl3dVectorInd $imgVec GLubyte $off] $w $h 3
        }
    }

    if { $gDemo(saveImgs) } {
        SaveImg $ident $imgVec $iw $ih
        $imgVec delete
        $rowVec delete
    }
    $toglwin swapbuffers
}

proc Cleanup {} {
    global gDemo

    catch { unset gDemo }
}

# Put all exit related code here.
proc ExitProg {} {
    exit
}

proc CreateWindow {} {
    global gDemo

    wm title . "Tcl3D demo: Perspective Algorithms"

    # Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
    frame .fr
    pack .fr 

    set gDemo(togl,Native)  .fr.native
    set gDemo(togl,Frustum) .fr.frustum
    set gDemo(togl,OSG)     .fr.osg
    set gDemo(togl,Offset)  .fr.offset
    set gDemo(togl,Row)     .fr.row

    ttk::label .fr.l_native -text "Native gluPerspective"
    togl $gDemo(togl,Native) -ident "Native" \
         -width $gDemo(winWidth) -height $gDemo(winHeight) \
         -rgba true -double true -depth true \
         -createcommand  CreateCallback \
         -reshapecommand ReshapeCallback \
         -displaycommand DisplayCallback

    ttk::label .fr.l_frustum -text "Frustum gluPerspective"
    togl $gDemo(togl,Frustum) -ident "Frustum" \
         -width $gDemo(winWidth) -height $gDemo(winHeight) \
         -rgba true -double true -depth true \
         -createcommand  CreateCallback \
         -reshapecommand ReshapeCallback \
         -displaycommand DisplayCallback

    ttk::label .fr.l_osg -text "OSG gluPerspective"
    togl $gDemo(togl,OSG) -ident "OSG" \
         -width $gDemo(winWidth) -height $gDemo(winHeight) \
         -rgba true -double true -depth true \
         -createcommand  CreateCallback \
         -reshapecommand ReshapeCallback \
         -displaycommand DisplayCallback

    ttk::label .fr.l_offset -text "Perspective with offset"
    togl $gDemo(togl,Offset) -ident "Offset" \
         -width $gDemo(winWidth) -height $gDemo(winHeight) \
         -rgba true -double true -depth true \
         -createcommand  CreateCallback \
         -reshapecommand ReshapeCallback \
         -displaycommand DisplayCallback

    ttk::label .fr.l_row -text "Perspective with offset ($gDemo(numRows) rows)"
    togl $gDemo(togl,Row) -ident "Row" \
         -width $gDemo(winWidth) -height $gDemo(numRows) \
         -rgba true -double true -depth true \
         -createcommand  CreateCallback \
         -reshapecommand ReshapeCallback \
         -displaycommand DisplayCallbackRow

    ttk::checkbutton .fr.save -text "Save images" -variable gDemo(saveImgs)
    ttk::label .fr.info

    bind $gDemo(togl,Native)  <1> "SetMousePos %x %y"
    bind $gDemo(togl,Frustum) <1> "SetMousePos %x %y"
    bind $gDemo(togl,OSG)     <1> "SetMousePos %x %y"
    bind $gDemo(togl,Offset)  <1> "SetMousePos %x %y"
    bind $gDemo(togl,Row)     <1> "SetMousePos %x %y"

    bind $gDemo(togl,Native)  <B1-Motion> "MotionEvent %W %x %y"
    bind $gDemo(togl,Frustum) <B1-Motion> "MotionEvent %W %x %y"
    bind $gDemo(togl,OSG)     <B1-Motion> "MotionEvent %W %x %y"
    bind $gDemo(togl,Offset)  <B1-Motion> "MotionEvent %W %x %y"
    bind $gDemo(togl,Row)     <B1-Motion> "MotionEvent %W %x %y"

    bind . <Key-Escape> ExitProg

    grid .fr.l_native         -row 0 -column 0 -sticky news
    grid .fr.l_frustum        -row 0 -column 1 -sticky news
    grid $gDemo(togl,Native)  -row 1 -column 0 
    grid $gDemo(togl,Frustum) -row 1 -column 1 
    grid .fr.l_osg            -row 2 -column 0 -sticky news
    grid .fr.l_offset         -row 2 -column 1 -sticky news
    grid $gDemo(togl,OSG)     -row 3 -column 0
    grid $gDemo(togl,Offset)  -row 3 -column 1
    grid .fr.l_row            -row 4 -column 0 -sticky news -columnspan 2
    grid $gDemo(togl,Row)     -row 5 -column 0
    grid .fr.save             -row 6 -column 0 -sticky news -columnspan 2
    grid .fr.info             -row 7 -column 0 -sticky news -columnspan 2
    grid rowconfigure    .fr 7 -weight 1
    grid columnconfigure .fr 7 -weight 1
}


CreateWindow
PrintInfo [tcl3dOglGetInfoString]
