Subversion Repositories or1k

#!/bin/sh
# ----------------------------------------------------------------------
#  PROGRAM: demo program for [incr Widgets]
# ----------------------------------------------------------------------
#  Michael J. McLennan
#  Bell Labs Innovations for Lucent Technologies
#  mmclennan@lucent.com
#  http://www.tcltk.com/itcl/
# ======================================================================
#  Copyright (c) 1993-1998  Lucent Technologies, Inc.
# ======================================================================
#\
exec itkwish3.0 "$0"

package require Iwidgets 3.0

# everything else is executed by itkwish...
# ----------------------------------------------------------------------
option add *Scrolledtext.textBackground white startupFile
option add *Scrolledlistbox.textBackground white startupFile
option add *Scrolledhtml.textBackground white startupFile
option add *Scrolledhtml.padX 10 startupFile
option add *boxColor blue startupFile
option add *boxTextColor white startupFile

# ----------------------------------------------------------------------
# USAGE:  iw_demo_file <name>
#
# Returns the proper demo file name for a demo called <name>.
# ----------------------------------------------------------------------
proc iw_demo_file {name} {
    global iwidgets::library
    return [file join $library demos $name]
}

# ----------------------------------------------------------------------
# USAGE:  iw_demo_manpage <name>
#
# Returns the proper man page file for a demo called <name>.
# ----------------------------------------------------------------------
proc iw_demo_manpage {name} {
    global iwidgets::library
    return [file join $library demos html $name.n.html]
}

