tcl/hierarchy.tcl

   1 ##
   2 ## hierarchy.tcl
   3 ## Hierarchical Display Widget
   4 ##
   5 ## Layout routines taken from oooold code, author unkown.
   6 ## Copyright 1995-1997 Jeffrey Hobbs
   7 ##
   8 ## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
   9 ##
  10 ## source standard_disclaimer.tcl
  11 ## source beer_ware.tcl
  12 ##
  13 ## Last Update: 28 June 1997
  14
  15 ##-----------------------------------------------------------------------
  16 ## PROCEDURE(S)
  17 ##      hierarchy, hierarchy_dir, hierarchy_widget
  18 ##
  19 ## ARGUMENTS && DESCRIPTION
  20 ##
  21 ## hierarchy <window pathname> <options>
  22 ##      Implements a hierarchical listbox
  23 ## hierarchy_dir <window pathname> <options>
  24 ##      Implements a hierarchical listbox using a directory view structure
  25 ##      for the default methods
  26 ## hierarchy_widget <window pathname> <options>
  27 ##      Implements a hierarchical listbox using a widget view structure
  28 ##      for the default methods
  29 ##
  30 ## OPTIONS
  31 ##      (Any canvas option may be used with a hierarchy)
  32 ##
  33 ## -autoscrollbar TCL_BOOLEAN                   DEFAULT: 1
  34 ##      Determines whether scrollbars automagically pop-up or
  35 ##      are permanently there.
  36 ##
  37 ## -browsecmd procedure                         DEFAULT: noop
  38 ##      A command which the widget will execute when the node is expanded
  39 ##      to retrieve the children of a node.  The widget and node path are
  40 ##      appended to the command as a list of node names which
  41 ##      form a path to the node from the root.  Thus the first
  42 ##      element of this list will always be the root node.
  43 ##
  44 ## -command procedure                           DEFAULT: noop
  45 ##      A command which the widget will execute when the node is toggled.
  46 ##      The name of the widget, the node path, and whether the children of
  47 ##      the node are showing (0/1) is appended to the procedure args.
  48 ##
  49 ## -common TCL_BOOLEAN                          DEFAULT: 0
  50 ##      If this is true, when a node gets added to the selection,
  51 ##      all other nodes with the same *name* (regardless of
  52 ##      the path to the node) get selected as well.  The selection
  53 ##      is reported only as a set of node names, not a set of node
  54 ##      paths.  Thus selection acts like an equivalence over nodes
  55 ##      of the same name.  Useful only in hierarchies where some
  56 ##      nodes in the hierarchy really refer to the same logical object.
  57 ##      NOTE: FEATURE NOT YET IMPLEMENTED
  58 ##
  59 ## -decoration TCL_BOOLEAN                      DEFAULT: 1
  60 ##      If this is true, the "tree" lines are drawn.
  61 ##
  62 ## -expand #                                    DEFAULT: 1
  63 ##      an integer value for an initial depth to expand to.
  64 ##
  65 ## -font fontname                               DEFAULT: fixed
  66 ##      The default font used for the text.
  67 ##
  68 ## -foreground color                            DEFAULT: black
  69 ##      The default foreground color used for text of unselected nodes.
  70 ##
  71 ## -ipad #                                      DEFAULT: 3
  72 ##      The internal space added between the image and the text for a
  73 ##      given node.
  74 ##
  75 ## -nodelook procedure                          DEFAULT: noop
  76 ##      A command the widget will execute to get the look of a node.
  77 ##      The node is appended to the command as a list of
  78 ##      node-names which form a path to the node from the root.
  79 ##      Thus the first element of this list will always be the
  80 ##      root node.  Also appended is a
  81 ##      boolean value which indicates whether the node's children
  82 ##      are currently displayed.  This allows the node's
  83 ##      look to change if it is "opened" or "closed".
  84 ##
  85 ##      This command must return a 4-tuple list containing:
  86 ##              0. the text to display at the node
  87 ##              1. the font to use for the text
  88 ##              2. an image to display
  89 ##              3. the foreground color to use for the node
  90 ##      If no font (ie. {}) is specified then
  91 ##      the value from -font is used.  If no image is specified
  92 ##      then no image is displayed.
  93 ##      The default is a command to which produces a nice look
  94 ##      for a file manager.
  95 ##
  96 ## -paddepth #                                  DEFAULT: 12
  97 ##      The indent space added for child branches.
  98 ##
  99 ## -padstack #                                  DEFAULT: 2
 100 ##      The space added between two rows
 101 ##
 102 ## -root rootname                               DEFAULT: {}
 103 ##      The name of the root node of the tree.  Each node
 104 ##      name must be unique amongst the children of each node.
 105 ##
 106 ## -selectbackground color                      DEFAULT: red
 107 ##      The default background color used for the text of selected nodes.
 108 ##
 109 ## -selectmode (single|browse|multiple)         DEFAULT: browse
 110 ##      Like listbox modes, "multiple" is a mix of multiple && extended.
 111 ##
 112 ## -showall TCL_BOOLEAN                         DEFAULT: 0
 113 ##      For directory nodelook, also show Unix '.' (hidden) files/dirs.
 114 ##
 115 ## -showfiles TCL_BOOLEAN                       DEFAULT: 0
 116 ##      Show files as well as directories.
 117 ##
 118 ## -showparent string                           DEFAULT: {}
 119 ##      For hierarchy_dir nodelook, if string != {}, then it will show that
 120 ##      string which will reset the root node to its parent.
 121 ##
 122 ## RETURNS: The window pathname
 123 ##
 124 ## METHODS
 125 ##      These are the methods that the hierachical listbox object recognizes.
 126 ##      (ie - hierachy .h ; .h <method> <args>)
 127 ##      Any unique substring is acceptable
 128 ##
 129 ## configure ?option? ?value option value ...?
 130 ## cget option
 131 ##      Standard tk widget routines.
 132 ##
 133 ## close index
 134 ##      Closes the specified index (will trigger -command).
 135 ##
 136 ## curselection
 137 ##      Returns the indices of the selected items.  This differs from the
 138 ##      listbox method because indices here have no implied order.
 139 ##
 140 ## get index ?index ...?
 141 ##      Returns the node paths of the items referenced.  Ranges are not
 142 ##      allowed.  Index specification is like that allowed by the index
 143 ##      method.
 144 ##
 145 ## qget index ?index ...?
 146 ##      As above, but the indices must be that of the item (as returned
 147 ##      by the index or curselection method).
 148 ##
 149 ## index index
 150 ##      Returns the hierarchy numerical index of the item (the numerical
 151 ##      index has no implied order relative to the list items).  index
 152 ##      may be of the form:
 153 ##
 154 ##      number - Specifies the element as a numerical index.
 155 ##      root   - specifies the root item.
 156 ##      string - Specifis an item that has that text in it's node.
 157 ##      @x,y   - Indicates the element that covers the point in
 158 ##              the listbox window specified by x and y (in pixel
 159 ##              coordinates).  If no element covers that point,
 160 ##              then the closest element to that point is used.
 161 ##
 162 ## open index
 163 ##      Opens the specified index (will trigger -command).
 164 ##
 165 ## see index
 166 ##      Ensures that the item specified by the index is viewable.
 167 ##
 168 ## selection option arg
 169 ##      This works like the listbox selection method with the following
 170 ##      exceptions:
 171 ##
 172 ##      The selection clear option can take multiple indices, but not a range.
 173 ##      No arguments to clear means clear all the selected elements.
 174 ##
 175 ##      The selection set option can take multiple indices, but not a range.
 176 ##      The key word 'all' sets the selection for all elements.
 177 ##
 178 ## size
 179 ##      Returns the number of items in the hierarchical listbox.
 180 ##
 181 ## toggle index
 182 ##      Toggles (open or closed) the item specified by index
 183 ##      (triggers -command).
 184 ##
 185 ## BINDINGS
 186 ##      Most Button-1 bindings on the hierarchy work in the same manner
 187 ##      as those for the listbox widget, as defined by the selectmode.
 188 ##      Those that vary are listed below:
 189 ##
 190 ## <Double-Button-1>
 191 ##      Toggles a node in the hierarchy
 192 ##
 193 ## NAMESPACE & STATE
 194 ##      The megawidget creates a global array with the classname, and a
 195 ## global array which is the name of each megawidget created.  The latter
 196 ## array is deleted when the megawidget is destroyed.
 197 ##      The procedure hierarchy and those beginning with Hierarchy are
 198 ## used.  Also, when a widget is created, commands named .$widgetname
 199 ## and Hierarchy$widgetname are created.
 200 ##
 201 ## Cryptic source code arguments explained:
 202 ## np   == node path
 203 ## cnp  == changed np
 204 ## knp  == kids np
 205 ## xcnp == extra cnp
 206 ##-----------------------------------------------------------------------
 207
 208 package require Widget 1.0
 209 package provide Hierarchy 1.11
 210
 211 ## Create the Hiearchy megawidget class definition
 212 ##
 213 ## In general, we cannot use $data(basecmd) in the construction, but the
 214 ## scrollbar commands won't be called until after it really exists as a
 215 ## proper command
 216 array set Hierarchy {
 217     type                frame
 218     base                {canvas canvas canvas {-relief sunken -bd 1 \
 219             -highlightthickness 1 \
 220             -yscrollcommand [list $data(yscrollbar) set] \
 221             -xscrollcommand [list $data(xscrollbar) set]}}
 222     components          {
 223         {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
 224                 -command [list $data(basecmd) xview]}}
 225         {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
 226                 -command [list $data(basecmd) yview]}}
 227     }
 228
 229     -autoscrollbar      {autoScrollbar  AutoScrollbar   1}
 230     -browsecmd          {browseCmd      BrowseCmd       {}}
 231     -command            {command        Command         {}}
 232     -decoration         {decoration     Decoration      1}
 233     -expand             {expand         Expand          1}
 234     -font               {font           Font            fixed}
 235     -foreground         {foreground     Foreground      black}
 236     -ipad               {ipad           Ipad            3}
 237     -nodelook           {nodeLook       NodeLook        {}}
 238     -paddepth           {padDepth       PadDepth        12}
 239     -padstack           {padStack       PadStack        2}
 240     -root               {root           Root            {}}
 241     -selectmode         {selectMode     SelectMode      browse}
 242     -selectbackground   {selectBackground SelectBackground red}
 243     -state              {state          State           normal}
 244
 245     -showall            {showAll        ShowAll         0}
 246     -showparent         {showParent     ShowParent      {}}
 247     -showfiles          {showFiles      ShowFiles       0}
 248 }
 249 # Create this to make sure there are registered in auto_mkindex
 250 # these must come before the [widget create ...]
 251 proc Hierarchy args {}
 252 proc hierarchy args {}
 253 widget create Hierarchy
 254
 255 proc hierarchy_dir {w args} {
 256     uplevel hierarchy $w -root [list [pwd]] \
 257             -nodelook   Hierarchy:FileLook \
 258             -command    Hierarchy:FileActivate \
 259             -browsecmd  Hierarchy:FileList \
 260             $args
 261 }
 262
 263 proc hierarchy_widget {w args} {
 264     uplevel hierarchy $w -root . \
 265             -nodelook   Hierarchy:WidgetLook \
 266             -command    Hierarchy:WidgetActivate \
 267             -browsecmd  Hierarchy:WidgetList \
 268             $args
 269 }
 270
 271 ;proc Hierarchy:construct { w } {
 272     upvar \#0 $w data
 273
 274     ## Private variables
 275     array set data [list \
 276             hasnodelook 0 \
 277             halfpstk    [expr $data(-padstack)/2] \
 278             width       400 \
 279             ]
 280
 281     grid $data(canvas) $data(yscrollbar) -sticky news
 282     grid $data(xscrollbar) -sticky ew
 283     grid columnconfig $w 0 -weight 1
 284     grid rowconfig $w 0 -weight 1
 285     bind $data(canvas) <Configure> [list Hierarchy:Resize $w %w %h]
 286 }
 287
 288 ;proc Hierarchy:init { w } {
 289     upvar \#0 $w data
 290
 291     set data(:$data(-root),showkids) 0
 292     Hierarchy:ExpandNodeN $w $data(-root) $data(-expand)
 293     if {[catch {$w see $data(-root)}]} {
 294         $data(basecmd) configure -scrollregion "0 0 1 1"
 295     }
 296 }
 297
 298 ;proc Hierarchy:configure {w args} {
 299     upvar \#0 $w data
 300
 301     set truth {^(1|yes|true|on)$}
 302     set resize 0
 303     foreach {key val} $args {
 304         switch -- $key {
 305             -autoscrollbar {
 306                 set val [regexp -nocase $truth $val]
 307                 if {$val} {
 308                     set resize 1
 309                 } else {
 310                     grid $data(xscrollbar)
 311                     grid $data(yscrollbar)
 312                 }
 313             }
 314             -decoration { set val [regexp -nocase $truth $val] }
 315             -padstack   { set data(halfpstk) [expr $val/2] }
 316             -nodelook   {
 317                 ## We set this special bool val because it saves some
 318                 ## computation in ExpandNode, a deeply nested proc
 319                 set data(hasnodelook) [string compare $val {}]
 320             }
 321             -root               {
 322                 if {[info exists data(:$data(-root),showkids)]} {
 323                     ## All data about items and selection should be
 324                     ## cleared and the items deleted
 325                     foreach name [concat [array names data :*] \
 326                             [array names data S,*]] {unset data($name)}
 327                     $data(basecmd) delete all
 328                     set data(-root) $val
 329                     set data(:$val,showkids) 0
 330                     Hierarchy:ExpandNodeN $w $val $data(-expand)
 331                     ## We can reset resize because ExpandNodeN forces it
 332                     set resize 0
 333                     continue
 334                 }
 335             }
 336             -selectbackground {
 337                 foreach i [array names data S,*] {
 338                     $data(basecmd) itemconfigure [string range $i 2 end] \
 339                             -fill $val
 340                 }
 341             }
 342             -state      {
 343                 if {![regexp {^(normal|disabled)$} $val junk val]} {
 344                     return -code error "bad state value \"$val\":\
 345                             must be normal or disabled"
 346                 }
 347             }
 348             -showall    -
 349             -showfiles  {
 350                 set val [regexp -nocase $truth $val]
 351                 if {$val == $data($key)} continue
 352                 if {[info exists data(:$data(-root),showkids)]} {
 353                     foreach i [array names data :*,kids] { unset data($i) }
 354                     foreach i [array names data :*,showkids] {
 355                         ## FIX - this doesn't really work dynamically
 356                         if {$data($i)} {
 357                             ## probably requires a call to Hierarchy:Redraw
 358                         }
 359                     }
 360                 }
 361             }
 362         }
 363         set data($key) $val
 364     }
 365     if {$resize} {
 366         Hierarchy:Resize $w [winfo width $data(canvas)] \
 367                 [winfo height $data(canvas)]
 368     }
 369 }
 370
 371 ;proc Hierarchy_index { w idx } {
 372     upvar \#0 $w data
 373     set c $data(basecmd)
 374     if {[string match all $idx]} {
 375         return [$c find withtag box]
 376     } elseif {[regexp {^(root|anchor)$} $idx]} {
 377         return [$c find withtag box:$data(-root)]
 378     }
 379     foreach i [$c find withtag $idx] {
 380         if {[string match rec* [$c type $i]]} { return $i }
 381     }
 382     if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
 383         return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
 384     }
 385     foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
 386     return -code error "bad hierarchy index \"$idx\":\
 387             must be current, @x,y, a number, or a node name"
 388 }
 389
 390 ;proc Hierarchy_selection { w args } {
 391     if {[string match {} $args]} {
 392         return -code error \
 393                 "wrong \# args: should be \"$w selection option args\""
 394     }
 395     upvar \#0 $w data
 396     set err [catch {Hierarchy_index $w [lindex $args 1]} idx]
 397     switch -glob -- [lindex $args 0] {
 398         an* {
 399             ## anchor
 400             ## stubbed out - too complicated to support
 401         }
 402         cl* {
 403             ## clear
 404             set c $data(basecmd)
 405             if {$err} {
 406                 foreach arg [array names data S,*] { unset data($arg) }
 407                 $c itemconfig box -fill {}
 408             } else {
 409                 catch {unset data(S,$idx)}
 410                 $c itemconfig $idx -fill {}
 411                 foreach idx [lrange $args 2 end] {
 412                     if {[catch {Hierarchy_index $w $idx} idx]} {
 413                         catch {unset data(S,$idx)}
 414                         $c itemconfig $idx -fill {}
 415                     }
 416                 }
 417             }
 418         }
 419         in* {
 420             ## includes
 421             if {$err} {
 422                 if {[llength $args]==2} {
 423                     return -code error $idx
 424                 } else {
 425                     return -code error "wrong \# args:\
 426                             should be \"$w selection includes index\""
 427                 }
 428             }
 429             return [info exists data(S,$idx)]
 430         }
 431         se* {
 432             ## set
 433             if {$err} {
 434                 if {[string compare {} $args]} return
 435                 return -code error "wrong \# args:\
 436                         should be \"$w selection set index ?index ...?\""
 437             } else {
 438                 set c $data(basecmd); set col $data(-selectbackground)
 439                 if {[string match all [lindex $args 1]]} {
 440                     foreach i $idx { set data(S,$i) 1 }
 441                     $c itemconfig box -fill $col
 442                 } else {
 443                     set data(S,$idx) 1
 444                     $c itemconfig $idx -fill $col
 445                     foreach idx [lrange $args 2 end] {
 446                         if {![catch {Hierarchy_index $w $idx} idx]} {
 447                             set data(S,$idx) 1
 448                             $c itemconfig $idx -fill $col
 449                         }
 450                     }
 451                 }
 452             }
 453         }
 454         default {
 455             return -code error "bad selection option \"[lindex $args 0]\":\
 456                     must be clear, includes, set"
 457         }
 458     }
 459 }
 460
 461 ;proc Hierarchy_curselection {w} {
 462     upvar \#0 $w data
 463
 464     set res {}
 465     foreach i [array names data S,*] { lappend res [string range $i 2 end] }
 466     return $res
 467 }
 468
 469 ;proc Hierarchy_get {w args} {
 470     upvar \#0 $w data
 471
 472     set nps {}
 473     foreach arg $args {
 474         if {![catch {Hierarchy_index $w $arg} idx] && \
 475                 [string compare {} $idx]} {
 476             set tags [$data(basecmd) gettags $idx]
 477             if {[set i [lsearch -glob $tags box:*]]>-1} {
 478                 lappend nps [string range [lindex $tags $i] 4 end]
 479             }
 480         }
 481     }
 482     return $nps
 483 }
 484
 485 ;proc Hierarchy_qget {w args} {
 486     upvar \#0 $w data
 487
 488     ## Quick get.  Avoids expensive Hierarchy_index call
 489     set nps {}
 490     foreach arg $args {
 491         set tags [$data(basecmd) itemcget $arg -tags]
 492         if {[set i [lsearch -glob $tags box:*]]>-1} {
 493             lappend nps [string range [lindex $tags $i] 4 end]
 494         }
 495     }
 496     return $nps
 497 }
 498
 499 ;proc Hierarchy_see {w args} {
 500     upvar \#0 $w data
 501
 502     if {[catch {Hierarchy_index $w $args} idx]} {
 503         return -code error $idx
 504     } elseif {[string compare {} $idx]} {
 505         set c $data(basecmd)
 506         foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
 507             set stk [lindex [$c cget -scrollregion] 3]
 508             set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
 509         }
 510         $c yview moveto $pos
 511     }
 512 }
 513
 514 ;proc Hierarchy_size {w} {
 515     upvar \#0 $w data
 516     return [llength [$data(basecmd) find withtag box]]
 517 }
 518
 519 ## This will be the one called by <Double-Button-1> on the canvas,
 520 ## if -state is normal, so we have to make sure that $w is correct.
 521 ##
 522 ;proc Hierarchy_toggle { w index } {
 523     Hierarchy:toggle $w $index toggle
 524 }
 525
 526 ;proc Hierarchy_close { w index } {
 527     Hierarchy:toggle $w $index close
 528 }
 529
 530 ;proc Hierarchy_open { w index } {
 531     Hierarchy:toggle $w $index open
 532 }
 533
 534 ;proc Hierarchy:toggle { w index which } {
 535     if {[string compare Hierarchy [winfo class $w]]} {
 536         set w [winfo parent $w]
 537     }
 538     upvar \#0 $w data
 539
 540     if {[string match {} [set np [$w get $index]]]} return
 541     set np [lindex $np 0]
 542
 543     set old [$data(basecmd) cget -cursor]
 544     $data(basecmd) config -cursor watch
 545     update
 546     switch $which {
 547         close   { Hierarchy:CollapseNodeAll $w $np }
 548         open    { Hierarchy:ExpandNodeN $w $np 1 }
 549         toggle  {
 550             if {$data(:$np,showkids)} {
 551                 Hierarchy:CollapseNodeAll $w $np
 552             } else {
 553                 Hierarchy:ExpandNodeN $w $np 1
 554             }
 555         }
 556     }
 557     if {[string compare {} $data(-command)]} {
 558         uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
 559     }
 560     $data(basecmd) config -cursor $old
 561     return
 562 }
 563
 564 ;proc Hierarchy:Resize { w wid hgt } {
 565     upvar \#0 $w data
 566     set c $data(basecmd)
 567     if {[string compare {} [set box [$c bbox image text]]]} {
 568         set X [lindex $box 2]
 569         if {$data(-autoscrollbar)} {
 570             set Y [lindex $box 3]
 571             if {$wid>$X} {
 572                 set X $wid
 573                 grid remove $data(xscrollbar)
 574             } else {
 575                 grid $data(xscrollbar)
 576             }
 577             if {$hgt>$Y} {
 578                 set Y $hgt
 579                 grid remove $data(yscrollbar)
 580             } else {
 581                 grid $data(yscrollbar)
 582             }
 583             $c config -scrollregion "0 0 $X $Y"
 584         }
 585         ## This makes full width highlight boxes
 586         ## data(width) is the default width of boxes
 587         if {$X>$data(width)} {
 588             set data(width) $X
 589             foreach b [$c find withtag box] {
 590                 foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
 591             }
 592         }
 593     } elseif {$data(-autoscrollbar)} {
 594         grid remove $data(xscrollbar) $data(yscrollbar)
 595     }
 596 }
 597
 598 ;proc Hierarchy:CollapseNodeAll { w np } {
 599     if {[Hierarchy:CollapseNode $w $np]} {
 600         upvar \#0 $w data
 601         Hierarchy:Redraw $w $np
 602         Hierarchy:DiscardChildren $w $np
 603         Hierarchy:Resize $w [winfo width $data(canvas)] \
 604                 [winfo height $data(canvas)]
 605     }
 606 }
 607
 608 ;proc Hierarchy:ExpandNodeN { w np n } {
 609     upvar \#0 $w data
 610     if {[Hierarchy:ExpandNodeN_aux $w $np $n] || \
 611             ([string compare $data(-root) {}] && \
 612             ![string compare $data(-root) $np])} {
 613         Hierarchy:Redraw $w $np
 614         Hierarchy:Resize $w [winfo width $data(canvas)] \
 615                 [winfo height $data(canvas)]
 616     }
 617 }
 618
 619 ;proc Hierarchy:ExpandNodeN_aux { w np n } {
 620     if {![Hierarchy:ExpandNode $w $np]} { return 0 }
 621     if {$n==1} { return 1 }
 622     incr n -1
 623     upvar \#0 $w data
 624     foreach k $data(:$np,kids) {
 625         Hierarchy:ExpandNodeN_aux $w "$np [list $k]" $n
 626     }
 627     return 1
 628 }
 629
 630 ########################################################################
 631 ##
 632 ## Private routines to collapse and expand a single node w/o redrawing
 633 ## Most routines return 0/1 to indicate if any change has occurred
 634 ##
 635 ########################################################################
 636
 637 ;proc Hierarchy:ExpandNode { w np } {
 638     upvar \#0 $w data
 639
 640     if {$data(:$np,showkids)} { return 0 }
 641     set data(:$np,showkids) 1
 642     if {![info exists data(:$np,kids)]} {
 643         if {[string compare $data(-browsecmd) {}]} {
 644             set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
 645         } else {
 646             set data(:$np,kids) {}
 647         }
 648     }
 649     if $data(hasnodelook) {
 650         set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
 651     } else {
 652         set data(:$np,look) {}
 653     }
 654     if {[string match {} $data(:$np,kids)]} {
 655         foreach {txt font img fg} $data(:$np,look) {
 656             lappend tags box:$np box $np
 657             set c $data(basecmd)
 658             if {[string compare $img {}]} {
 659                 ## Catch just in case the image doesn't exist
 660                 catch {
 661                     $c itemconfigure img:$np -image $img
 662                     lappend tags $img
 663                 }
 664             }
 665             if {[string compare $txt {}]} {
 666                 if {[string match {} $font]} { set font $data(-font) }
 667                 if {[string match {} $fg]}   { set fg $data(-foreground) }
 668                 $c itemconfigure txt:$np -fill $fg -text $txt -font $font
 669                 if {[string compare $np $txt]} { lappend tags $txt }
 670             }
 671             $c itemconfigure box:$np -tags $tags
 672             ## We only want to go through once
 673             break
 674         }
 675         return 0
 676     }
 677     foreach k $data(:$np,kids) {
 678         set knp "$np [list $k]"
 679         set data(:$knp,showkids) 0
 680         if $data(hasnodelook) {
 681             set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
 682         } else {
 683             set data(:$knp,look) {}
 684         }
 685     }
 686     return 1
 687 }
 688
 689 ;proc Hierarchy:CollapseNode { w np } {
 690     upvar \#0 $w data
 691     if {!$data(:$np,showkids)} { return 0 }
 692     set data(:$np,showkids) 0
 693     if {[string match {} $data(:$np,kids)]} { return 0 }
 694     if {[string compare $data(-nodelook) {}]} {
 695         set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
 696     } else {
 697         set data(:$np,look) {}
 698     }
 699     foreach k $data(:$np,kids) { Hierarchy:CollapseNode $w "$np [list $k]" }
 700     return 1
 701 }
 702
 703 ;proc Hierarchy:DiscardChildren { w np } {
 704     upvar \#0 $w data
 705     if {[info exists data(:$np,kids)]} {
 706         foreach k $data(:$np,kids) {
 707             set knp "$np [list $k]"
 708             $data(basecmd) delete img:$knp txt:$knp box:$knp
 709             foreach i {showkids look stkusg stack iwidth offset} {
 710                 catch {unset data(:$knp,$i)}
 711             }
 712             Hierarchy:DiscardChildren $w $knp
 713         }
 714         unset data(:$np,kids)
 715     }
 716 }
 717
 718 ## REDRAW mechanism
 719 ## 2 parts:     recompute offsets of all children from changed node path
 720 ##              then redraw children based on their offsets and look
 721 ##
 722 ;proc Hierarchy:Redraw { w cnp } {
 723     upvar \#0 $w data
 724
 725     set c $data(basecmd)
 726     # When a node changes, the positions of a whole lot of things
 727     # change.  The size of the scroll region also changes.
 728     $c delete decor
 729
 730     # Calculate the new offset locations of everything
 731     Hierarchy:Recompute $w $data(-root) [lrange $cnp 1 end]
 732
 733     # Next recursively move all the bits around to their correct positions.
 734     # We choose an initial point (4,4) to begin at.
 735     Hierarchy:Redraw_aux $w $data(-root) 4 4
 736
 737     # Necessary to make sure find closest gets the right item
 738     # ordering: image > text > box
 739     after idle "catch { $c raise image text; $c lower box text }"
 740 }
 741
 742 ## RECOMPUTE recurses through the tree working out the relative offsets
 743 ## of children from their parents in terms of stack values.
 744 ##
 745 ## "cnp" is either empty or a node name which indicates where the only
 746 ## changes have occured in the hierarchy since the last call to Recompute.
 747 ## This is used because when a node is toggled on/off deep in the
 748 ## hierarchy then not all the positions of items need to be recomputed.
 749 ## The only ones that do are everything below the changed node (of
 750 ## course), and also everything which might depend on the stack usage of
 751 ## that node (i.e. everything above it).  Specifically the usages of the
 752 ## changed node's siblings do *not* need to be recomputed.
 753 ##
 754 ;proc Hierarchy:Recompute { w np cnp } {
 755     upvar \#0 $w data
 756     # If the cnp now has only one element then
 757     # it must be one of the children of the current node.
 758     # We do not need to Recompute the usages of its siblings if it is.
 759     set cnode_is_child [expr [llength $cnp]==1]
 760     if {$cnode_is_child} {
 761         set cnode [lindex $cnp 0]
 762     } else {
 763         set xcnp [lrange $cnp 1 end]
 764     }
 765
 766     # Run through the children, recursively calculating their usage of
 767     # stack real-estate, and allocating an intial placement for each child
 768     #
 769     # Values do not need to be recomputed for siblings of the changed
 770     # node and their descendants.  For the cnode itself, in the
 771     # recursive call we set the value of cnode to {} to prevent
 772     # any further cnode checks.
 773
 774     set children_stack 0
 775     if {$data(:$np,showkids)} {
 776         foreach k $data(:$np,kids) {
 777             set knp "$np [list $k]"
 778             set data(:$knp,offset) $children_stack
 779             if {$cnode_is_child && [string match $cnode $k]} {
 780                 set data(:$knp,stkusg) [Hierarchy:Recompute $w $knp {}]
 781             } elseif {!$cnode_is_child} {
 782                 set data(:$knp,stkusg) [Hierarchy:Recompute $w $knp $xcnp]
 783             }
 784             incr children_stack $data(:$knp,stkusg)
 785             incr children_stack $data(-padstack)
 786         }
 787     }
 788
 789     ## Make the image/text if they don't exist.
 790     ## Positioning occurs in Hierarchy:Redraw_aux.
 791     ## And calculate the stack usage of our little piece of the world.
 792     set img_height 0; set img_width 0; set txt_width 0; set txt_height 0
 793
 794     foreach {txt font img fg} $data(:$np,look) {
 795         lappend tags box:$np box $np
 796         set c $data(basecmd)
 797         if {[string compare $img {}]} {
 798             if {[string match {} [$c find withtag img:$np]]} {
 799                 $c create image 0 0 -anchor nw -tags [list img:$np image]
 800             }
 801             ## Catch just in case the image doesn't exist
 802             catch {
 803                 $c itemconfigure img:$np -image $img
 804                 lappend tags $img
 805                 foreach {x y img_width img_height} [$c bbox img:$np] {
 806                     incr img_width -$x; incr img_height -$y
 807                 }
 808             }
 809         }
 810         if {[string compare $txt {}]} {
 811             if {[string match {} [$c find withtag txt:$np]]} {
 812                 $c create text 0 0 -anchor nw -tags [list txt:$np text]
 813             }
 814             if {[string match {} $font]} { set font $data(-font) }
 815             if {[string match {} $fg]}   { set fg $data(-foreground) }
 816             $c itemconfigure txt:$np -fill $fg -text $txt -font $font
 817             if {[string compare $np $txt]} { lappend tags $txt }
 818             foreach {x y txt_width txt_height} [$c bbox txt:$np] {
 819                 incr txt_width -$x; incr txt_height -$y
 820             }
 821         }
 822         if {[string match {} [$c find withtag box:$np]]} {
 823             $c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
 824         }
 825         $c itemconfigure box:$np -tags $tags
 826         ## We only want to go through this once
 827         break
 828     }
 829
 830     if {$txt_height>$img_height} {
 831         set stack $txt_height
 832     } else {
 833         set stack $img_height
 834     }
 835
 836     # Now reposition the children downward by "stack"
 837     set overall_stack [expr $children_stack+$stack]
 838
 839     if {$data(:$np,showkids)} {
 840         set off [expr $stack+$data(-padstack)]
 841         foreach k $data(:$np,kids) {
 842             set knp "$np [list $k]"
 843             incr data(:$knp,offset) $off
 844         }
 845     }
 846     # remember some facts for locating the image and drawing decor
 847     array set data [list :$np,stack $stack :$np,iwidth $img_width]
 848
 849     return $overall_stack
 850 }
 851
 852 ;proc Hierarchy:Redraw_aux { w np deppos stkpos} {
 853     upvar \#0 $w data
 854
 855     set c $data(basecmd)
 856     $c coords img:$np $deppos $stkpos
 857     $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
 858     $c coords box:$np 0 [expr $stkpos-$data(halfpstk)] \
 859             $data(width) [expr $stkpos+$data(:$np,stack)+$data(halfpstk)]
 860
 861     if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return
 862
 863     set minkid_stkpos 100000
 864     set maxkid_stkpos 0
 865     set bar_deppos [expr $deppos+$data(-paddepth)/2]
 866     set kid_deppos [expr $deppos+$data(-paddepth)]
 867
 868     foreach k $data(:$np,kids) {
 869         set knp "$np [list $k]"
 870         set kid_stkpos [expr $stkpos+$data(:$knp,offset)]
 871         Hierarchy:Redraw_aux $w $knp $kid_deppos $kid_stkpos
 872
 873         if {$data(-decoration)} {
 874             if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
 875             set kid_stkpos [expr $kid_stkpos+$data(:$knp,stack)/2]
 876             if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
 877
 878             $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
 879                     -width 1 -tags decor
 880         }
 881     }
 882     if {$data(-decoration)} {
 883         $c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
 884                 -width 1 -tags decor
 885     }
 886 }
 887
 888
 889 ##
 890 ## DEFAULT BINDINGS FOR HIERARCHY
 891 ##
 892 ## Since we give no border to the frame, all Hierarchy bindings
 893 ## will always register on the canvas widget
 894 ##
 895 bind Hierarchy <Double-Button-1> {
 896     set w [winfo parent %W]
 897     if {[string match normal [$w cget -state]]} {
 898         $w toggle @%x,%y
 899     }
 900 }
 901 bind Hierarchy <ButtonPress-1> {
 902     if {[winfo exists %W]} { Hierarchy:BeginSelect [winfo parent %W] @%x,%y }
 903 }
 904 bind Hierarchy <B1-Motion> {
 905     set tkPriv(x) %x
 906     set tkPriv(y) %y
 907     Hierarchy:Motion [winfo parent %W] @%x,%y
 908 }
 909 bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
 910 bind Hierarchy <Shift-1>   { Hierarchy:BeginExtend [winfo parent %W] @%x,%y }
 911 bind Hierarchy <Control-1> { Hierarchy:BeginToggle [winfo parent %W] @%x,%y }
 912 bind Hierarchy <B1-Leave> {
 913     set tkPriv(x) %x
 914     set tkPriv(y) %y
 915     Hierarchy:AutoScan [winfo parent %W]
 916 }
 917 bind Hierarchy <B1-Enter>       { tkCancelRepeat }
 918
 919 ## Should reserve L/R U/D for traversing nodes
 920 bind Hierarchy <Up>             { %W yview scroll -1 units }
 921 bind Hierarchy <Down>           { %W yview scroll  1 units }
 922 bind Hierarchy <Left>           { %W xview scroll -1 units }
 923 bind Hierarchy <Right>          { %W xview scroll  1 units }
 924
 925 bind Hierarchy <Control-Up>     { %W yview scroll -1 pages }
 926 bind Hierarchy <Control-Down>   { %W yview scroll  1 pages }
 927 bind Hierarchy <Control-Left>   { %W xview scroll -1 pages }
 928 bind Hierarchy <Control-Right>  { %W xview scroll  1 pages }
 929 bind Hierarchy <Prior>          { %W yview scroll -1 pages }
 930 bind Hierarchy <Next>           { %W yview scroll  1 pages }
 931 bind Hierarchy <Control-Prior>  { %W xview scroll -1 pages }
 932 bind Hierarchy <Control-Next>   { %W xview scroll  1 pages }
 933 bind Hierarchy <Home>           { %W xview moveto 0 }
 934 bind Hierarchy <End>            { %W xview moveto 1 }
 935 bind Hierarchy <Control-slash>  { Hierarchy:SelectAll [winfo parent %W] }
 936 bind Hierarchy <Control-backslash> { [winfo parent %W] selection clear }
 937
 938 bind Hierarchy <2> {
 939     set tkPriv(x) %x
 940     set tkPriv(y) %y
 941     %W scan mark %x %y
 942 }
 943 bind Hierarchy <B2-Motion> {
 944     %W scan dragto $tkPriv(x) %y
 945 }
 946
 947 # Hierarchy:BeginSelect --
 948 #
 949 # This procedure is typically invoked on button-1 presses.  It begins
 950 # the process of making a selection in the hierarchy.  Its exact behavior
 951 # depends on the selection mode currently in effect for the hierarchy;
 952 # see the Motif documentation for details.
 953 #
 954 # Arguments:
 955 # w -           The hierarchy widget.
 956 # el -          The element for the selection operation (typically the
 957 #               one under the pointer).  Must be in numerical form.
 958
 959 ;proc Hierarchy:BeginSelect {w el} {
 960     global tkPriv
 961     if {[catch {Hierarchy_index $w $el} el]} return
 962     $w selection clear
 963     $w selection set $el
 964     set tkPriv(hierarchyPrev) $el
 965 }
 966
 967 # Hierarchy:Motion --
 968 #
 969 # This procedure is called to process mouse motion events while
 970 # button 1 is down.  It may move or extend the selection, depending
 971 # on the hierarchy's selection mode.
 972 #
 973 # Arguments:
 974 # w -           The hierarchy widget.
 975 # el -          The element under the pointer (must be a number).
 976
 977 ;proc Hierarchy:Motion {w el} {
 978     global tkPriv
 979     if {[catch {Hierarchy_index $w $el} el] || \
 980             [string match $el $tkPriv(hierarchyPrev)]} return
 981     switch [Hierarchy_cget $w -selectmode] {
 982         browse {
 983             Hierarchy_selection $w clear 0 end
 984             if {![catch {Hierarchy_selection $w set $el}]} {
 985                 set tkPriv(hierarchyPrev) $el
 986             }
 987         }
 988         multiple {
 989             ## This happens when a double-1 occurs and all the index boxes
 990             ## have changed
 991             if {[catch {Hierarchy_selection $w includes \
 992                     $tkPriv(hierarchyPrev)} inc]} {
 993                 set tkPriv(hierarchyPrev) [Hierarchy_index $w $el]
 994                 return
 995             }
 996             if {$inc} {
 997                 Hierarchy_selection $w set $el
 998             } else {
 999                 Hierarchy_selection $w clear $el
1000             }
1001             set tkPriv(hierarchyPrev) $el
1002         }
1003     }
1004 }
1005
1006 # Hierarchy:BeginExtend --
1007 #
1008 # This procedure is typically invoked on shift-button-1 presses.  It
1009 # begins the process of extending a selection in the hierarchy.  Its
1010 # exact behavior depends on the selection mode currently in effect
1011 # for the hierarchy;
1012 #
1013 # Arguments:
1014 # w -           The hierarchy widget.
1015 # el -          The element for the selection operation (typically the
1016 #               one under the pointer).  Must be in numerical form.
1017
1018 ;proc Hierarchy:BeginExtend {w el} {
1019     if {[catch {Hierarchy_index $w $el} el]} return
1020     if {[string match multiple [$w cget -selectmode]]} {
1021         Hierarchy:Motion $w $el
1022     }
1023 }
1024
1025 # Hierarchy:BeginToggle --
1026 #
1027 # This procedure is typically invoked on control-button-1 presses.  It
1028 # begins the process of toggling a selection in the hierarchy.  Its
1029 # exact behavior depends on the selection mode currently in effect
1030 # for the hierarchy;  see the Motif documentation for details.
1031 #
1032 # Arguments:
1033 # w -           The hierarchy widget.
1034 # el -          The element for the selection operation (typically the
1035 #               one under the pointer).  Must be in numerical form.
1036
1037 ;proc Hierarchy:BeginToggle {w el} {
1038     global tkPriv
1039     if {[catch {Hierarchy_index $w $el} el]} return
1040     if {[string match multiple [$w cget -selectmode]]} {
1041         $w selection anchor $el
1042         if {[$w selection includes $el]} {
1043             $w selection clear $el
1044         } else {
1045             $w selection set $el
1046         }
1047         set tkPriv(hierarchyPrev) $el
1048     }
1049 }
1050
1051 # Hierarchy:AutoScan --
1052 # This procedure is invoked when the mouse leaves an entry window
1053 # with button 1 down.  It scrolls the window up, down, left, or
1054 # right, depending on where the mouse left the window, and reschedules
1055 # itself as an "after" command so that the window continues to scroll until
1056 # the mouse moves back into the window or the mouse button is released.
1057 #
1058 # Arguments:
1059 # w -           The hierarchy widget.
1060
1061 ;proc Hierarchy:AutoScan {w} {
1062     global tkPriv
1063     if {![winfo exists $w]} return
1064     set x $tkPriv(x)
1065     set y $tkPriv(y)
1066     if {$y>=[winfo height $w]} {
1067         $w yview scroll 1 units
1068     } elseif {$y<0} {
1069         $w yview scroll -1 units
1070     } elseif {$x>=[winfo width $w]} {
1071         $w xview scroll 2 units
1072     } elseif {$x<0} {
1073         $w xview scroll -2 units
1074     } else {
1075         return
1076     }
1077     #Hierarchy:Motion $w [$w index @$x,$y]
1078     set tkPriv(afterId) [after 50 Hierarchy:AutoScan $w]
1079 }
1080
1081 # Hierarchy:SelectAll
1082 #
1083 # This procedure is invoked to handle the "select all" operation.
1084 # For single and browse mode, it just selects the root element.
1085 # Otherwise it selects everything in the widget.
1086 #
1087 # Arguments:
1088 # w -           The hierarchy widget.
1089
1090 ;proc Hierarchy:SelectAll w {
1091     if {[regexp (browse|single) [$w cget -selectmode]]} {
1092         $w selection clear
1093         $w selection set root
1094     } else {
1095         $w selection set all
1096     }
1097 }
1098
1099 #------------------------------------------------------------
1100 # Default nodelook methods
1101 #------------------------------------------------------------
1102
1103 ;proc Hierarchy:FileLook { w np isopen } {
1104     upvar \#0 $w data
1105     set path [eval file join $np]
1106     set file [lindex $np end]
1107     set bmp  {}
1108     if {[file readable $path]} {
1109         if {[file isdirectory $path]} {
1110             if {$isopen} {
1111                 ## We know that kids will always be set by the time
1112                 ## the isopen is set to 1
1113                 if {[string compare $data(:$np,kids) {}]} {
1114                     set bmp bmp:dir_minus
1115                 } else {
1116                     set bmp bmp:dir
1117                 }
1118             } else {
1119                 set bmp bmp:dir_plus
1120             }
1121             if 0 {
1122                 ## NOTE: accurate, but very expensive
1123                 if {[string compare [Hierarchy:FileList $w $np] {}]} {
1124                     if {$isopen} {set bmp bmp:dir_minus} {set bmp bmp:dir_plus}
1125                 } else {
1126                     set bmp bmp:dir
1127                 }
1128             }
1129         }
1130         set fg \#000000
1131     } elseif {[string compare $data(-showparent) {}] && \
1132             [string match $data(-showparent) $file]} {
1133         set fg \#0000FF
1134         set bmp bmp:up
1135     } else {
1136         set fg \#a9a9a9
1137         if {[file isdirectory $path]} {set bmp bmp:dir}
1138     }
1139     return [list $file $data(-font) $bmp $fg]
1140 }
1141
1142 ## Hierarchy:FileList
1143 # ARGS: w       hierarchy widget
1144 #       np      node path
1145 # Returns:      directory listing
1146 ##
1147 ;proc Hierarchy:FileList { w np } {
1148     set pwd [pwd]
1149     if {[catch "cd \[file join $np\]"]} {
1150         set list {}
1151     } else {
1152         global tcl_platform
1153         upvar \#0 $w data
1154         set str *
1155         if {!$data(-showfiles)} { append str / }
1156         if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
1157             ## NOTE: Use of non-core lremove
1158             if {[catch {lsort [concat [glob -nocomplain $str] \
1159                     [lremove [glob -nocomplain .$str] {. ..}]]} list]} {
1160                 return {}
1161             }
1162         } else {
1163             ## The extra catch is necessary for unusual error conditions
1164             if {[catch {lsort [glob -nocomplain $str]} list]} {
1165                 return {}
1166             }
1167         }
1168         set root $data(-root)
1169         if {[string compare {} $data(-showparent)] && \
1170                 [string match $root $np]} {
1171             if {![regexp {^(.:)?/+$} $root] && \
1172                     [string compare [file dir $root] $root]} {
1173                 set list [linsert $list 0 $data(-showparent)]
1174             }
1175         }
1176     }
1177     cd $pwd
1178     return $list
1179 }
1180
1181 ;proc Hierarchy:FileActivate { w np isopen } {
1182     upvar \#0 $w data
1183     set path [eval file join $np]
1184     if {[file isdirectory $path]} return
1185     if {[string compare $data(-showparent) {}] && \
1186             [string match $data(-showparent) [lindex $np end]]} {
1187         $w config -root [file dir $data(-root)]
1188     }
1189 }
1190
1191 ;proc Hierarchy:WidgetLook { W np isopen } {
1192     upvar \#0 $W data
1193     if {$data(-showall)} {
1194         set w [lindex $np end]
1195     } else {
1196         set w [join $np {}]
1197         regsub {\.\.} $w {.} w
1198     }
1199     if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
1200     return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
1201 }
1202
1203 ;proc Hierarchy:WidgetList { W np } {
1204     upvar \#0 $W data
1205     if {$data(-showall)} {
1206         set w [lindex $np end]
1207     } else {
1208         set w [join $np {}]
1209         regsub {\.\.} $w {.} w
1210     }
1211     set kids {}
1212     foreach i [lsort [winfo children $w]] {
1213         if {$data(-showall)} {
1214             lappend kids $i
1215         } else {
1216             lappend kids [file extension $i]
1217         }
1218     }
1219     return $kids
1220 }
1221
1222 ;proc Hierarchy:WidgetActivate { w np isopen } {}
1223
1224
1225 ## BITMAPS
1226 ##
1227 image create bitmap bmp:dir -data {#define folder_width 16
1228 #define folder_height 12
1229 static char folder_bits[] = {
1230   0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
1231   0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1232 image create bitmap bmp:dir_plus -data {#define folder_plus_width 16
1233   #define folder_plus_height 12
1234 static char folder_plus_bits[] = {
1235   0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
1236   0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1237 image create bitmap bmp:dir_minus -data {#define folder_minus_width 16
1238 #define folder_minus_height 12
1239 static char folder_minus_bits[] = {
1240   0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
1241   0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1242 image create bitmap bmp:up -data {#define up.xbm_width 16
1243 #define up.xbm_height 12
1244 static unsigned char up.xbm_bits[] = {
1245   0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
1246   0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
1247 image create bitmap bmp:text -data {#define text_width 15
1248 #define text_height 14
1249 static char text_bits[] = {
1250   0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
1251   0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}
1252
1253 return