# Copyright:      2005-2025 Paul Obermeier (obermeier@tcl3d.org)
#
#                 See the file "Tcl3D_License.txt" for information on 
#                 usage and redistribution of this file, and for a
#                 DISCLAIMER OF ALL WARRANTIES.
#
# Module:         Tcl3D
# Filename:       tcl3dInfo.tcl
#
# Author:         Paul Obermeier
#
# Description:    Tcl script to display OpenGL related information.
#                 When called without arguments, a window is opened with
#                 buttons to display OpenGL information for the following
#                 categories: 
#                 - General information                           (-info)
#                 - Available OpenGL commands in Tcl              (-cmd)
#                 - Available OpenGL enumerations in Tcl          (-enum)
#
#                 The information texts can also be printed to stdout
#                 whithout opening a GUI, if calling this Tcl script
#                 with any of the above listed command line options.
#                 To display all four categories, the option "-all"
#                 can be used.
#
#                 Note: To retrieve all necessary information, an OpenGL
#                       context has to be established. So the batch mode
#                       needs a DISPLAY, too.

proc InitPackages { args } {
    global gPo

    foreach pkg $args {
        set retVal [catch {package require $pkg} gPo(ext,$pkg,version)]
        set gPo(ext,$pkg,avail) [expr !$retVal]
    }
}

package require tcl3dogl
set gVectorTypes(base) [info commands new_*]

InitPackages tcl3d

set gVectorTypes(all) [info commands new_*]

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

proc GetPackageInfo {} {
    global gPo

    set msgList {}
    foreach name [lsort [array names gPo "ext,*,avail"]] {
        set pkg [lindex [split $name ","] 1]
        lappend msgList [list $pkg $gPo(ext,$pkg,avail) $gPo(ext,$pkg,version)]
    }
    return $msgList
}

proc AddMenuCmd { menu label acc cmd args } {
    eval {$menu add command -label $label -accelerator $acc -command $cmd} $args
}
 
proc AddMenuRadio { menu label acc var val cmd args } {
    eval {$menu add radiobutton -label $label -accelerator $acc \
                                -variable $var -value $val -command $cmd} $args
}

proc AddMenuCheck { menu label acc var cmd args } {
    eval {$menu add checkbutton -label $label -accelerator $acc \
                                -variable $var -command $cmd} $args
}

