#!/bin/sh
# the next line restarts using wish \
exec wish8.4 "$0" "$@"

#************************************************************************
# Based on ogl_benchmark_sphere.tcl 
# as contained in Paul Obermeiers Tcl3D
#
#************************************************************************

package require Tk
package require Img
package require tcl3d 0.2

set g_WinWidth  640
set g_WinHeight 480

set g_LastMousePosX 0
set g_LastMousePosY 0

set g_fSpinX 0.0
set g_fSpinY 0.0

set aufloesung  11

proc bgerror { msg } {
    tk_messageBox -icon error -type ok -message "Error: $msg"
    exit
}

proc GetMouseInput { x y } {
    set nXDiff [expr ($x - $::g_LastMousePosX)]
    set nYDiff [expr ($y - $::g_LastMousePosY)]
        
    set ::g_fSpinX [expr $::g_fSpinX - $nXDiff]
    set ::g_fSpinY [expr $::g_fSpinY - $nYDiff]

    set ::g_LastMousePosX $x
    set ::g_LastMousePosY $y
    .fr.toglwin postredisplay
}



proc tclReshapeFunc { toglwin w h } {
    glViewport 0 0 $w $h
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45.0 [expr double($w)/double($h)] 0.1 100.0
}

proc tclCreateFunc { toglwin } {
    set haveSwapControl [tcl3dHaveExtension "WGL_EXT_swap_control"]
    if { $haveSwapControl } {
        wglSwapIntervalEXT 0
    }

    glEnable GL_TEXTURE_2D
    glEnable GL_DEPTH_TEST
    # Nur Kanten darstellen
    #        glPolygonMode GL_FRONT_AND_BACK GL_LINE

    # Flächen mit Bitmap darstellen  
    glPolygonMode GL_FRONT_AND_BACK GL_FILL

    glClearColor 0.0 0.0 0.0 1.0

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45.0 [expr double($::g_WinWidth)/double($::g_WinHeight)] 0.1 100.0

    # Load texture image.
    set bitmap gitter.png ;# worked_stone_8180226.JPG

    if [catch { image create photo -file $bitmap } phImg] {
        error "Error reading image mars.bmp ($phImg)"
    } else {
	# Erzeugt einen OpenGL Vector aus dem Image
        set w [image width  $phImg]
        set h [image height $phImg]
        set n [tcl3dPhotoChans $phImg]
        set pTextureImage [tcl3dVector GLubyte [expr $w * $h * $n]]
        tcl3dPhoto2Vector $phImg $pTextureImage
        image delete $phImg
    }

    set ::g_textureID [tcl3dVector GLuint 1]
    glGenTextures 1 $::g_textureID

    glBindTexture GL_TEXTURE_2D [$::g_textureID get 0]

    # Gibt Interpolation an
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR

    if { $n == 3 } {
        set type $::GL_RGB
    } else {
       set type $::GL_RGBA
    }
    glTexImage2D GL_TEXTURE_2D 0 $n $w $h 0 $type GL_UNSIGNED_BYTE $pTextureImage

    $pTextureImage delete


    # DisplayListe erzeugen
    set ::g_sphereDList [glGenLists 1]
    glNewList $::g_sphereDList GL_COMPILE

    # und mit Geometrie und Textur füllen
    renderSphere 0.0 0.0 0.0 1.5 $::aufloesung
    glEndList


}

# Create a sphere centered at cy, cx, cz with radius r, and 
# precision p. Based on a function Written by Paul Bourke. 
# http://astronomy.swin.edu.au/~pbourke/opengl/sphere/
proc renderSphere { cx cy cz r p } {
    set PI     3.14159265358979
    set TWOPI  6.28318530717958
    set PIDIV2 1.57079632679489

    set theta1 0.0
    set theta2 0.0
    set theta3 0.0

    set ex 0.0
    set ey 0.0
    set ez 0.0

    set px 0.0
    set py 0.0
    set pz 0.0

    # Disallow a negative number for radius.
    if { $r < 0 } {
        set r [expr -1.0 * $r]
    }

    # Disallow a negative number for precision.
    if { $p < 4 } {
        set p 4
    }

    # If the sphere is too small, just render a OpenGL point instead.
    if { $p < 4 || $r <= 0 } {
        glBegin GL_POINTS
        glVertex3f $cx $cy $cz
        glEnd
        return
    }

    set p2 [expr $p / 2]
    for {set i 0 } { $i < $p2 } { incr i } {
        set theta1 [expr {$i * $TWOPI / $p - $PIDIV2}]
        set theta2 [expr {($i + 1) * $TWOPI / $p - $PIDIV2}]

        glBegin GL_TRIANGLE_STRIP
        for {set j 0 } { $j <= $p } { incr j } {
            set theta3 [expr {$j * $TWOPI / $p}]

            set normalX [expr {cos($theta2) * cos($theta3)}]
            set normalY [expr {sin($theta2)}]
            set normalZ [expr {cos($theta2) * sin($theta3)}]
            set posX [expr {$cx + $r * $normalX}]
            set posY [expr {$cy + $r * $normalY}]
            set posZ [expr {$cz + $r * $normalZ}]

            glNormal3f $normalX $normalY $normalZ
            glTexCoord2f [expr {-1.0 * ($j/double($p))}] \
                         [expr { 2.0 * ($i+1)/double($p)}]
            glVertex3f $posX $posY $posZ

            set normalX [expr {cos($theta1) * cos($theta3)}]
            set normalY [expr {sin($theta1)}]
            set normalZ [expr {cos($theta1) * sin($theta3)}]
            set posX [expr {$cx + $r * $normalX}]
            set posY [expr {$cy + $r * $normalY}]
            set posZ [expr {$cz + $r * $normalZ}]

            glNormal3f $normalX $normalY $normalZ
            glTexCoord2f [expr {-1.0 * ($j/double($p))}] \
                         [expr { 2.0 * ($i/double($p))}]
            glVertex3f $posX $posY $posZ
        }
        glEnd
    }
}

proc CreateSphereDisplayList { toglwin } {

    set ::g_sphereDList [glGenLists 1]

    glNewList $::g_sphereDList GL_COMPILE
    renderSphere 0.0 0.0 0.0 1.5 $::aufloesung
    glEndList

    $toglwin postredisplay
}

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

    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0.0 0.0 -5.0
    glRotatef [expr -1.0*$::g_fSpinY] 1.0 0.0 0.0
    glRotatef [expr -1.0*$::g_fSpinX] 0.0 1.0 0.0

    # Render test sphere...
    glBindTexture GL_TEXTURE_2D [$::g_textureID get 0]
    glCallList $::g_sphereDList

     $toglwin swapbuffers
}

proc tclDisplayFunc { toglwin } {
    render $toglwin
}

frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width $g_WinWidth -height $g_WinHeight \
                 -double true -depth true \
                 -createproc tclCreateFunc \
                 -reshapeproc tclReshapeFunc \
                 -displayproc tclDisplayFunc 

grid .fr.toglwin -row 0 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
wm title . "Listing 4: Textur"

bind . <1> {set ::g_LastMousePosX %x; set ::g_LastMousePosY %y}
bind . <B1-Motion> "GetMouseInput %x %y"