# 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 -> tcl3dTogl
# Filename:       tcl3dFont.tcl
#
# Author:         Paul Obermeier
#
# Description:    Tcl script to select a font. The font is displayed in
#                 a Tk widget as well as in an OpenGL window.
#                 The font name in XLFD notation is
#                 shown in a text widget for copy/paste.
#                 This demo shows the usage of the "loadbitmapfont"
#                 command built into the Togl widget.
#                 Note: The Tk font might look nicer, because font 
#                 antialiasing is enabled. On Windows this can be toggled
#                 in the display property window (Appearance->Effects).

package require tcl3d

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

proc GetListboxEntry { wid type } {
    global gStyle

    set indList [$wid curselection]
    if { [llength $indList] > 0 } {
        set val [$wid get [lindex $indList 0]]
        set gStyle($type) $val
        ChangeFont
    }
}

proc UpdateXLFD {} {
    global gStyle glFont

    set weight $gStyle(weight)
    if { $gStyle(weight) eq "normal" } {
        set weight "medium"
    }
    set glFont \
        [format "-*-%s-%s-%s-*-*-%d-*-*-*-*-*-*-*" \
            $gStyle(family) \
            $weight \
            [string index $gStyle(slant) 0] \
            $gStyle(size)]
}

proc ChangeFont {} {
    global fontSpec
    global gStyle

    foreach foo [list family size weight underline slant overstrike] {
        if {[set gStyle($foo)] == ""} {
            return
        }
    }
    set fontSpec "-family \"$gStyle(family)\" -size [expr -1 * $gStyle(size)] "
    if { $gStyle(weight) ne "*" } {
        append fontSpec " -weight $gStyle(weight)"
    }
    if { $gStyle(slant) ne "*" } {
        append fontSpec " -slant $gStyle(slant)"
    }
    if { $gStyle(underline) ne "*" } {
        append fontSpec " -underline $gStyle(underline)"
    }
    if { $gStyle(overstrike) ne "*" } {
        append fontSpec " -overstrike $gStyle(overstrike)"
    }
    $::msgWid configure -font $fontSpec

    UpdateXLFD
    $::toglWid postredisplay
}

proc CreateCallback { toglwin } {
    glShadeModel GL_FLAT
    glClearColor 1.0 1.0 1.0 1.0
}

proc printString { str font } {
    set len [string length $str]
    if { $len > 0 } {
        glListBase $font
        set sa [tcl3dVectorFromString GLubyte $str]
        glCallLists $len GL_UNSIGNED_BYTE $sa
        $sa delete
    }
}

proc DisplayCallback { toglwin } {
    glClear GL_COLOR_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]

    glColor3f 0.0 0.0 0.0

    set y 1
    set retVal [catch { $toglwin loadbitmapfont $::glFont } fontBase]
    if { $retVal == 0 } {
        .fr.bfr.font configure -background "#A0FFA0"
        foreach str $::msgStr {
            glRasterPos2i 2 [expr [$toglwin height] - $y * ($::gStyle(size) + 2)]
            printString $str $fontBase
            incr y
        }
        $toglwin unloadbitmapfont $fontBase
    } else {
        .fr.bfr.font configure -background "#FFA0A0"
    }
    glFlush
    $toglwin swapbuffers
}

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

    glViewport 0 0 $w $h
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glOrtho 0.0 $w 0.0 $h -1.0 1.0
    glMatrixMode GL_MODELVIEW
}

# Default values
set sizeList   [list 8 9 10 12 13 14 15 16 18 20 24 28 32 36 40]
set familyList [lsort [font families]]

set gStyle(size)       [lindex $sizeList 3]
set gStyle(family)     [lindex $familyList 0]
set gStyle(slant)      roman
set gStyle(weight)     normal
set gStyle(overstrike) 0
set gStyle(underline)  0
UpdateXLFD

set msgStr [list \
            "ABCDEFGHIJKLMNOPQRSTUVWXYZ" \
            "abcdefghijklmnopqrstuvwxyz" \
            "0123456789~`!@#$%^&*()_-+=" \
            "ÄÖÜäöüß" \
            "{}[]:;\"'<>,.?/"]