proc ShowMainWin {title} {
    global gTextId
    global gToglWin

    # Create the windows title.
    wm title . $title

    if { [tcl3dHaveAqua] } {
        set btnRelief flat
    } else {
        set btnRelief solid
    }

    frame .fr -relief sunken -borderwidth 1
    pack .fr -side top -fill both -expand 1

    frame .fr.catfr  -relief raised -borderwidth 1
    frame .fr.resfr  -relief raised -borderwidth 1
    frame .fr.infofr -relief sunken -borderwidth 1

    grid .fr.catfr  -row 0 -column 0 -sticky nwe -ipadx 2
    grid .fr.resfr  -row 0 -column 1 -sticky nwse -ipadx 2 
    grid .fr.infofr -row 1 -column 0 -sticky nwse -columnspan 2
    grid rowconfigure .fr 0 -weight 1
    grid columnconfigure .fr 1 -weight 1

    # Create menus File and Help
    set hMenu .fr.menufr
    menu $hMenu -borderwidth 2 -relief sunken
    $hMenu add cascade -menu $hMenu.file -label "File" -underline 0
    $hMenu add cascade -menu $hMenu.help -label "Help" -underline 0

    set fileMenu $hMenu.file
    menu $fileMenu -tearoff 0
    AddMenuCmd $fileMenu "Save As ..."   "Ctrl+S" SaveAs
    if { $::tcl_platform(os) ne "Darwin" } {
        AddMenuCmd $fileMenu "Quit" "Ctrl+Q" ExitProg
    }
    bind . <Control-s> SaveAs
    bind . <Control-q> ExitProg
    bind . <Escape>    ExitProg
    wm protocol . WM_DELETE_WINDOW "ExitProg"

    set helpMenu $hMenu.help
    menu $helpMenu -tearoff 0
    AddMenuCmd $helpMenu "About $::appName ..." ""  HelpAbout

    . configure -menu $hMenu
    
    set gTextId \
        [tcl3dCreateScrolledText .fr.resfr "Result window" \
         -bg white -wrap word]

    label .fr.infofr.label -textvariable ::gCmdArgs -anchor nw
    pack  .fr.infofr.label -fill x -in .fr.infofr

    set catFr .fr.catfr

    set row 0
    set curFr $catFr.fr$row
    frame $curFr
    grid $curFr -row $row -column 0 -sticky news
    togl $curFr.togl -width 1 -height 1
    pack $curFr.togl
    set gToglWin $curFr.togl

    incr row
    set curFr $catFr.fr$row
    frame $curFr -relief groove
    grid  $curFr -row $row -column 0 -sticky news
    checkbutton $curFr.save -variable ::optInfo \
                -text "General Tcl3D information" -anchor w -bg gray

    set ::gInitButton $curFr.bVers
    radiobutton $curFr.bPkg  -text "Tcl packages"  -command PkgInfo \
                -anchor w -relief $btnRelief -value $row.0 \
                -indicatoron [tcl3dShowIndicator]
    radiobutton $curFr.bVers -text "GL versions"   -command GLInfo \
                -anchor w -relief $btnRelief -value $row.1 \
                -indicatoron [tcl3dShowIndicator]
    radiobutton $curFr.bExt  -text "GL extensions" -command GLExtInfo \
                -anchor w -relief $btnRelief -value $row.2 \
                -indicatoron [tcl3dShowIndicator]
    radiobutton $curFr.bVec -text "Vector types" -command VectorInfo \
                -anchor w -relief $btnRelief -value $row.3 \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.save  -side top -expand 1 -fill both
    pack $curFr.bPkg  -side top -expand 1 -fill x
    pack $curFr.bVers -side top -expand 1 -fill x
    pack $curFr.bExt  -side top -expand 1 -fill x
    pack $curFr.bVec  -side top -expand 1 -fill x

    incr row
    set curFr $catFr.fr$row
    frame $curFr -relief groove
    grid  $curFr -row $row -column 0 -sticky news
    checkbutton $curFr.save -variable ::optCmd \
                -text "Tcl3D commands" -bg gray -anchor w
    pack $curFr.save -side top -expand 1 -fill both

    set num 0
    radiobutton $curFr.bglCmds  -text "GL commands" -command _GLCmdInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bglCmds -side top -expand 1 -fill x

    incr num
    radiobutton $curFr.bgluCmds -text "GLU commands" -command _GLUCmdInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bgluCmds -side top -expand 1 -fill x

    incr num
    radiobutton $curFr.bsdlCmds  -text "SDL commands" -command _SDLCmdInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bsdlCmds -side top -expand 1 -fill x

    incr num
    radiobutton $curFr.bftglCmds  -text "FTGL commands" -command _FTGLCmdInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bftglCmds -side top -expand 1 -fill x

    incr row
    set curFr $catFr.fr$row
    frame $curFr -relief groove
    grid  $curFr -row $row -column 0 -sticky news
    checkbutton $curFr.save -variable ::optEnum \
                -text "Tcl3D enumerations" -anchor w -bg gray
    pack $curFr.save -side top -expand 1 -fill both

    set num 0
    radiobutton $curFr.bglEnums  -text "GL enums" -command _GLEnumInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bglEnums -side top -expand 1 -fill x 

    incr num
    radiobutton $curFr.bgluEnums -text "GLU enums" -command _GLUEnumInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bgluEnums -side top -expand 1 -fill x

    incr num
    radiobutton $curFr.bsdlEnums  -text "SDL enums" -command _SDLEnumInfo \
                -anchor w -relief $btnRelief -value $row.$num \
                -indicatoron [tcl3dShowIndicator]
    pack $curFr.bsdlEnums -side top -expand 1 -fill x

    bind . <Configure> RemapLabelSize
    set ::initDir [pwd]
    wm title . $title
}

proc RemapLabelSize {} {
    set xsize [winfo width .fr.infofr.label]
    .fr.infofr.label configure -wraplength $xsize
}

proc SaveAs {} {
    set fileTypes {
        {{Text}      {.txt}}
        {{All files} *}
    }
    set initFile [format "OS_%s_GL_%s.txt" \
                  $::tcl_platform(platform) \
                  [glGetString GL_VERSION]]
    set fileName [tk_getSaveFile -filetypes $fileTypes \
                  -initialfile $initFile -initialdir $::initDir]
    if { $fileName != "" } {
        set ::initDir [file dirname $fileName]
        PrintInfoToFile $fileName $::optInfo $::optCmd $::optEnum
    }
}

proc Cleanup {} {
    uplevel #0 unset gPo
    uplevel #0 unset gVectorTypes
}

proc ExitProg {} {
    exit
}

proc HelpAbout {} {
   tk_messageBox \
       -title "Tcl3D information viewer." \
       -message "tcl3dInfo Version 1.0.2.\nCopyright 2005-2025 Paul Obermeier." \
       -type ok -icon info
}

