OUTPUT BUFFER:
# Copyright: 2005-2010 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 0.3 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 } { glListBase $font set len [string length $str] 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 green 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 red } glFlush } 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 frame .fr.lfr.infofr 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 grid .fr.lfr.infofr -row 3 -column 0 -sticky news set msgWid .fr.rfr.msg label .fr.rfr.msgWidTitle -text "Tk canvas" 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 canvas" togl $toglWid -width 300 -height 100 -double false \ -createproc CreateCallback \ -reshapeproc ReshapeCallback \ -displayproc 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 <