Demo 5 of 5 in category tcl3dTogl
 |
# Copyright: 2006-2024 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: tcl3dToglFonts.tcl
#
# Author: Paul Obermeier
#
# Description: Program demonstrating and testing the different
# possibilities of specifing a bitmap font for the
# Togl widget.
package require tcl3d
# Font to be used in the Tk listbox.
set listFont {-family {Courier} -size 10}
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
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 print { toglwin str } {
global gPos
glColor3fv [tcl3dName2rgbf "black"]
set retVal [catch {eval $toglwin $str} fontBase]
if { $retVal != 0 } {
# If a font could not be allocated, we load the default font
# append the error message and print the string in red.
append str " ($fontBase)"
set fontBase [$toglwin loadbitmapfont]
glColor3fv [tcl3dName2rgbf "red"]
}
glRasterPos2i $gPos(x) $gPos(y)
printString $str $fontBase
$toglwin unloadbitmapfont $fontBase
incr gPos(y) -25
}
proc DisplayCallback { toglwin } {
global gPos
set gPos(x) 2
set gPos(y) [expr [$toglwin height] - 20]
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]
print $toglwin "loadbitmapfont"
print $toglwin "loadbitmapfont -family courier"
print $toglwin "loadbitmapfont -family times"
print $toglwin "loadbitmapfont -family fixed -size 12 -weight medium -slant regular"
print $toglwin "loadbitmapfont -family fixed -size 12 -weight bold -slant italic"
print $toglwin "loadbitmapfont -slant xyz"
print $toglwin "loadbitmapfont -weight xyz"
print $toglwin "loadbitmapfont -size 20"
print $toglwin "loadbitmapfont -size 20 -weight bold"
print $toglwin "loadbitmapfont -size 20 -slant italic"
print $toglwin "loadbitmapfont -*-courier-bold-r-*-*-10-*-*-*-*-*-*-*"
print $toglwin "loadbitmapfont -family 8x13"
print $toglwin "loadbitmapfont 8x13"
print $toglwin "loadbitmapfont -family a-b"
print $toglwin "loadbitmapfont a-b"
print $toglwin "loadbitmapfont -family"
print $toglwin "loadbitmapfont -family -weight -slant"
print $toglwin "loadbitmapfont -unknownoption"
print $toglwin "loadbitmapfont -unknownoption unknownfont"
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
}
# Create the OpenGL window and some Tk helper widgets.
frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width 600 -height 500 \
-double true -depth false \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
listbox .fr.usage -font $::listFont -height 1
label .fr.info
grid .fr.toglwin -row 0 -column 0 -sticky news
grid .fr.usage -row 1 -column 0 -sticky news
grid .fr.info -row 2 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
wm title . "Tcl3D demo: Togl bitmap font specification examples"
# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "exit"
bind . <Key-Escape> "exit"
.fr.usage insert end "Key-Escape Exit"
.fr.usage configure -state disabled
.fr.info configure -text [tcl3dOglGetInfoString]
|