proc drawTitle { tw titleStr } {
    global gLastKeys gTextId

    if { ! [info exists gLastKeys($tw)] } {
        set gLastKeys($tw) ""
    }
    tcl3dSetScrolledTitle $gTextId "$titleStr : <$gLastKeys($tw)>"
}

proc SearchIndexList { tw titleStr textWidget key sym } {
    global gLastKeys

    if { ! [info exists gLastKeys($tw)] } {
        set gLastKeys($tw) ""
    }

    set lkey [string tolower $key]
    if { $sym eq "BackSpace" } {
        set gLastKeys($tw) [string range $gLastKeys($tw) 0 end-1]
    } else {
        if { $sym ne "Return" } {
            append gLastKeys($tw) $lkey
        }
    }
    scan [$textWidget index end] %d noLines
    set keyLen [string length $gLastKeys($tw)]
    drawTitle $tw $titleStr
    for { set i 1 } { $i < $noLines } { incr i } {
        if { [string compare $gLastKeys($tw) \
             [string tolower [$textWidget get $i.0 $i.$keyLen]]] == 0 } {
            $textWidget see $i.0
            $textWidget mark set insert $i.0
            break
        }
    }
}

proc GetCmdArgs { textWidget x y } {
    global gCmdArgs

    set ind [$textWidget index @$x,$y]
    set line [lindex [split $ind "."] 0]
    set cmd [string trim [$textWidget get $line.0 $line.end]]

    set ind [lsearch -exact [tcl3dOglGetFuncList] $cmd]
    if { $ind >= 0 } {
        set vers [tcl3dOglGetFuncVersion $cmd]
        set sig  [tcl3dOglGetFuncSignature $cmd]
        set gCmdArgs "$vers: $sig"
    } else {
        set retVal [catch {eval $cmd} errMsg]
        set existStr ""
        set helpStr  ""
        if { $retVal == 0 } {
            set existStr "No parameters"
        } else {
            set startInd [string first $cmd $errMsg]
            set endInd [expr [string last "argument" $errMsg] -1]
            if { $endInd < 0 } {
                set endInd end
            }
            set helpStr [string trim [string range $errMsg $startInd $endInd] " \""]
        }
        set gCmdArgs "$existStr $helpStr"
    }
}

proc PkgInfo {} {
    global gTextId

    $gTextId configure -state normal
    $gTextId delete 1.0 end
    foreach pkgInfo [GetPackageInfo] {
        set msgStr "Package [lindex $pkgInfo 0]: [lindex $pkgInfo 2]\n"
        if { [lindex $pkgInfo 1] == 1} {
            set tag avail
        } else {
            set tag unavail
        }
        $gTextId insert end $msgStr $tag
        if { [string compare [lindex $pkgInfo 0] "tcl3d"] == 0 } {
            if { [info procs tcl3dGetPackageInfo] ne "" } {
                foreach tcl3dInfo [tcl3dGetPackageInfo] {
                    set libVer [lindex $tcl3dInfo 3]
                    set msgStr "\tPackage [lindex $tcl3dInfo 0]: [lindex $tcl3dInfo 2]"
                    if { $libVer ne "" } {
                        append msgStr " ($libVer)\n"
                    } else {
                        append msgStr "\n"
                    }
                    if { [lindex $tcl3dInfo 1] == 1} {
                        set tag avail
                    } else {
                        set tag unavail
                    }
                    $gTextId insert end $msgStr $tag
                }
            }
        }
    }
    $gTextId tag configure avail   -background lightgreen
    $gTextId tag configure unavail -background red
    $gTextId configure -state disabled
    tcl3dSetScrolledTitle $gTextId "Tcl packages"
    bind $gTextId <1> {}
}

proc GLInfo {} {
    global gTextId
    global gToglWin

    $gTextId configure -state normal
    $gTextId delete 1.0 end
    foreach glInfo [tcl3dOglGetVersions $gToglWin] {
        set msgStr "[lindex $glInfo 0]: [lindex $glInfo 1]\n"
        $gTextId insert end $msgStr avail
    }
    $gTextId tag configure avail -background lightgreen
    $gTextId configure -state disabled
    tcl3dSetScrolledTitle $gTextId "OpenGL versions"
    bind $gTextId <1> {}
}

proc GetExtList {} {
    global gToglWin

    return [lsort -dictionary -unique [tcl3dOglGetExtensions $gToglWin "all"]]
}

