Demo 2 of 5 in category tcl3dTogl
 |
# Copyright: 2005-2022 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"
|