# ----------------------------------------------------------------------
# USAGE:  iw_load_demo <name>
#
# Loads a demo program with the given <name>.  Demos can be written
# as if they will pop up in the main application window, but they will
# pop up inside the tab notebook instead.
# ----------------------------------------------------------------------
proc iw_load_demo {name} {
    global widgets

    catch {eval destroy [winfo children $widgets(info-example)]}
    iw_lock on
    iw_status "Loading..."

    set win [frame $widgets(info-example).inner]
    pack $win -expand yes

    set loadcmd {
        set fid [open [iw_demo_file $name] r]
        set code [read $fid]
        close $fid
    }
    if {[catch $loadcmd result] == 0} {
        regsub -all "(\"|\{|\\\[| |\n|^)((\\.\[A-Za-z0-9\]+)+)" \
            $code "\\1$win\\2" code
        regsub -all "(\"|\{|\\\[| |\n|^)(\\. )" \
            $code "\\1$win " code
        if {[catch {uplevel #0 $code} result] == 0} {
            $widgets(info-code) clear
            $widgets(info-code) import [iw_demo_file $name]
            iw_draw_hier $name
            iw_load_manpage $name
            iw_lock off
            iw_status ""
            return
        }
    }
    catch {eval destroy [winfo children $win]}
    label $win.err -background white -wraplength 4i \
        -text "Can't load demo:\n$result"
    pack $win.err -expand yes
    iw_lock off
    iw_status ""
}

# overload a few critical functions that might be used by demo programs...
rename exit tcl_exit
proc exit {{status 0}} {
    # do nothing
}

rename puts tcl_puts
proc puts {args} {
    global widgets
    if {[llength $args] == 1} {
        iw_status [lindex $args 0]
    } else {
        eval tcl_puts $args
    }
}

# ----------------------------------------------------------------------
# USAGE:  iw_load_manpage
#
# Loads the man page for the current demo.  Man pages are not
# automatically loaded unless the man page viewer is visible.
# This procedure checks to see if the viewer is visible, and loads
# the man page if needed.
# ----------------------------------------------------------------------
set iwManPage ""
proc iw_load_manpage {{name ""}} {
    global widgets iwManPage

    if {[winfo ismapped $widgets(info-manpage)]} {
        if {$name == ""} {
            set name [$widgets(list) getcurselection]
        }
        if {$name != $iwManPage} {
            iw_lock on
            iw_status "Loading man page..."
            $widgets(info-manpage) import [iw_demo_manpage $name]
            iw_lock off
            iw_status ""
        }
        set iwManPage $name
    }
}

# ----------------------------------------------------------------------
# USAGE:  iw_manpage_progress
#
# Handles the progress meter whenever an HTML man page is rendered.
# If the progress meter is not showing, it is put up, and the current
# state is updated.  If the meter is at 100%, it is taken down.
# ----------------------------------------------------------------------
proc iw_manpage_progress {n max} {
    global widgets

    if {$n == $max} {
        place forget $widgets(info-manpage-feedback)
    } else {
        if {![winfo ismapped $widgets(info-manpage-feedback)]} {
            $widgets(info-manpage-feedback) configure -steps $max
            $widgets(info-manpage-feedback) reset
            place $widgets(info-manpage-feedback) -relx 0.5 -rely 0.5 -anchor c
            update
        }
        $widgets(info-manpage-feedback) step
    }
}

# ----------------------------------------------------------------------
# USAGE:  iw_status <message>
#
# Displays a status <message> near the top of the window.
# ----------------------------------------------------------------------
proc iw_status {message} {
    global widgets
    $widgets(status) configure -text $message
    update
}

# ----------------------------------------------------------------------
# USAGE:  iw_lock <state>
#
# Locks or unlocks the main window.  Sets a grab on the main menu,
# so that all events are sent to it.
# ----------------------------------------------------------------------
proc iw_lock {state} {
    global widgets
    if {$state} {
        grab set $widgets(mainMenu)
        . configure -cursor watch
    } else {
        grab release $widgets(mainMenu)
        . configure -cursor ""
    }
}

# ----------------------------------------------------------------------
# USAGE:  iw_draw_hier <name>
#
# Queries the hierarchy for a particular class in demo <name> and
# draws a class diagram into a display window.  Usually invoked when
# a demo is loaded to display the class hierarchy for the associated
# widget.
# ----------------------------------------------------------------------
proc iw_draw_hier {name} {
    global widgets
    set canv $widgets(info-hier)
    $canv delete all

    set class [string toupper [string index $name 0]][string tolower [string range $name 1 end]]

    if {[catch {namespace eval $class {info inherit}}] == 0} {
        iw_draw_level $canv $class
        set bbox [$canv bbox all]
        $canv move all [lindex $bbox 0] [lindex $bbox 1]
        update idletasks
        $canv xview moveto 0
        $canv yview moveto 0
    }
}

# ----------------------------------------------------------------------
# USAGE:  iw_draw_level <canv> <class>
#
# Draws one level of the hierarchy for <class>.
# ----------------------------------------------------------------------
proc iw_draw_level {canv class} {
    set org [iw_draw_box $canv $class]
    set top $org

    set offset 0
    foreach base [namespace eval $class {info inherit}] {
        $canv lower [$canv create line $offset $org \
            $offset [expr $top-10] \
            -40 [expr $top-10] \
            -24 [expr $top-10] \
            -20 [expr $top-16] \
            -16 [expr $top-10] \
            -20 [expr $top-16] \
            -20 [expr $top-26]]
        $canv move all 20 [expr -($top-26+$org)]
        set del [iw_draw_level $canv $base]
        $canv move all -20 [expr $top-26+$org]
        set top [expr $top+$del-30+$org]
        incr offset 4
    }
    return $top
}

# ----------------------------------------------------------------------
# USAGE:  iw_draw_box <canv> <class>
#
# Draws one box for a class hierarchy onto a canvas window.
# ----------------------------------------------------------------------
proc iw_draw_box {canv class} {
    set bg [option get $canv boxColor BoxColor]
    set textbg [option get $canv boxTextColor BoxTextColor]

    set cname [string trimleft $class :]
    $canv create text 0 0 -anchor center -text $cname \
        -fill $textbg -tags $class

    set bbox [$canv bbox $class]
    set x0 [expr [lindex $bbox 0]-4]
    set y0 [expr [lindex $bbox 1]-4]
    set x1 [expr [lindex $bbox 2]+4]
    set y1 [expr [lindex $bbox 3]+4]

    $canv create rectangle $x0 $y0 $x1 $y1 \
        -outline black -fill $bg

    $canv raise $class

    return $y0
}

# ----------------------------------------------------------------------
wm title . {[incr Widgets] Demo}
wm geometry . 620x440

frame .mbar -borderwidth 2 -relief raised
pack .mbar -fill x
set widgets(mainMenu) [menubutton .mbar.main -text "Main" -menu .mbar.main.m]
pack .mbar.main -side left

menu .mbar.main.m
.mbar.main.m add command -label "About..." -command {.about activate}
.mbar.main.m add separator
.mbar.main.m add command -label "Quit" -command tcl_exit

iwidgets::panedwindow .pw -orient vertical
pack .pw -expand yes -fill both

.pw add "widgets"
set pane [.pw childsite "widgets"]
set widgets(list) $pane.wlist

iwidgets::scrolledlistbox $widgets(list) -labeltext "Select a widget:" \
    -selectioncommand {iw_load_demo [$widgets(list) getcurselection]} \
    -labelpos nw -vscrollmode dynamic -hscrollmode none \
    -exportselection no
pack $widgets(list) -expand yes -fill both -padx 8

.pw add "info"
set pane [.pw childsite "info"]
set widgets(info) $pane.info

set widgets(status) [label $pane.status]
pack $pane.status -anchor w

iwidgets::tabnotebook $widgets(info) -tabpos s
pack $widgets(info) -expand yes -fill both

set widgets(info-example) [$widgets(info) add -label "Example"]
$widgets(info-example) configure -background white

set win [$widgets(info) add -label "Example Code"]
set widgets(info-code) [iwidgets::scrolledtext $win.code \
    -wrap none -vscrollmode dynamic -hscrollmode none]
pack $widgets(info-code) -expand yes -fill both -padx 4 -pady 4

set win [$widgets(info) add -label "Inheritance"]
set widgets(info-hier) [iwidgets::scrolledcanvas $win.canv -textbackground white \
    -vscrollmode dynamic -hscrollmode dynamic]
pack $widgets(info-hier) -expand yes -fill both -padx 4 -pady 4

set win [$widgets(info) add -label "Man Page"]
set widgets(info-manpage) [iwidgets::scrolledhtml $win.html \
    -wrap word -vscrollmode dynamic -hscrollmode none \
    -feedback "iw_manpage_progress" \
    -linkcommand "$win.html import -link"]
pack $widgets(info-manpage) -expand yes -fill both -padx 4 -pady 4

set widgets(info-manpage-feedback) [iwidgets::feedback $win.html.fb \
    -borderwidth 2 -relief raised]

bind $widgets(info-manpage) <Map> {iw_load_manpage}

.pw fraction 25 75
$widgets(info) select "Example"

# ----------------------------------------------------------------------
# "About" window
# ----------------------------------------------------------------------
iwidgets::dialog .about -title {About: [incr Widgets] Demo} -modality none
.about hide "Apply"
.about hide "Help"
.about hide "Cancel"
.about buttonconfigure "OK" -command ".about deactivate"
.about default "OK"

set win [.about childsite]
label $win.title -text {[incr Widgets]}
pack $win.title
catch {$win.title configure -font -*-helvetica-bold-o-normal-*-*-180-*}

set file [file join ${iwidgets::library} demos iwidgets.gif]
label $win.icon -image [image create photo -file $file]
pack $win.icon -side left

label $win.by -text "Contributed By"
pack $win.by
catch {$win.by configure -font -*-helvetica-medium-r-normal-*-*-100-*}

label $win.authors -text "Mark L. Ulferts
Sue Yockey
John Sigler
Bill Scott
Alfredo Jahn
Tako Schotanus
Kris Raney"
pack $win.authors
catch {$win.authors configure -font -*-helvetica-medium-o-normal-*-*-120-*}

# ----------------------------------------------------------------------
# Load up a list of demos...
# ----------------------------------------------------------------------
foreach file [lsort [glob [file join ${iwidgets::library} demos *]]] {
    set name [file tail $file]
    if {![file isdirectory $file] && ![string match *.* $name]} {
        $widgets(list) insert end $name
    }
}
$widgets(list) selection set 0
uplevel #0 [$widgets(list) cget -selectioncommand]