proc GLExtInfo {} {
    global gTextId

    set tw GLExtInfoWin
    $gTextId configure -state normal
    $gTextId delete 1.0 end

    foreach ext [GetExtList] {
        set msgStr "$ext\n"
        $gTextId insert end $msgStr name
    }
    set numExt [llength [GetExtList]]
    $gTextId tag configure name -background lightgreen
    $gTextId configure -state disabled
    set titleStr "OpenGL Extensions ($numExt extensions)"
    drawTitle $tw $titleStr

    bind $gTextId <KeyPress> "SearchIndexList $tw [list $titleStr] $gTextId %A %K"
    bind $gTextId <1> {}
    focus $gTextId
}

proc VectorInfo {} {
    global gTextId
    global gVectorTypes

    set tw VectorInfoWin
    $gTextId configure -state normal
    $gTextId delete 1.0 end

    set numBaseTypes [llength $gVectorTypes(base)]
    set numAllTypes  [llength $gVectorTypes(all)]
    set msgStr "Base types with tcl3dVector support: ($numBaseTypes types)\n"
    $gTextId insert end $msgStr header
    foreach objCmd [lsort $gVectorTypes(base)] {
        scan $objCmd "new_%s" type
        $gTextId insert end "$type \n" name
    }
    set msgStr "All types with tcl3dVector support: ($numAllTypes types)\n"
    $gTextId insert end $msgStr header
    foreach objCmd [lsort $gVectorTypes(all)] {
        scan $objCmd "new_%s" type
        $gTextId insert end "$type \n" name
    }
    $gTextId tag configure header -background gray
    $gTextId tag configure name   -background lightgreen
    $gTextId configure -state disabled
    set titleStr "Types with tcl3dVector support"
    drawTitle $tw $titleStr

    bind $gTextId <KeyPress> "SearchIndexList $tw [list $titleStr] $gTextId %A %K"
    bind $gTextId <1> {}
    focus $gTextId
}

proc _CmdInfo { cmdList title cmdWin } {
    global gTextId

    set tw InfoWin_$cmdWin
    $gTextId configure -state normal
    $gTextId delete 1.0 end

    set numCmds 0
    foreach cmd [lsort $cmdList] {
        set tag avail
        if { ! [tcl3dOglHaveFunc $cmd] } {
            set tag unavail
        }
        set msgStr "$cmd\n"
        $gTextId insert end $msgStr $tag
        incr numCmds
    }
    $gTextId tag configure avail   -background lightgreen
    $gTextId tag configure unavail -background red
    $gTextId configure -state disabled
    set titleStr "$title ($numCmds commands)"
    drawTitle $tw $titleStr

    bind $gTextId <KeyPress> "SearchIndexList $tw [list $titleStr] $gTextId %A %K"
    bind $gTextId <1> "GetCmdArgs $gTextId %x %y"
    focus $gTextId
}

proc _EnumInfo { enumList title enumWin } {
    global gTextId

    set tw InfoWin_$enumWin
    $gTextId configure -state normal
    $gTextId delete 1.0 end

    set numEnums 0
    foreach cmd [lsort $enumList] {
        set cmdStr [format "::%s" $cmd]
        set msgStr "$cmd [set $cmdStr]\n"
        $gTextId insert end $msgStr
        incr numEnums
    }
    $gTextId configure -state disabled
    set titleStr "$title ($numEnums enumerations)"
    drawTitle $tw $titleStr

    bind $gTextId <KeyPress> "SearchIndexList $tw [list $titleStr] $gTextId %A %K"
    bind $gTextId <1> {}
    focus $gTextId
}

proc _GLCmdInfo {} {
    _CmdInfo $::glCmds "OpenGL core commands" "glCmds"
}

proc _GLUCmdInfo {} {
    _CmdInfo $::gluCmds "OpenGL utility commands" "gluCmds"
}

proc _SDLCmdInfo {} {
    _CmdInfo [info commands SDL_*] "SDL library commands" "sdlCmds"
}

proc _FTGLCmdInfo {} {
    _CmdInfo [info commands FT*] "FTGL library commands" "ftglCmds"
}


proc _GLEnumInfo {} {
    _EnumInfo [info globals GL_*] "OpenGL core enums" "glEnum"
}

proc _GLUEnumInfo {} {
    _EnumInfo [info globals GLU_*] "OpenGL utility enums" "gluEnum"
}

proc _SDLEnumInfo {} {
    _EnumInfo [info globals SDL_*] "SDL enums" "sdlEnum"
}

proc CmdPrint { cmdList title fp } {
    puts $fp [format "----%s:\n" $title]
    set numCmds 0
    foreach cmd [lsort $cmdList] {
        set msgStr "$cmd"
        puts $fp $msgStr
        incr numCmds
    }
    puts $fp [format "Number of %s: %d\n\n" $title $numCmds]
    flush $fp
}