wm title . "Tcl3D demo: Tk fonts vs. Togl fonts"

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

frame .fr.lfr -borderwidth 2 -relief groove
frame .fr.rfr -relief groove
frame .fr.bfr -bg green
grid .fr.lfr -row 0 -column 0 -sticky nw
grid .fr.rfr -row 0 -column 1 -sticky news
grid .fr.bfr -row 1 -column 0 -columnspan 2 -sticky ew
grid rowconfigure    .fr 0 -weight 1
grid columnconfigure .fr 1 -weight 1

frame .fr.lfr.fontfr
frame .fr.lfr.sizefr
frame .fr.lfr.stylefr
grid .fr.lfr.fontfr    -row 0 -column 0 -sticky nw
grid .fr.lfr.sizefr    -row 1 -column 0 -sticky nw
grid .fr.lfr.stylefr   -row 2 -column 0 -sticky nw

set msgWid .fr.rfr.msg
label .fr.rfr.msgWidTitle -text "Tk font"
label $msgWid -background white -justify left -anchor nw
$msgWid configure -text [join $msgStr "\n"]

set toglWid .fr.rfr.toglwin
label .fr.rfr.toglWidTitle -text "Togl font"
togl $toglWid -width 300 -height 100 -double true \
              -createcommand CreateCallback \
              -reshapecommand ReshapeCallback \
              -displaycommand DisplayCallback 

pack .fr.rfr.msgWidTitle
pack $msgWid -expand 1 -fill both
pack .fr.rfr.toglWidTitle
pack $toglWid -side top -expand 1 -fill both

set fontWid [tcl3dCreateScrolledListbox .fr.lfr.fontfr "Font Family" \
             -exportselection 0]
bind $fontWid <<ListboxSelect>> "GetListboxEntry $fontWid family"
foreach family $familyList {
    $fontWid insert end $family
}

set sizeWid [tcl3dCreateScrolledListbox .fr.lfr.sizefr "Font Size" \
             -height 5 -exportselection 0]
bind $sizeWid <<ListboxSelect>> "GetListboxEntry $sizeWid size"
foreach val $sizeList {
    $sizeWid insert end $val
}

checkbutton .fr.lfr.stylefr.bold -variable gStyle(weight) \
            -indicatoron false -onvalue bold -offvalue normal \
            -text "B" -width 2 -height 1 \
            -font {-weight bold -family Times -size 10} \
            -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
            -command ChangeFont
pack .fr.lfr.stylefr.bold -side left

checkbutton .fr.lfr.stylefr.italic -variable gStyle(slant) \
            -indicatoron false -onvalue italic -offvalue roman \
            -text "I" -width 2 -height 1 \
            -font {-slant italic -family Times -size 10} \
            -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
            -command ChangeFont
pack .fr.lfr.stylefr.italic -side left

checkbutton .fr.lfr.stylefr.underline -variable gStyle(underline) \
            -indicatoron false -onvalue 1 -offvalue 0 \
            -text "U" -width 2 -height 1 \
            -font {-underline 1 -family Times -size 10} \
            -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
            -command ChangeFont
pack .fr.lfr.stylefr.underline -side left

checkbutton .fr.lfr.stylefr.overstrike -variable gStyle(overstrike) \
            -indicatoron false -onvalue 1 -offvalue 0 \
            -text "O" -width 2 -height 1 \
            -font {-overstrike 1 -family Times -size 10} \
            -highlightthickness 1 -padx 0 -pady 0 -borderwidth 1 \
            -command ChangeFont
pack .fr.lfr.stylefr.overstrike -side left

entry .fr.bfr.font -textvariable ::glFont -justify center
label .fr.bfr.note -text "Note: Underline and overstrike not yet supported in Togl canvas."
pack .fr.bfr.font .fr.bfr.note -expand 1 -fill x

$fontWid selection set 0
$sizeWid selection set 3
ChangeFont

bind . <Key-Escape> "exit"