proc EnumPrint { enumList title fp } {
    puts $fp [format "----%s:\n" $title]
    set numEnums 0
    foreach cmd [lsort $enumList] {
        set cmdStr [format "::%s" $cmd]
        set msgStr "$cmd [set $cmdStr]"
        puts $fp $msgStr
        incr numEnums
    }
    puts $fp [format "Number of %s: %d\n\n" $title $numEnums]
    flush $fp
}

proc PrintInfoToFile { {fileName "glInfo.txt"} {inf 1} {cmd 1} {enum 1} } {
    set fp [open $fileName "w"]
    PrintInfo $fp $inf $cmd $enum
    close $fp
}

proc PrintInfo { {fp stdout} {inf 1} {cmd 1} {enum 1} } {
    global gVectorTypes
    global gToglWin

    if { $inf } {
        puts $fp "----Package information:\n"
        foreach pkgInfo [GetPackageInfo] {
            if { [lindex $pkgInfo 1] == 1} {
                set msgStr "[lindex $pkgInfo 0]: [lindex $pkgInfo 2]"
                puts $fp $msgStr
            }
            if { [string compare [lindex $pkgInfo 0] "tcl3d"] == 0 } {
                if { [info procs tcl3dGetPackageInfo] ne "" } {
                    foreach tcl3dInfo [tcl3dGetPackageInfo] {
                        if { [lindex $tcl3dInfo 1] == 1} {
                            set libVer [lindex $tcl3dInfo 3]
                            set msgStr "\t[lindex $tcl3dInfo 0]: [lindex $tcl3dInfo 2]"
                            if { $libVer ne "" } {
                                append msgStr " ($libVer)"
                            }
                            puts $fp $msgStr
                        }
                    }
                }
            }
        }
        puts $fp "\n"
        flush $fp

        puts $fp "----OpenGL version information:\n"
        foreach glInfo [tcl3dOglGetVersions $gToglWin] {
            set msgStr "[lindex $glInfo 0]: [lindex $glInfo 1]"
            puts $fp $msgStr
        }
        puts $fp "\n"
        flush $fp

        puts $fp "----OpenGL extensions:\n"
        set count 0
        foreach ext [GetExtList] {
            set msgStr "$ext"
            puts $fp $msgStr
        }
        set count [llength [GetExtList]]
        puts $fp "Number of OpenGL extensions: $count\n\n"
        flush $fp

        puts $fp "----Vector types:\n"
        foreach objCmd [lsort $gVectorTypes(all)] {
            scan $objCmd "new_%s" type
            puts $fp "$type : $objCmd"
        }
        puts $fp "Number of vector types: [llength $gVectorTypes(all)]\n\n"
        flush $fp
    }

    if { $cmd } {
        CmdPrint $::glCmds  "OpenGL core commands"    $fp
        CmdPrint $::gluCmds "OpenGL utility commands" $fp
        if { $::tcl_platform(platform) == "windows" } {
            CmdPrint [info commands wgl*] "OpenGL windows specific commands" $fp
        }
        CmdPrint [info commands SDL_*] "SDL commands"        $fp
        CmdPrint [info commands FTGL*] "FTGL commands"       $fp
    }

    if { $enum } {
        EnumPrint [info globals GL_*]  "OpenGL core enums"    $fp
        EnumPrint [info globals GLU_*] "OpenGL utility enums" $fp
        EnumPrint [info globals SDL_*] "SDL enums" $fp
    }
}

set appName "tcl3dInfo"
set optInfo  0
set optCmd   0
set optEnum  0

set glCmds  [tcl3dOglGetFuncList]
set gluCmds [list]
foreach cmd [info commands glu*] {
    lappend gluCmds $cmd
}
foreach cmd [info commands glm*] {
    lappend gluCmds $cmd
}

ShowMainWin "$appName: Tcl3D Information"
$::gInitButton invoke

if { $argc > 0 } {
    set i 0
    while { $i < $argc } {
        set arg [lindex $argv $i]
        if { [string compare $arg "--info"] == 0 } {
            set optInfo 1
        } elseif { [string compare $arg "--cmd"] == 0 } {
            set optCmd 1
        } elseif { [string compare $arg "--enum"] == 0 } {
            set optEnum 1
        } elseif { [string compare $arg "--all"] == 0 } {
            set optInfo  1
            set optCmd   1
            set optEnum  1
        } else {
            puts "Ignoring unknown option: $arg"
        }
        incr i
    }
    PrintInfo stdout $optInfo $optCmd $optEnum
    exit 0
}
