Stringscan

<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>Stringscan</string>
	<key>CFBundleGetInfoString</key>
	<string>Stringscan $1 (c) 2018 WordTech Communications LLC</string>
        <key>NSPrincipalClass</key>
        <string>NSApplication</string>
<key>NSHighResolutionCapable</key>
	<true/>
	<key>LSMinimumSystemVersionByArchitecture</key>
	<dict>
	<key>i386</key>
	<string>10.13</string>
	<key>x86_64</key>
	<string>10.13</string>
	</dict>
	<key>LSArchitecturePriority</key>
<array>
<string>x86_64</string>
<string>i386</string>
</array>
	<key>LSApplicationCategoryType</key>
	<string>public.app-category.utilities</string>
	<key>NSHumanReadableCopyright</key>
	<string>(c) 2018 WordTech Communications LLC</string>
	<key>CFBundleIconFile</key>
	<string>stringscan.icns</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleDocumentTypes</key>
	<array>
		<dict>
................................................................................
	<key>CFBundlePackageType</key>
	<string>APPL</string>
	<key>CFBundleShortVersionString</key>
	<string>$1</string>
	<key>CFBundleVersion</key>
	<string>$1</string>
	<key>LSMinimumSystemVersion</key>
	<string>10.13</string>
	<key>LSRequiresCarbon</key>
	<true/>	
	<key>NSSupportsAutomaticTermination</key>
	<string>YES</string>
	<key>NSSupportsSuddenTermination</key>
	<string>YES</string>






</dict>
</plist>
EOT


/usr/local/ruby/bin/ruby-beautify -c 4 -s stringscan.rb > main.rb
ruby2app
................................................................................

xattr -cr build/Stringscan.app

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  build/Stringscan.app

echo "Creating and signing DMG file..."

hdiutil create  -srcfolder build -fs HFS+ -volname Stringscan Stringscan.dmg

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  Stringscan.dmg

echo "Uploading DMG..."

upload Stringscan.dmg updates

upload stringscan-changes.tcl

upload stringscan-version.tcl

cd ../

#create archive of entire source tree
tar cvfz Stringscan-$1.tgz Stringscan


echo "Done."

<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>Stringscan</string>
	<key>CFBundleGetInfoString</key>
	<string>Stringscan $1 (c) 2020 WordTech Communications LLC</string>
        <key>NSPrincipalClass</key>
        <string>NSApplication</string>
<key>NSHighResolutionCapable</key>
	<true/>
	<key>LSMinimumSystemVersionByArchitecture</key>
	<dict>


	<key>x86_64</key>
	<string>10.15</string>
	</dict>
	<key>LSArchitecturePriority</key>
<array>
<string>x86_64</string>
<string>i386</string>
</array>
	<key>LSApplicationCategoryType</key>
	<string>public.app-category.utilities</string>
	<key>NSHumanReadableCopyright</key>
	<string>(c) 2020 WordTech Communications LLC</string>
	<key>CFBundleIconFile</key>
	<string>stringscan.icns</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleDocumentTypes</key>
	<array>
		<dict>
................................................................................
	<key>CFBundlePackageType</key>
	<string>APPL</string>
	<key>CFBundleShortVersionString</key>
	<string>$1</string>
	<key>CFBundleVersion</key>
	<string>$1</string>
	<key>LSMinimumSystemVersion</key>
	<string>10.15</string>
	<key>LSRequiresCarbon</key>
	<true/>	
	<key>NSSupportsAutomaticTermination</key>
	<string>YES</string>
	<key>NSSupportsSuddenTermination</key>
	<string>YES</string>
	<key>OSAScriptingDefinition</key>
	<string>Wish.sdef</string>
<key>CFBundleHelpBookFolder</key>
	<string>Stringscan User Help.help</string>
	<key>CFBundleHelpBookName</key>
	<string>Stringscan User Help</string>
</dict>
</plist>
EOT


/usr/local/ruby/bin/ruby-beautify -c 4 -s stringscan.rb > main.rb
ruby2app
................................................................................

xattr -cr build/Stringscan.app

codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  build/Stringscan.app

echo "Creating and signing DMG file..."

#hdiutil create  -srcfolder build -fs HFS+ -volname Stringscan Stringscan.dmg

#codesign  --signature-size 9400 -f -s "Developer ID Application: Kevin Walzer" --verbose=2  Stringscan.dmg

echo "Uploading DMG..."

#upload Stringscan.dmg updates

#upload stringscan-changes.tcl

#upload stringscan-version.tcl

cd ../

#create archive of entire source tree
#tar cvfz Stringscan-$1.tgz Stringscan


echo "Done."

#
# Tcl package index file
#
package ifneeded aem 1.0 "
    package require Tk 8.5-
    if {\"AppKit\" ni \[winfo server .\]} {error {TkAqua Cocoa required}}
        load [list [file join $dir libaem1.0.dylib]] aem"

	    event generate . <<DarkAqua>>
	} else {
	    event generate . <<LightAqua>>
	}
    }
    
    
    bind all <<LightAqua>> {changeImagesLight}
    bind all <<DarkAqua>> {changeImagesDark}
    
    namespace export *
    
}

	    event generate . <<DarkAqua>>
	} else {
	    event generate . <<LightAqua>>
	}
    }
    
    



    namespace export *
    
}

    #raise window if closed--dock click
    proc ::tk::mac::ReopenApplication {} {
	if { [wm state .] == "withdrawn"} {
	    wm state . normal
	    raise .
	} else {
	    wm deiconify .
	    raise .
	}
    }

# autoscroll.tcl --
#
#       Package to create scroll bars that automatically appear when
#       a window is too small to display its content.
#
# Copyright (c) 2003    Kevin B Kenny <kennykb@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: autoscroll.tcl,v 1.8 2005/06/01 02:37:51 andreas_kupries Exp $

package require Tk
package provide autoscroll 1.1

namespace eval ::autoscroll {
    namespace export autoscroll unautoscroll
    bind Autoscroll <Destroy> [namespace code [list destroyed %W]]
    bind Autoscroll <Map> [namespace code [list map %W]]
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::autoscroll --
 #
 #       Create a scroll bar that disappears when it is not needed, and
 #       reappears when it is.
 #
 # Parameters:
 #       w    -- Path name of the scroll bar, which should already exist
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       The widget command is renamed, so that the 'set' command can
 #       be intercepted and determine whether the widget should appear.
 #       In addition, the 'Autoscroll' bind tag is added to the widget,
 #       so that the <Destroy> event can be intercepted.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::autoscroll { w } {
    if { [info commands ::autoscroll::renamed$w] != "" } { return $w }
    rename $w ::autoscroll::renamed$w
    interp alias {} ::$w {} ::autoscroll::widgetCommand $w
    bindtags $w [linsert [bindtags $w] 1 Autoscroll]
    eval [list ::$w set] [renamed$w get]
    return $w
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::unautoscroll --
 #
 #       Return a scrollbar to its normal static behavior by removing
 #       it from the control of this package.
 #
 # Parameters:
 #       w    -- Path name of the scroll bar, which must have previously
 #               had ::autoscroll::autoscroll called on it.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       The widget command is renamed to its original name. The widget
 #       is mapped if it was not currently displayed. The widgets
 #       bindtags are returned to their original state. Internal memory
 #       is cleaned up.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::unautoscroll { w } {
    if { [info commands ::autoscroll::renamed$w] != "" } {
        variable grid
        rename ::$w {}
        rename ::autoscroll::renamed$w ::$w
        if { [set i [lsearch -exact [bindtags $w] Autoscroll]] > -1 } {
            bindtags $w [lreplace [bindtags $w] $i $i]
        }
        if { [info exists grid($w)] } {
            eval [join $grid($w) \;]
            unset grid($w)
        }
    }
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::widgetCommand --
 #
 #       Widget command on an 'autoscroll' scrollbar
 #
 # Parameters:
 #       w       -- Path name of the scroll bar
 #       command -- Widget command being executed
 #       args    -- Arguments to the commane
 #
 # Results:
 #       Returns whatever the widget command returns
 #
 # Side effects:
 #       Has whatever side effects the widget command has.  In
 #       addition, the 'set' widget command is handled specially,
 #       by gridding/packing the scroll bar according to whether
 #       it is required.
 #
 #------------------------------------------------------------

proc ::autoscroll::widgetCommand { w command args } {
    variable grid
    if { $command == "set" } {
        foreach { min max } $args {}
        if { $min <= 0 && $max >= 1 } {
            switch -exact -- [winfo manager $w] {
                grid {
                    lappend grid($w) "[list grid $w] [grid info $w]"
                    grid forget $w
                }
                pack {
                    foreach x [pack slaves [winfo parent $w]] {
                        lappend grid($w) "[list pack $x] [pack info $x]"
                    }
                    pack forget $w
                }
            }
        } elseif { [info exists grid($w)] } {
            eval [join $grid($w) \;]
            unset grid($w)
        }
    }
    return [eval [list renamed$w $command] $args]
}


 #----------------------------------------------------------------------
 #
 # ::autoscroll::destroyed --
 #
 #       Callback executed when an automatic scroll bar is destroyed.
 #
 # Parameters:
 #       w -- Path name of the scroll bar
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       Cleans up internal memory.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::destroyed { w } {
    variable grid
    catch { unset grid($w) }
    rename ::$w {}
}


 #----------------------------------------------------------------------
 #
 # ::autoscroll::map --
 #
 #       Callback executed when an automatic scroll bar is mapped.
 #
 # Parameters:
 #       w -- Path name of the scroll bar.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       Geometry of the scroll bar's top-level window is constrained.
 #
 # This procedure keeps the top-level window associated with an
 # automatic scroll bar from being resized automatically after the
 # scroll bar is mapped.  This effect avoids a potential endless loop
 # in the case where the resize of the top-level window resizes the
 # widget being scrolled, causing the scroll bar no longer to be needed.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::map { w } {
    wm geometry [winfo toplevel $w] [wm geometry [winfo toplevel $w]]
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::wrap --
 #
 #       Arrange for all new scrollbars to be automatically autoscrolled
 #
 # Parameters:
 #       None.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       ::scrollbar is overloaded to automatically autoscroll any new
 #          scrollbars.
 #
 #----------------------------------------------------------------------

proc ::autoscroll::wrap {} {
    if {[info commands ::autoscroll::_scrollbar] != ""} {return}
    rename ::scrollbar ::autoscroll::_scrollbar
    proc ::scrollbar {w args} {
        eval ::autoscroll::_scrollbar [list $w] $args
        ::autoscroll::autoscroll $w
        return $w
    }
}

 #----------------------------------------------------------------------
 #
 # ::autoscroll::unwrap --
 #
 #       Turns off automatic autoscrolling of new scrollbars. Does not
 #         effect existing scrollbars.
 #
 # Parameters:
 #       None.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       ::scrollbar is returned to its original state
 #
 #----------------------------------------------------------------------

proc ::autoscroll::unwrap {} {
    if {[info commands ::autoscroll::_scrollbar] == ""} {return}
    rename ::scrollbar {}
    rename ::autoscroll::_scrollbar ::scrollbar
}

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.2] } { return }
package ifneeded autoscroll 1.1 [list source [file join $dir autoscroll.tcl]]

## -*- tcl -*-
# ### ### ### ######### ######### #########

# Known issue :: It is unspecified who is responsible for the images
#                after they are used in the canvas. The canvas
#                currently doesn't delete them. Meaning, this is
#                likely leaking memory like mad when switching between
#                sources, and dragging around.

# sqmap = square map.

# Ideas to work on ...

# -- Factor the low-level viewport tracking and viewport stabilization
#    across scroll-region changes out into its own canvas class.

# -- Factor the grid layer handling into its own class. That is a
#    requisite for the handling of multiple layers,

# -- Create a hexmap, i.e. hexagonal tiling. This can be done with
#    images as well, with parts properly transparent and then
#    positioned to overlap. Regarding coordinates this can be seen
#    as a skewed cartesian system, so only 2 coordinates required

# -- Consider viewport stabilization for when the canvas is resized.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4          ; # No {*}-expansion! :(
package require snit             ; # 
package require uevent::onidle   ; # Some defered actions.
package require cache::async 0.3 ; # Internal tile cache.

# ### ### ### ######### ######### #########
##

snit::widgetadaptor canvas::sqmap {
    # ### ### ### ######### ######### #########
    ## API

    # All canvas options, except for -scrollregion are accepted by
    # this widget(adaptor), and propagated to the embedded canvas. The
    # region is always implicitly (0,0,w,h), with w and h computed
    # from the number of grid rows, columns and the cell dimensions.

    delegate option * to hull except -scrollregion

    # All canvas methods are accepted and propagated to the embedded
    # canvas. Some of them we intercept however, to either impose
    # restrictions (*), or get information we need and not available
    # otherwise (**).

    # (*) The images used as background have to stay lower than all
    #     user-created items, to be that background. We cannot allow
    #     them to be raised, nor must others go below them.

    #     If we were extremely rigourous we would have to intercept
    #     all methods and filter out our internal tags and items ids,
    #     to make them completely invisible to the user. The last 5%
    #     needing 90% of the effort. *** Defered ***

    # (**) Dragging changes the viewport, we do not see this without
    #      interception.

    delegate method *           to hull except {lower raise scan xview yview}
    delegate method {scan mark} to hull as {scan mark}

    # New options: Information about the grid, and where to get the
    # images.
    # rows    = number of rows the grid consists of. <0 <=> unlimited
    # columns = s.a., columns
    # cell-width   = width of a cell in the grid, in pixels
    # cell-height  = s.a., height
    # cell-source  = command prefix called to get the image for a cell in the grid.

    option -grid-cell-width   -default 0  -configuremethod O-ReconfigureNum -type {snit::integer -min 0}
    option -grid-cell-height  -default 0  -configuremethod O-ReconfigureNum -type {snit::integer -min 0}
    option -grid-cell-command -default {} -configuremethod O-ReconfigureStr
    option -scrollregion      -default {} -configuremethod O-ReconfigureStr

    # NOTE AK, maybe, for the future.
    # rows/columns - we may wish to have min/max values, if any to represent
    #              - grid boundaries.
    #option -grid-rows        -default 0  -configuremethod O-ReconfigureNum
    #option -grid-columns     -default 0  -configuremethod O-ReconfigureNum

    # NOTE !!! Use -grid-show-borders only for short-term debugging.
    # NOTE !!! The items created when true are never deleted, i.e. leaking memory

    option -grid-show-borders -default 0 -type snit::boolean

    option -viewport-command -default {} -configuremethod O-vp-command

    constructor {args} {
	installhull using canvas

	install reconfigure using uevent::onidle ${selfns}::reconfigure \
	    [mymethod Reconfigure]

	install redraw using uevent::onidle ${selfns}::redraw \
	    [mymethod Redraw]

	install tilecache using cache::async ${selfns}::tilecache \
	    [mymethod Tile] -full-async-results 0
	# Configuration means synchronous return of in-cache results.
	# This is needed to get proper use and disposal of ->
	# myfreeitems.

	bind $win <Configure> [mymethod Configure]

	$self configurelist $args
	return
    }

    # ### ### ### ######### ######### #########
    ## API. Define/Remove images from grid cells. These are the main
    ## commands to control grid appearance. The -grid-cell-command should
    ## use these commands as well to provide its results to the
    ## widget.

    method {image set} {at image} {
	$tilecache set $at $image

	# Nothing more is required for an invisible cell.
	if {![info exists myvisible($at)]} return

	# For empty cells we create proper items now.
	set theitem $myvisible($at)
	if {$theitem eq ""} {
	    set theitem [$self GetItem [GridToPixel $at]]
	    set myvisible($at) $theitem
	}

	# Show the chosen image
	$hull itemconfigure $theitem -image $image
	return
    }

    method {image unset} {at} {
	$tilecache unset $at

	# Nothing more is required for an invisible cell.
	if {![info exists myvisible($at)]} return

	# Nothing more is required for an empty cell.
	set theitem $myvisible($at)
	if {$theitem eq ""} return

	# Mark the cell as empty and drop the associated item.
	set myvisible($at) ""
	$hull delete $theitem
	return
    }

    # ### ### ### ######### ######### #########
    ## Force a full reload of all (visible) cells.

    method flush {} {
	$tilecache clear
	set mypixelview {}
	#puts REDRAW-RQ/flush
	$redraw request
	return
    }

    # ### ### ### ######### ######### #########
    ## Intercepting the methods changing the display order, to ensure
    ## that our grid is kept at the bottom. It is the background after
    ## all.

    method raise {args} {
	eval [linsert $args 0 $hull raise]
	# Ensure that our cells stay at the bottom.
	$hull lower $ourtag
	return
    }

    method lower {args} {
	eval [linsert $args 0 $hull lower]
	# Ensure that our cells stay at the bottom.
	$hull lower $ourtag
	return
    }

    # ### ### ### ######### ######### #########
    ## Intercepting the dragto command to keep track of the
    ## viewport. See the scroll method interception below too.

    # NOTE: 'scan mark' interception will be needed if we wish to
    # allow items to float in place regardless of dragging (i.e. as UI
    # elements, for example a zoom-scale).

    method {scan dragto} {x y {gain 1}} {
	# Regular handling of dragging ...
	$hull scan dragto $x $y $gain

	# ... then compute and record the changed viewport, and
	# request a redraw to be done when the system has time for it
	$self SetPixelView
	return
    }

    # ### ### ### ######### ######### #########
    ## Intercepting the scroll methods to keep track of the viewport.
    ## The canvas has no way to report changes on its own. No
    ## callbacks, nothing. See the dragto interception above too.

    method xview {args} {
	# Regular handling of scrolling ...
	set res [eval [linsert $args 0 $hull xview]]
	# Keep track of the viewport in case of changes.
	if {[llength $args]} { $self SetPixelView }
	return $res
    }

    method yview {args} {
	# Regular handling of scrolling ...
	set res [eval [linsert $args 0 $hull yview]]
	# Keep track of the viewport in case of changes.
	if {[llength $args]} { $self SetPixelView }
	return $res
    }

    # ### ### ### ######### ######### #########
    ## Intercept <Configure> events on the canvas. This changes the
    ## viewport. At the time the event happens the new viewport is not
    ## yet known, as this is done in a canvas-internal idle-handler. We
    ## simply trigger our redraw in our idle-handler, and force it to
    ## recompute the viewport.

    method Configure {} {
	set mypixelview {} ; # Force full recalculation.
	#puts REDRAW-RQ/configure
	$redraw request
	return
    }

    # ### ### ### ######### ######### #########

    method O-vp-command {o v} {
        #puts $o=$v
        if {$options($o) eq $v} return
        set  options($o) $v
        set myhasvpcommand [expr {!![llength $v]}]
        if {!$myhasvpcommand} return
        # Callback changed and ok, request first call with current
        # settings.
        $self PixelViewExport
        return
    }

    variable myhasvpcommand     0 ; # Track use of viewport-command callback

    method PixelViewExport {} {
        if {!$myhasvpcommand} return
	if {![llength $mypixelview]} return
        foreach {xl yt xr yb} $mypixelview break
        uplevel \#0 [linsert $options(-viewport-command) end $xl $yt $xr $yb]
        return
    }

    method SetPixelView {} {
	set mypixelview [PV]
	$self PixelViewExport
	# Viewport changes imply redraws
	#puts REDRAW-RQ/set-pixel-view
	$redraw request
	return
    }

    proc PV {} {
        upvar 1 hull hull win win
        return [list \
                    [$hull canvasx 0] \
                    [$hull canvasy 0] \
                    [$hull canvasx [winfo width $win]] \
                    [$hull canvasy [winfo height $win]]]
    }

    # ### ### ### ######### ######### #########
    ## Option processing. Any changes force a refresh of the grid
    ## information, and then a redraw.

    method O-ReconfigureNum {o v} {
	#puts $o=$v
	if {$options($o) == $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-ReconfigureStr {o v} {
	#puts $o=$v
	if {$options($o) eq $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    component reconfigure
    method Reconfigure {} {
	#puts /reconfigure

	# The grid definition has changed, in parts, or all. We have
	# to redraw the background, even if nothing else was changed.
	# Here we commit all changed option values to the engine.
	# This is the only place accessing the options array.

	set oldsr $myscrollregion

	set mygridwidth    $options(-grid-cell-width)
	set mygridheight   $options(-grid-cell-height)
	set mygridcmd      $options(-grid-cell-command)
	set myscrollregion $options(-scrollregion)

	# Commit region change to the canvas itself

	$hull configure -scrollregion $myscrollregion

	# Flush the cache to force a reload of the entire visible
	# area now, and of the invisible part later when scrolling.
	$tilecache clear

	# Now save and restore the view, keeping the center of the
	# view as stable as possible across the transition. Note, the
	# scrapyard at the end of this file contains the same
	# calculations in long form, i.e. all steps written out. Here
	# the various expressions are inlined and simplified.

	foreach { sxl  syt  sxr  syb} $oldsr break
	if {[llength $oldsr] && (($sxr - $sxl) > 0) && (($syb - $syt) > 0)} {
	    # Old and new scroll regions.
	    foreach {nsxl nsyt nsxr nsyb} $myscrollregion break

	    #puts OSR=($oldsr)
	    #puts NSR=($myscrollregion)

	    # Get current pixel view, and limit it to the old
	    # scrollregion (as the canvas may show more than the
	    # scrollregion).
	    foreach {xl yt xr yb} $mypixelview break
	    if {$xl < $sxl} { set xl $sxl }
	    if {$xr > $sxr} { set xr $sxr }
	    if {$yt < $syt} { set yt $syt }
	    if {$yb > $syb} { set yb $syb }

	    # Determine the center of the pixel view, as fractions
	    # relative to old scroll origin.
	    set xcfrac [expr {double((($xr + $xl)/2) - $sxl) / ($sxr - $sxl)}]
	    set ycfrac [expr {double((($yt + $yb)/2) - $syt) / ($syb - $syt)}]

	    # The fractions for the topleft corner are the fractions
	    # of the center less the (fractional manhattan radii
	    # around the center, relative to the new region).
	    set nxlfrac [expr {$xcfrac - double(($xr - $xl)/2) / ($nsxr - $nsxl)}]
	    set nytfrac [expr {$ycfrac - double(($yb - $yt)/2) / ($nsyb - $nsyt)}]

	    # Limit the fractions to the scroll origin (>= 0).
	    if {$nxlfrac < 0} { set nxlfrac 0 }
	    if {$nytfrac < 0} { set nytfrac 0 }

	    # Adjust canvas view to keep the center as stable as
	    # possible across the transition. Note that this goes
	    # through our own xview/yview method, calls SetPixelView,
	    # and through that requests a redraw. No need to have the
	    # redraw done by this method.

	    #puts MOVETO\t$nxlfrac,$nytfrac
	    $self xview moveto $nxlfrac
	    $self yview moveto $nytfrac

	    # Note however that we still have to force the redraw to
	    # be fully done.
	    set mypixelview {}
	} else {
	    # Nearly last, redraw full. This happens only because no
	    # view adjustments were done which would have forced it
	    # (see above), so in this cause we have to do it
	    # ourselves.
	    $self Redraw 1
	}
	#puts reconfigure/done
	return
    }

    # ### ### ### ######### ######### #########
    ## Grid redraw. This is done after changes to the viewport,
    ## and when the system is idle.

    component redraw
    method Redraw {{forced 0}} {
	#puts /redraw/$forced

	# Compute viewport in tile coordinates and compare to last.
	# This will tell us where to update and how, if any.

	if {![llength $mypixelview]} {
	    # Undefined viewport, generate baseline, and force
	    # redraw. Scheduling another redraw is however not needed,
	    # so we are inlining only parts of SetPixelView.
	    set mypixelview [PV]
	    $self PixelViewExport
	    #puts \tforce-due-undefined-viewport
	    set forced 1
	}

	set gridview [PixelToGrid $mypixelview]
	foreach {xl yt xr yb} $gridview        break
	foreach {ll lt lr lb} $myshowngridview break

	#puts \tVP=($mypixelview)
	#puts \tVG=($gridview)
	#puts \tVL=($myshowngridview)
	#puts \tF'=$forced

	if {!$forced} {
	    # Viewport unchanged, nothing to do.
	    if {($xl == $ll) && ($xr == $lr) &&
		($yt == $lt) && ($yb == $lb)} {
		#puts \tunchanged,ignore
		return
	    }
	}

	set myfreeitems {}

	# NOTE. The code below is suboptimal. While already better
	# than dropping and recreating all items, we could optimize by
	# using the structure of the viewport (rectangles) to
	# determine directly which grid cells became (in)visible, from
	# the viewport boundary coordinates. This will however be also
	# quite more complex, with all the possible cases of
	# overlapping old and new views.

	if {$forced} {
	    # Forced redraw, simply make all items available
	    # for the upcoming fill.

	    foreach at [array names myvisible] {
		$self FreeCell $at
	    }
	} elseif {[llength $myshowngridview]} {
	    # Scan through the grid cells of the view used at the ast
	    # redraw, and check which of them have become
	    # invisible. Put these on the list of items we can reuse
	    # for the cells which just became visible and thus in need
	    # of items.

	    for {set r $lt} {$r <= $lb} {incr r} {
		for {set c $ll} {$c <= $lr} {incr c} {
		    if {($r < $yt) || ($yb < $r) || ($c < $xl) || ($xr < $c)} {
			# The grid cell dropped out of the viewport.
			$self FreeCell [list $r $c]
			#puts /drop/$idx
		    }
		}
	    }
	}

	# Remember location for next redraw.
	set myshowngridview $gridview

	for {set r $yt} {$r <= $yb} {incr r} {
	    for {set c $xl} {$c <= $xr} {incr c} {
		# Now scan through the cells of the new viewport.
		# Ignore those which are still visible, and create the
		# remainder.
		set at [list $r $c]
		if {[info exists myvisible($at)]} continue
		#puts /make/$idx
		set myvisible($at) "" ; # placeholder
		$tilecache get $at [mymethod image]
		# This cache access re-uses the items in myfreeitems
		# as images already in the cache are delivered
		# synchronously, going through 'image set' and
		# GetItem. Only unknown cells will come later.
	    }
	}

	# Delete all items which were not reused.

	# No, no need. Canvas image items without an image configured
	# for display are effectively invisible, regardless of
	# location. Keep them around for late coming provider results.
	#$self DropFreeItems
	#puts redraw/done
	return
    }

    method FreeCell {at} {
	# Ignore already invisible cells
	if {![info exists myvisible($at)]} return

	# Clear empty cells, nothing more
	set theitem $myvisible($at)
	unset myvisible($at)
	if {$theitem eq ""} return

	# Record re-usable item and clear the image it used. Note that
	# this doesn't delete the image!
	lappend myfreeitems $theitem
	$hull itemconfigure $theitem -image {}
	return
    }

    method {Tile get} {at donecmd} {
	# Tile cache provider callback. The request is routed to the
	# canvas's own tile provider. Responses go to the cache. The
	# cache is set up that its responses go to the 'image ...'
	# methods.

	if {![llength $mygridcmd]} return
	#puts \t\t\t\tGet($at)
	uplevel #0 [linsert $mygridcmd end get $at $donecmd]
	return
    }

    method GetItem {location} {
	# location = pixel position, list (x y)
	if {[llength $myfreeitems]} {
	    # Free items were found, reuse one of them.

	    set theitem     [lindex   $myfreeitems end]
	    set myfreeitems [lreplace $myfreeitems end end]

	    $hull coords        $theitem $location
	    $hull itemconfigure $theitem -image {}
	} else {
	    # Nothing available for reuse, create a new item.

	    if {$options(-grid-show-borders)} {
		# Helper markers for debugging, showing cell borders
		# and coordinates.

		# NOTE !!! Use -grid-show-borders only for short-term debugging.
		# NOTE !!! The items create here are never deleted, i.e. leaking memory

		foreach {x y} $location break
		set x [expr {int($x)}]
		set y [expr {int($y)}]
		set t "<[expr {$y/$mygridheight}],[expr {$x/$mygridwidth}]>"

		incr x 2 ; incr y 2
		set x1 $x ; incr x1 $mygridwidth  ; incr x1 -2
		set y1 $y ; incr y1 $mygridheight ; incr y1 -2

		$hull create rectangle $x $y $x1 $y1 -outline red
		incr x 4 ; incr y 4
		set t [$hull create text $x $y -fill red -anchor nw -text $t]
		$hull raise $t
	    }

	    set theitem [$hull create image $location -anchor nw -tags [list $ourtag]]
	    $hull lower $theitem
	}
	return $theitem
    }

    method DropFreeItems {} {
	if {[llength $myfreeitems]} {
	    eval [linsert $myfreeitems 0 $hull delete]
	    set myfreeitems {}
	}
	return
    }

    # ### ### ### ######### ######### #########

    proc PixelToGrid {pixelview} {
	# Import grid definitions ...
	upvar 1 mygridwidth gcw mygridheight gch
	foreach {xl yt xr yb} $pixelview break

	set coll [expr {int($xl / double($gcw))}]
	set colr [expr {int($xr / double($gcw))}]
	set rowt [expr {int($yt / double($gch))}]
	set rowb [expr {int($yb / double($gch))}]

	# NOTE AK: Maybe limit cell coordinates to boundaries, if
	# NOTE AK: so requested.

	return [list $coll $rowt $colr $rowb]
    }

    proc GridToPixel {at} {
	# Import grid definitions ...
	upvar 1 mygridwidth gcw mygridheight gch
	foreach {r c} $at break
	set y [expr {int($r * double($gch))}]
	set x [expr {int($c * double($gcw))}]
	return [list $x $y]
    }

    # ### ### ### ######### ######### #########
    ## State

    # Active copies of various options. Their use prevents races in
    # the redraw logic using new option values while other parts are
    # not adapted to the changes. The 'Reconfigure' method is
    # responsible for the atomic commit of external changes to the
    # internal engine.

    variable mygridwidth    {} ; # Grid definition used by the engine.
    variable mygridheight   {} ; # s.a.
    variable mygridcmd      {} ; # s.a.
    variable myscrollregion {} ; # s.a.

    # All arrays using grid cells as keys, i.e. 'myvisible', use grid
    # cell coordinates to reference grid cell, in the form
    # 	tuple(row, col)
    #
    # This is the same form taken by the grid-cell-command command prefix and makes
    # use of keys easier as it they are the same across the board.

    # Cache for quick lookup of images and image misses we have seen
    # before, to avoid async round-trips through the
    # grid-cell-command, aka image provider.

    component tilecache

    # Tracking the viewport, i.e. the visible area of the canvas
    # within the scrollregion.

    variable mypixelview     {} ; # Current viewport of the hull, in pixels.
    variable myshowngridview {} ; # Viewport set by last Redraw, in grid cell coordinates

    # Tracking the grid cells shown in the viewport and their canvas
    # items.

    variable myvisible -array {} ; # Visible grid cells, mapped to their canvas items.

    # Transient list of items available for reassignment.

    variable myfreeitems {}

    # Tag used to mark all canvas items used for the grid cell display.

    typevariable ourtag canvas::sqmap::cells

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready

package provide canvas::sqmap 0.2
return

## -*- tcl -*-
# ### ### ### ######### ######### #########

## A discrete zoom-control widget based on buttons. The API is similar
## to a scale.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4        ; # No {*}-expansion :(
package require snit           ; # 
package require uevent::onidle ; # Some defered actions.

# ### ### ### ######### ######### #########
##

snit::widget canvas::zoom {
    # ### ### ### ######### ######### #########
    ## API

    option -orient   -default vertical -configuremethod O-orient -type {snit::enum -values {vertical horizontal}}
    option -levels   -default 0        -configuremethod O-levels -type {snit::integer -min 0}
    option -variable -default {}       -configuremethod O-variable
    option -command  -default {}       -configuremethod O-command

    constructor {args} {
	install reconfigure using uevent::onidle ${selfns}::reconfigure \
	    [mymethod Reconfigure]

	$self configurelist $args
	return
    }

    # ### ### ### ######### ######### #########
    ## Option processing. Any changes force a refresh of the grid
    ## information, and then a redraw.

    method O-orient {o v} {
	#puts $o=$v
	if {$options($o) eq $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-levels {o v} {
	#puts $o=$v
	if {$options($o) == $v} return
	set  options($o) $v
	$reconfigure request
	return
    }

    method O-variable {o v} {
	if {$v eq $options(-variable)} return
	if {$options(-variable) ne ""} {
	    # Drop tracing of now disconnected variable.
	    trace remove variable $options(-variable) write [mymethod ZoomChanged]
	}
	set options(-variable) $v
	if {$options(-variable) ne ""} {
	    # Start to trace the now connected variable. Also import
	    # the zoomlevel external value.
	    upvar #0 $options(-variable) zoomlevel
	    set myzoomlevel $zoomlevel
	    trace add variable $options(-variable) write [mymethod ZoomChanged]
	}
	$reconfigure request
	return
    }

    method O-command {o v} {
	if {$v eq $options(-command)} return
	set options(-command) $v
	# Export current zoom level through the new callback.
	$self Callback
	return
    }

    # ### ### ### ######### ######### #########

    component reconfigure
    method Reconfigure {} {
	# (Re)generate the user interface.

	eval [linsert [winfo children $win] 0 destroy]

	set side $ourside($options(-orient))
	set max  $options(-levels)

	button $win.outz -text - -command [mymethod ZoomOut]
	pack   $win.outz -side $side -expand 0 -fill both

	set mynormalbg [$win.outz cget -bg]

	for {set level 0} {$level < $max} {incr level} {
	    button $win.l$level -text $level -command [mymethod ZoomSet $level]
	    pack   $win.l$level -side $side  -expand 0 -fill both
	}

	button $win.inz -text + -command [mymethod ZoomIn]
	pack   $win.inz -side $side -expand 0 -fill both

	# Validate the current zoom level, it may have become invalid
	# due to a change to max allowed levels.

	set z [Cap $myzoomlevel]
	if {$z == $myzoomlevel} return
	$self Update $z
	return
    }

    # ### ### ### ######### ######### #########
    ## Handle option changes

    # ### ### ### ######### ######### #########
    ## Events from inside and outside which act on the zoomlevel.

    method ZoomChanged {args} {
	upvar #0 $options(-variable) zoomlevel
	set z [Cap $zoomlevel]
	if {$myzoomlevel == $z} return
	$self Update $z
	return
    }

    method ZoomSet {new} {
	if {$new == $myzoomlevel} return
	$self Update $new
	return
    }

    method ZoomIn {} {
	if {$myzoomlevel >= ($options(-levels)-1)} return
	set  new $myzoomlevel
	incr new
	$self Update $new
	return
    }

    method ZoomOut {} {
	if {$myzoomlevel <= 0} return
	set  new $myzoomlevel
	incr new -1
	$self Update $new
	return
    }

    proc Cap {n} {
	upvar 1 options(-levels) max
	if {$n < 0 } { return 0 }
	if {$n >= $max } { return [expr {$max - 1}] }
	return $n
    }

    # ### ### ### ######### ######### #########
    ## Helper, update visible widget state for new level, and
    ## propagate new level to the model as well, via either -variable
    ## or -command.

    method Update {newlevel} {
	catch { $win.l$myzoomlevel configure -bg $mynormalbg }
	set myzoomlevel $newlevel
	catch { $win.l$myzoomlevel configure -bg steelblue }

	if {$options(-variable) ne ""} {
	    upvar #0 $options(-variable) zoomlevel
	    set zoomlevel $myzoomlevel
	}

	$self Callback
	return
    }

    method Callback {} {
	if {![llength $options(-command)]} return
	uplevel #0 [linsert $options(-command) end $win $myzoomlevel]
	return
    }

    # ### ### ### ######### ######### #########
    ## State

    variable mynormalbg {} ; # Color of non-highlighted button.
    variable myzoomlevel 0 ; # Currently chosen zoom level.

    # Map from the -orientation to the widget -side to use for
    # pack'ing.

    typevariable ourside -array {
	vertical   bottom
	horizontal right
    }

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready

package provide canvas::zoom 0.1
return

# ### ### ### ######### ######### #########
## Scrap yard.

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded canvas::sqmap 0.2 [list source [file join $dir canvas_sqmap.tcl]]
package ifneeded canvas::zoom  0.1 [list source [file join $dir canvas_zoom.tcl]]

# chatwidget.tcl --
#
#	This package provides a composite widget suitable for use in chat
#	applications. A number of panes managed by panedwidgets are available
#	for displaying user names, chat text and for entering new comments.
#	The main display area makes use of text widget peers to enable a split
#	view for history or searching.
#
# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: chatwidget.tcl,v 1.4 2008/06/20 22:53:54 patthoyts Exp $

package require Tk 8.5

namespace eval chatwidget {
    variable version 1.1.0

    namespace export chatwidget

    ttk::style layout ChatwidgetFrame {
        Entry.field -sticky news -border 1 -children {
            ChatwidgetFrame.padding -sticky news
        }
    }
    if {[lsearch -exact [font names] ChatwidgetFont] == -1} {
        eval [list font create ChatwidgetFont] [font configure TkTextFont]
        eval [list font create ChatwidgetBoldFont] \
            [font configure ChatwidgetFont] -weight bold
        eval [list font create ChatwidgetItalicFont] \
            [font configure ChatwidgetFont] -slant italic
    }
}

proc chatwidget::chatwidget {w args} {
    Create $w
    interp hide {} $w
    interp alias {} $w {} [namespace origin WidgetProc] $w
    return $w
}

proc chatwidget::WidgetProc {self cmd args} {
    upvar #0 [namespace current]::$self state
    switch -- $cmd {
        hook {
            if {[llength $args] < 2} {
                return -code error "wrong \# args: should be\
                    \"\$widget hook add|remove|list hook_type ?script? ?priority?\""
            }
            return [uplevel 1 [list [namespace origin Hook] $self] $args]
        }
        cget {
            return [uplevel 1 [list [namespace origin Cget] $self] $args]
        }
        configure {
            return [uplevel 1 [list [namespace origin Configure] $self] $args]
        }
        insert {
            return [uplevel 1 [list [namespace origin Insert] $self] $args]
        }
        message {
            return [uplevel 1 [list [namespace origin Message] $self] $args]
        }
        name {
            return [uplevel 1 [list [namespace origin Name] $self] $args]
        }
        topic {
            return [uplevel 1 [list [namespace origin Topic] $self] $args]
        }
        names {
            return [uplevel 1 [list [namespace origin Names] $self] $args]
        }
        entry {
            return [uplevel 1 [list [namespace origin Entry] $self] $args]
        }
        peer {
            return [uplevel 1 [list [namespace origin Peer] $self] $args]
        }
        chat - 
        default {
            return [uplevel 1 [list [namespace origin Chat] $self] $args]
        }
    }
    return
}

proc chatwidget::Chat {self args} {
    upvar #0 [namespace current]::$self state
    if {[llength $args] == 0} {
        return $state(chat_widget)
    }
    return [uplevel 1 [list $state(chat_widget)] $args]
}

proc chatwidget::Cget {self args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- [set what [lindex $args 0]] {
        -chatstate { return $state(chatstate) }
        -history { return $state(history) }
        default {
            return [uplevel 1 [list $state(chat_widget) cget] $args]
        }
    }
}

proc chatwidget::Configure {self args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- [set option [lindex $args 0]] {
        -chatstate {
            if {[llength $args] > 1} { set state(chatstate) [Pop args 1] }
            else { return $state(chatstate) }
        }
        -history {
            if {[llength $args] > 1} { set state(history) [Pop args 1] }
            else { return $state(history) }
        }
        -font {
            if {[llength $args] > 1} {
                set font [Pop args 1]
                set family [font actual $font -family]
                set size [font actual $font -size]
                font configure ChatwidgetFont -family $family -size $size
                font configure ChatwidgetBoldFont -family $family -size $size
                font configure ChatwidgetItalicFont -family $family -size $size
            } else { return [$state(chat_widget) cget -font] }
        }
        default {
            return [uplevel 1 [list $state(chat_widget) configure] $args]
        }
    }
}

proc chatwidget::Peer {self args} {
    upvar #0 [namespace current]::$self state
    if {[llength $args] == 0} {
        return $state(chat_peer_widget)
    }
    return [uplevel 1 [list $state(chat_peer_widget)] $args]
}

proc chatwidget::Topic {self cmd args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- $cmd {
        show { grid $self.topic -row 0 -column 0 -sticky new }
        hide { grid forget $self.topic }
        set  { set state(topic) [lindex $args 0] }
        default {
            return -code error "bad option \"$cmd\":\
                must be show, hide or set"
        }
    }
}

proc chatwidget::Names {self args} {
    upvar #0 [namespace current]::$self state
    set frame [winfo parent $state(names_widget)]
    set pane [winfo parent $frame]
    if {[llength $args] == 0} {
        return $state(names_widget)
    }
    if {[llength $args] == 1 && [lindex $args 0] eq "hide"} {
        return [$pane forget $frame]
    }
    if {[llength $args] == 1 && [lindex $args 0] eq "show"} {
        return [$pane add $frame]
    }
    return [uplevel 1 [list $state(names_widget)] $args] 
}

proc chatwidget::Entry {self args} {
    upvar #0 [namespace current]::$self state
    if {[llength $args] == 0} {
        return $state(entry_widget)
    }
    if {[llength $args] == 1 && [lindex $args 0] eq "text"} {
        return [$state(entry_widget) get 1.0 end-1c]
    }
    return [uplevel 1 [list $state(entry_widget)] $args]
}

proc chatwidget::Message {self text args} {
    upvar #0 [namespace current]::$self state
    set chat $state(chat_widget)

    set mark end
    set type normal
    set nick Unknown
    set time [clock seconds]
    set tags {}

    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -nick { set nick [Pop args 1] }
            -time { set time [Pop args 1] }
            -type { set type [Pop args 1] }
            -mark { set mark [Pop args 1] }
            -tags { set tags [Pop args 1] }
            default {
                return -code error "unknown option \"$option\""
            }
        }
        Pop args
    }

    if {[catch {Hook $self run message $text \
                    -mark $mark -type $type -nick $nick \
                    -time $time -tags $tags}] == 3} then {
        return
    }

    if {$type ne "system"} { lappend tags NICK-$nick }
    lappend tags TYPE-$type
    $chat configure -state normal
    set ts [clock format $time -format "\[%H:%M\]\t"]
    $chat insert $mark $ts [concat BOOKMARK STAMP $tags]
    if {$type eq "action"} {
        $chat insert $mark "   * $nick " [concat BOOKMARK NICK $tags]
        lappend tags ACTION
    } elseif {$type eq "system"} {
    } else {
        $chat insert $mark "$nick\t" [concat BOOKMARK NICK $tags]
    }
    if {$type ne "system"} { lappend tags MSG NICK-$nick }
    #$chat insert $mark $text $tags
    Insert $self $mark $text $tags
    $chat insert $mark "\n" $tags
    $chat configure -state disabled
    if {$state(autoscroll)} {
        $chat see $mark
    }
    return
}

proc chatwidget::Insert {self mark args} {
    upvar #0 [namespace current]::$self state
    if {![info exists state(urluid)]} {set state(urluid) 0}
    set w $state(chat_widget)
    set parts {}
    foreach {s t} $args {
        while {[regexp -indices {\m(https?://[^\s]+)} $s -> ndx]} {
            foreach {fr bk} $ndx break
            lappend parts [string range $s 0 [expr {$fr - 1}]] $t
            lappend parts [string range $s $fr $bk] \
                [linsert $t end URL URL-[incr state(urluid)]]
            set s [string range $s [incr bk] end]
        }
        lappend parts $s $t
    }
    set ws [$w cget -state]
    $w configure -state normal
    eval [list $w insert $mark] $parts
    $w configure -state $ws
}

# $w name add ericthered -group admin -color red
# state(names) {{pat -color red -group admin -thing wilf} {eric ....}}
proc chatwidget::Name {self cmd args} {
    upvar #0 [namespace current]::$self state
    switch -exact -- $cmd {
        list {
            switch -exact -- [lindex $args 0] {
                -full {
                    return $state(names)
                }
                default {
                    foreach item $state(names) { lappend r [lindex $item 0] }
                    return $r
                }
            }
        }
        add {
            if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
                return -code error "wrong # args: should be\
                    \"add nick ?-group group ...?\""
            }
            set nick [lindex $args 0]
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] == -1} {
                array set opts {-group {} -colour black}
                array set opts [lrange $args 1 end]
                lappend state(names) [linsert [array get opts] 0 $nick]
            } else {
                array set opts [lrange [lindex $state(names) $ndx] 1 end]
                array set opts [lrange $args 1 end]
                lset state(names) $ndx [linsert [array get opts] 0 $nick]
            }
            UpdateNames $self
        }
        delete {
            if {[llength $args] != 1} {
                return -code error "wrong # args: should be \"delete nick\""
            }
            set nick [lindex $args 0]
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
                set state(names) [lreplace $state(names) $ndx $ndx]
                UpdateNames $self
            }
        }
        get {
            if {[llength $args] < 1} {
                return -code error "wrong # args:\
                    should be \"get nick\" ?option?"
            }
            set result {}
            set nick [lindex $args 0]
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
                set result [lindex $state(names) $ndx]
                if {[llength $args] > 1} {
                    if {[set ndx [lsearch $result [lindex $args 1]]] != -1} {
                        set result [lindex $result [incr ndx]]
                    } else {
                        set result {}
                    }
                }
            }
            return $result
        }
        default {
            return -code error "bad name option \"$cmd\":\
                must be list, names, add or delete"
        }
    }
}

proc chatwidget::UpdateNames {self} {
    upvar #0 [namespace current]::$self state
    if {[info exists state(updatenames)]} {
        after cancel $state(updatenames)
    }
    set state(updatenames) [after idle [list [namespace origin UpdateNamesExec] $self]]
}

proc chatwidget::UpdateNamesExec {self} {
    upvar #0 [namespace current]::$self state
    unset state(updatenames)
    set names $state(names_widget)
    set chat  $state(chat_widget)
    
    foreach tagname [lsearch -all -inline [$names tag names] NICK-*] {
        $names tag delete $tagname
    }
    foreach tagname [lsearch -all -inline [$names tag names] GROUP-*] {
        $names tag delete $tagname
    }

    $names configure -state normal
    $names delete 1.0 end
    array set groups {}
    foreach item $state(names) {
        set group {}
        if {[set ndx [lsearch $item -group]] != -1} {
            set group [lindex $item [incr ndx]]
        }
        lappend groups($group) [lindex $item 0]
    }

    foreach group [lsort [array names groups]] {
        Hook $self run names_group $group
        $names insert end "$group\n" [list SUBTITLE GROUP-$group]
        foreach nick [lsort -dictionary $groups($group)] {
            $names tag configure NICK-$nick
            unset -nocomplain opts ; array set opts {}
            if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
                array set opts [lrange [lindex $state(names) $ndx] 1 end]
                if {[info exists opts(-color)]} {
                    $names tag configure NICK-$nick -foreground $opts(-color)
                    $chat  tag configure NICK-$nick -foreground $opts(-color)
                }
                eval [linsert [lindex $state(names) $ndx] 0 \
                          Hook $self run names_nick]
            }
            $names insert end $nick\n [list NICK NICK-$nick GROUP-$group]
        }
    }
    $names insert end "[llength $state(names)] nicks\n" [list SUBTITLE]

    $names configure -state disabled
}

proc chatwidget::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

proc chatwidget::Hook {self do type args} {
    upvar #0 [namespace current]::$self state
    set valid {message post names_group names_nick chatstate url}
    if {[lsearch -exact $valid $type] == -1} {
        return -code error "unknown hook type \"$type\":\
                must be one of [join $valid ,]"
    }
    switch -exact -- $do {
	add {
            if {[llength $args] < 1 || [llength $args] > 2} {
                return -code error "wrong # args: should be \"add hook cmd ?priority?\""
            }
            foreach {cmd pri} $args break
            if {$pri eq {}} { set pri 50 }
            lappend state(hook,$type) [list $cmd $pri]
            set state(hook,$type) [lsort -real -index 1 [lsort -unique $state(hook,$type)]]
	}
        remove {
            if {[llength $args] != 1} {
                return -code error "wrong # args: should be \"remove hook cmd\""
            }
            if {![info exists state(hook,$type)]} { return }
            for {set ndx 0} {$ndx < [llength $state(hook,$type)]} {incr ndx} {
                set item [lindex $state(hook,$type) $ndx]
                if {[lindex $item 0] eq [lindex $args 0]} {
                    set state(hook,$type) [lreplace $state(hook,$type) $ndx $ndx]
                    break
                }
            }
            set state(hook,$type)
        }
        run {
            if {![info exists state(hook,$type)]} { return }
            set res ""
            foreach item $state(hook,$type) {
                foreach {cmd pri} $item break
                set code [catch {eval $cmd $args} err]
                if {$code} {
                    ::bgerror "error running \"$type\" hook: $err"
                    break
                } else {
                    lappend res $err
                }
            }
            return $res
        }
        list {
            if {[info exists state(hook,$type)]} {
                return $state(hook,$type)
            }
        }
	default {
	    return -code error "unknown hook action \"$do\":\
                must be add, remove, list or run"
	}
    }
}

proc chatwidget::Grid {w {row 0} {column 0}} {
    grid rowconfigure $w $row -weight 1
    grid columnconfigure $w $column -weight 1
}

proc chatwidget::Create {self} {
    upvar #0 [set State [namespace current]::$self] state
    set state(history) {}
    set state(current) 0
    set state(autoscroll) 1
    set state(names) {}
    set state(chatstatetimer) {}
    set state(chatstate) active

    # NOTE: By using a non-ttk frame as the outermost part we are able
    # to be [wm manage]d. The outermost frame should be invisible at all times.
    set self [frame $self -class Chatwidget \
                  -borderwidth 0 -highlightthickness 0 -relief flat]
    set outer [ttk::panedwindow $self.outer -orient vertical]
    set inner [ttk::panedwindow $outer.inner -orient horizontal]

    # Create a topic/subject header
    set topic [ttk::frame $self.topic]
    ttk::label $topic.label -anchor w -text Topic
    ttk::entry $topic.text -state disabled -textvariable [set State](topic)
    grid $topic.label $topic.text -sticky new -pady {2 0} -padx 1
    Grid $topic 0 1

    # Create the usernames scrolled text
    set names [ttk::frame $inner.names -style ChatwidgetFrame]
    text $names.text -borderwidth 0 -relief flat -font ChatwidgetFont
    ttk::scrollbar $names.vs -command [list $names.text yview]
    $names.text configure -width 10 -height 10 -state disabled \
        -yscrollcommand [list [namespace origin scroll_set] $names.vs $inner 0]
    bindtags $names.text [linsert [bindtags $names.text] 1 ChatwidgetNames]
    grid $names.text $names.vs -sticky news -padx 1 -pady 1
    Grid $names 0 0
    set state(names_widget) $names.text

    # Create the chat display
    set chatf [ttk::frame $inner.chat -style ChatwidgetFrame]
    set peers [ttk::panedwindow $chatf.peers -orient vertical]
    set upper [ttk::frame $peers.upper]
    set lower [ttk::frame $peers.lower]

    set chat [text $lower.text -borderwidth 0 -relief flat -wrap word \
                  -state disabled -font ChatwidgetFont]
    set chatvs [ttk::scrollbar $lower.vs -command [list $chat yview]]
    $chat configure -height 10 -state disabled \
        -yscrollcommand [list [namespace origin scroll_set] $chatvs $peers 1]
    grid $chat $chatvs -sticky news
    Grid $lower 0 0
    set peer [$chat peer create $upper.text -borderwidth 0 -relief flat \
                  -wrap word -state disabled -font ChatwidgetFont]
    set peervs [ttk::scrollbar $upper.vs -command [list $peer yview]]
    $peer configure -height 0 \
        -yscrollcommand [list [namespace origin scroll_set] $peervs $peers 0]
    grid $peer $peervs -sticky news
    Grid $upper 0 0
    $peers add $upper
    $peers add $lower -weight 1
    grid $peers -sticky news -padx 1 -pady 1
    Grid $chatf 0 0
    bindtags $chat [linsert [bindtags $chat] 1 ChatwidgetText]
    set state(chat_widget) $chat
    set state(chat_peer_widget) $peer
    
    # Create the entry widget
    set entry [ttk::frame $outer.entry -style ChatwidgetFrame]
    text $entry.text -borderwidth 0 -relief flat -font ChatwidgetFont
    ttk::scrollbar $entry.vs -command [list $entry.text yview]
    $entry.text configure -height 1 \
        -yscrollcommand [list [namespace origin scroll_set] $entry.vs $outer 0]
    bindtags $entry.text [linsert [bindtags $entry.text] 1 ChatwidgetEntry]
    grid $entry.text $entry.vs -sticky news -padx 1 -pady 1
    Grid $entry 0 0
    set state(entry_widget) $entry.text

    bind ChatwidgetEntry <Return> "[namespace origin Post] \[[namespace origin Self] %W\]"
    bind ChatwidgetEntry <KP_Enter> "[namespace origin Post] \[[namespace origin Self] %W\]"
    bind ChatwidgetEntry <Shift-Return> "#"
    bind ChatwidgetEntry <Control-Return> "#"
    bind ChatwidgetEntry <Key-Up>   "[namespace origin History] \[[namespace origin Self] %W\] prev"
    bind ChatwidgetEntry <Key-Down> "[namespace origin History] \[[namespace origin Self] %W\] next"
    bind ChatwidgetEntry <Key-Tab> "[namespace origin Nickcomplete] \[[namespace origin Self] %W\]"
    bind ChatwidgetEntry <Key-Prior> "\[[namespace origin Self] %W\] chat yview scroll -1 pages"
    bind ChatwidgetEntry <Key-Next> "\[[namespace origin Self] %W\] chat yview scroll 1 pages"
    bind ChatwidgetEntry <Key> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] composing"
    bind ChatwidgetEntry <FocusIn> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] active"
    bind $self <Destroy> "+unset -nocomplain [namespace current]::%W"
    bind $peer       <Map> [list [namespace origin PaneMap] %W $peers 0]
    bind $names.text <Map> [list [namespace origin PaneMap] %W $inner -90]
    bind $entry.text <Map> [list [namespace origin PaneMap] %W $outer -28]

    bind ChatwidgetText <<ThemeChanged>> {
        ttk::style layout ChatwidgetFrame {
            Entry.field -sticky news -border 1 -children {
                ChatwidgetFrame.padding -sticky news
            }
        }
    }

    $names.text tag configure SUBTITLE \
        -background grey80 -font ChatwidgetBoldFont
    $chat tag configure NICK        -font ChatwidgetBoldFont
    $chat tag configure TYPE-system -font ChatwidgetItalicFont
    $chat tag configure URL         -underline 1

    $inner add $chatf -weight 1
    $inner add $names
    $outer add $inner -weight 1
    $outer add $entry
    
    grid $outer -row 1 -column 0 -sticky news -padx 1 -pady 1
    Grid $self 1 0
    return $self
}

proc chatwidget::Self {widget} {
    set class [winfo class [set w $widget]]
    while {[winfo exists $w] && [winfo class $w] ne "Chatwidget"} {
        set w [winfo parent $w]
    }
    if {![winfo exists $w]} {
        return -code error "invalid window $widget" 
    }
    return $w
}

# Set initial position of sash
proc chatwidget::PaneMap {w pane offset} {
    bind $pane <Map> {}
    if {[llength [$pane panes]] > 1} {
        if {$offset < 0} {
            if {[$pane cget -orient] eq "horizontal"} {
                set axis width
            } else {
                set axis height
            }
            #after idle [list $pane sashpos 0 [expr {[winfo $axis $pane] + $offset}]]
            after idle [namespace code [list PaneMapImpl $pane $axis $offset]]
        } else {
            #after idle [list $pane sashpos 0 $offset]
            after idle [namespace code [list PaneMapImpl $pane {} $offset]]
        }
    }
}

proc chatwidget::PaneMapImpl {pane axis offset} {
    if {$axis eq {}} {
        set size 0
    } else {
        set size [winfo $axis $pane]
    }
    set sashpos [expr {$size + $offset}]
    #puts stderr "PaneMapImpl $pane $axis $offset : size:$size sashpos:$sashpos"
    after 0 [list $pane sashpos 0 $sashpos]
}

# Handle auto-scroll smarts. This will cause the scrollbar to be removed if
# not required and to disable autoscroll for the text widget if we are not
# tracking the bottom line.
proc chatwidget::scroll_set {scrollbar pw set f1 f2} {
    $scrollbar set $f1 $f2
    if {($f1 == 0) && ($f2 == 1)} {
	grid remove $scrollbar
    } else {
        if {[winfo manager $scrollbar] eq {}} {}
            if {[llength [$pw panes]] > 1} {
                set pos [$pw sashpos 0]
                grid $scrollbar
                after idle [list $pw sashpos 0 $pos]
            } else {
                grid $scrollbar
            }
        
    }
    if {$set} {
        upvar #0 [namespace current]::[Self $scrollbar] state
        set state(autoscroll) [expr {(1.0 - $f2) < 1.0e-6 }]
    }
}

proc chatwidget::Post {self} {
    set msg [$self entry get 1.0 end-1c]
    if {$msg eq ""} { return -code break "" }
    if {[catch {Hook $self run post $msg}] != 3} {
        $self entry delete 1.0 end
        upvar #0 [namespace current]::$self state
        set state(history) [lrange [lappend state(history) $msg] end-50 end]
        set state(current) [llength $state(history)]
    }
    return -code break ""
}

proc chatwidget::History {self dir} {
    upvar #0 [namespace current]::$self state
    switch -exact -- $dir {
        prev {
            if {$state(current) == 0} { return }
            if {$state(current) == [llength $state(history)]} {
                set state(temp) [$self entry get 1.0 end-1c]
            }
            if {$state(current)} { incr state(current) -1 }
            $self entry delete 1.0 end
            $self entry insert 1.0 [lindex $state(history) $state(current)]
            return
        }
        next {
            if {$state(current) == [llength $state(history)]} { return }
            if {[incr state(current)] == [llength $state(history)] && [info exists state(temp)]} {
                set msg $state(temp)
            } else {
                set msg [lindex $state(history) $state(current)]
            }
            $self entry delete 1.0 end
            $self entry insert 1.0 $msg
        }
        default {
            return -code error "invalid direction \"$dir\":
                must be either prev or next"
        }
    }
}

proc chatwidget::Nickcomplete {self} {
    upvar #0 [namespace current]::$self state
    if {[info exists state(nickcompletion)]} {
        foreach {index matches after} $state(nickcompletion) break
        after cancel $after
        incr index
        if {$index > [llength $matches]} { set index 0 }
        set delta 2c
    } else {
        set delta 1c
        set partial [$self entry get "insert - $delta wordstart" "insert - $delta wordend"]
        set matches [lsearch -all -inline -glob -index 0 $state(names) $partial*]
        set index 0
    }
    switch -exact -- [llength $matches] {
        0 { bell ; return -code break ""}
        1 { set match [lindex [lindex $matches 0] 0]}
        default {
            set match [lindex [lindex $matches $index] 0]
            set state(nickcompletion) [list $index $matches \
                [after 2000 [list [namespace origin NickcompleteCleanup] $self]]]
        }
    }
    $self entry delete "insert - $delta wordstart" "insert - $delta wordend"
    $self entry insert insert "$match "
    return -code break ""
}

proc chatwidget::NickcompleteCleanup {self} {
    upvar #0 [namespace current]::$self state
    if {[info exists state(nickcompletion)]} {
        unset state(nickcompletion)
    }
}

# Update the widget chatstate (one of active, composing, paused, inactive, gone)
# These are from XEP-0085 but seem likey useful in many chat-type environments.
# Note: this state is _per-widget_. This is not the same as [tk inactive]
# active = got focus and recently active
#   composing = typing
#   paused = 5 secs non typing
# inactive = no activity for 30 seconds
# gone = no activity for 2 minutes or closed the window
proc chatwidget::Chatstate {self what} {
    upvar #0 [namespace current]::$self state
    after cancel $state(chatstatetimer)
    switch -exact -- $what {
        composing - active {
            set state(chatstatetimer) [after 5000 [namespace code [list Chatstate $self paused]]]
        }
        paused {
            set state(chatstatetimer) [after 25000 [namespace code [list Chatstate $self inactive]]]
        }
        inactive {
            set state(chatstatetimer) [after 120000 [namespace code [list Chatstate $self gone]]]
        }
        gone {}
    }
    set fire [expr {$state(chatstate) eq $what ? 0 : 1}]
    set state(chatstate) $what
    if {$fire} {
        catch {Hook $self run chatstate $what}
        event generate $self <<ChatwidgetChatstate>>
    }
}
    
package provide chatwidget $chatwidget::version

package ifneeded chatwidget 1.1.0 [list source [file join $dir chatwidget.tcl]]

# crosshair.tcl -
#
# Kevin's mouse-tracking crosshair in Tk's canvas widget.
#
# This package displays a mouse-tracking crosshair in the canvas widget.
#
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
# Redistribution permitted under the terms in
#  http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tcl/tcl/license.terms?rev=1.3&content-type=text/plain
#
# Copyright (c) 2008 Andreas Kupries. Added ability to provide the tracking
#               information to external users.
#

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.4
package require Tk  8.4

namespace eval ::crosshair {}

# ### ### ### ######### ######### #########
## API 

#----------------------------------------------------------------------
#
# ::crosshair::crosshair --
#
#       Displays a pair of cross-hairs in a canvas widget.  The
#       cross-hairs track the pointing device.
#
# Parameters:
#       w    - The path name of the canvas
#       args - Remaining args are treated as options as for
#              [$w create line].  Of particular interest are
#              -fill and -dash.
#
# Results:
#       None.
#
# Side effects:
#       Adds the 'crosshair' bind tag to the widget so that 
#       crosshairs will be displayed on pointing device motion.
#
#----------------------------------------------------------------------

proc ::crosshair::crosshair { w args } {
    variable config
    set opts(args) $args
    bindtags $w [linsert [bindtags $w] 1 Crosshair]
    set config($w) [array get opts]
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::off -
#
#       Removes the crosshairs from a canvas widget
#
# Parameters:
#       w - The canvas from which the crosshairs should be removed
#
# Results:
#       None.
#
# Side effects:
#       If the widget has crosshairs, they are removed. The 'Crosshair'
#       bind tag is removed so that mouse motion will not restore them.
#
#----------------------------------------------------------------------

proc ::crosshair::off { w } {
    variable config
    if { ![info exists config($w)] } return
    array set opts $config($w)
    if { [winfo exists $w] } {
	Hide
	set bindtags [bindtags $w]
	set pos [lsearch -exact $bindtags Configure]
	if { $pos >= 0 } {
	    eval [list bindtags $w] [lreplace $bindtags $pos $pos]
	}
    }
    unset config($w)
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::configure --
#
#       Changes the appearance of crosshairs in the canvas widget.
#
# Parameters:
#       w    - Path name of the widget
#       args - Additional args are flags to [$w create line]. Interesting
#              ones include -fill and -dash
#
# Results:
#       Returns the crosshairs' current configuration settings. 
#
#----------------------------------------------------------------------

proc ::crosshair::configure { w args } {
    variable config
    if { ![info exists config($w)] } {
	return -code error "no crosshairs in $w"
    }
    array set opts $config($w)
    if { [llength $args] > 0 } {
	array set flags $opts(args)
	array set flags $args
	set opts(args) [array get flags]
	if { [info exists opts(hhairl)] } {
	    eval [list $w itemconfig $opts(hhairl)] $args
	    eval [list $w itemconfig $opts(hhairr)] $args
	    eval [list $w itemconfig $opts(vhaird)] $args
	    eval [list $w itemconfig $opts(vhairu)] $args
	}
	set config($w) [array get opts]
    }
    return $opts(args)
}

#----------------------------------------------------------------------
#
# ::crosshair::track --
#
#       (De)activates reporting of the cross-hair coordinates through
#       a user-specified callback.
#
# Parameters:
#       which - What to do (legal values: 'on', 'off').
#       w     - The path name of the canvas
#       cmd   - Only for which == 'on', the command prefix to
#               use for execute.
#
#	The cmd is called with 7 arguments: The widget, and the x- and
#	y-coordinates of 3 points: Crosshair position, and the topleft
#	and bottomright corners of the canvas viewport. All position
#	data in pixels.
#
# Results:
#       None.
#
# Side effects:
#      See description.
#
#----------------------------------------------------------------------

proc ::crosshair::track { which w args } {
    variable config

    if { ![info exists config($w)] } {
	return -code error "no crosshairs in $w"
    }

    if { ![info exists config($w)] } return
    array set opts $config($w)

    switch -exact -- $which {
	on {
	    if {[llength $args] != 1} {
		return -code error "wrong\#args: Expected 'on w cmdprefix'"
	    }
	    set opts(track) [lindex $args 0]
	}
	off {
	    if {[llength $args] != 0} {
		return -code error "wrong\#args: Expected 'off w'"
	    }
	    catch { unset opts(track) }
	}
    }

    set config($w) [array get opts]
    return
}

# ### ### ### ######### ######### #########
## Internal commands.

#----------------------------------------------------------------------
#
# ::crosshair::Hide --
#
#       Hides the crosshair temporarily
#
# Parameters:
#       w - Canvas widget containing crosshairs
#
# Results:
#       None.
#
# Side effects:
#       If the canvas contains crosshairs, they are hidden.
#
# This procedure is invoked in response to the <Leave> event to
# hide the crosshair when the pointer is not in the window.
#
#----------------------------------------------------------------------

proc ::crosshair::Hide { w } {
    variable config
    if { ![info exists config($w)] } return
    array set opts $config($w)
    if { ![info exists opts(hhairl)] } return
    $w delete $opts(hhairl)
    $w delete $opts(hhairr)
    $w delete $opts(vhaird)
    $w delete $opts(vhairu)
    unset opts(hhairl)
    unset opts(hhairr)
    unset opts(vhairu)
    unset opts(vhaird)
    set config($w) [array get opts]
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::Unhide --
#
#       Places a hidden crosshair back on display
#
# Parameters:
#       w - Canvas widget containing crosshairs
#       x - x co-ordinate relative to the window where the vertical
#           crosshair should appear
#       y - y co-ordinate relative to the window where the horizontal
#           crosshair should appear.
#
# Results:
#       None.
#
# Side effects:
#       Crosshairs are put on display.
#
# This procedure is invoked in response to the <Enter> event to
# restore the crosshair to the display.
#
#----------------------------------------------------------------------

proc ::crosshair::Unhide { w x y } {
    variable config
    if { ![info exists config($w)] } return
    array set opts $config($w)
    if { ![info exists opts(hhairl)] } {
	set opts(hhairl) [eval [list $w create line 0 0 0 0] $opts(args)]
	set opts(hhairr) [eval [list $w create line 0 0 0 0] $opts(args)]
	set opts(vhaird) [eval [list $w create line 0 0 0 0] $opts(args)]
	set opts(vhairu) [eval [list $w create line 0 0 0 0] $opts(args)]
    }
    set config($w) [array get opts]
    Move $w $x $y
    return
}

#----------------------------------------------------------------------
#
# ::crosshair::Move --
#
#       Moves the crosshairs in a camvas
#
# Parameters:
#       w - Canvas widget containing crosshairs
#       x - x co-ordinate relative to the window where the vertical
#           crosshair should appear
#       y - y co-ordinate relative to the window where the horizontal
#           crosshair should appear.
#
# Results:
#       None.
#
# Side effects:
#       Crosshairs move.
#
# This procedure is called in response to a <Motion> event in a canvas
# with crosshairs.
#
#----------------------------------------------------------------------

proc ::crosshair::Move { w x y } {
    variable config
    array set opts $config($w)
    set opts(x) [$w canvasx $x]
    set opts(y) [$w canvasy $y]
    set opts(x0) [$w canvasx 0]
    set opts(x1) [$w canvasx [winfo width $w]]
    set opts(y0) [$w canvasy 0]
    set opts(y1) [$w canvasy [winfo height $w]]
    if { [info exists opts(hhairl)] } {
	# +/-4 is the minimal possible distance which still prevents
	# the canvas from choosing the crosshairs as 'current' object
	# under the cursor.
	set n 4
	$w coords $opts(hhairl) $opts(x0) $opts(y) [expr {$opts(x)-$n}] $opts(y)
	$w coords $opts(hhairr) [expr {$opts(x)+$n}] $opts(y) $opts(x1) $opts(y)
	$w coords $opts(vhairu) $opts(x) $opts(y0) $opts(x) [expr {$opts(y)-$n}]
	$w coords $opts(vhaird) $opts(x) [expr {$opts(y)+$n}] $opts(x) $opts(y1)
	$w raise $opts(hhairl)
	$w raise $opts(hhairr)
	$w raise $opts(vhaird)
	$w raise $opts(vhairu)
    }
    set config($w) [array get opts]
    if {[info exists opts(track)]} {
	uplevel \#0 [linsert $opts(track) end $w $opts(x) $opts(y) $opts(x0) $opts(y0) $opts(x1) $opts(y1)]
    }
    return
}

# ### ### ### ######### ######### #########
## State

namespace eval ::crosshair {
    
    # Array holding information describing crosshairs in canvases
    
    variable  config
    array set config {}
    
    # Controller that positions crosshairs according to user actions
    
    bind Crosshair <Destroy> "[namespace code off] %W"
    bind Crosshair <Enter>   "[namespace code Unhide] %W %x %y"
    bind Crosshair <Leave>   "[namespace code Hide] %W"
    bind Crosshair <Motion>  "[namespace code Move] %W %x %y"
}

# ### ### ### ######### ######### #########
## Ready

package provide crosshair 1.0.2

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded crosshair 1.0.2 [list source [file join $dir crosshair.tcl]]

# By George Peter Staplin
# See also the README for a list of contributors
# RCS: @(#) $Id: ctext.tcl,v 1.7 2008/08/19 21:08:27 georgeps Exp $

package require Tk
package provide ctext 3.2

namespace eval ctext {}

#win is used as a unique token to create arrays for each ctext instance
proc ctext::getAr {win suffix name} {
	set arName __ctext[set win][set suffix]
	uplevel [list upvar #0 $arName $name]
	return $arName
}

proc ctext {win args} {
	if {[llength $args] & 1} {
		return -code error "invalid number of arguments given to ctext (uneven number after window) : $args"
	}

	frame $win -class Ctext

	set tmp [text .__ctextTemp]

	ctext::getAr $win config ar

	set ar(-fg) [$tmp cget -foreground]
	set ar(-bg) [$tmp cget -background]
	set ar(-font) [$tmp cget -font]
	set ar(-relief) [$tmp cget -relief]
	destroy $tmp
	set ar(-yscrollcommand) ""
	set ar(-linemap) 1
	set ar(-linemapfg) $ar(-fg)
	set ar(-linemapbg) $ar(-bg)
	set ar(-linemap_mark_command) {}
	set ar(-linemap_markable) 1
	set ar(-linemap_select_fg) black
	set ar(-linemap_select_bg) yellow
	set ar(-highlight) 1
	set ar(win) $win
	set ar(modified) 0
	set ar(commentsAfterId) ""
	set ar(highlightAfterId) ""
	set ar(blinkAfterId) ""

	set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \
-font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \
-linemap_select_bg]

	array set ar $args

	foreach flag {foreground background} short {fg bg} {
		if {[info exists ar(-$flag)] == 1} {
			set ar(-$short) $ar(-$flag)
			unset ar(-$flag)
		}
	}

	#Now remove flags that will confuse text and those that need modification:
	foreach arg $ar(ctextFlags) {
		if {[set loc [lsearch $args $arg]] >= 0} {
			set args [lreplace $args $loc [expr {$loc + 1}]]
		}
	}

	text $win.l -font $ar(-font) -width 1 -height 1 \
		-relief $ar(-relief) -fg $ar(-linemapfg) \
		-bg $ar(-linemapbg) -takefocus 0

	set topWin [winfo toplevel $win]
	bindtags $win.l [list $win.l $topWin all]

	if {$ar(-linemap) == 1} {
		grid $win.l -sticky ns -row 0 -column 0
	}

	set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]]

	#escape $win, because it could have a space
	eval text \$win.t -font \$ar(-font) $args

	grid $win.t -row 0 -column 1 -sticky news
	grid rowconfigure $win 0 -weight 100
	grid columnconfigure $win 1 -weight 100

	bind $win.t <Configure> [list ctext::linemapUpdate $win]
	bind $win.l <ButtonPress-1> [list ctext::linemapToggleMark $win %y]
	bind $win.t <KeyRelease-Return> [list ctext::linemapUpdate $win]
	rename $win __ctextJunk$win
	rename $win.t $win._t

	bind $win <Destroy> [list ctext::event:Destroy $win %W]
	bindtags $win.t [linsert [bindtags $win.t] 0 $win]

	interp alias {} $win {} ctext::instanceCmd $win
	interp alias {} $win.t {} $win

	#If the user wants C comments they should call ctext::enableComments
	ctext::disableComments $win
	ctext::modified $win 0
	ctext::buildArgParseTable $win

	return $win
}

proc ctext::event:yscroll {win clientData args} {
	ctext::linemapUpdate $win

	if {$clientData == ""} {
		return
	}
	uplevel #0 $clientData $args
}

proc ctext::event:Destroy {win dWin} {
	if {![string equal $win $dWin]} {
		return
	}

	ctext::getAr $win config configAr

	catch {after cancel $configAr(commentsAfterId)}
	catch {after cancel $configAr(highlightAfterId)}
	catch {after cancel $configAr(blinkAfterId)}

	catch {rename $win {}}
	interp alias {} $win.t {}
	ctext::clearHighlightClasses $win
	array unset [ctext::getAr $win config ar]
}

#This stores the arg table within the config array for each instance.
#It's used by the configure instance command.
proc ctext::buildArgParseTable win {
	set argTable [list]

	lappend argTable any -linemap_mark_command {
		set configAr(-linemap_mark_command) $value
		break
	}

	lappend argTable {1 true yes} -linemap {
		grid $self.l -sticky ns -row 0 -column 0
		grid columnconfigure $self 0 \
			-minsize [winfo reqwidth $self.l]
		set configAr(-linemap) 1
		break
	}

	lappend argTable {0 false no} -linemap {
		grid forget $self.l
		grid columnconfigure $self 0 -minsize 0
		set configAr(-linemap) 0
		break
	}

	lappend argTable any -yscrollcommand {
		set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]]

		if {[catch $cmd res]} {
			return $res
		}
		set configAr(-yscrollcommand) $value
		break
	}

	lappend argTable any -linemapfg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		$self.l config -fg $value
		set configAr(-linemapfg) $value
		break
	}

	lappend argTable any -linemapbg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		$self.l config -bg $value
		set configAr(-linemapbg) $value
		break
	}

	lappend argTable any -font {
		if {[catch {$self.l config -font $value} res]} {
			return -code error $res
		}
		$self._t config -font $value
		set configAr(-font) $value
		break
	}

	lappend argTable {0 false no} -highlight {
		set configAr(-highlight) 0
		break
	}

	lappend argTable {1 true yes} -highlight {
		set configAr(-highlight) 1
		break
	}

	lappend argTable {0 false no} -linemap_markable {
		set configAr(-linemap_markable) 0
		break
	}

	lappend argTable {1 true yes} -linemap_markable {
		set configAr(-linemap_markable) 1
		break
	}

	lappend argTable any -linemap_select_fg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		set configAr(-linemap_select_fg) $value
		$self.l tag configure lmark -foreground $value
		break
	}

	lappend argTable any -linemap_select_bg {
		if {[catch {winfo rgb $self $value} res]} {
			return -code error $res
		}
		set configAr(-linemap_select_bg) $value
		$self.l tag configure lmark -background $value
		break
	}

	ctext::getAr $win config ar
	set ar(argTable) $argTable
}

proc ctext::commentsAfterIdle {win} {
	ctext::getAr $win config configAr

	if {"" eq $configAr(commentsAfterId)} {
		set configAr(commentsAfterId) [after idle [list ctext::comments $win [set afterTriggered 1]]]
	}
}

proc ctext::highlightAfterIdle {win lineStart lineEnd} {
	ctext::getAr $win config configAr

	if {"" eq $configAr(highlightAfterId)} {
		set configAr(highlightAfterId) [after idle [list ctext::highlight $win $lineStart $lineEnd [set afterTriggered 1]]]
	}
}

proc ctext::instanceCmd {self cmd args} {
	#slightly different than the RE used in ctext::comments
	set commentRE {\"|\\|'|/|\*}

	switch -glob -- $cmd {
		append {
			if {[catch {$self._t get sel.first sel.last} data] == 0} {
				clipboard append -displayof $self $data
			}
		}

		cget {
			set arg [lindex $args 0]
			ctext::getAr $self config configAr

			foreach flag $configAr(ctextFlags) {
				if {[string match ${arg}* $flag]} {
					return [set configAr($flag)]
				}
			}
			return [$self._t cget $arg]
		}

		conf* {
			ctext::getAr $self config configAr

			if {0 == [llength $args]} {
				set res [$self._t configure]
				set del [lsearch -glob $res -yscrollcommand*]
				set res [lreplace $res $del $del]
				foreach flag $configAr(ctextFlags) {
					lappend res [list $flag [set configAr($flag)]]
				}
				return $res
			}

			array set flags {}
			foreach flag $configAr(ctextFlags) {
				set loc [lsearch $args $flag]
				if {$loc < 0} {
					continue
				}

				if {[llength $args] <= ($loc + 1)} {
					#.t config -flag
					return [set configAr($flag)]
				}

				set flagArg [lindex $args [expr {$loc + 1}]]
				set args [lreplace $args $loc [expr {$loc + 1}]]
				set flags($flag) $flagArg
			}

			foreach {valueList flag cmd} $configAr(argTable) {
				if {[info exists flags($flag)]} {
					foreach valueToCheckFor $valueList {
						set value [set flags($flag)]
						if {[string equal "any" $valueToCheckFor]} $cmd \
						elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd
					}
				}
			}

			if {[llength $args]} {
				#we take care of configure without args at the top of this branch
				uplevel 1 [linsert $args 0 $self._t configure]
			}
		}

		copy {
			tk_textCopy $self
		}

		cut {
			if {[catch {$self.t get sel.first sel.last} data] == 0} {
				clipboard clear -displayof $self.t
				clipboard append -displayof $self.t $data
				$self delete [$self.t index sel.first] [$self.t index sel.last]
				ctext::modified $self 1
			}
		}

		delete {
			#delete n.n ?n.n
		
			set argsLength [llength $args]

			#first deal with delete n.n
			if {$argsLength == 1} {
				set deletePos [lindex $args 0]
				set prevChar [$self._t get $deletePos]

				$self._t delete $deletePos
				set char [$self._t get $deletePos]

				set prevSpace [ctext::findPreviousSpace $self._t $deletePos]
				set nextSpace [ctext::findNextSpace $self._t $deletePos]

				set lineStart [$self._t index "$deletePos linestart"]
				set lineEnd [$self._t index "$deletePos + 1 chars lineend"]

				#This pattern was used in 3.1.  We may want to investigate using it again
				#eventually to reduce flicker.  It caused a bug with some patterns.
				#if {[string equal $prevChar "#"] || [string equal $char "#"]} {
				#	set removeStart $lineStart
				#	set removeEnd $lineEnd
				#} else {
				#	set removeStart $prevSpace
				#	set removeEnd $nextSpace
				#}
				set removeStart $lineStart
				set removeEnd $lineEnd

				foreach tag [$self._t tag names] {
					if {[string equal $tag "_cComment"] != 1} {
						$self._t tag remove $tag $removeStart $removeEnd
					}
				}

				set checkStr "$prevChar[set char]"

				if {[regexp $commentRE $checkStr]} {
					ctext::commentsAfterIdle $self
				}

				ctext::highlightAfterIdle $self $lineStart $lineEnd
				ctext::linemapUpdate $self
			} elseif {$argsLength == 2} {
				#now deal with delete n.n ?n.n?
				set deleteStartPos [lindex $args 0]
				set deleteEndPos [lindex $args 1]

				set data [$self._t get $deleteStartPos $deleteEndPos]

				set lineStart [$self._t index "$deleteStartPos linestart"]
				set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"]
				eval \$self._t delete $args

				foreach tag [$self._t tag names] {
					if {[string equal $tag "_cComment"] != 1} {
						$self._t tag remove $tag $lineStart $lineEnd
					}
				}

				if {[regexp $commentRE $data]} {
					ctext::commentsAfterIdle $self
				}

				ctext::highlightAfterIdle $self $lineStart $lineEnd
				if {[string first "\n" $data] >= 0} {
					ctext::linemapUpdate $self
				}
			} else {
				return -code error "invalid argument(s) sent to $self delete: $args"
			}
			ctext::modified $self 1
		}

		fastdelete {
			eval \$self._t delete $args
			ctext::modified $self 1
			ctext::linemapUpdate $self
		}

		fastinsert {
			eval \$self._t insert $args
			ctext::modified $self 1
			ctext::linemapUpdate $self
		}

		highlight {
			ctext::highlight $self [lindex $args 0] [lindex $args 1]
			ctext::comments $self
		}

		insert {
			if {[llength $args] < 2} {
				return -code error "please use at least 2 arguments to $self insert"
			}

			set insertPos [lindex $args 0]
			set prevChar [$self._t get "$insertPos - 1 chars"]
			set nextChar [$self._t get $insertPos]
			set lineStart [$self._t index "$insertPos linestart"]
			set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c]
			set data [lindex $args 1]
			eval \$self._t insert $args

			set nextSpace [ctext::findNextSpace $self._t insert]
			set lineEnd [$self._t index "insert lineend"]

			if {[$self._t compare $prevSpace < $lineStart]} {
				set prevSpace $lineStart
			}

			if {[$self._t compare $nextSpace > $lineEnd]} {
				set nextSpace $lineEnd
			}

			foreach tag [$self._t tag names] {
				if {[string equal $tag "_cComment"] != 1} {
					$self._t tag remove $tag $prevSpace $nextSpace
				}
			}

			set REData $prevChar
			append REData $data
			append REData $nextChar
			if {[regexp $commentRE $REData]} {
				ctext::commentsAfterIdle $self
			}

			ctext::highlightAfterIdle $self $lineStart $lineEnd
			
			switch -- $data {
				"\}" {
					ctext::matchPair $self "\\\{" "\\\}" "\\"
				}
				"\]" {
					ctext::matchPair $self "\\\[" "\\\]" "\\"
				}
				"\)" {
					ctext::matchPair $self "\\(" "\\)" ""
				}
				"\"" {
					ctext::matchQuote $self
				}
			}
			ctext::modified $self 1
			ctext::linemapUpdate $self
		}

		paste {
			tk_textPaste $self
			ctext::modified $self 1
		}

		edit {
			set subCmd [lindex $args 0]
			set argsLength [llength $args]

			ctext::getAr $self config ar

			if {"modified" == $subCmd} {
				if {$argsLength == 1} {
					return $ar(modified)
				} elseif {$argsLength == 2} {
					set value [lindex $args 1]
					set ar(modified) $value
				} else {
					return -code error "invalid arg(s) to $self edit modified: $args"
				}
			} else {
				#Tk 8.4 has other edit subcommands that I don't want to emulate.
				return [uplevel 1 [linsert $args 0 $self._t $cmd]]
			}
		}

		default {
			return [uplevel 1 [linsert $args 0 $self._t $cmd]]
		}
	}
}

proc ctext::tag:blink {win count {afterTriggered 0}} {
	if {$count & 1} {
		$win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg]
	} else {
		$win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg]
	}

	ctext::getAr $win config configAr
	if {$afterTriggered} {
		set configAr(blinkAfterId) ""
	}

	if {$count == 4} {
		$win tag delete __ctext_blink 1.0 end
		return
	}

	incr count
	if {"" eq $configAr(blinkAfterId)} {
		set configAr(blinkAfterId) [after 50 [list ctext::tag:blink $win $count [set afterTriggered 1]]]
	}
}

proc ctext::matchPair {win str1 str2 escape} {
	set prevChar [$win get "insert - 2 chars"]

	if {[string equal $prevChar $escape]} {
		#The char that we thought might be the end is actually escaped.
		return
	}

	set searchRE "[set str1]|[set str2]"
	set count 1

	set pos [$win index "insert - 1 chars"]
	set endPair $pos
	set lastFound ""
	while 1 {
		set found [$win search -backwards -regexp $searchRE $pos]

		if {$found == "" || [$win compare $found > $pos]} {
			return
		}

		if {$lastFound != "" && [$win compare $found == $lastFound]} {
			#The search wrapped and found the previous search
			return
		}

		set lastFound $found
		set char [$win get $found]
		set prevChar [$win get "$found - 1 chars"]
		set pos $found

		if {[string equal $prevChar $escape]} {
			continue
		} elseif {[string equal $char [subst $str2]]} {
			incr count
		} elseif {[string equal $char [subst $str1]]} {
			incr count -1
			if {$count == 0} {
				set startPair $found
				break
			}
		} else {
			#This shouldn't happen.  I may in the future make it return -code error
			puts stderr "ctext seems to have encountered a bug in ctext::matchPair"
			return
		}
	}

	$win tag add __ctext_blink $startPair
	$win tag add __ctext_blink $endPair
	ctext::tag:blink $win 0
}

proc ctext::matchQuote {win} {
	set endQuote [$win index insert]
	set start [$win index "insert - 1 chars"]

	if {[$win get "$start - 1 chars"] == "\\"} {
		#the quote really isn't the end
		return
	}
	set lastFound ""
	while 1 {
		set startQuote [$win search -backwards \" $start]
		if {$startQuote == "" || [$win compare $startQuote > $start]} {
			#The search found nothing or it wrapped.
			return
		}

		if {$lastFound != "" && [$win compare $lastFound == $startQuote]} {
			#We found the character we found before, so it wrapped.
			return
		}
		set lastFound $startQuote
		set start [$win index "$startQuote - 1 chars"]
		set prevChar [$win get $start]

		if {$prevChar == "\\"} {
			continue
		}
		break
	}

	if {[$win compare $endQuote == $startQuote]} {
		#probably just \"
		return
	}

	$win tag add __ctext_blink $startQuote $endQuote
	ctext::tag:blink $win 0
}

proc ctext::enableComments {win} {
	$win tag configure _cComment -foreground khaki
}
proc ctext::disableComments {win} {
	catch {$win tag delete _cComment}
}

proc ctext::comments {win {afterTriggered 0}} {
	if {[catch {$win tag cget _cComment -foreground}]} {
		#C comments are disabled
		return
	}

	if {$afterTriggered} {
		ctext::getAr $win config configAr
		set configAr(commentsAfterId) ""
	}

	set startIndex 1.0
	set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/}
	set commentStart 0
	set isQuote 0
	set isSingleQuote 0
	set isComment 0
	$win tag remove _cComment 1.0 end
	while 1 {
		set index [$win search -count length -regexp $commentRE $startIndex end]

		if {$index == ""} {
			break
		}

		set endIndex [$win index "$index + $length chars"]
		set str [$win get $index $endIndex]
		set startIndex $endIndex

		if {$str == "\\\\"} {
			continue
		} elseif {$str == "\\\""} {
			continue
		} elseif {$str == "\\'"} {
			continue
		} elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} {
			if {$isQuote} {
				set isQuote 0
			} else {
				set isQuote 1
			}
		} elseif {$str == "'" && $isComment == 0 && $isQuote == 0} {
			if {$isSingleQuote} {
				set isSingleQuote 0
			} else {
				set isSingleQuote 1
			}
		} elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} {
			if {$isComment} {
				#comment in comment
				break
			} else {
				set isComment 1
				set commentStart $index
			}
		} elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} {
			if {$isComment} {
				set isComment 0
				$win tag add _cComment $commentStart $endIndex
				$win tag raise _cComment
			} else {
				#comment end without beginning
				break
			}
		}
	}
}

proc ctext::addHighlightClass {win class color keywords} {
	set ref [ctext::getAr $win highlight ar]
	foreach word $keywords {
		set ar($word) [list $class $color]
	}
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $keywords]
}

#For [ ] { } # etc.
proc ctext::addHighlightClassForSpecialChars {win class color chars} {
	set charList [split $chars ""]

	set ref [ctext::getAr $win highlightSpecialChars ar]
	foreach char $charList {
		set ar($char) [list $class $color]
	}
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $charList]
}

proc ctext::addHighlightClassForRegexp {win class color re} {
	set ref [ctext::getAr $win highlightRegexp ar]

	set ar($class) [list $re $color]
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $class]
}

#For things like $blah
proc ctext::addHighlightClassWithOnlyCharStart {win class color char} {
	set ref [ctext::getAr $win highlightCharStart ar]

	set ar($char) [list $class $color]
	$win tag configure $class

	ctext::getAr $win classes classesAr
	set classesAr($class) [list $ref $char]
}

proc ctext::deleteHighlightClass {win classToDelete} {
	ctext::getAr $win classes classesAr

	if {![info exists classesAr($classToDelete)]} {
		return -code error "$classToDelete doesn't exist"
	}

	foreach {ref keyList} [set classesAr($classToDelete)] {
		upvar #0 $ref refAr
		foreach key $keyList {
			if {![info exists refAr($key)]} {
				continue
			}
			unset refAr($key)
		}
	}
	unset classesAr($classToDelete)
}

proc ctext::getHighlightClasses win {
	ctext::getAr $win classes classesAr

	array names classesAr
}

proc ctext::findNextChar {win index char} {
	set i [$win index "$index + 1 chars"]
	set lineend [$win index "$i lineend"]
	while 1 {
		set ch [$win get $i]
		if {[$win compare $i >= $lineend]} {
			return ""
		}
		if {$ch == $char} {
			return $i
		}
		set i [$win index "$i + 1 chars"]
	}
}

proc ctext::findNextSpace {win index} {
	set i [$win index $index]
	set lineStart [$win index "$i linestart"]
	set lineEnd [$win index "$i lineend"]
	#Sometimes the lineend fails (I don't know why), so add 1 and try again.
	if {[$win compare $lineEnd == $lineStart]} {
		set lineEnd [$win index "$i + 1 chars lineend"]
	}

	while {1} {
		set ch [$win get $i]

		if {[$win compare $i >= $lineEnd]} {
			set i $lineEnd
			break
		}

		if {[string is space $ch]} {
			break
		}
		set i [$win index "$i + 1 chars"]
	}
	return $i
}

proc ctext::findPreviousSpace {win index} {
	set i [$win index $index]
	set lineStart [$win index "$i linestart"]
	while {1} {
		set ch [$win get $i]

		if {[$win compare $i <= $lineStart]} {
			set i $lineStart
			break
		}

		if {[string is space $ch]} {
			break
		}

		set i [$win index "$i - 1 chars"]
	}
	return $i
}

proc ctext::clearHighlightClasses {win} {
	#no need to catch, because array unset doesn't complain
	#puts [array exists ::ctext::highlight$win]

	ctext::getAr $win highlight ar
	array unset ar

	ctext::getAr $win highlightSpecialChars ar
	array unset ar

	ctext::getAr $win highlightRegexp ar
	array unset ar

	ctext::getAr $win highlightCharStart ar
	array unset ar

	ctext::getAr $win classes ar
	array unset ar
}

#This is a proc designed to be overwritten by the user.
#It can be used to update a cursor or animation while
#the text is being highlighted.
proc ctext::update {} {

}

proc ctext::highlight {win start end {afterTriggered 0}} {
	ctext::getAr $win config configAr

	if {$afterTriggered} {
		set configAr(highlightAfterId) ""
	}

	if {!$configAr(-highlight)} {
		return
	}

	set si $start
	set twin "$win._t"

	#The number of times the loop has run.
	set numTimesLooped 0
	set numUntilUpdate 600

	ctext::getAr $win highlight highlightAr
	ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr
	ctext::getAr $win highlightRegexp highlightRegexpAr
	ctext::getAr $win highlightCharStart highlightCharStartAr

	while 1 {
		set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end]
		if {$res == ""} {
			break
		}

		set wordEnd [$twin index "$res + $length chars"]
		set word [$twin get $res $wordEnd]
		set firstOfWord [string index $word 0]

		if {[info exists highlightAr($word)] == 1} {
			set wordAttributes [set highlightAr($word)]
			foreach {tagClass color} $wordAttributes break

			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color

		} elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} {
			set wordAttributes [set highlightCharStartAr($firstOfWord)]
			foreach {tagClass color} $wordAttributes break

			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color
		}
		set si $wordEnd

		incr numTimesLooped
		if {$numTimesLooped >= $numUntilUpdate} {
			ctext::update
			set numTimesLooped 0
		}
	}

	foreach {ichar tagInfo} [array get highlightSpecialCharsAr] {
		set si $start
		foreach {tagClass color} $tagInfo break

		while 1 {
			set res [$twin search -- $ichar $si $end]
			if {"" == $res} {
				break
			}
			set wordEnd [$twin index "$res + 1 chars"]

			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color
			set si $wordEnd

			incr numTimesLooped
			if {$numTimesLooped >= $numUntilUpdate} {
				ctext::update
				set numTimesLooped 0
			}
		}
	}

	foreach {tagClass tagInfo} [array get highlightRegexpAr] {
		set si $start
		foreach {re color} $tagInfo break
		while 1 {
			set res [$twin search -count length -regexp -- $re $si $end]
			if {"" == $res} {
				break
			}

			set wordEnd [$twin index "$res + $length chars"]
			$twin tag add $tagClass $res $wordEnd
			$twin tag configure $tagClass -foreground $color
			set si $wordEnd

			incr numTimesLooped
			if {$numTimesLooped >= $numUntilUpdate} {
				ctext::update
				set numTimesLooped 0
			}
		}
	}
}

proc ctext::linemapToggleMark {win y} {
	ctext::getAr $win config configAr

	if {!$configAr(-linemap_markable)} {
		return
	}

	set markChar [$win.l index @0,$y]
	set lineSelected [lindex [split $markChar .] 0]
	set line [$win.l get $lineSelected.0 $lineSelected.end]

	if {$line == ""} {
		return
	}

	ctext::getAr $win linemap linemapAr

	if {[info exists linemapAr($line)] == 1} {
		#It's already marked, so unmark it.
		array unset linemapAr $line
		ctext::linemapUpdate $win
		set type unmarked
	} else {
		#This means that the line isn't toggled, so toggle it.
		array set linemapAr [list $line {}]
		$win.l tag add lmark $markChar [$win.l index "$markChar lineend"]
		$win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \
-background $configAr(-linemap_select_bg)
		set type marked
	}

	if {[string length $configAr(-linemap_mark_command)]} {
		uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line]
	}
}

#args is here because -yscrollcommand may call it
proc ctext::linemapUpdate {win args} {
	if {[winfo exists $win.l] != 1} {
		return
	}

	set pixel 0
	set lastLine {}
	set lineList [list]
	set fontMetrics [font metrics [$win._t cget -font]]
	set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}]

	while {$pixel < [winfo height $win.l]} {
		set idx [$win._t index @0,$pixel]

		if {$idx != $lastLine} {
			set line [lindex [split $idx .] 0]
			set lastLine $idx
			lappend lineList $line
		}
		incr pixel $incrBy
	}

	ctext::getAr $win linemap linemapAr

	$win.l delete 1.0 end
	set lastLine {}
	foreach line $lineList {
		if {$line == $lastLine} {
			$win.l insert end "\n"
		} else {
			if {[info exists linemapAr($line)]} {
				$win.l insert end "$line\n" lmark
			} else {
				$win.l insert end "$line\n"
			}
		}
		set lastLine $line
	}
	set endrow [lindex [split [$win._t index end-1c] .] 0]
	$win.l configure -width [string length $endrow]
}

proc ctext::modified {win value} {
	ctext::getAr $win config ar
	set ar(modified) $value
	event generate $win <<Modified>>
	return $value
}

package ifneeded ctext 3.2 [list source [file join $dir ctext.tcl]]

# cursor.tcl --
#
#       Tk cursor handling routines
#
# Copyright (c) 2001 by Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: cursor.tcl,v 1.2 2006/12/08 23:30:31 hobbs Exp $

package require Tk 8.0
package provide cursor 0.2

namespace eval ::cursor {
    namespace export propagate restore display

    variable cursors [list \
	    X_cursor arrow based_arrow_down based_arrow_up boat bogosity \
	    bottom_left_corner bottom_right_corner bottom_side bottom_tee \
	    box_spiral center_ptr circle clock coffee_mug cross cross_reverse \
	    crosshair diamond_cross dot dotbox double_arrow draft_large \
	    draft_small draped_box exchange fleur gobbler gumby hand1 hand2 \
	    heart icon iron_cross left_ptr left_side left_tee leftbutton \
	    ll_angle lr_angle man middlebutton mouse pencil pirate plus \
	    question_arrow right_ptr right_side right_tee rightbutton \
	    rtl_logo sailboat sb_down_arrow sb_h_double_arrow sb_left_arrow \
	    sb_right_arrow sb_up_arrow sb_v_double_arrow shuttle sizing \
	    spider spraycan star target tcross top_left_arrow top_left_corner \
	    top_right_corner top_side top_tee trek ul_angle umbrella \
	    ur_angle watch xterm \
	    ]

    switch -exact $::tcl_platform(os) {
	"windows" {
	    lappend cursors no starting size \
		    size_ne_sw size_ns size_nw_se size_we uparrow wait
	}
	"macintosh" {
	    lappend cursors text cross-hair
	}
	"unix" {
	    # no extra cursors
	}
    }
}

# ::cursor::propagate --
#
#	Propagates a cursor to a widget and all descendants.
#
# Arguments:
#	w	Parent widget to set cursor on (includes children)
#	cursor	The cursor to use
#
# Results:
#	Set the cursor of $w and all descendants to $cursor

proc ::cursor::propagate {w cursor} {
    variable CURSOR
    # Ignores {} cursors or widgets that don't have a -cursor option
    if {![catch {set CURSOR($w) [$w cget -cursor]}] && $CURSOR($w) != ""} {
	$w config -cursor $cursor
    } else {
	catch {unset CURSOR($w)}
    }
    foreach child [winfo children $w] { propagate $child $cursor }
}

# ::cursor::restores --
#
#	Restores original cursor of a widget and all descendants.
#
# Arguments:
#	w	Parent widget to restore cursor for (includes children)
#	cursor	The default cursor to use (if none was cached by propagate)
#
# Results:
#	Restore the cursor of $w and all descendants

proc ::cursor::restore {w {cursor {}}} {
    variable CURSOR
    if {[info exists CURSOR($w)]} {
	$w config -cursor $CURSOR($w)
    } else {
	# Not all widgets have -cursor
	catch {$w config -cursor $cursor}
    }
    foreach child [winfo children $w] { restore $child $cursor }
}


# ::cursor::display --
#
#	Show all known cursors for viewing
#
# Arguments:
#	w	Parent widget to use for dialog
#
# Results:
#	Pops up a dialog

proc ::cursor::display {{root .}} {
    variable cursors
    if {$root == "."} {
	set t .__cursorDisplay
    } else {
	set t $root.__cursorDisplay
    }
    destroy $t
    toplevel $t
    wm withdraw $t
    label $t.lbl -text "Select a cursor:" -anchor w
    listbox $t.lb -selectmode single -yscrollcommand [list $t.sy set]
    scrollbar $t.sy -orient v -command [list $t.lb yview]
    button $t.d -text Dismiss -command [list destroy $t]
    pack $t.d -side bottom
    pack $t.lbl -side top -fill x
    pack $t.sy -side right -fill y
    pack $t.lb -side right -fill both -expand 1
    eval [list $t.lb insert end] $cursors
    bind $t.lb <Button-1> { %W config -cursor [%W get [%W nearest %y]] }
    wm deiconify $t
}

package ifneeded cursor 0.2 [list source [file join $dir cursor.tcl]]

##+##########################################################################
#
# datefield.tcl
#
# Implements a datefield entry widget ala Iwidget::datefield
# by Keith Vetter (keith@ebook.gemstar.com)
#
# Datefield creates an entry widget but with a special binding to KeyPress
# (based on Iwidget::datefield) to ensure that the current value is always
# a valid date. All normal entry commands and configurations still work.
#
# Usage:
#  ::datefield::datefield .df -background yellow -textvariable myDate
#  pack .df
#
# Bugs:
#   o won't work if you programmatically put in an invalid date
#     e.g. .df insert end "abc"	  will cause it to behave erratically
#
# Revisions:
# KPV Feb 07, 2002 - initial revision
#
##+##########################################################################
#############################################################################

package require Tk 8.0
package provide datefield 0.2

namespace eval ::datefield {
    namespace export datefield

    # Have the widget use tile/ttk should it be available.

    variable entry entry
    if {![catch {
	package require tile
    }]} {
	set entry ttk::entry
    }

    proc datefield {w args} {
	variable entry

	eval $entry $w -width 10 -justify center $args
	$w insert end [clock format [clock seconds] -format "%m/%d/%Y"]
	$w icursor 0

	bind $w <KeyPress> [list ::datefield::KeyPress $w %A %K %s]
	bind $w <Button1-Motion> break
	bind $w <Button2-Motion> break
	bind $w <Double-Button>	 break
	bind $w <Triple-Button>	 break
	bind $w <2>		 break

	return $w
    }

    # internal routine for all key presses in the datefield entry widget
    proc KeyPress {w char sym state} {
	set icursor [$w index insert]

	# Handle some non-number characters first
	if {$sym == "plus" || $sym == "Up" || \
		$sym == "minus" || $sym == "Down"} {
	    set dir "1 day"
	    if {$sym == "minus" || $sym == "Down"} {
		set dir "-1 day"
	    }
	    set base [clock scan [$w get]]
	    if {[catch {set new [clock scan $dir -base $base]}] != 0} {
		bell
		return -code break
	    }
	    set date [clock format $new -format "%m/%d/%Y"]
	    if {[catch {clock scan $date}]} {
		bell
		return -code break
	    }
	    $w delete 0 end
	    $w insert end $date
	    $w icursor $icursor
	    return -code break
	} elseif {$sym == "Right" || $sym == "Left" || $sym == "BackSpace" || \
		$sym == "Delete"} {
	    set dir -1
	    if {$sym == "Right"} {set dir 1}

	    set icursor [expr {($icursor + 10 + $dir) % 10}]
	    if {$icursor == 2 || $icursor == 5} {;# Don't land on a slash
		set icursor [expr {($icursor + 10 + $dir) % 10}]
	    }
	    $w icursor $icursor
	    return -code break
	} elseif {($sym == "Control_L") || ($sym == "Shift_L") || \
		($sym == "Control_R") || ($sym == "Shift_R")} {
	    return -code break
	} elseif {$sym == "Tab" && $state == 0} {;# Tab key
	    if {$icursor < 3} {
		$w icursor 3
	    } elseif {$icursor < 6} {
		$w icursor 8
	    } else {
		return -code continue
	    }
	    return -code break
	} elseif {$sym == "Tab" && ($state == 1 || $state == 4)} {
	    if {$icursor > 4} {
		$w icursor 3
	    } elseif {$icursor > 1} {
		$w icursor 0
	    } else {
		return -code continue
	    }
	    return -code break
	}

	if {! [regexp {[0-9]} $char]} {		;# Unknown character
	    bell
	    return -code break
	}

	if {$icursor >= 10} {			;# Can't add beyond end
	    bell
	    return -code break
	}
	foreach {month day year} [split [$w get] "/"] break

	# MONTH SECTION
	if {$icursor < 2} {
	    foreach {m1 m2} [split $month ""] break
	    set cursor 3			;# Where to leave the cursor
	    if {$icursor == 0} {		;# 1st digit of month
		if {$char < 2} {
		    set month "$char$m2"
		    set cursor 1
		} else {
		    set month "0$char"
		}
		if {$month > 12} {set month 10}
		if {$month == "00"} {set month "01"}
	    } else {				;# 2nd digit of month
		set month "$m1$char"
		if {$month > 12} {set month "0$char"}
		if {$month == "00"} {
		    bell
		    return -code break
		}
	    }
	    $w delete 0 2
	    $w insert 0 $month
	    # Validate the day of the month
	    if {$day > [set endday [lastDay $month $year]]} {
		$w delete 3 5
		$w insert 3 $endday
	    }
	    $w icursor $cursor

	    return -code break
	}
	# DAY SECTION
	if {$icursor < 5} {			;# DAY
	    set endday [lastDay $month $year]
	    foreach {d1 d2} [split $day ""] break
	    set cursor 6			;# Where to leave the cursor
	    if {$icursor <= 3} {		;# 1st digit of day
		if {$char < 3 || ($char == 3 && $month != "02")} {
		    set day "$char$d2"
		    if {$day == "00"} { set day "01" }
		    if {$day > $endday} {set day $endday}
		    set cursor 4
		} else {
		    set day "0$char"
		}
	    } else {				;# 2nd digit of day
		set day "$d1$char"
		if {$day > $endday || $day == "00"} {
		    bell
		    return -code break
		}
	    }
	    $w delete 3 5
	    $w insert 3 $day
	    $w icursor $cursor
	    return -code break
	}

	# YEAR SECTION
	set y1 [lindex [split $year ""] 0]
	if {$icursor < 7} {			;# 1st digit of year
	    if {$char != "1" && $char != "2"} {
		bell
		return -code break
	    }
	    if {$char != $y1} {			;# Different century
		set y 1999
		if {$char == "2"} {set y 2000 }
		$w delete 6 end
		$w insert end $y
	    }
	    $w icursor 7
	    return -code break
	}
	$w delete $icursor
	$w insert $icursor $char
	if {[catch {clock scan [$w get]}] != 0} {;# Validate the year
	    $w delete 6 end
	    $w insert end $year			;# Put back in the old year
	    $w icursor $icursor
	    bell
	    return -code break
	}
	return -code break
    }
    # internal routine that returns the last valid day of a given month and year
    proc lastDay {month year} {
	set days [clock format [clock scan "+1 month -1 day" \
		-base [clock scan "$month/01/$year"]] -format %d]
    }
}

package ifneeded datefield 0.2 [list source [file join $dir datefield.tcl]]

# draw_diagram.tcl
#    A toy derived from "PIC" by B. Kernighan to draw diagrams
#
# TODO:
#    - Update the arrow and line drawing routines
#    - Routines to:
#      - Re-initialise a page
#      - Collect the height and width of text (for objects that
#        have several text strings possibly in different fonts)
#    - Consolidate examples/tests in separate examples
#
#
if { 0 } {
'''Concise user documentation:'''

''General commands for positioning and setup:''

drawin $canvas
    Set the canvas widget in which to draw

saveps $filename
    Save the drawing in a PostScript file

direction $newdir
    Set the direction for moving the current position
    direction is one of:
        north  northeast  east southeast  south
        southwest west northwest
        N      NE         E    SE         S     SW        W    NW
        up     up-right   left down-right down  down-left left up-left
        centre center     C

currentpos $pos
    Set the current position explicitly (argument must be
    a position "object"

getpos $anchor $obj
    Get the position of a particular "anchor" point of an object
    anchor should be one of the direction strings

position $xcoord $ycoord
    Create a position "object"
    xcoord and ycoord are in pixels

''Drawing objects:''

box $text $width $height
    Draw a box from the current position
    (width and height are both optional; if not given, the text
    determines the width and height)

plaintext $text $width $height
    Draw plain text from the current position
    (width and height are both optional; if not given, the text
    determines the width and height)

circle $text $radius
    Draw a circle from the current position
    (the radius is optional)

slanted $text $width $height $angle
    Draw a slanted box from the current position
    (width, height and angle are optional)

diamond $text $width $height
    Draw a diamond-shaped box from the current position
    (width and height are both optional; if not given, the text
    determines the width and height)

drum $text $width $height
    (width and height are both optional; if not given, the text
    determines the width and height)

arrow $text $length
    Draw an arrow from the current position to the next.
    The text is drawn next to the arrow, the length (in pixels) is
    optional. If not given the gap parameters are used.

line $args
    Draw a line specified via positions or via line segments
    The arguments are either position or length-angle pairs

''Attributes:''

(Note: attributes are persistent)

attach $anchor
    Set the anchor point for attaching arrows to

color $name
    Set the color for the outline of a box etc.

fillcolor $name
    Set the color to fill the objects

textcolor $name
    Set the color to draw the text in

usegap $use
    Turn the gap on (1) or off (0). Note: usually a small gap is used
    when positioning objects.

xgap $value
    Size of the gap in horizontal direction (in pixels)

ygap $value
    Size of the gap in vertical direction (in pixels)

textfont $name
    Set the name of the font to use

linewidth $pixels
    Set the width of the lines (in line objects and arrows)

linestyle $style
    Set the style of the lines and arrows

spline $yesno
    Draw curved lines and arrows or not


'''Commands for implmenting new objects:'''

Note: it is best to study how for instance box objects are implemented
first.

pushstate
    Save the current global settings
    Used when defining an object that is composed of other objects

popstate
    Restore the previously saved global settings

computepos
    Compute the current position

boxcoords $x1 $y1 $x2 $y2
    Compute the anchor coordinates for a box-like object
    (this is merely a convenience routine. In general, you will
    have to compute the list of coordinates yourself - see
    for instance the diamond object)

moveobject $obj
    Move the object to the right position and return the new
    information

}

namespace eval ::Diagrams {
    variable box_coord_name \
        {north  northeast  east southeast  south southwest west northwest
         N      NE         E    SE         S     SW        W    NW
         up     up-right   left down-right down  down-left left up-left
         centre center     C}
    variable box_coord_id   \
        {0      1          2    3          4     5         6    7
         0      1          2    3          4     5         6    7
         0      1          2    3          4     5         6    7
         8      8          8}

    variable state
    variable state_saved
    variable anchors
    variable dirinfo
    variable torad [expr {3.1415926/180.0}]

    namespace export currentpos getpos direction \
                     arrow box circle diamond drum line slanted \
                     pushstate popstate \
                     drawin saveps line position plaintext linestyle

    array set state {
        attach         "northwest"
        canvas         ""
        colour         "black"
        default_dir    "east"
        dir            "init"
        textfont       "Helvetica 12"
        justify        center
        default_width  "fitting"
        default_height 20
        xdir           1
        ydir           0
        xshift         0
        yshift         0
        xcurr          10
        ycurr          10
        xgap           10
        ygap           10
        scale          {1.0}
        xprev          10
        yprev          10
        lastitem       {}
        usegap         0
        spline         0
        color          "black"
        fillcolor      {}
        textcolor      "black"
        linewidth      1
        linestyle      {}
    }

    # Name of direction, xdir, ydir, default attachment, anchor for text near arrow
    set dirinfo(south)      {south  0  1 north e}
    set dirinfo(north)      {north  0 -1 south w}
    set dirinfo(west)       {west  -1  0 east n}
    set dirinfo(east)       {east   1  0 west s}
    set dirinfo(southwest)  {southwest  -1  1 north ne}
    set dirinfo(northwest)  {northwest  -1 -1 south se}
    set dirinfo(southeast)  {southeast   1  1 north nw}
    set dirinfo(northeast)  {northeast   1 -1 south sw}
    set dirinfo(down)       $dirinfo(south)
    set dirinfo(up)         $dirinfo(north)
    set dirinfo(left)       $dirinfo(west)
    set dirinfo(right)      $dirinfo(east)
    set dirinfo(SE)         $dirinfo(southeast)
    set dirinfo(NE)         $dirinfo(northeast)
    set dirinfo(SW)         $dirinfo(southwest)
    set dirinfo(NW)         $dirinfo(northwest)
}

# attach, fillcolor, ... --
#    Procedures to set simple attributes
# Arguments:
#    args     New value for the attribute or empty to get the current value
# Result:
#    Current or new value, depending on whether a new value was given
#
foreach p {attach color fillcolor textcolor usegap xgap ygap textfont
           linewidth spline} {
    eval [string map [list PP $p] \
        {proc ::Diagrams::PP {args} {
             variable state
             if { [llength $args] == 1 } {
                 set state(PP) [lindex $args 0]
             }
             return $state(PP)
         }
         namespace eval ::Diagrams {namespace export PP}
        }]
}

# linestyle --
#    Set the line style for all objects
# Arguments:
#    style     New style
# Result:
#    None
#
proc ::Diagrams::linestyle {style} {
    variable state

    switch -- $style {
        "solid"        { set pattern "" }
        "dot"          { set pattern . }
        "dash"         { set pattern - }
        "dash-dot"     { set pattern -. }
        "dash-dot-dot" { set pattern -.. }
        default        { set pattern $style }
    }

    set state(linestyle) $pattern
}

# drawin --
#    Set the canvas widget in which to draw
# Arguments:
#    widget    Name of the canvas widget to use
# Result:
#    None
#
proc ::Diagrams::drawin {widget} {
    variable state
    set state(canvas) $widget
}

# saveps --
#    Save the drawing in a PostScript file
# Arguments:
#    filename   Name of the file to write
# Result:
#    None
#
proc ::Diagrams::saveps {filename} {
    variable state
    update
    $state(canvas) postscript -file $filename
}

# direction --
#    Set the direction for moving the current position
# Arguments:
#    newdir    Direction (down, left, up, right)
# Result:
#    None
#
proc ::Diagrams::direction {newdir} {
    variable state
    variable dirinfo

    if { [info exists dirinfo($newdir)] } {
        foreach s {dir xdir ydir attach anchor} v $dirinfo($newdir) {
            set state($s) $v
        }
    } else {
        return
    }
    #
    # TODO: problem with arrows/lines
    #
    if { $state(lastitem) != {} && [lindex $state(lastitem) 0] == "BOX" } {
        currentpos [getpos $state(dir) $state(lastitem)]
    }
}

# horizontal --
#    Compute the length of a line segment whose horizontal
#    extension is given
# Arguments:
#    length    Length over which the line extends in horizontal direction
# Result:
#    None
#
proc ::Diagrams::horizontal {length} {
    variable state
    variable dirinfo

    #
    # Does the direction allow for a horizontal component?
    #
    TODO!
    if { $state(dir) == "NW" $newdir) } {
        foreach s {dir xdir ydir attach} v $dirinfo($newdir) {
            set state($s) $v
        }
    } else {
        return
    }
    #
    # TODO: problem with arrows/lines
    #
    if { $state(lastitem) != {} && [lindex $state(lastitem) 0] == "BOX" } {
        currentpos [getpos $state(dir) $state(lastitem)]
    }
}

# pushstate
#    Save the current global settings
# Arguments:
#    None
# Result:
#    None
# Side effect:
#    Pushes the global settings up a stack for later reuse
#
proc ::Diagrams::pushstate {} {
    variable state
    variable state_saved

    lappend state_saved [array get state]
}

# popstate
#    Restore the previously saved global settings
# Arguments:
#    None
# Result:
#    None
# Side effect:
#    Restores the previous settings and pops the stack
#
proc ::Diagrams::popstate {} {
    variable state
    variable state_saved

    if { [llength $state_saved] > 0 } {
        set old_state [lindex $state_saved end]
        set state_saved [lrange $state_saved 0 end-1]
        array set state $old_state
    }
}

# currentpos
#    Set the current position explicitly
# Arguments:
#    pos       Position "object" (optional)
# Result:
#    Current position as an "object"
# Side effect:
#    Current position set
#
proc ::Diagrams::currentpos { {pos {}} } {
    variable state

    if { [lindex $pos 0] == "POSITION" } {
        set state(xprev) $state(xcurr)
        set state(yprev) $state(ycurr)
        set state(xcurr) [lindex $pos 1]
        set state(ycurr) [lindex $pos 2]
    }

    return [list POSITION $state(xcurr) $state(ycurr)]
}

# getpos
#    Get the position of a particular "anchor" point of an object
# Arguments:
#    anchor    Which point to return
#    obj       Drawable "object"
# Result:
#    Position of the requested point
#
proc ::Diagrams::getpos {anchor obj} {
    variable state
    variable box_coord_name
    variable box_coord_id

    if { $anchor == "init" } {
        direction "east"
        set anchor "east"
    }

    if { [lindex $obj 0] == "BOX" } {
        set idx [lsearch $box_coord_name $anchor]
        if { $idx < 0 } {
            return -code error "Unknown anchor - $anchor"
        }
        set idx [lindex $box_coord_id $idx]
    } else {
        set idx $anchor
    }

    set xp [lindex [lindex $obj 2] [expr {2*$idx}]]
    set yp [lindex [lindex $obj 2] [expr {2*$idx+1}]]

    return [list POSITION $xp $yp]
}

# computepos
#    Compute the new position
# Arguments:
#    None
# Result:
#    X- and Y-coordinates
#
proc ::Diagrams::computepos {} {
    variable state

    set xcoord [expr {$state(xcurr)+$state(xgap)*$state(xdir)*$state(usegap)}]
    set ycoord [expr {$state(ycurr)+$state(ygap)*$state(ydir)*$state(usegap)}]

    return [list "POSITION" $xcoord $ycoord]
}

# position
#    Create a position "object"
# Arguments:
#    xcoord    X-coordinate
#    ycoord    Y-coordinate
# Result:
#    List representing the object
#
proc ::Diagrams::position {xcoord ycoord} {

    return [list "POSITION" $xcoord $ycoord]
}

# boxcoords --
#    Compute the anchor coordinates for a box-like object
# Arguments:
#    x1        X-coordinate top-left (order is important!)
#    y1        Y-coordinate top-left
#    x2        X-coordinate bottom-right
#    y2        Y-coordinate bottom-right
# Result:
#    List of coordinates in the right order
# Note:
#    The coordinates typically come from a [canvas bbox] command
#
proc ::Diagrams::boxcoords {x1 y1 x2 y2} {
    set coords {}
    set xns    [expr {($x1+$x2)/2.0}]
    set yew    [expr {($y1+$y2)/2.0}]

    return [list $xns $y1 $x2 $y1 $x2 $yew $x2 $y2 \
                 $xns $y2 $x1 $y2 $x1 $yew $x1 $y1 $xns $yew]
}

# moveobject --
#    Move the object to the right position and return the new
#    information
# Arguments:
#    obj       Object at the default position
# Result:
#    Updated list with new object coordinates
#
proc ::Diagrams::moveobject {obj} {
    variable state

    #
    # Compute the coordinates of the object (positioned correctly)
    #
    foreach {dummy xcurr ycurr}     [computepos] {break}
    foreach {dummy xanchor yanchor} [getpos $state(attach) $obj] {break}

    set xt [expr {$xcurr-$xanchor}]
    set yt [expr {$ycurr-$yanchor}]

    set newobj [lrange $obj 0 1]
    set items  [lindex $obj 1]

    foreach i $items {
        $state(canvas) move $i $xt $yt
    }
    set newcrd {}
    foreach {x y} [lindex $obj 2] {
        set xn [expr {$x+$xt}]
        set yn [expr {$y+$yt}]
        lappend newcrd $xn $yn
    }
    lappend newobj $newcrd

    currentpos [getpos $state(dir) $newobj]

    set state(lastitem) $newobj
    return $newobj
}

# box --
#    Draw a box from the current position
# Arguments:
#    text      Text to be fitted in the box
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the box
# Side effect:
#    Box drawn with text inside, current position set
#
proc ::Diagrams::box {text {width {}} {height {}}} {
    variable state

    #
    # Before we create the text object, we need to store the
    # current position ...
    #
    pushstate
    set textobj [plaintext $text $width $height]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set x1 [expr {$x1-5}]
    set y1 [expr {$y1-5}]
    set x2 [expr {$x2+5}]
    set y2 [expr {$y2+5}]

    #
    # Construct the box
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create rectangle $x1 $y1 $x2 $y2 \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items [boxcoords $x1 $y1 $x2 $y2]]]
    set state(usegap)   1
    return $obj
}

# plaintext --
#    Draw plain text from the current position
# Arguments:
#    text      Text to be fitted in the box
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the box
# Side effect:
#    Text drawn, current position set
#
proc ::Diagrams::plaintext {text {width {}} {height {}}} {
    variable state

    if { $width == {} } {
        set width $state(default_width)
    }

    if { $height == {} } {
        set height $state(default_height)
    }

    set items [$state(canvas) create text 0 0 -text $text \
                  -font         $state(textfont) \
                  -fill         $state(textcolor) \
                  -justify      $state(justify)]


    if { $width == "fitting" } {
        foreach {x1 y1 x2 y2} [$state(canvas) bbox $items] {break}
    } else {
        set x1 [expr {-$width/2}]
        set x2 [expr {$width/2}]
        set y1 [expr {-$height/2}]
        set y2 [expr {$height/2}]
       # set width  [expr {$x2-$x1}]
       # set height [expr {$y2-$y1}]
    }

    #
    # Construct the coordinates and the object
    #
    set coords [boxcoords $x1 $y1 $x2 $y2]
    set obj    [list BOX $items $coords]

    #
    # Move the object to the right position
    #
    set obj    [moveobject $obj]
    set state(usegap)   1
    return $obj
}

# circle --
#    Draw a circle from the current position
# Arguments:
#    text      Text to be fitted in the circle
#    radius    (Optional) radius in pixels or "fitting"
# Result:
#    ID of the circle
# Side effect:
#    Circle drawn with text inside, current position set
#
proc ::Diagrams::circle {text {radius {}} } {
    variable state
    variable torad

    #
    # Before we create the text object, we need to store the
    # current state ...
    #
    pushstate
    set textobj [plaintext $text $radius $radius]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set xc [expr {($x1+$x2)/2.0}]
    set yc [expr {($y1+$y2)/2.0}]
    if { $radius == {} } {
       set radius [expr {hypot($x1-$xc,$y1-$yc)}]
    }
    set x1 [expr {$xc-$radius-5}]
    set x2 [expr {$xc+$radius+5}]
    set y1 [expr {$yc-$radius-5}]
    set y2 [expr {$yc+$radius+5}]

    #
    # Construct the circle
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create oval $x1 $y1 $x2 $y2 \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate

    #
    # Construct the list of coordinates
    #
    set coords {}
    set radius [expr {$radius+5}]
    foreach angle {90 45 0 -45 -90 -135 180 135} {
        set x [expr {$xc+$radius*cos($angle*$torad)}]
        set y [expr {$yc-$radius*sin($angle*$torad)}]
        lappend coords $x $y
    }
    lappend coords $xc $yc
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# slanted --
#    Draw a slanted box from the current position
# Arguments:
#    text      Text to be fitted in the box
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
#    angle     (Optional) angle of the slant (90 degrees gives a rectangle)
# Result:
#    ID of the slanted box
# Side effect:
#    Slanted box drawn with text inside, current position set
#
proc ::Diagrams::slanted {text {width {}} {height {}} {angle 70} } {
    variable state
    variable torad

    #
    # Before we create the text object, we need to store the
    # current state ...
    #
    pushstate

    #
    # Compute the available width
    #
    set cosa [expr {cos($angle*3.1415926/180.0)}]
    set sina [expr {sin($angle*3.1415926/180.0)}]

    set twidth  $width
    set theight $height
    if { $width != {} && $width != "fitting" } {
        set twidth  [expr {($width-10)-$cosa*($height-10)}]
        set theight [expr {$height-10}]
    }

    set textobj [plaintext $text $twidth $theight]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    #
    # Construct the coordinates
    #
    set bwidth  [expr {10+$x2-$x1}]
    set bheight [expr {10+$y2-$y1}]
    set width   [expr {$bwidth+$cosa*$bheight}]
    set height  $bheight
    set xc      [expr {($x1+$x2)/2.0}]
    set yc      [expr {($y1+$y2)/2.0}]

    set xnw     [expr {$xc-$bwidth/2.0}]
    set ynw     [expr {$yc-$bheight/2.0}]
    set xne     [expr {$xc+$bwidth/2.0+$cosa*$bheight}]
    set yne     $ynw
    set xn      [expr {($xnw+$xne)/2.0}]
    set yn      [expr {($ynw+$yne)/2.0}]

    set xse     [expr {$xc+$bwidth/2.0}]
    set yse     [expr {$yc+$height/2.0}]
    set xe      [expr {($xne+$xse)/2.0}]
    set ye      [expr {($yne+$yse)/2.0}]

    set xsw     [expr {$xc-$bwidth/2.0-$cosa*$bheight}]
    set ysw     $yse
    set xs      [expr {($xse+$xsw)/2.0}]
    set ys      [expr {($yse+$ysw)/2.0}]
    set xw      [expr {($xnw+$xsw)/2.0}]
    set yw      [expr {($ynw+$ysw)/2.0}]

    set coords  [list $xn $yn $xne $yne $xe $ye $xse $yse $xs $ys \
                      $xsw $ysw $xw $yw $xnw $ynw $xc $yc]

    #
    # Create the object
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create polygon  \
                       $xnw $ynw $xne $yne $xse $yse $xsw $ysw $xnw $ynw \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# diamond --
#    Draw a diamond-shaped box from the current position
# Arguments:
#    text      Text to be fitted in the diamond
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the diamond
# Side effect:
#    Diamond-shaped box drawn with text inside, current position set
# Note:
#    The aspect ratio of the diamond in case of fitting the text
#    is set to width:heihgt = 2:1
#
proc ::Diagrams::diamond {text {width {}} {height {}} } {
    variable state

    #
    # Before we create the text object, we need to store the
    # current position ...
    #
    pushstate
    set textobj [plaintext $text $width $height]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set alpha 2.0

    if { $width == {} || $width == "fitting" } {
        set width  [expr {$x2-$x1+4+($y2-$y1+4)*$alpha}]
        set height [expr {$width/$alpha}]
    }

    set xc  [expr {($x1+$x2)/2.0}]
    set yc  [expr {($y1+$y2)/2.0}]

    set xn  $xc
    set yn  [expr {$yc-$height/2.0}]

    set xs  $xc
    set ys  [expr {$yc+$height/2.0}]

    set xe  [expr {$xc+$width/2.0}]
    set ye  $yc

    set xw  [expr {$xc-$width/2.0}]
    set yw  $yc

    set xnw [expr {($xn+$xw)/2.0}]
    set ynw [expr {($yn+$yw)/2.0}]
    set xsw [expr {($xs+$xw)/2.0}]
    set ysw [expr {($ys+$yw)/2.0}]

    set xne [expr {($xn+$xe)/2.0}]
    set yne [expr {($yn+$ye)/2.0}]
    set xse [expr {($xs+$xe)/2.0}]
    set yse [expr {($ys+$ye)/2.0}]

    set coords  [list $xn $yn $xne $yne $xe $ye $xse $yse $xs $ys \
                      $xsw $ysw $xw $yw $xnw $ynw $xc $yc]

    #
    # Construct the diamond
    #
    set     items [lindex $textobj 1]
    lappend items [$state(canvas) create polygon \
                       $xn $yn $xe $ye $xs $ys $xw $yw \
                       -fill    $state(fillcolor) \
                       -outline $state(color)     \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# drum --
#    Draw a drum-shape from the current position
# Arguments:
#    text      Text to be fitted in the drum
#    width     (Optional) width in pixels or "fitting"
#    height    (Optional) height in pixels
# Result:
#    ID of the drum
# Side effect:
#    Drum-shape box drawn with text inside, current position set
#
proc ::Diagrams::drum {text {width {}} {height {}} } {
    variable state

    #
    # Before we create the text object, we need to store the
    # current position ...
    #
    pushstate
    set textobj [plaintext $text $width $height]

    foreach {dummy x1 y1} [getpos NW $textobj] {break}
    foreach {dummy x2 y2} [getpos SE $textobj] {break}

    set aspect 0.35

    if { $width == {} || $width == "fitting" } {
        set width  [expr {$x2-$x1+10}]
        set height [expr {$y2-$y1+10+$aspect*$width}]
    }

    set xc  [expr {($x1+$x2)/2.0}]
    set yc  [expr {($y1+$y2)/2.0}]

    set hellips [expr {$height*$aspect}]

    set xtop1   [expr {$xc-$width/2}]
    set xtop2   [expr {$xc+$width/2}]
    set ytop1   [expr {$yc-$height/2+$hellips/2}]
    set ytop2   [expr {$yc-$height/2-$hellips/2}]

    set xline1  $xtop1
    set xline2  $xtop2
    set yline1  [expr {$yc-$height/2}]
    set yline2  [expr {$yc+$height/2}]

    set xbot1   $xtop1
    set xbot2   $xtop2
    set ybot1   [expr {$yc+$height/2+$hellips/2}]
    set ybot2   [expr {$yc+$height/2-$hellips/2}]

    set coords  [list $xc     $ytop2  $xline2 $yline1 $xline2 $yc     \
                      $xline2 $yline2 $xc     $ybot2  $xline1 $yline2 \
                      $xline1 $yc     $xline1 $yline2 $xc     $yc     ]

    #
    # Construct the drum
    # (We need quite a few pieces here ...)
    #
    set     items [lindex $textobj 1]
    lappend items \
        [$state(canvas) create rectangle $xline1 $yline1 $xline2 $yline2 \
             -fill $state(fillcolor) -outline {}] \
        [$state(canvas) create line $xline1 $yline1 $xline1 $yline2 \
             -fill $state(color)] \
        [$state(canvas) create line $xline2 $yline1 $xline2 $yline2 \
             -fill $state(color)] \
        [$state(canvas) create oval $xtop1  $ytop1  $xtop2  $ytop2 \
             -fill  $state(fillcolor) -outline $state(color) \
             -width $state(linewidth) -dash    $state(linestyle) ] \
        [$state(canvas) create arc  $xbot1  $ybot1  $xbot2  $ybot2 \
             -fill $state(fillcolor) -outline {} \
             -dash    $state(linestyle) \
             -start 179 -extent 182 -style chord] \
        [$state(canvas) create arc  $xbot1  $ybot1  $xbot2  $ybot2 \
             -fill  $state(fillcolor) -outline $state(color) \
             -width $state(linewidth) -dash    $state(linestyle) \
             -start 179 -extent 182 -style arc]
    $state(canvas) raise [lindex $items 0]

    #
    # Move the combined object to the original "current" position
    #
    popstate
    set obj [moveobject [list BOX $items $coords]]
    set state(usegap)   1
    return $obj
}

# arrow --
#    Draw an arrow from the current position to the next
# Arguments:
#    text      (Optional) text to written above the arrow
#    length    (Optional) length in pixels
#    heads     (Optional) which arrow heads (defaults to end)
# Result:
#    ID of the arrow
# Side effect:
#    Arrow drawn
#
proc ::Diagrams::arrow { {text {}} {length {}} {heads last}} {
    variable state

    if { $length != {} } {
        set factor  [expr {hypot($state(xdir),$state(ydir))}]
        set dxarrow [expr {$length*$state(xdir)/$factor}]
        set dyarrow [expr {$length*$state(ydir)/$factor}]
    } else {
        set dxarrow [expr {$state(xdir)*$state(xgap)}]
        set dyarrow [expr {$state(ydir)*$state(ygap)}]
    }

    set x1      $state(xcurr)
    set y1      $state(ycurr)
    set x2      [expr {$state(xcurr)+$dxarrow}]
    set y2      [expr {$state(ycurr)+$dyarrow}]

    set item [$state(canvas) create line $x1 $y1 $x2 $y2 \
                 -fill    $state(colour)    \
                 -smooth  $state(spline)    \
                 -arrow   $heads            \
                 -width   $state(linewidth) \
                 -dash    $state(linestyle) ]

    set xt [expr {($x1+$x2)/2}]
    set yt [expr {($y1+$y2)/2}]

    set item [$state(canvas) create text $xt $yt -text $text \
                 -font    $state(textfont) \
                 -anchor  $state(anchor)   \
                 -justify $state(justify)]

    set item [list ARROW $item [list $x1 $y1 $x2 $y2]]

    #
    # Ignore the direction of motion - we need the end point
    #
    currentpos [position $x2 $y2]

    set state(lastitem) $item
    set state(usegap)   0
    return $item
}

# line --
#    Draw a line specified via positions or via line segments
# Arguments:
#    args        All arguments (either position or length-angle pairs)
# Result:
#    ID of the line
# Side effect:
#    Line drawn
#
proc ::Diagrams::line {args} {
    variable state
    variable torad

    #
    # Get the current position if the first arguments
    # are line segments (this guarantees that x, y are
    # defined)
    #
    if { [lindex [lindex $args 0] 0] != "POSITION" } {
        set args [linsert $args 0 [currentpos]]
    }

    set xycoords {}
    set x1       {}
    set x2       {}
    set y1       {}
    set y2       {}

    set idx 0
    set number [llength $args]
    while { $idx < $number } {
        set arg [lindex $args $idx]

        if { [lindex $arg 0] != "POSITION" } {
            incr idx
            set length $arg
            set angle  [lindex $args $idx]

            set x      [expr {$x+$length*cos($torad*$angle)}]
            set y      [expr {$y-$length*sin($torad*$angle)}]
        } else {
            foreach {dummy x y} [lindex $args $idx] {break}
        }

        lappend xycoords $x $y

        if { $x1 == {} || $x1 > $x } { set x1 $x }
        if { $x2 == {} || $x2 < $x } { set x2 $x }
        if { $y1 == {} || $y1 > $y } { set y1 $y }
        if { $y2 == {} || $y2 < $y } { set y2 $y }

        incr idx
    }

    set item [$state(canvas) create line $xycoords \
                 -smooth  $state(spline)    \
                 -fill    $state(colour)    \
                 -width   $state(linewidth) \
                 -dash    $state(linestyle) ]

    set item [list LINE $item [list $x1 $y1 $x2 $y2]]

    currentpos [getpos 1 $item] ;# Absolute index, rather than particular direction

    set state(lastitem) $item
    set state(usegap)   0
    return $item
}

# bracket --
#    Draw three line segments in the form of a square bracket from
#    one position to the next
# Arguments:
#    dir         Direction of the bracket (east, west, north or south)
#    dist        Distance of the
# Result:
#    ID of the "bracket"
# Side effect:
#    Three line segments drawn
#
proc ::Diagrams::bracket {dir dist begin end} {
    variable state

    set coords [lrange $begin 1 2]
    if { $dir == "west" } {
       lappend coords [expr {[lindex $begin 1]-$dist}] [lindex $begin 2]
       lappend coords [expr {[lindex $begin 1]-$dist}] [lindex $end 2]
    }
    if { $dir == "east" } {
       lappend coords [expr {[lindex $begin 1]+$dist}] [lindex $begin 2]
       lappend coords [expr {[lindex $begin 1]+$dist}] [lindex $end 2]
    }
    if { $dir == "south" } {
       lappend coords [lindex $begin 1] [expr {[lindex $begin 2]+$dist}]
       lappend coords [lindex $end 1]   [expr {[lindex $begin 2]+$dist}]
    }
    if { $dir == "north" } {
       lappend coords [lindex $begin 1] [expr {[lindex $begin 2]-$dist}]
       lappend coords [lindex $end 1]   [expr {[lindex $begin 2]-$dist}]
    }
    lappend coords [lindex $end 1] [lindex $end 2]

    $state(canvas) create line $coords -arrow last \
                       -width   $state(linewidth) \
                       -dash    $state(linestyle) ]

    set item [list ARROW $item [join [lrange $coords 0 1] [lrange $coords end-1 end]]]

    #
    # Ignore the direction of motion - we need the end point
    #
    currentpos [position [lindex $coords end-1] [lindex $coords end]]

    set state(lastitem) $item
    set state(usegap)   0
    return $item
}

# Announce our presence
#
package provide Diagrams 0.2

#
# A small demonstration ...
#
if { 0 } {
pack [canvas .c -width 500 -height 500 -bg white]

namespace import ::Diagrams::*

console show
drawin .c
linestyle dot

textcolor green
set C [circle "Hi there!" 20]
arrow "XX" 40 none
direction south
arrow "YY" 40
set B [box Aha]

puts "Pos: [getpos S $C]"
line [getpos S $B] 100 270
line [getpos S $B] 100 0

}
if { 0 } {
pack [canvas .c -width 500 -height 500 -bg white]

namespace import ::Diagrams::*

console show
drawin .c
#linestyle dot
#linewidth 3

textcolor green
box "There is\nstill a lot to\ndo!"
arrow "" 230
textcolor blue
box "But it looks nice"
direction south
textcolor black
color magenta; circle "Or does it?" ;color black
direction southwest
arrow "" 100
set B1 [box "Yes, it sure does!"]

fillcolor red
foreach {text dir} {A southwest B south C southeast} {
    direction $dir
    currentpos [getpos $dir $B1]
    arrow "" 100
    box $text
}
slanted "Hm, this\nis okay ..."
direction south
arrow ""
diamond "Okay\n?"
direction west
arrow "" 50
drum "Yes!"

fillcolor green
currentpos [position 70 200]
slanted Hm
direction north ; arrow N 30
#
# This does not work cleanly: lastitem = arrow :(
#
direction south
arrow S 30

#line 20 45 20 90 20 135 30 10

}
#
# Experiments with mathematical formulae
#
proc ::Diagrams::segm {args} {
    variable state
    #
    # TODO: the horizontal centre!!
    #
    set pos [currentpos]
    set items {}
    foreach text $args {
        usegap 0
        if { [lindex [split $text] 0] != "BOX" } {
            puts "text: $text"
            set text [plaintext $text]
        } else {
            puts "original object: $text"
            set text [moveobject $text]
        }
        puts "object: $text"
        set items [concat $items [lindex $text 1]]
        direction east
    }

    foreach {x1 y1 x2 y2} [eval $state(canvas) bbox $items] {break}
    set xc     [expr {($x1+$x2)/2}]
    set yc     [expr {($y1+$y2)/2}]
    set coords [list $xc $y1 $x2 $y1 $x2 $yc $x2 $y2 $xc $y2 \
                     $x1 $y2 $x1 $yc $x1 $y1 $xc $yc]
    set obj [list BOX $items $coords]
    usegap 0
    puts "result: $obj"
    currentpos $pos
    return $obj
}
proc ::Diagrams::div {numerator denominator} {
    variable state

    usegap 0
    set pos [currentpos]
    direction north
    set num [segm $numerator]
    currentpos $pos
    direction south
    usegap 0
    set den [segm $denominator]
    currentpos $pos

    foreach {dummy xn1 yn1} [getpos NW $num] {break}
    foreach {dummy xn2 yn2} [getpos SE $num] {break}
    foreach {dummy xd1 yd1} [getpos NW $den] {break}
    foreach {dummy xd2 yd2} [getpos SE $den] {break}

    set twidth [expr {$xn2-$xn1}]
    if { ($xn2-$xn1) < ($xd2-$xd1) } {
        set twidth [expr {$xd2-$xd1}]
    }
    set x1   [expr {[lindex $pos 1]-$twidth/2}]
    set x2   [expr {[lindex $pos 1]+$twidth/2}]
    set y    [lindex $pos 2]
    set item [$state(canvas) create line $x1 $y $x2 $y \
                 -fill    $state(colour)]

    puts "line: $x1 $y $x2 $y"

    set items [concat [lindex $num 1] [lindex $den 1] $item]

    set xc [expr {$x1+$x2}]
    set coords [list $xc  $yn1   $x2  $yn1   $x2  $y   \
                     $x2  $yd2   $xc  $yd2   $x1  $yd2 \
                     $x1  $y     $x1  $yn1   $xc  $y ]

   #set obj [moveobject [list BOX $items $coords]]
    set obj [list BOX $items $coords]
    usegap 1
    return $obj
}
if { 0 } {
currentpos [position 100 100]
set nn [::Diagrams::div A B]
puts "nn: $nn"
set bb [::Diagrams::segm B+C+ $nn]
currentpos [position 100 100]
puts [::Diagrams::div A $bb]


#
# Experiments with chemical structure formulae
# (Awaits update of "line")
#
if { 0 } {
proc ring {} {
   set side 20
   line $side 60 $side 0 $side -60 $side -120 $side 180 $side 120
}

proc bond {} {
   set side 20
   line $side 0
}

#
# Very primitive chemical formula
# -- order of direction/currentpos important!
#
direction east
currentpos [position 100 400]
ring; bond; ring; bond; plaintext CH3
}

saveps arjen.eps
}

if {![package vsatisfies [package provide Tcl] 8.3]} {
    # PRAGMA: returnok
    return
}
package ifneeded Diagrams 0.2 [list source [file join $dir draw_diagram.tcl]]

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.4] } { return }
package ifneeded getstring 0.1 [list source [file join $dir tk_getString.tcl]]

# tk_getString.tcl --
#
#       A dialog which prompts for a string input
#
# Copyright (c) 2005    Aaron Faupell <afaupell@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tk_getString.tcl,v 1.11 2005/04/13 01:29:22 andreas_kupries Exp $

package require Tk
package provide getstring 0.1

namespace eval ::getstring {
    namespace export tk_getString
}

if {[tk windowingsystem] == "win32"} {
    option add *TkSDialog*Button.width -8 widgetDefault
    option add *TkSDialog*Button.padX 1m widgetDefault
} else {
    option add *TkSDialog.borderWidth 1 widgetDefault
    option add *TkSDialog*Button.width 5 widgetDefault
}
option add *TkSDialog*Entry.width 20 widgetDefault

proc ::getstring::tk_getString {w var text args} {
    array set options {
        -allowempty 0
        -entryoptions {}
        -title "Enter Information"
    }
    parseOpts options {{-allowempty boolean} {-entryoptions {}} {-geometry {}} \
                       {-title {}}} $args

    variable ::getstring::result
    upvar $var result
    catch {destroy $w}
    set focus [focus]
    set grab [grab current .]

    toplevel $w -relief raised -class TkSDialog
    wm title $w $options(-title)
    wm iconname $w $options(-title)
    wm protocol $w WM_DELETE_WINDOW {set ::getstring::result 0}
    wm transient $w [winfo toplevel [winfo parent $w]]
    wm resizable $w 1 0

    eval [list entry $w.entry] $options(-entryoptions)
    button $w.ok -text OK -default active -command {set ::getstring::result 1}
    button $w.cancel -text Cancel -command {set ::getstring::result 0}
    label $w.label -text $text

    grid $w.label -columnspan 2 -sticky ew -padx 5 -pady 3
    grid $w.entry -columnspan 2 -sticky ew -padx 5 -pady 3
    grid $w.ok $w.cancel -padx 4 -pady 7
    grid rowconfigure $w 2 -weight 1
    grid columnconfigure $w {0 1} -uniform 1 -weight 1

    bind $w <Return> [list $w.ok invoke]
    bind $w <Escape> [list $w.cancel invoke]
    bind $w <Destroy> {set ::getstring::result 0}
    if {!$options(-allowempty)} {
        bind $w.entry <KeyPress> [list after idle [list ::getstring::getStringEnable $w]]
        $w.ok configure -state disabled 
    }

    wm withdraw $w
    update idletasks
    focus -force $w.entry
    if {[info exists options(-geometry)]} {
        wm geometry $w $options(-geometry)
    } elseif {[winfo parent $w] == "."} {
        set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
        set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
        wm geom $w +$x+$y
    } else {
        set t [winfo toplevel [winfo parent $w]]
        set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}]
        set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}]
        wm geom $w +$x+$y
    }
    wm deiconify $w
    grab $w

    tkwait variable ::getstring::result
    set result [$w.entry get]
    bind $w <Destroy> {}
    grab release $w
    destroy $w
    focus -force $focus
    if {$grab != ""} {grab $grab}
    update idletasks
    return $::getstring::result
}

proc ::getstring::parseOpts {var opts input} {
    upvar $var output
    for {set i 0} {$i < [llength $input]} {incr i} {
        for {set a 0} {$a < [llength $opts]} {incr a} {
           if {[lindex $opts $a 0] == [lindex $input $i]} { break }
        }
        if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" }
        set opt [lindex $opts $a]
        if {[llength $opt] > 1} {
            foreach {opt type} $opt {break}
            if {[incr i] >= [llength $input]} { error "$opt requires an argument" }
            if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" }
            set output($opt) [lindex $input $i]
        } else {
            set output($opt) {}
        }
    }
}

proc ::getstring::getStringEnable {w} {
    if {![winfo exists $w.entry]} { return }
    if {[$w.entry get] != ""} {
        $w.ok configure -state normal
    } else {
        $w.ok configure -state disabled
    }
}

# history.tcl --
#
#       Provides a history mechanism for entry widgets
#
# Copyright (c) 2005    Aaron Faupell <afaupell@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: history.tcl,v 1.4 2005/08/25 03:36:58 andreas_kupries Exp $

package require Tk
package provide history 0.1

namespace eval history {
    bind History <Up>   {::history::up %W}
    bind History <Down> {::history::down %W}
}

proc ::history::init {w {len 30}} {
    variable history
    variable prefs
    set bt [bindtags $w]
    if {[lsearch $bt History] > -1} { error "$w already has a history" }
    if {[set i [lsearch $bt $w]] < 0} { error "cant find $w in bindtags" }
    bindtags $w [linsert $bt [expr {$i + 1}] History]
    array set history [list $w,list {} $w,cur -1]
    set prefs(maxlen,$w) $len
    return $w
}

proc ::history::remove {w} {
    variable history
    variable prefs
    set bt [bindtags $w]
    if {[set i [lsearch $bt History]] < 0} { error "$w has no history" }
    bindtags $w [lreplace $bt $i $i]
    unset prefs(maxlen,$w) history($w,list) history($w,cur)
}

proc ::history::add {w line} {
    variable history
    variable prefs
    if {$history($w,cur) > -1 && [lindex $history($w,list) $history($w,cur)] == $line} {
        set history($w,list) [lreplace $history($w,list) $history($w,cur) $history($w,cur)]
    }
    set history($w,list) [linsert $history($w,list) 0 $line]
    set history($w,list) [lrange $history($w,list) 0 $prefs(maxlen,$w)]
    set history($w,cur) -1
}

proc ::history::up {w} {
    variable history
    if {[lindex $history($w,list) [expr {$history($w,cur) + 1}]] != ""} {
        if {$history($w,cur) == -1} {
            set history($w,tmp) [$w get]
        }
        $w delete 0 end
        incr history($w,cur)
        $w insert end [lindex $history($w,list) $history($w,cur)]
    } else {
        alert $w
    }
}

proc ::history::down {w} {
    variable history
    if {$history($w,cur) != -1} {
        $w delete 0 end
        if {$history($w,cur) == 0} {
            $w insert end $history($w,tmp)
            set history($w,cur) -1
        } else {
            incr history($w,cur) -1
            $w insert end [lindex $history($w,list) $history($w,cur)]
        }
    } else {
        alert $w
    }
}

proc ::history::get {w} {
    variable history
    return $history($w,list)
}

proc ::history::clear {w} {
    variable history
    set history($w,cur) -1
    set history($w,list) {}
    unset -nocomplain history($w,tmp)
}

proc ::history::configure {w option {value {}}} {
    variable history
    variable prefs
    switch -exact -- $option {
        length {
            if {$value == ""} { return $prefs(maxlen,$w) }
            if {![string is integer -strict $value]} { error "length must be an integer" }
            set prefs(maxlen,$w) $value
        }
        alert {
            if {$value == ""} { return [info body ::history::alert] }
            proc ::history::alert w $value
        }
        default {
            error "unknown option $option"
        }
    }
}

proc ::history::alert {w} {bell}

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if { ![package vsatisfies [package provide Tcl] 8.4] } { return }
package ifneeded history 0.1 [list source [file join $dir history.tcl]]

# ico.tcl --
#
# Win32 ico manipulation code
#
# Copyright (c) 2003-2007 Aaron Faupell
# Copyright (c) 2003-2004 ActiveState Corporation
#
# RCS: @(#) $Id: ico.tcl,v 1.28 2008/03/12 07:25:49 hobbs Exp $

# Sample usage:
#	set file bin/wish.exe
#	set icos [::ico::icons $file]
#	set img  [::ico::getIcon $file [lindex $icos 1] -format image -res 32]

package require Tcl 8.4

# Instantiate vars we need for this package
namespace eval ::ico {
    namespace export icons iconMembers getIcon getIconByName writeIcon copyIcon transparentColor clearCache EXEtoICO
    # stores cached indices of icons found
    variable  RES
    array set RES {}

    # used for 4bpp number conversion
    variable BITS
    array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \
			0101 5 0110 6 0111 7 1000 8 1001 9 \
			1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \
			\
			00000 00 00001 0F 00010 17 00011 1F \
			00100 27 00101 2F 00110 37 00111 3F \
			01000 47 01001 4F 01010 57 01011 5F \
			01100 67 01101 6F 01110 77 01111 7F \
			10000 87 10001 8F 10010 97 10011 9F \
			10100 A7 10101 AF 10110 B7 10111 BF \
			11000 C7 11001 CF 11010 D7 11011 DF \
			11100 E7 11101 EF 11110 F7 11111 FF]
}


# icons --
#
# List of icons in a file
#
# ARGS:
#	file	File to extract icon info from.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO, ICL, BMP, and ICODATA
#
# RETURNS:
#	list of icon names or numerical IDs
#
proc ::ico::icons {file args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getIconList$type]]} {
	return -code error "unsupported file format $type"
    }
    getIconList$type [file normalize $file]
}

# iconMembers --
#
# Get info on images which make up an icon
#
# ARGS:
#	file		File containing icon
#       name		Name of the icon in the file
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO, ICL, BMP, and ICODATA
#
# RETURNS:
#	list of icons as tuples {name width height bpp}
#
proc ::ico::iconMembers {file name args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getIconMembers$type]]} {
	return -code error "unsupported file format $type"
    }
    getIconMembers$type [file normalize $file] $name
}

# getIcon --
#
# Get pixel data or image of icon
#
# ARGS:
#	file		File to extract icon info from.
#	name		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	?-res?		Set the preferred resolution.
#	?-bpp?		Set the preferred color depth in bits per pixel.
#	?-exact?	Accept only exact matches for res and bpp. Returns
#			an error if there is no exact match.
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO, ICL, BMP, and ICODATA
#	?-format?	Output format. Must be one of "image" or "colors"
#			'image' will return the name of a Tk image.
#			'colors' will return a list of pixel values
#	?-image?	If output is image, use this as the name of Tk image
#			created
#
# RETURNS:
#	pixel data as a list that could be passed to 'image create'
#	or the name of a Tk image
#
proc ::ico::getIcon {file name args} {
    set image {}
    set format image
    set exact 0
    set bpp 24
    parseOpts {type format image res bpp exact} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getRawIconData$type]]} {
        return -code error "unsupported file format $type"
    }
    # ICODATA is a pure data type - not a real file
    if {$type ne "ICODATA"} {
	set file [file normalize $file]
    }

    set mem [getIconMembers$type $file $name]

    if {![info exists res]} {
        set icon [lindex $mem 0 0]
    } elseif {$exact} {
        set icon [lsearch -inline -glob $mem "* $res $bpp"]
        if {$icon == ""} { return -code error "No matching icon" }
    } else {
        set mem [lsort -integer -index 1 $mem]
        set match ""
        foreach x $mem {
            if {[lindex $x 1] == [lindex $res 0]} { lappend match $x }
        }
        if {$match == ""} {
            # todo: resize a larger icon
            #return -code error "No matching icon"
            set match [list [lindex $mem end]]
        }
        set match [lsort -integer -decreasing -index 3 $match]
        foreach x $match {
            if {[lindex $x 3] <= $bpp} { set icon [lindex $x 0]; break }
        }
        if {![info exists icon]} { set icon [lindex $match end 0]}
    }
    if {$format eq "name"} {
        return $icon
    }
    set colors [eval [linsert [getRawIconData$type $file $icon] 0 getIconAsColorList]]
    if {$format eq "image"} {
        return [createImage $colors $image]
    }
    return $colors
}

# getIconByName --
#
# Get pixel data or image of icon name in file. The icon name
# is the first element of the sublist from [iconMembers].
#
# ARGS:
#	file		File to extract icon info from.
#	name		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO, ICL, BMP, and ICODATA
#	?-format?	Output format. Must be one of "image" or "colors"
#			'image' will return the name of a Tk image.
#			'colors' will return a list of pixel values
#	?-image?	If output is image, use this as the name of Tk image
#			created
#
# RETURNS:
#	pixel data as a list that could be passed to 'image create'
#
proc ::ico::getIconByName {file name args} {
    set format image
    set image {}
    parseOpts {type format image} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getRawIconData$type]]} {
        return -code error "unsupported file format $type"
    }
    # ICODATA is a pure data type - not a real file
    if {$type ne "ICODATA"} {
        set file [file normalize $file]
    }
    set colors [eval [linsert [getRawIconData$type $file $name] 0 getIconAsColorList]]
    if {$format eq "image"} {
        return [createImage $colors $image]
    }
    return $colors
}

# getFileIcon --
#
# Get the registered icon for the file under Windows
#
# ARGS:
#	file	File to get icon for.
#	
#	optional arguments and return values are the same as getIcon
#
proc ::ico::getFileIcon {file args} {
    set icon "%SystemRoot%\\System32\\shell32.dll,0"
    if {[file isdirectory $file] || $file == "Folder"} {
        if {![catch {registry get HKEY_CLASSES_ROOT\\Folder\\DefaultIcon ""} reg]} {
            set icon $reg
        }
    } else {
        set ext [file extension $file]
        if {![catch {registry get HKEY_CLASSES_ROOT\\$ext ""} doctype]} {
            if {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\CLSID ""} clsid] && \
                ![catch {registry get HKEY_CLASSES_ROOT\\CLSID\\$clsid\\DefaultIcon ""} reg]} {
                set icon $reg
            } elseif {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\DefaultIcon ""} reg]} {
                set icon $reg
            }
        }
    }
    set index [lindex [split $icon ,] 1]
    set icon [lindex [split $icon ,] 0]
    if {$index == ""} { set index 0 }
    set icon [string trim $icon "@'\" "]
    while {[regexp -nocase {%([a-z]+)%} $icon -> var]} {
        set icon [string map [list %$var% $::env($var)] $icon]
    }
    set icon [string map [list %1 $file] $icon]
    if {$index < 0} {
        if {![catch {eval [list getIcon $icon [string trimleft $index -]] $args} output]} {
            return $output
        }
        set index 0
    }
    return [eval [list getIcon $icon [lindex [icons $icon] $index]] $args]
}

# writeIcon --
#
# Overwrite write image in file with depth/pixel data
#
# ARGS:
#	file	File to extract icon info from.
#	name	Name of image in the file to use.  The name is the first element
#		in the sublists returned by iconMembers.
#	bpp	bit depth of icon we are writing
#	data	Either pixel color data (as returned by getIcon -format color)
#		or the name of a Tk image.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO and ICL
#
# RETURNS:
#	nothing
#
proc ::ico::writeIcon {file name bpp data args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands writeIcon$type]]} {
	return -code error "unsupported file format $type"
    }
    if {[llength $data] == 1} {
        set data [getColorListFromImage $data]
    } elseif {[lsearch -glob [join $data] #*] > -1} {
        set data [translateColors $data]
    }
    if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} {
	return -code error "invalid color depth"
    }
    set palette {}
    if {$bpp <= 8} {
	set palette [getPaletteFromColors $data]
	if {[lindex $palette 0] > (1 << $bpp)} {
	    return -code error "specified color depth too low"
	}
	set data  [lindex $palette 2]
	set palette [lindex $palette 1]
	append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]]
    }
    set and [getAndMaskFromColors $data]
    set xor [getXORFromColors $bpp $data]
    # writeIcon$type file index w h bpp palette xor and
    writeIcon$type [file normalize $file] $name \
	[llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and
}


# copyIcon --
#
# Copies an icon directly from one file to another
#
# ARGS:
#	file1	        File to extract icon info from.
#	name1		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	file2	        File to write icon to.
#	name2		Name of image in the file to use.  The name is the first element
#			in the sublists returned by iconMembers.
#	?-fromtype?	Type of source file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO, ICL, BMP, and ICODATA
#	?-totype?	Type of destination file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO, ICL, BMP, and ICODATA
#
# RETURNS:
#	nothing
#
proc ::ico::copyIcon {file1 name1 file2 name2 args} {
    parseOpts {fromtype totype} $args
    if {![info exists fromtype]} {
        # $type wasn't specified - get it from the extension
        set fromtype [fileext $file1]
    }
    if {![info exists totype]} {
        # $type wasn't specified - get it from the extension
        set totype [fileext $file2]
    }
    if {![llength [info commands writeIcon$totype]]} {
	return -code error "unsupported file format $totype"
    }
    if {![llength [info commands getRawIconData$fromtype]]} {
	return -code error "unsupported file format $fromtype"
    }
    set src [getRawIconData$fromtype $file1 $name1]
    writeIcon $file2 $name2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype
}

#
# transparentColor --
#
# Turns on transparency for all pixels in the image that match the color
#
# ARGS:
#	img	        Name of the Tk image to modify, or an image in color list format
#	color	        Color in #hex format which will be made transparent
#
# RETURNS:
#	the data or image after modification
#
proc ::ico::transparentColor {img color} {
    if {[llength $img] == 1} {
        package require Tk
        if {[string match "#*" $color]} {
            set color [scan $color "#%2x%2x%2x"]
        }
        set w [image width $img]
        set h [image height $img]
        for {set y 0} {$y < $h} {incr y} {
            for {set x 0} {$x < $w} {incr x} {
                if {[$img get $x $y] eq $color} {$img transparency set $x $y 1}
            }
        }
    } else {
        set y 0
        foreach row $img {
            set x 0
            foreach px $row {
                if {$px == $color} {lset img $y $x {}}
                incr x
            }
            incr y
        }
    }
    return $img
}

#
# clearCache --
#
# Clears the cache of icon offsets
#
# ARGS:
#	file	optional filename
#
#
# RETURNS:
#	nothing
#
proc ::ico::clearCache {{file {}}} {
    variable RES
    if {$file ne ""} {
	array unset RES $file,*
    } else {
	unset RES
	array set RES {}
    }
}

#
# EXEtoICO --
#
# Convert all icons found in exefile into regular icon files
#
# ARGS:
#	exeFile	        Input EXE filename
#	?icoDir?	Output ICO directory. Default is the
#			same directory exeFile is located in
#
# RETURNS:
#	nothing
#
proc ::ico::EXEtoICO {exeFile {icoDir {}}} {
    variable RES

    set file [file normalize $exeFile]
    FindResources $file

    if {$icoDir == ""} { set icoDir [file dirname $file] }

    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    foreach group $RES($file,group,names) {
        set dir  {}
        set data {}
        foreach icon $RES($file,group,$group,members) {
            seek $fh $RES($file,icon,$icon,offset) start
	    set ico $RES($file,icon,$icon,data)
	    eval [list lappend dir] $ico
	    append data [read $fh [eval calcSize $ico 40]]
        }

        # write them out to a file
        set ifh [open [file join $icoDir [file tail $exeFile]-$group.ico] w+]
        fconfigure $ifh -eofchar {} -encoding binary -translation lf

        bputs $ifh sss 0 1 [llength $RES($file,group,$group,members)]
        set offset [expr {6 + ([llength $RES($file,group,$group,members)] * 16)}]
        foreach {w h bpp} $dir {
            set len [calcSize $w $h $bpp 40]
            lappend fix $offset $len
            bputs $ifh ccccssii $w $h [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 1 $bpp $len $offset
            set offset [expr {$offset + $len}]
        }
        puts -nonewline $ifh $data
        foreach {offset size} $fix {
            seek $ifh [expr {$offset + 20}] start
            bputs $ifh i $size
        }
        close $ifh
    }
    close $fh
}



##
## Internal helper commands.
## Some may be appropriate for exposing later, but would need docs
## and make sure they "fit" in the API.
##

# gets the file extension as we use it internally (upper case, no '.')
proc ::ico::fileext {file} {
    return [string trimleft [string toupper [file extension $file]] .]
}

# helper proc to parse optional arguments to some of the public procs
proc ::ico::parseOpts {acc opts} {
    foreach {key val} $opts {
        set key [string trimleft $key -]
	if {[lsearch -exact $acc $key] >= 0} {
	    upvar $key $key
	    set $key $val
	} elseif {$key ne ""} {
	    return -code error "unknown option \"$key\": must be one of $acc"
	}
    }
}

# formats a single color from a binary decimal list format to the #hex format
proc ::ico::formatColor {r g b} {
    format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c]
}

# translates a color list from the #hex format to the decimal list format
#                                #0000FF                  {0 0 255}
proc ::ico::translateColors {colors} {
    set new {}
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    lappend tline [scan $x "#%2x%2x%2x"]
	}
	set new [linsert $new 0 $tline]
    }
    return $new
}

# reads a 32 bit signed integer from the filehandle
proc ::ico::getdword {fh} {
    binary scan [read $fh 4] i* tmp
    return $tmp
}

proc ::ico::getword {fh} {
    binary scan [read $fh 2] s* tmp
    return $tmp
}

proc ::ico::getulong {fh} {
    binary scan [read $fh 4] i tmp
    return [format %u $tmp]
}

proc ::ico::getushort {fh} {
    binary scan [read $fh 2] s tmp
    return [expr {$tmp & 0x0000FFFF}]
}

proc ::ico::bputs {fh format args} {
    puts -nonewline $fh [eval [list binary format $format] $args]
}

proc ::ico::createImage {colors {name {}}} {
    package require Tk
    set h [llength $colors]
    set w [llength [lindex $colors 0]]
    if {$name ne ""} {
	set img [image create photo $name -width $w -height $h]
    } else {
	set img [image create photo -width $w -height $h]
    }
    if {0} {
	# if image supported "" colors as transparent pixels,
	# we could use this much faster op
	$img put -to 0 0 $colors
    } else {
	for {set x 0} {$x < $w} {incr x} {
	    for {set y 0} {$y < $h} {incr y} {
                set clr [lindex $colors $y $x]
                if {$clr ne ""} {
                    $img put -to $x $y $clr
                }
            }
        }
    }
    return $img
}

# return a list of colors in the #hex format from raw icon data
# returned by readDIB
proc ::ico::getIconAsColorList {w h bpp palette xor and} {
    # Create initial empty color array that we'll set indices in
    set colors {}
    set row    {}
    set empty  {}
    for {set x 0} {$x < $w} {incr x} { lappend row $empty }
    for {set y 0} {$y < $h} {incr y} { lappend colors $row }

    set x 0
    set y [expr {$h-1}]
    if {$bpp == 1} {
	binary scan $xor B* xorBits
	foreach i [split $xorBits {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                lset colors $y $x [lindex $palette $i]
	    }
	    incr x
	}
    } elseif {$bpp == 4} {
	variable BITS
	binary scan $xor B* xorBits
	set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                set bits [string range $xorBits $i [expr {$i+3}]]
                lset colors $y $x [lindex $palette $BITS($bits)]
            }
            incr i 4
            incr x
	}
    } elseif {$bpp == 8} {
	foreach i [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                lset colors $y $x [lindex $palette [scan $i %c]]
	    }
	    incr x
	}
    } elseif {$bpp == 16} {
        variable BITS
        binary scan $xor b* xorBits
        set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                set b1 [string range $xorBits      $i        [expr {$i+4}]]
                set b2 [string range $xorBits [expr {$i+5}]  [expr {$i+9}]]
                set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]]
                lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)"
            }
            incr i 16
            incr x
        }
    } elseif {$bpp == 24} {
        foreach {b g r} [split $xor {}] a [split $and {}] {
            if {$x == $w} { set x 0; incr y -1 }
            if {$a == 0} {
                lset colors $y $x [formatColor $r $g $b]
            }
            incr x
        }
    } elseif {$bpp == 32} {
	foreach {b g r n} [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
                lset colors $y $x [formatColor $r $g $b]
	    }
	    incr x
	}
    }
    return $colors
}

# creates a binary formatted AND mask by reading a list of colors in the decimal list format
# and checking for empty colors which designate transparency
proc ::ico::getAndMaskFromColors {colors} {
    set and {}
    foreach line $colors {
	set l {}
	foreach x $line {append l [expr {$x eq ""}]}
	append l [string repeat 0 [expr {[string length $l] % 32}]]
	foreach {a b c d e f g h} [split $l {}] {
	    append and [binary format B8 $a$b$c$d$e$f$g$h]
	}
    }
    return $and
}

# creates a binary formatted XOR mask in the specified depth format from
# a list of colors in the decimal list format
proc ::ico::getXORFromColors {bpp colors} {
    set xor {}
    if {$bpp == 1} {
	foreach line $colors {
	    foreach {a b c d e f g h} $line {
                foreach x {a b c d e f g h} {
                    if {[set $x] == ""} {set $x 0}
		}
		binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a
		append xor [binary format b8 $a$b$c$d$e$f$g$h]
	    }
	}
    } elseif {$bpp == 4} {
	foreach line $colors {
	    foreach {a b} $line {
		if {$a == ""} {set a 0}
		if {$b == ""} {set b 0}
		binary scan $a$b b4b4 b a
		append xor [binary format b8 $a$b]
	    }
	}
    } elseif {$bpp == 8} {
	foreach line $colors {
	    foreach x $line {
		if {$x == ""} {set x 0}
		append xor [binary format c $x]
	    }
	}
    } elseif {$bpp == 24} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format ccc 0 0 0]
		} else {
		    foreach {a b c n} $x {
			append xor [binary format ccc $c $b $a]
		    }
		}
	    }
	}
    } elseif {$bpp == 32} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format cccc 0 0 0 0]
		} else {
		    foreach {a b c n} $x {
			if {$n == ""} {set n 0}
			append xor [binary format cccc $c $b $a $n]
		    }
		}
	    }
	}
    }
    return $xor
}

# translates a Tk image into a list of colors in the {r g b} format
# one element per pixel and {} designating transparent
# used by writeIcon when writing from a Tk image
proc ::ico::getColorListFromImage {img} {
    package require Tk
    set w [image width $img]
    set h [image height $img]
    set r {}
    for {set y [expr $h - 1]} {$y > -1} {incr y -1} {
	set l {}
	for {set x 0} {$x < $w} {incr x} {
	    if {[$img transparency get $x $y]} {
		lappend l {}
	    } else {
		lappend l [$img get $x $y]
	    }
	}
	lappend r $l
    }
    return $r
}

# creates a palette from a list of colors in the decimal list format
# a palette consists of 3 values, the number of colors, the palette entry itself,
# and the color list transformed to point to palette entries instead of color names
# the palette entry itself is stored as 32bpp in "G B R padding" order
proc ::ico::getPaletteFromColors {colors} {
    set palette "\x00\x00\x00\x00"
    array set tpal {{0 0 0} 0}
    set new {}
    set i 1
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    if {![info exists tpal($x)]} {
		foreach {a b c n} $x {
		    append palette [binary format cccc $c $b $a 0]
		}
		set tpal($x) $i
		incr i
	    }
	    lappend tline $tpal($x)
	}
	lappend new $tline
    }
    return [list $i $palette $new]
}

# calculate byte size of an icon.
# often passed $w twice because $h is double $w in the binary data
proc ::ico::calcSize {w h bpp {offset 0}} {
    set s [expr {int(($w*$h) * ($bpp/8.0)) \
		     + ((($w*$h) + ($h*($w%32)))/8) + $offset}]
    if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] }
    return $s
}

# read a Device Independent Bitmap from the current offset, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIB {fh} {
    binary scan [read $fh 16] x4iix2s w h bpp
    set h [expr {$h / 2}]
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	set colors [read $fh [expr {1 << ($bpp + 2)}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

# read a Device Independent Bitmap from raw data, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIBFromData {data loc} {
    # Read info from location
    binary scan $data @${loc}x4iix2s w h bpp
    set h [expr {$h / 2}]
    # Move over w/h/bpp info + magic offset to start of DIB
    set cnt [expr {$loc + 16 + 24}]

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	# Could do: [binary scan $data @${cnt}c$len colors]
	# and iter over colors, but this is more consistent with $fh version
	set len    [expr {1 << ($bpp + 2)}]
	set colors [string range $data $cnt [expr {$cnt + $len - 1}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
	incr cnt $len
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    # Use -1 to account for string range inclusiveness
    set end  [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}]
    set xor  [string range $data $cnt $end]
    set and1 [string range $data [expr {$end + 1}] \
		  [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	# Has to be decoded by row, in order
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

proc ::ico::getIconListICO {file} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    if {"[getword $fh] [getword $fh]" ne "0 1"} {
	return -code error "not an icon file"
    }
    close $fh
    return 0
}

proc ::ico::getIconListICODATA {data} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    return 0
}

proc ::ico::getIconListBMP {file} {
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    close $fh
    return 0
}

proc ::ico::getIconListEXE {file} {
    variable RES

    set file [file normalize $file]
    if {[FindResources $file] > -1} {
        return $RES($file,group,names)
    } else {
        return ""
    }
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersICO {file name} {
    variable RES

    if {$name ne "0"} { return -code error "no icon \"$name\"" }
    set file [file normalize $file]
    if {[info exists RES($file,group,$name,members)]} {
        set ret ""
        foreach x $RES($file,group,$name,members) {
            lappend ret [linsert $RES($file,icon,$x,data) 0 $x]
        }
        return $ret
    }

    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
        close $fh
	return -code error "not an icon file"
    }

    set ret ""
    set num [getword $fh]
    for {set i 0} {$i < $num} {incr i} {
        set info ""
        lappend RES($file,group,$name,members) $i
	lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c]
	set bpp [scan [read $fh 1] %c]
        if {$bpp == 0} {
	    set orig [tell $fh]
	    seek $fh 9 current
	    seek $fh [expr {[getdword $fh] + 14}] start
	    lappend info [getword $fh]
	    seek $fh $orig start
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend ret [linsert $info 0 $i]
	set RES($file,icon,$i,data) $info
	seek $fh 13 current
    }
    close $fh
    return $ret
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersICODATA {data} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    set r {}
    set cnt 6
    for {set i 0} {$i < $num} {incr i} {
	if {[binary scan $data @${cnt}ccc w h bpp] != 3} {
	    return -code error "error decoding icon data"
	}
	incr cnt 3
	set info [list $i $w $h]
	if {$bpp == 0} {
	    set off [expr {$cnt + 9}]
	    binary scan $data @${off}i off
	    incr off 14
	    binary scan $data @${off}s bpp
	    lappend info $bpp
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend r $info
	incr cnt 13
    }
    return $r
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersBMP {file {name 0}} {
    if {$name ne "0"} { return -code error "no icon \"$name\"" }
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    close $fh
    return [list 1 $w $h $bpp]
}

# returns a list of images that make up the named icon
# as tuples {name width height bpp}. Called by [iconMembers]
proc ::ico::getIconMembersEXE {file name} {
    variable RES
    set file [file normalize $file]
    FindResources $file
    if {![info exists RES($file,group,$name,members)]} { return -code error "no icon \"$name\"" }
    set ret ""
    foreach x $RES($file,group,$name,members) {
        lappend ret [linsert $RES($file,icon,$x,data) 0 $x]
    }
    return $ret
}

# returns an icon in the form:
#       {width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataICO {file name} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
        close $fh
        return -code error "not an icon file"
    }
    set num [getword $fh]
    if {![string is integer -strict $name] || $name < 0 || $name >= $num} { return -code error "no icon \"$name\"" }

    seek $fh [expr {(16 * $name) + 12}] current
    seek $fh [getdword $fh] start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]

    close $fh
    return $dib
}

# returns an icon in the form:
#       {width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataICODATA {data name} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    if {![string is integer -strict $name] || $name < 0 || $name >= $num} {
	return -code error "No icon $name"
    }
    # Move to ico location
    set cnt [expr {6 + (16 * $name) + 12}]
    binary scan $data @${cnt}i loc

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIBFromData $data $loc]

    return $dib
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataBMP {file {name 1}} {
    if {$name ne "1"} {return -code error "No icon \"$name\""}
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
        set colors [read $fh [expr {1 << ($bpp + 2)}]]
        foreach {b g r x} [split $colors {}] {
            lappend palette [formatColor $r $g $b]
        }
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
        # do nothing here
    } else {
        return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and [string repeat 0 [expr {$w * $h}]]
    close $fh

    return [list $w $h $bpp $palette $xor $and]
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataEXE {file name} {
    variable RES

    set file [file normalize $file]
    FindResources $file

    if {![info exists RES($file,icon,$name,offset)]} { error "No icon \"$name\"" }
    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh $RES($file,icon,$name,offset) start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]
    close $fh
    return $dib
}

proc ::ico::writeIconICO {file name w h bpp palette xor and} {
    if {![file exists $file]} {
	set fh [open $file w+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
	set num 0
    } else {
	set fh [open $file r+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
	if {"[getword $fh] [getword $fh]" ne "0 1"} {
	    close $fh
	    return -code error "not an icon file"
	}
	set num [getword $fh]
	seek $fh [expr {6 + (16 * $num)}] start
    }

    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]
    set newicon [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]$palette$xor$and

    set data {}
    for {set i 0} {$i < $num} {incr i} {
        binary scan [read $fh 24] ix16i a b
        seek $fh -24 current
        lappend data [read $fh [expr {$a + $b}]]
    }

    if {![string is integer -strict $name] || $name < 0 || $name >= $num} {
        set name [llength $data]
        lappend data $newicon
    } else {
        set data [lreplace $data $name $name $newicon]
    }
    set num [llength $data]

    seek $fh 0 start
    bputs $fh sss 0 1 $num
    set offset [expr {6 + (16 * $num)}]
    foreach x $data {
        binary scan $x x4iix2s w h bpp
        set len [string length $x]
	# use original height in icon table header
        bputs $fh ccccssii $w [expr {$h / 2}] [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 0 $bpp $len $offset
        incr offset $len
    }
    puts -nonewline $fh [join $data {}]
    close $fh

    return $name
}

proc ::ico::writeIconICODATA {file name w h bpp palette xor and} {
    upvar 2 [file tail $file] input
    if {![info exists input] || ([binary scan $input sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1)} {
	set num 0
    }

    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]
    set newicon [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]$palette$xor$and

    set readpos [expr {6 + (16 * $num)}]
    set data {}
    for {set i 0} {$i < $num} {incr i} {
        binary scan $input @{$readpos}ix16i a b
        lappend data [string range $data $readpos [expr {$readpos + $a + $b}]]
        incr readpos [expr {$readpos + $a + $b}]
    }

    if {![string is integer -strict $name] || $name < 0 || $name >= $num} {
        set name [llength $data]
        lappend data $newicon
    } else {
        set data [lreplace $data $name $name $newicon]
    }
    set num [llength $data]

    set new [binary format sss 0 1 $num]
    set offset [expr {6 + (16 * $num)}]
    foreach x $data {
        binary scan $x x4iix2s w h bpp
        set len [string length $x]
	# use original height in icon table header
        append new [binary format ccccssii $w [expr {$h / 2}] [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 0 $bpp $len $offset]
        incr offset $len
    }
    set input $new
    append input [join $data {}]

    return $name
}

proc ::ico::writeIconBMP {file name w h bpp palette xor and} {
    set fh [open $file w+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    set size [expr {[string length $palette] + [string length $xor]}]
    # bitmap header: magic, file size, reserved, reserved, offset of bitmap data
    bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54
    bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0
    puts -nonewline $fh $palette$xor
    close $fh
}

proc ::ico::writeIconEXE {file name w h bpp palette xor and} {
    variable RES

    set file [file normalize $file]
    set members [getIconMembersEXE $file $name]

    if {![info exists RES($file,icon,$name,data)]} {
        return -code error "no icon \"$name\""
    }
    if {![string match "* $w $h $bpp" $RES($file,icon,$name,data)]} {
	return -code error "icon format differs from original"
    }
    
    set fh [open $file r+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh [expr {$RES($file,icon,$name,offset) + 40}] start

    puts -nonewline $fh $palette$xor$and
    close $fh
}

proc ::ico::FindResources {file} {
    variable RES

    if {[info exists RES($file,group,names)]} {
        return [llength $RES($file,group,names)]
    }

    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    if {[read $fh 2] ne "MZ"} {
	close $fh
	return -code error "unknown file format"
    }
    seek $fh 60 start
    seek $fh [getword $fh] start
    set sig [read $fh 4]
    seek $fh -4 current
    if {$sig eq "PE\000\000"} {
        return [FindResourcesPE $fh $file]
    } elseif {[string match NE* $sig]} {
        return [FindResourcesNE $fh $file]
    } else {
        return -code error "unknown file format"
    }
}

# parse the resource table of 16 bit windows files for icons
proc ::ico::FindResourcesNE {fh file} {
    variable RES

    seek $fh 36 current
    seek $fh [expr {[getword $fh] - 38}] current
    set base [tell $fh]
    set shift [expr {int(pow(2, [getushort $fh]))}]
    while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} {
        set num [getushort $fh]
        if {$type != 3 && $type != 14} {
            seek $fh [expr {($num * 12) + 4}] current
            continue
        }
        set type [string map {3 icon 14 group} $type]
        seek $fh 4 current
        for {set i 0} {$i < $num} {incr i} {
            set offset [expr {[getushort $fh] * $shift}]
            seek $fh 4 current
            set name [getNEResName $fh $base [getushort $fh]]
            set RES($file,$type,$name,offset) $offset
            lappend RES($file,$type,names) $name
            seek $fh 4 current
        }
    }
    if {[array names RES $file,*] == ""} {
        close $fh
        return -1
    }
    foreach x [array names RES $file,group,*,offset] {
        seek $fh [expr {$RES($x) + 4}] start
        binary scan [read $fh 2] s a
        set x [lindex [split $x ,] 2]
        for {set i 0} {$i < $a} {incr i} {
            binary scan [read $fh 14] x12s n
            lappend RES($file,group,$x,members) $n
        }
    }
    foreach x [array names RES $file,icon,*,offset] {
        seek $fh [expr {$RES($x)}] start
        set x [lindex [split $x ,] 2]
        binary scan [read $fh 16] x4iix2s w h bpp
        set RES($file,icon,$x,data) [list $w [expr {$h / 2}] $bpp]
    }
    close $fh
    return [llength $RES($file,group,names)]
}

proc ::ico::getNEResName {fh base data} {
    if {$data == 0} {
        return 0
    }
    binary scan $data b* tmp
    if {[string index $tmp 0] == 0} {
        set cur [tell $fh]
        seek $fh [expr {$data + $base}] start
        binary scan [read $fh 1] c len
        set name [read $fh $len]
        seek $fh $cur start
        return $name
    } else {
        return [expr {$data & 0x7fff}]
    }
}

# parse the resource tree of 32 bit windows files for icons
proc ::ico::FindResourcesPE {fh file} {
    variable RES

    # find the .rsrc section by reading the coff header
    binary scan [read $fh 24] x6sx12s sections headersize
    seek $fh $headersize current
    for {set i 0} {$i < $sections} {incr i} {
        binary scan [read $fh 40] a8x4ix4i type baserva base
        if {[string match .rsrc* $type]} {break}
    }
    # no resource section found = no icons
    if {![string match .rsrc* $type]} {
        close $fh
        return -1
    }
    seek $fh $base start

    seek $fh 12 current
    # number of entries in the resource table. each one is a different resource type
    set entries [expr {[getushort $fh] + [getushort $fh]}]
    for {set i 0} {$i < $entries} {incr i} {
        set type [getulong $fh]
        set offset [expr {[getulong $fh] & 0x7fffffff}]
        if {$type != 3 && $type != 14} {continue}
        set type [string map {3 icon 14 group} $type]

        set cur [tell $fh]
        seek $fh [expr {$base + $offset + 12}] start
        set entries2 [expr {[getushort $fh] + [getushort $fh]}]
        for {set i2 0} {$i2 < $entries2} {incr i2} {
            set name [getPEResName $fh $base [getulong $fh]]
            lappend RES($file,$type,names) $name
            set offset [expr {[getulong $fh] & 0x7fffffff}]

            set cur2 [tell $fh]
            seek $fh [expr {$offset + $base + 12}] start
            set entries3 [expr {[getushort $fh] + [getushort $fh]}]
            for {set i3 0} {$i3 < $entries3} {incr i3} {
                seek $fh 4 current
                set offset [expr {[getulong $fh] & 0x7fffffff}]
                set cur3 [tell $fh]

                seek $fh [expr {$offset + $base}] start
                set rva [getulong $fh]
                set RES($file,$type,$name,offset) [expr {$rva - $baserva + $base}]

                seek $fh $cur3 start
            }

            seek $fh $cur2 start
        }
        seek $fh $cur start
    }
    if {[array names RES $file,*] == ""} {
        close $fh
        return -1
    }
    foreach x [array names RES $file,group,*,offset] {
        seek $fh [expr {$RES($x) + 4}] start
        binary scan [read $fh 2] s a
        set x [lindex [split $x ,] 2]
        for {set i 0} {$i < $a} {incr i} {
            binary scan [read $fh 14] x12s n
            lappend RES($file,group,$x,members) $n
        }
    }
    foreach x [array names RES $file,icon,*,offset] {
        seek $fh [expr {$RES($x)}] start
        set x [lindex [split $x ,] 2]
        binary scan [read $fh 16] x4iix2s w h bpp
        set RES($file,icon,$x,data) [list $w [expr {$h / 2}] $bpp]
    }

    close $fh
    return [llength $RES($file,group,names)]
}

proc ::ico::getPEResName {fh start data} {
    if {($data & 0x80000000) != 0} {
        set cur [tell $fh]
        seek $fh [expr {($data & 0x7fffffff) + $start}] start
        set len [getushort $fh]
        set name [read $fh [expr {$len * 2}]]
        seek $fh $cur start
        return [encoding convertfrom unicode $name]
    } else {
        return $data
    }
}

interp alias {} ::ico::getIconListDLL    {} ::ico::getIconListEXE
interp alias {} ::ico::getIconMembersDLL {} ::ico::getIconMembersEXE
interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconDLL      {} ::ico::writeIconEXE
interp alias {} ::ico::getIconListICL    {} ::ico::getIconListEXE
interp alias {} ::ico::getIconMembersICL {} ::ico::getIconMembersEXE
interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconICL      {} ::ico::writeIconEXE

package provide ico 1.0.3

# ico.tcl --
#
# Win32 ico manipulation code
#
# Copyright (c) 2003 Aaron Faupell
# Copyright (c) 2003-2004 ActiveState Corporation
#
# RCS: @(#) $Id: ico0.tcl,v 1.2 2007/02/23 23:28:33 hobbs Exp $

# JH: speed has been considered in these routines, although they
# may not be fully optimized.  Running EXEtoICO on explorer.exe,
# which has nearly 100 icons, takes .2 secs on a P4/2.4ghz machine.
#

# Sample usage:
#	set file bin/wish.exe
#	set icos [::ico::getIconList $file]
#	set img  [::ico::getIcon $file 1 -format image]

package require Tcl 8.4

# Instantiate vars we need for this package
namespace eval ::ico {
    namespace export getIconList getIcon writeIcon copyIcon transparentColor clearCache EXEtoICO
    # stores cached indices of icons found
    variable  ICONS
    array set ICONS {}

    # used for 4bpp number conversion
    variable BITS
    array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \
			0101 5 0110 6 0111 7 1000 8 1001 9 \
			1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \
			\
			00000 00 00001 0F 00010 17 00011 1F \
			00100 27 00101 2F 00110 37 00111 3F \
			01000 47 01001 4F 01010 57 01011 5F \
			01100 67 01101 6F 01110 77 01111 7F \
			10000 87 10001 8F 10010 97 10011 9F \
			10100 A7 10101 AF 10110 B7 10111 BF \
			11000 C7 11001 CF 11010 D7 11011 DF \
			11100 E7 11101 EF 11110 F7 11111 FF]
}


# getIconList --
#
# List of icons in the file (each element a list of w h and bpp)
#
# ARGS:
#	file	File to extra icon info from.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO and ICL
#
# RETURNS:
#	list of icons' dimensions as tuples {width height bpp}
#
proc ::ico::getIconList {file args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getIconList$type]]} {
	return -code error "unsupported file format $type"
    }
    getIconList$type [file normalize $file]
}

# getIcon --
#
# Get pixel data or image of icon @ index in file
#
# ARGS:
#	file		File to extra icon info from.
#	index		Index of icon in the file to use.  The ordering is the
#			same as returned by getIconList.  (0-based)
#	?-type?		Type of file.  If not specified, it is derived from
#			the file extension.  Currently recognized types are
#			EXE, DLL, ICO and ICL
#	?-format?	Output format. Must be one of "image" or "colors"
#			'image' will return the name of a Tk image.
#			'colors' will return a list of pixel values
#	?-name?		If output is image, use this as the name of Tk image
#			created
#
# RETURNS:
#	pixel data as a list that could be passed to 'image create'
#
proc ::ico::getIcon {file index args} {
    set name {}
    set format image
    parseOpts {type format name} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands getRawIconData$type]]} {
        return -code error "unsupported file format $type"
    }
    # ICODATA is a pure data type - not a real file
    if {$type ne "ICODATA"} {
	set file [file normalize $file]
    }
    set colors [eval [linsert [getRawIconData$type $file $index] 0 getIconAsColorList]]
    if {$format eq "image"} {
        return [createImage $colors $name]
    }
    return $colors
}

# writeIcon --
#
# Overwrite write icon @ index in file of specific type with depth/pixel data
#
# ARGS:
#	file	File to extra icon info from.
#	index	Index of icon in the file to use.  The ordering is the
#		same as returned by getIconList.  (0-based)
#	bpp	bit depth of icon we are writing
#	data	Either pixel color data (as returned by getIcon -format color)
#		or the name of a Tk image.
#	?-type?	Type of file.  If not specified, it is derived from
#		the file extension.  Currently recognized types are
#		EXE, DLL, ICO and ICL
#
# RETURNS:
#	Tk image based on the specified icon
#
proc ::ico::writeIcon {file index bpp data args} {
    parseOpts type $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }
    if {![llength [info commands writeIcon$type]]} {
	return -code error "unsupported file format $type"
    }
    if {[llength $data] == 1} {
        set data [getColorListFromImage $data]
    } elseif {[lsearch -glob [join $data] #*] > -1} {
        set data [translateColors $data]
    }
    if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} {
	return -code error "invalid color depth"
    }
    set palette {}
    if {$bpp <= 8} {
	set palette [getPaletteFromColors $data]
	if {[lindex $palette 0] > (1 << $bpp)} {
	    return -code error "specified color depth too low"
	}
	set data  [lindex $palette 2]
	set palette [lindex $palette 1]
	append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]]
    }
    set and [getAndMaskFromColors $data]
    set xor [getXORFromColors $bpp $data]
    # writeIcon$type file index w h bpp palette xor and
    writeIcon$type [file normalize $file] $index \
	[llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and
}


# copyIcon --
#
# Copies an icon directly from one file to another
#
# ARGS:
#	file	        File to extract icon info from.
#	index	        Index of icon in the file to use.  The ordering is the
#		        same as returned by getIconList.  (0-based)
#	?-fromtype?	Type of source file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO and ICL
#	?-totype?	Type of destination file.  If not specified, it is derived from
#		        the file extension.  Currently recognized types are
#		        EXE, DLL, ICO and ICL
#
# RETURNS:
#	nothing
#
proc ::ico::copyIcon {f1 i1 f2 i2 args} {
    parseOpts {fromtype totype} $args
    if {![info exists fromtype]} {
        # $type wasn't specified - get it from the extension
        set fromtype [fileext $f1]
    }
    if {![info exists totype]} {
        # $type wasn't specified - get it from the extension
        set totype [fileext $f2]
    }
    if {![llength [info commands writeIcon$totype]]} {
	return -code error "unsupported file format $totype"
    }
    if {![llength [info commands getRawIconData$fromtype]]} {
	return -code error "unsupported file format $fromtype"
    }
    set src [getRawIconData$fromtype $f1 $i1]
    writeIcon $f2 $i2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype
}

#
# transparentColor --
#
# Turns on transparency for all pixels in the image that match the color
#
# ARGS:
#	img	        Name of the Tk image to modify, or an image in color list format
#	color	        Color in #hex format which will be made transparent
#
# RETURNS:
#	the data or image after modification
#
proc ::ico::transparentColor {img color} {
    if {[llength $img] == 1} {
        package require Tk
        if {[string match "#*" $color]} {
            set color [scan $color "#%2x%2x%2x"]
        }
        set w [image width $img]
        set h [image height $img]
        for {set y 0} {$y < $h} {incr y} {
            for {set x 0} {$x < $w} {incr x} {
                if {[$img get $x $y] eq $color} {$img transparency set $x $y 1}
            }
        }
    } else {
        set y 0
        foreach row $img {
            set x 0
            foreach px $row {
                if {$px == $color} {lset img $y $x {}}
                incr x
            }
            incr y
        }
    }
    return $img
}

#
# clearCache --
#
# Clears the cache of icon offsets
#
# ARGS:
#	file	optional filename
#
#
# RETURNS:
#	nothing
#
proc ::ico::clearCache {{file {}}} {
    variable ICONS
    if {$file ne ""} {
	array unset ICONS $file,*
    } else {
	unset ICONS
	array set ICONS {}
    }
}

#
# EXEtoICO --
#
# Convert all icons found in exefile into a regular icon file
#
# ARGS:
#	exeFile	        Input EXE filename
#	icoFile	        Output ICO filename
#
# RETURNS:
#	nothing
#
proc ::ico::EXEtoICO {exeFile icoFile} {
    variable ICONS

    set file [file normalize $exeFile]
    set cnt  [SearchForIcos $file]
    set dir  {}
    set data {}
    
    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    for {set i 0} {$i <= $cnt} {incr i} {
        seek $fh $ICONS($file,$i) start
	set ico $ICONS($file,$i,data)
	eval [list lappend dir] $ico
	append data [read $fh [eval calcSize $ico 40]]
    }
    close $fh

    # write them out to a file
    set ifh [open $icoFile w+]
    fconfigure $ifh -eofchar {} -encoding binary -translation lf

    bputs $ifh sss 0 1 [expr {$cnt + 1}]
    set offset [expr {6 + (($cnt + 1) * 16)}]
    foreach {w h bpp} $dir {
	set colors 0
	if {$bpp <= 8} {set colors [expr {1 << $bpp}]}
	set s [calcSize $w $h $bpp 40]
	lappend fix $offset $s
	bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset
	set offset [expr {$offset + $s}]
    }
    puts -nonewline $ifh $data
    foreach {offset size} $fix {
	seek $ifh [expr {$offset + 20}] start
	bputs $ifh i $size
    }
    close $ifh
}

##
## Internal helper commands.
## Some may be appropriate for exposing later, but would need docs
## and make sure they "fit" in the API.
##

# gets the file extension as we use it internally (upper case, no '.')
proc ::ico::fileext {file} {
    return [string trimleft [string toupper [file extension $file]] .]
}

# helper proc to parse optional arguments to some of the public procs
proc ::ico::parseOpts {acc opts} {
    foreach {key val} $opts {
        set key [string trimleft $key -]
	if {[lsearch -exact $acc $key] >= 0} {
	    upvar $key $key
	    set $key $val
	} elseif {$key ne ""} {
	    return -code error "unknown option \"$key\": must be one of $acc"
	}
    }
}

# formats a single color from a binary decimal list format to the #hex format
proc ::ico::formatColor {r g b} {
    format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c]
}

# translates a color list from the #hex format to the decimal list format
#                                #0000FF                  {0 0 255}
proc ::ico::translateColors {colors} {
    set new {}
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    lappend tline [scan $x "#%2x%2x%2x"]
	}
	set new [linsert $new 0 $tline]
    }
    return $new
}

proc ::ico::getdword {fh} {
    binary scan [read $fh 4] i* tmp
    return $tmp
}

proc ::ico::getword {fh} {
    binary scan [read $fh 2] s* tmp
    return $tmp
}

proc ::ico::getulong {fh} {
    binary scan [read $fh 4] i tmp
    return [format %u $tmp]
}

proc ::ico::getushort {fh} {
    binary scan [read $fh 2] s tmp
    return [expr {$tmp & 0x0000FFFF}]
}

# binary puts
proc ::ico::bputs {fh format args} {
    puts -nonewline $fh [eval [list binary format $format] $args]
}

# creates a Tk image from a list of colors in the #hex format
proc ::ico::createImage {colors {name {}}} {
    package require Tk
    set h [llength $colors]
    set w [llength [lindex $colors 0]]
    if {$name ne ""} {
	set img [image create photo $name -width $w -height $h]
    } else {
	set img [image create photo -width $w -height $h]
    }
    if {0} {
	# if image supported "" colors as transparent pixels,
	# we could use this much faster op
	$img put -to 0 0 $colors
    } else {
	for {set x 0} {$x < $w} {incr x} {
	    for {set y 0} {$y < $h} {incr y} {
		set clr [lindex $colors $y $x]
		if {$clr ne ""} {
		    $img put -to $x $y $clr
		}
	    }
	}
    }
    return $img
}

# return a list of colors in the #hex format from raw icon data
# returned by readDIB
proc ::ico::getIconAsColorList {w h bpp palette xor and} {
    # Create initial empty color array that we'll set indices in
    set colors {}
    set row    {}
    set empty  {}
    for {set x 0} {$x < $w} {incr x} { lappend row $empty }
    for {set y 0} {$y < $h} {incr y} { lappend colors $row }

    set x 0
    set y [expr {$h-1}]
    if {$bpp == 1} {
	binary scan $xor B* xorBits
	foreach i [split $xorBits {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [lindex $palette $i]
	    }
	    incr x
	}
    } elseif {$bpp == 4} {
	variable BITS
	binary scan $xor B* xorBits
	set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		set bits [string range $xorBits $i [expr {$i+3}]]
		lset colors $y $x [lindex $palette $BITS($bits)]
	    }
	    incr i 4
	    incr x
	}
    } elseif {$bpp == 8} {
	foreach i [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [lindex $palette [scan $i %c]]
	    }
	    incr x
	}
    } elseif {$bpp == 16} {
        variable BITS
        binary scan $xor b* xorBits
        set i 0
	foreach a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		set b1 [string range $xorBits      $i        [expr {$i+4}]]
		set b2 [string range $xorBits [expr {$i+5}]  [expr {$i+9}]]
		set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]]
		lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)"
	    }
	    incr i 16
	    incr x
	}
    } elseif {$bpp == 24} {
	foreach {b g r} [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [formatColor $r $g $b]
	    }
	    incr x
	}
    } elseif {$bpp == 32} {
	foreach {b g r n} [split $xor {}] a [split $and {}] {
	    if {$x == $w} { set x 0; incr y -1 }
	    if {$a == 0} {
		lset colors $y $x [formatColor $r $g $b]
	    }
	    incr x
	}
    }
    return $colors
}

# creates a binary formatted AND mask by reading a list of colors in the decimal list format
# and checking for empty colors which designate transparency
proc ::ico::getAndMaskFromColors {colors} {
    set and {}
    foreach line $colors {
	set l {}
	foreach x $line {append l [expr {$x eq ""}]}
	append l [string repeat 0 [expr {[string length $l] % 32}]]
	foreach {a b c d e f g h} [split $l {}] {
	    append and [binary format B8 $a$b$c$d$e$f$g$h]
	}
    }
    return $and
}

# creates a binary formatted XOR mask in the specified depth format from
# a list of colors in the decimal list format
proc ::ico::getXORFromColors {bpp colors} {
    set xor {}
    if {$bpp == 1} {
	foreach line $colors {
	    foreach {a b c d e f g h} $line {
		foreach x {a b c d e f g h} {
		    if {[set $x] == ""} {set $x 0}
		}
		binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a
		append xor [binary format b8 $a$b$c$d$e$f$g$h]
	    }
	}
    } elseif {$bpp == 4} {
	foreach line $colors {
	    foreach {a b} $line {
		if {$a == ""} {set a 0}
		if {$b == ""} {set b 0}
		binary scan $a$b b4b4 b a
		append xor [binary format b8 $a$b]
	    }
	}
    } elseif {$bpp == 8} {
	foreach line $colors {
	    foreach x $line {
		if {$x == ""} {set x 0}
		append xor [binary format c $x]
	    }
	}
    } elseif {$bpp == 24} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format ccc 0 0 0]
		} else {
		    foreach {a b c n} $x {
			append xor [binary format ccc $c $b $a]
		    }
		}
	    }
	}
    } elseif {$bpp == 32} {
	foreach line $colors {
	    foreach x $line {
		if {![llength $x]} {
		    append xor [binary format cccc 0 0 0 0]
		} else {
		    foreach {a b c n} $x {
			if {$n == ""} {set n 0}
			append xor [binary format cccc $c $b $a $n]
		    }
		}
	    }
	}
    }
    return $xor
}

# translates a Tk image into a list of colors in the {r g b} format
# one element per pixel and {} designating transparent
# used by writeIcon when writing from a Tk image
proc ::ico::getColorListFromImage {img} {
    package require Tk
    set w [image width $img]
    set h [image height $img]
    set r {}
    for {set y [expr $h - 1]} {$y > -1} {incr y -1} {
	set l {}
	for {set x 0} {$x < $w} {incr x} {
	    if {[$img transparency get $x $y]} {
		lappend l {}
	    } else {
		lappend l [$img get $x $y]
	    }
	}
	lappend r $l
    }
    return $r
}

# creates a palette from a list of colors in the decimal list format
# a palette consists of 3 values, the number of colors, the palette entry itself,
# and the color list transformed to point to palette entries instead of color names
# the palette entry itself is stored as 32bpp in "G B R padding" order
proc ::ico::getPaletteFromColors {colors} {
    set palette "\x00\x00\x00\x00"
    array set tpal {{0 0 0} 0}
    set new {}
    set i 1
    foreach line $colors {
	set tline {}
	foreach x $line {
	    if {$x eq ""} {lappend tline {}; continue}
	    if {![info exists tpal($x)]} {
		foreach {a b c n} $x {
		    append palette [binary format cccc $c $b $a 0]
		}
		set tpal($x) $i
		incr i
	    }
	    lappend tline $tpal($x)
	}
	lappend new $tline
    }
    return [list $i $palette $new]
}

# calculate byte size of an icon.
# often passed $w twice because $h is double $w in the binary data
proc ::ico::calcSize {w h bpp {offset 0}} {
    set s [expr {int(($w*$h) * ($bpp/8.0)) \
		     + ((($w*$h) + ($h*($w%32)))/8) + $offset}]
    if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] }
    return $s
}

# read a Device Independent Bitmap from the current offset, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIB {fh} {
    binary scan [read $fh 16] x4iix2s w h bpp
    set h [expr {$h / 2}]
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	set colors [read $fh [expr {1 << ($bpp + 2)}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

# read a Device Independent Bitmap from raw data, return:
#	{width height depth palette XOR_mask AND_mask}
proc ::ico::readDIBFromData {data loc} {
    # Read info from location
    binary scan $data @${loc}x4iix2s w h bpp
    set h [expr {$h / 2}]
    # Move over w/h/bpp info + magic offset to start of DIB
    set cnt [expr {$loc + 16 + 24}]

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	# Could do: [binary scan $data @${cnt}c$len colors]
	# and iter over colors, but this is more consistent with $fh version
	set len    [expr {1 << ($bpp + 2)}]
	set colors [string range $data $cnt [expr {$cnt + $len - 1}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
	incr cnt $len
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    # Use -1 to account for string range inclusiveness
    set end  [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}]
    set xor  [string range $data $cnt $end]
    set and1 [string range $data [expr {$end + 1}] \
		  [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]]

    set and {}
    set row [expr {((($w - 1) / 32) * 32 + 32) / 8}]
    set len [expr {$row * $h}]
    for {set i 0} {$i < $len} {incr i $row} {
	# Has to be decoded by row, in order
	binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp
	append and $tmp
    }

    return [list $w $h $bpp $palette $xor $and]
}

proc ::ico::getIconListICO {file} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
	return -code error "not an icon file"
    }
    set num [getword $fh]
    set r {}
    for {set i 0} {$i < $num} {incr i} {
	set info {}
	lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c]
	set bpp [scan [read $fh 1] %c]
	if {$bpp == 0} {
	    set orig [tell $fh]
	    seek $fh 9 current
	    seek $fh [expr {[getdword $fh] + 14}] start
	    lappend info [getword $fh]
	    seek $fh $orig start
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend r $info
	seek $fh 13 current
    }
    close $fh
    return $r
}

proc ::ico::getIconListICODATA {data} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    set r {}
    set cnt 6
    for {set i 0} {$i < $num} {incr i} {
	if {[binary scan $data @${cnt}ccc w h bpp] != 3} {
	    return -code error "error decoding icon data"
	}
	incr cnt 3
	set info [list $w $h]
	if {$bpp == 0} {
	    set off [expr {$cnt + 9}]
	    binary scan $data @${off}i off
	    incr off 14
	    binary scan $data @${off}s bpp
	    lappend info $bpp
	} else {
	    lappend info [expr {int(sqrt($bpp))}]
	}
	lappend r $info
	incr cnt 13
    }
    return $r
}

proc ::ico::getIconListBMP {file} {
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    close $fh
    return [list $w $h $bpp]
}

proc ::ico::getIconListEXE {file} {
    variable ICONS

    set file [file normalize $file]
    set cnt  [SearchForIcos $file]

    set icons [list]
    for {set i 0} {$i <= $cnt} {incr i} {
	lappend icons $ICONS($file,$i,data)
    }

    return $icons
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataICO {file index} {
    set fh [open $file r]
    fconfigure $fh -eofchar {} -encoding binary -translation lf

    # both words must be read to keep in sync with later reads
    if {"[getword $fh] [getword $fh]" ne "0 1"} {
        close $fh
	return -code error "not an icon file"
    }
    if {$index < 0 || $index >= [getword $fh]} {
	return -code error "index out of range"
    }

    seek $fh [expr {(16 * $index) + 12}] current
    seek $fh [getdword $fh] start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]

    close $fh
    return $dib
}

proc ::ico::getRawIconDataICODATA {data index} {
    if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} {
	return -code error "not icon data"
    }
    if {$index < 0 || $index >= $num} {
	return -code error "index out of range: must be between 0 and $num"
    }
    # Move to ico location
    set cnt [expr {6 + (16 * $index) + 12}]
    binary scan $data @${cnt}i loc

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIBFromData $data $loc]

    return $dib
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataBMP {file {index 0}} {
    if {$index != 0} {return -code error "index out of range"}
    set fh [open $file]
    if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" }
    seek $fh 14 start
    binary scan [read $fh 16] x4iix2s w h bpp
    seek $fh 24 current

    set palette [list]
    if {$bpp == 1 || $bpp == 4 || $bpp == 8} {
	set colors [read $fh [expr {1 << ($bpp + 2)}]]
	foreach {b g r x} [split $colors {}] {
	    lappend palette [formatColor $r $g $b]
	}
    } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} {
	# do nothing here
    } else {
	return -code error "unsupported color depth: $bpp"
    }

    set xor  [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]]
    set and [string repeat 0 [expr {$w * $h}]]
    close $fh

    return [list $w $h $bpp $palette $xor $and]
}

# returns an icon in the form:
#	{width height depth palette xor_mask and_mask}
proc ::ico::getRawIconDataEXE {file index} {
    variable ICONS

    set file [file normalize $file]
    set cnt  [SearchForIcos $file $index]

    if {$cnt < $index} { return -code error "index out of range" }

    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh $ICONS($file,$index) start

    # readDIB returns: {w h bpp palette xor and}
    set dib [readDIB $fh]
    close $fh
    return $dib
}

proc ::ico::writeIconICO {file index w h bpp palette xor and} {
    if {![file exists $file]} {
	set fh [open $file w+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
	bputs $fh sss 0 1 0
	seek $fh 0 start
    } else {
	set fh [open $file r+]
	fconfigure $fh -eofchar {} -encoding binary -translation lf
    }
    if {[file size $file] > 4 && "[getword $fh] [getword $fh]" ne "0 1"} {
	close $fh
	return -code error "not an icon file"
    }
    set num [getword $fh]
    if {$index eq "end"} { set index $num }
    if {$index < 0 || $index > $num} {
	close $fh
	return -code error "index out of range"
    }
    set colors 0
    if {$bpp <= 8} {set colors [expr {1 << $bpp}]}
    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]

    # if we are adding a new icon at the end
    if {$index == $num} {
        # increment the icon count
	seek $fh -2 current
	bputs $fh s [expr {$num + 1}]
	# save all the data past the icon dir entries
	seek $fh [expr {$num * 16}] current
	set olddata [read $fh]
	# increment all the offsets in the existing dir entries by 16 to account for our new entry
	set cur 0
	while {$cur < $num} {
	    seek $fh [expr {($cur * 16) + 18}] start
	    set toff [getdword $fh]
	    seek $fh -4 current
	    bputs $fh i [expr {$toff + 16}]
	    incr cur
	}
	# insert new icon dir entry
	bputs $fh ccccss $w $h $colors 0 0 $bpp
	bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}]
	# put all the icon data back
	puts -nonewline $fh $olddata
	# put our new icon at the end
	bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0
	puts -nonewline $fh $palette
	puts -nonewline $fh $xor
	puts -nonewline $fh $and
    } else {
        # we are overwriting an icon - not necesarily the same size
        # get existing icon offset and length
	seek $fh [expr {($index * 16) + 8}] current
	set len [getdword $fh]
	set offset [getdword $fh]
	# adjust offset in existing icon dir entries higher than our new icon to account
	# for new icon length
	set cur [expr {$index + 1}]
	while {$cur < $num} {
	    seek $fh [expr {($cur * 16) + 18}] start
	    set toff [getdword $fh]
	    seek $fh -4 current
	    bputs $fh i [expr {$toff + (($size + 40) - $len)}]
	    incr cur
	}
	# save all data after new icon
	seek $fh [expr {$offset + $len}] start
	set olddata [read $fh]
	# overwrite icon dir entry
	seek $fh [expr {($index * 16) + 6}] start
	bputs $fh ccccssi $w $h $colors 0 0 $bpp [expr {$size + 40}]
	# insert new icon and saved data
	seek $fh $offset start
	bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0
	puts -nonewline $fh $palette
	puts -nonewline $fh $xor
	puts -nonewline $fh $and
	puts -nonewline $fh $olddata
    }
    close $fh
}

proc ::ico::writeIconICODATA {file index w h bpp palette xor and} {
    if {$index != 0} {return -code error "index out of range"}
    upvar 2 [file tail $file] data
    set data [binary format sss 0 1 1]
    set colors 0
    if {$bpp <= 8} {set colors [expr {1 << $bpp}]}
    set size [expr {[string length $palette] + [string length $xor] + [string length $and]}]
    append data [binary format ccccssii $w $h $colors 0 0 $bpp [expr {$size + 40}] 22]
    append data [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]
    append data $palette $xor $and
}

proc ::ico::writeIconBMP {file index w h bpp palette xor and} {
    if {$index != 0} {return -code error "index out of range"}
    set fh [open $file w+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    set size [expr {[string length $palette] + [string length $xor]}]
    # bitmap header: magic, file size, reserved, reserved, offset of bitmap data
    bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54
    bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0
    puts -nonewline $fh $palette$xor
    close $fh
}

proc ::ico::writeIconEXE {file index w h bpp palette xor and} {
    variable ICONS

    set file [file normalize $file]
    set cnt  [SearchForIcos $file $index]

    if {$index eq "end"} {set index $cnt}
    if {$cnt < $index} { return -code error "index out of range" }

    if {[list $w $h $bpp] != $ICONS($file,$index,data)} {
	return -code error "icon format differs from original"
    }
    
    set fh [open $file r+]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    seek $fh [expr {$ICONS($file,$index) + 40}] start

    puts -nonewline $fh $palette$xor$and
    close $fh
}

proc ::ico::SearchForIcos {file {index -1}} {
    variable ICONS	  ; # stores icos offsets by index, and [list w h bpp]

    if {[info exists ICONS($file,$index)]} {
	return $ICONS($file,$index)
    }
    set fh [open $file]
    fconfigure $fh -eofchar {} -encoding binary -translation lf
    if {[read $fh 2] ne "MZ"} {
	close $fh
	return -code error "unknown file format"
    }
    seek $fh 60 start
    seek $fh [getword $fh] start
    set sig [read $fh 4]
    seek $fh -4 current
    if {$sig eq "PE\000\000"} {
        return [SearchForIcosPE $fh $file $index]
    } elseif {[string match NE* $sig]} {
        return [SearchForIcosNE $fh $file $index]
    } else {
        return -code error "unknown file format"
    }
}

# parse the resource table of 16 bit windows files for icons
proc ::ico::SearchForIcosNE {fh file index} {
    variable ICONS ; # stores icos offsets by index, and [list w h bpp]
    set idx   -1   ; # index of icos found

    seek $fh 36 current
    seek $fh [expr {[getword $fh] - 38}] current
    
    set base [tell $fh]
    set shift [expr {int(pow(2, [getushort $fh]))}]
    while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} {
        set num [getushort $fh]
        if {$type != 3} {
            seek $fh [expr {($num * 12) + 4}] current
            continue
        }
        seek $fh 4 current
        for {set i 0} {$i < $num} {incr i} {
            incr idx
            set ICONS($file,$idx) [expr {[getushort $fh] * $shift}]
            seek $fh 10 current
            set cur [tell $fh]

            seek $fh $ICONS($file,$idx) start
            binary scan [read $fh 16] x4iix2s w h bpp
            set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp]

            seek $fh $cur start
        }
        close $fh
        return $idx
    }
    close $fh
    return -1
}

# parse the resource tree of 32 bit windows files for icons
proc ::ico::SearchForIcosPE {fh file index} {
    variable ICONS ; # stores icos offsets by index, and [list w h bpp]
    set idx -1     ; # index of icos found

    # find the .rsrc section by reading the coff header
    binary scan [read $fh 24] x6sx12s sections headersize
    seek $fh $headersize current
    for {set i 0} {$i < $sections} {incr i} {
        binary scan [read $fh 40] a8x4ix4i type baserva base
        if {[string match .rsrc* $type]} {break}
    }
    # no resource section found = no icons
    if {![string match .rsrc* $type]} {
        close $fh
        return -1
    }
    seek $fh $base start

    seek $fh 12 current
    set entries [expr {[getushort $fh] + [getushort $fh]}]
    for {set i 0} {$i < $entries} {incr i} {
        set name [getulong $fh]
        set offset [expr {[getulong $fh] & 0x7fffffff}]
        if {$name != 3} {continue}
        seek $fh [expr {$base + $offset + 12}] start

        set entries2 [expr {[getushort $fh] + [getushort $fh]}]
        for {set i2 0} {$i2 < $entries2} {incr i2} {
            seek $fh 4 current
            set offset [expr {[getulong $fh] & 0x7fffffff}]
            set cur2 [tell $fh]
            seek $fh [expr {$offset + $base + 12}] start

            set entries3 [expr {[getushort $fh] + [getushort $fh]}]
            for {set i3 0} {$i3 < $entries3} {incr i3} {
                seek $fh 4 current
                set offset [expr {[getulong $fh] & 0x7fffffff}]
                set cur3 [tell $fh]
                seek $fh [expr {$offset + $base}] start

                set rva [getulong $fh]
                incr idx
                set ICONS($file,$idx) [expr {$rva - $baserva + $base}]
                seek $fh $ICONS($file,$idx) start
                binary scan [read $fh 16] x4iix2s w h bpp
                set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp]

                seek $fh $cur3 start
            }
            seek $fh $cur2 start
        }
        close $fh
        return $idx
    }
    close $fh
    return -1
}

interp alias {} ::ico::getIconListDLL    {} ::ico::getIconListEXE
interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconDLL      {} ::ico::writeIconEXE
interp alias {} ::ico::getIconListICL    {} ::ico::getIconListEXE
interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE
interp alias {} ::ico::writeIconICL      {} ::ico::writeIconEXE

proc ::ico::showaux {files} {
    if {[llength $files]} {
	set file [lindex $files 0]
	Show $f
	update
	after 50 [list ::ico::showaux [lrange $files 1 end]]
    }
}

# Application level command: Find icons in a file and show them.
proc ::ico::Show {file args} {
    package require BWidget
    
    set parent .
    parseOpts {type parent} $args
    if {![info exists type]} {
        # $type wasn't specified - get it from the extension
        set type [fileext $file]
    }

    set file  [file normalize $file]
    set icos  [getIconList $file -type $type]
    set wname [string map {. _ : _} $file]

    if {$parent eq "."} { set w ""} else { set w $parent }

    set mf $w.mainsw
    if {![winfo exists $mf]} {
	set sw [ScrolledWindow $mf]
	set sf [ScrollableFrame $mf.sf -constrainedwidth 1]
	$sw setwidget $sf
	pack $sw -fill both -expand 1
	grid columnconfigure [$mf.sf getframe] 0 -weight 1
    }
    set mf [$mf.sf getframe]

    set lf $mf.f$wname
    if {[winfo exists $lf]} { destroy $lf }
    if {![llength $icos]} {
	label $lf -text "No icons in '$file'" -anchor w
	grid $lf -sticky ew
    } else {
	labelframe $lf -text "[llength $icos] Icons in '$file'"
	grid $lf -sticky news
	set sw [ScrolledWindow $lf.sw$wname]
	set height 48
	set fh [expr {[font metrics [$lf cget -font] -linespace] + 4}]
	set sf [ScrollableFrame $lf.sf$wname -constrainedheight 1 \
		    -height [expr {$height + $fh}]]
	$sw setwidget $sf
	set sf [$sf getframe]
	pack $sw -fill both -expand 1
	set col 0
	for {set x 0} {$x < [llength $icos]} {incr x} {
	    # catch in case theres any icons with unsupported color
	    if {[catch {getIcon $file $x -type $type} img]} {
		set txt "ERROR: $img"
		set lbl [label $sf.lbl$wname-$x -anchor w -text $txt]
		grid $lbl -sticky s -row 0 -column [incr col]
	    } else {
		set txt [eval {format "$x: %sx%s %sbpp"} [lindex $icos $x]]
		set lbl [label $sf.lbl$wname-$x -anchor w -text $txt \
			     -compound top -image $img]
		if {[image height $img] > $height} {
		    set height [image height $img]
		    $lf.sf$wname configure -height [expr {$height + $fh}]
		}
		grid $lbl -sticky s -row 0 -column [incr col]
	    }
	    update idletasks
	}
    }
    grid rowconfigure $parent 0 -weight 1
    grid columnconfigure $parent 0 -weight 1
}

package provide ico 0.3.1

# pkgIndex.tcl --
#
# Copyright (c) 2003 ActiveState Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgIndex.tcl,v 1.8 2008/03/12 07:25:49 hobbs Exp $

package ifneeded ico 0.3.1 [list source [file join $dir ico0.tcl]]
package ifneeded ico 1.0.3 [list source [file join $dir ico.tcl]]

# ipentry.tcl --
#
#       An entry widget for IP addresses.
#
# Copyright (c) 2003-2008 Aaron Faupell <afaupell@users.sourceforge.net>
# Copyright (c) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
#  
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: ipentry.tcl,v 1.19 2009/01/21 07:10:03 afaupell Exp $

package require Tk
package provide ipentry 0.3

namespace eval ::ipentry {
    namespace export ipentry ipentry6
    # copy all the bindings from Entry class to our own IPEntrybindtag class
    foreach x [bind Entry] {
        bind IPEntrybindtag $x [bind Entry $x]
    }
    # then replace certain keys we are interested in with our own
    bind IPEntrybindtag <KeyPress>         {::ipentry::keypress %W %K}
    bind IPEntrybindtag <BackSpace>        {::ipentry::backspace %W}
    bind IPEntrybindtag <period>           {::ipentry::dot %W}
    bind IPEntrybindtag <Key-Right>        {::ipentry::arrow %W %K}
    bind IPEntrybindtag <Key-Left>         {::ipentry::arrow %W %K}
    bind IPEntrybindtag <FocusIn>          {::ipentry::FocusIn %W}
    bind IPEntrybindtag <FocusOut>         {::ipentry::FocusOut %W}
    bind IPEntrybindtag <<Paste>>          {::ipentry::Paste %W CLIPBOARD}
    bind IPEntrybindtag <<PasteSelection>> {::ipentry::Paste %W PRIMARY}
    
    # copy all the bindings from IPEntrybindtag
    foreach x [bind IPEntrybindtag] {
        bind IPEntrybindtag6 $x [bind IPEntrybindtag $x]
    }
    # and replace certain keys with ip6 bindings
    bind IPEntrybindtag6 <KeyPress>         {::ipentry::keypress %W %K 6}
    bind IPEntrybindtag6 <colon>            {::ipentry::dot %W}
    bind IPEntrybindtag6 <period>           {}

    #if {[package vsatisfies [package provide Tk] 8.5]} {
    #     ttk::style layout IPEntryFrame {
    #         Entry.field -sticky news -border 1 -children {
    #             IPEntryFrame.padding -sticky news
    #         }
    #     }
    #     bind [winfo class .] <<ThemeChanged>> \
    #         [list +ttk::style layout IPEntryFrame \
    #              [ttk::style layout IPEntryFrame]]
    # }
}

# ipentry --
#
# main entry point - construct a new ipentry widget
#
# ARGS:
#       w       path name of widget to create
#
#               see ::ipentry::configure for args
#
# RETURNS:
#       the widget path name
#
proc ::ipentry::ipentry {w args} {
    upvar #0 [namespace current]::widget_$w state
    #set state(themed) [package vsatisfies [package provide Tk] 8.5]
    set state(themed) 0
    foreach {name val} $args {
        if {$name eq "-themed"} {
            set state(themed) $val
        }
    }
    if {$state(themed)} {
        ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0
    } else {
        frame $w -relief sunken -class IPEntry;#-padx 5
    }
    foreach x {0 1 2 3} y {d1 d2 d3 d4} {
        #if {$state(themed)} {
        #    ttk::entry $w.$x -width 3 -justify center
        #    ttk::label $w.$y -text .
        #}
        entry $w.$x -borderwidth 0 -width 3 -highlightthickness 0 \
            -justify center -takefocus 0
        label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text . \
            -justify center -cursor [$w.$x cget -cursor] \
             -background [$w.$x cget -background] \
             -disabledforeground [$w.$x cget -disabledforeground]
        pack $w.$x $w.$y -side left
        bindtags $w.$x [list $w.$x IPEntrybindtag . all]
        bind $w.$y <Button-1> {::ipentry::dotclick %W %x}
    }
    destroy $w.d4
    $w.0 configure -takefocus 1
    if {$state(themed)} {
        pack configure $w.0 -padx {1 0} -pady 1
        pack configure $w.3 -padx {0 1} -pady 1 -fill x -expand 1
        $w.3 configure -justify left
    } else {
        $w configure -borderwidth [lindex [$w.0 configure -bd] 3]
            #-background [$w.0 cget -bg]
    }
    rename ::$w ::ipentry::_$w
    # redirect the widget name command to the widgetCommand dispatcher
    interp alias {} ::$w {} ::ipentry::widgetCommand $w
    bind $w <Destroy> [list ::ipentry::destroyWidget $w]
    if {[llength $args] > 0} {
        eval [list $w configure] $args
    }
    return $w
}

# ipentry --
#
# main entry point - construct a new ipentry6 widget
#
# ARGS:
#       w       path name of widget to create
#
#               see ::ipentry::configure for args
#
# RETURNS:
#       the widget path name
#
proc ::ipentry::ipentry6 {w args} {
    upvar #0 [namespace current]::widget_$w state
    #set state(themed) [package vsatisfies [package provide Tk] 8.5]
    set state(themed) 0
    foreach {name val} $args {
        if {$name eq "-themed"} {
            set state(themed) $val
        }
    }
    if {$state(themed)} {
        ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0
    } else {
        frame $w -relief sunken -class IPEntry;#-padx 5
    }
    foreach x {0 1 2 3 4 5 6 7} y {d1 d2 d3 d4 d5 d6 d7 d8} {
        entry $w.$x -borderwidth 0 -width 4 -highlightthickness 0 \
            -justify center -takefocus 0
        label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text : \
            -justify center -cursor [$w.$x cget -cursor] \
            -background [$w.$x cget -background] \
            -disabledforeground [$w.$x cget -disabledforeground]
        pack $w.$x $w.$y -side left
        bindtags $w.$x [list $w.$x IPEntrybindtag6 . all]
        bind $w.$y <Button-1> {::ipentry::dotclick %W %x}
    }
    destroy $w.d8
    $w.0 configure -takefocus 1
    if {$state(themed)} {
        pack configure $w.0 -padx {1 0} -pady 1
        pack configure $w.7 -padx {0 1} -pady 1 -fill x -expand 1
        $w.7 configure -justify left
    } else {
        $w configure -borderwidth [lindex [$w.0 configure -bd] 3]
            #-background [$w.0 cget -bg]
    }
    rename ::$w ::ipentry::_$w
    # redirect the widget name command to the widgetCommand dispatcher
    interp alias {} ::$w {} ::ipentry::widgetCommand6 $w
    bind $w <Destroy> [list ::ipentry::destroyWidget $w]
    if {[llength $args] > 0} {
        eval [list $w configure] $args
    }
    return $w
}

# keypress --
#
# called every time a key is pressed in an ipentry widget
# used by both ipentry and ipentry6
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     the keysym (%K) from the event
#       type    empty string or "6" depending on the type of ipentry
#
# RETURNS:
#       nothing
#
proc ::ipentry::keypress {w key {type {}}} {
    if {![validate$type $w $key]} { return }
    # sel.first and sel.last throw an error if the selection isnt in $w
    catch {
        set insert [$w index insert]
        # if a key is pressed while there is a selection then delete the
        # selected chars
        if {([$w index sel.first] <= $insert) && ([$w index sel.last] >= $insert)} {
            $w delete sel.first sel.last
        }
    }
    $w insert insert $key
    ::ipentry::updateTextvar $w
}

# backspace --
#
# called when the Backspace key is pressed in an ipentry widget
# used by both ipentry and ipentry6
#
# try to act like a normal backspace except if the cursor is at index 0
# of one entry we need to move to the end of the preceding entry
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::backspace {w} {
    if {[$w selection present]} {
        $w delete sel.first sel.last
    } else {
        if {[$w index insert] == 0} {
            set w [skip $w prev]
        }
        $w delete [expr {[$w index insert] - 1}]
    }
    ::ipentry::updateTextvar $w
}

# dot --
#
# called when the dot (Period) key is pressed in an ipentry widget
# used by both ipentry and ipentry6
#
# treat the current entry as done and move to the next entry field
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::dot {w} {
    if {[string length [$w get]] > 0} {
        skip $w next 1
    }
    ::ipentry::updateTextvar $w
}

# FocusIn --
#
# called when the focus enters any of the child widgets of an ipentry
# used by both ipentry and ipentry6
#
# clear the selection of all child widgets other than the one with focus
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::FocusIn {w} {
    set p [winfo parent $w]
    foreach x {0 1 2 3 4 5 6 7} {
        if {![winfo exists $p.$x]} { break }
        if {"$p.$x" != $w} {
            $p.$x selection clear
        }
    }
}

# FocusOut --
#
# called when the focus leaves any of the child widgets of an ipentry
# used by both ipentry and ipentry6
#
# dont allow a 0 in the first quad
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::FocusOut {w} {
    set s [$w get]
    if {[string match {*.0} $w] && $s != "" && $s < 1} {
        $w delete 0 end
        $w insert end 1
        ::ipentry::updateTextvar $w
    }
    # trim off leading zeros
    if {[string length $s] > 1} {
        set n [string trimleft $s 0]
        if {$n eq ""} { set n 0 }
        if {![string equal $n $s]} {
            $w delete 0 end
            $w insert end $n
        }
    }
}

# Paste --
#
# called from the <<Paste>> virtual event
# used by ipentry only
#
# clear the selection of all child widgets other than the one with focus
#
# ARGS:
#       w       window argument (%W) from the event binding
#       sel     one of CLIPBOARD or PRIMARY
#
# RETURNS:
#       nothing
#
proc ::ipentry::Paste {w sel} {
    if {[catch {::tk::GetSelection $w $sel} paste]} { return }
    $w delete 0 end
    foreach char [split $paste {}] {
        # ignore everything except dots and digits
        if {![string match {[0123456789.]} $char]} { continue }
        if {$char != "."} {
            $w insert end $char
        }
        # if value is over 255 truncate it
        if {[$w get] > 255} {
            $w delete 0 end
            $w insert 0 255
        }
        # if char is a . then get the index of the current entry
        # and update $w to point to the next entry
        if {$char == "."} {
            set n [string index $w end]
            if { $n >= 3 } { return }
            set w [string trimright $w "0123"][expr {$n + 1}]
            $w delete 0 end
            continue
        }
    }
    ::ipentry::updateTextvar $w
}

# Paste6 --
#
# called from the <<Paste>> virtual event
# used by both ipentry6 only
#
# clear the selection of all child widgets other than the one with focus
#
# ARGS:
#       w       window argument (%W) from the event binding
#       sel     one of CLIPBOARD or PRIMARY
#
# RETURNS:
#       nothing
#
proc ::ipentry::Paste6 {w sel} {
    if {[catch {::tk::GetSelection $w $sel} paste]} { return }
    $w delete 0 end
    foreach char [split $paste {}] {
        # ignore everything except colons and hex digits
        if {![string match {[0123456789abcdefABCDEF:]} $char]} { continue }
        if {$char != ":"} {
            $w insert end $char
        }
        # if char is a : then get the index of the current entry
        # and update $w to point to the next entry
        if {$char == ":"} {
            set n [string index $w end]
            if { $n >= 7 } { return }
            set w [string trimright $w "01234567"][expr {$n + 1}]
            $w delete 0 end
            continue
        }
    }
    ::ipentry::updateTextvar $w
}

# dotclick --
#
# called when mouse button 1 is clicked on any of the label widgets
# used by both ipentry and ipentry6
#
# decide which side of the dot was clicked and put the focus and cursor
# in the correct entry
#
# ARGS:
#       w       window argument (%W) from the event binding
#
# RETURNS:
#       nothing
#
proc ::ipentry::dotclick {w x} {
    if {$x > ([winfo width $w] / 2)} {
        set w [winfo parent $w].[string index $w end]
        focus $w
        $w icursor 0
    } else {
        set w [winfo parent $w].[expr {[string index $w end] - 1}]
        focus $w
        $w icursor end
    }
}

# arrow --
#
# called when the left or right arrow keys are pressed in an ipentry
# used by both ipentry and ipentry6
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     one of Left or Right
#
# RETURNS:
#       nothing
#
proc ::ipentry::arrow {w key} {
    set i [$w index insert]
    set l [string length [$w get]]
    # move the icursor +1 or -1 position
    $w icursor [expr $i [string map {Right + Left -} $key] 1]
    $w selection clear
    # if we are moving right and the cursor is at the end, or the entry is empty
    if {$key == "Right" && ($i == $l || $l == 0)} {
        skip $w next
    } elseif {$key == "Left" && $i == 0} {
        skip $w prev
    }
}

# validate --
#
# called by keypress to validate the input
# used by ipentry only
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     the key pressed
#
# RETURNS:
#       a boolean indicating if the key is valid or not
#
proc ::ipentry::validate {w key} {
    if {![string match {[0123456789]} $key]} { return 0 }
    set curval [$w get]
    set insert [$w index insert]
    # dont allow more than a single 0 to be entered
    if {$curval == "0" && $key == "0"} { return 0 }
    if {[string length $curval] == 2} {
        set curval [join [linsert [split $curval {}] $insert $key] {}]
        if {$curval > 255} {
            $w delete 0 end
            $w insert 0 255
            $w selection range 0 end
            ::ipentry::updateTextvar $w
            return 0
        } elseif {$insert == 2} {
            skip $w next 1
        }
        return 1
    }
    if {[string length $curval] >= 3 && ![$w selection present]} {
        if {$insert == 3} { skip $w next 1 }
        return 0
    }
    return 1
}

# validate6 --
#
# called by keypress to validate the input
# used by ipentry6 only
#
# ARGS:
#       w       window argument (%W) from the event binding
#       key     the key pressed
#
# RETURNS:
#       a boolean indicating if the key is valid or not
#
proc ::ipentry::validate6 {w key} {
    if {![string is xdigit $key]} { return 0 }
    set curval 0x[$w get]
    set insert [$w index insert]
    # dont allow more than a single 0 to be entered
    if {$curval == "0" && $key == "0"} { return 0 }
    if {[string length $curval] == 5} {
        set curval [join [linsert [split $curval {}] $insert $key] {}]
        if {$insert == 3} {
            skip $w next 1
        }
        return 1
    }
    if {[string length $curval] >= 6 && ![$w selection present]} {
        if {$insert == 4} { skip $w next 1 }
        return 0
    }
    return 1
}

# skip --
#
# move the cursor to the previous or next entry widget
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the current entry widget 
#       dir     direction to move, one of next or prev
#       sel     boolean indicating whether to select the digits in the next entry
#
# RETURNS:
#       the name of the widget with focus
#
proc ::ipentry::skip {w dir {sel 0}} {
    set n [string index $w end]
    if {$dir == "next"} {
        set next [string trimright $w "012345678"][expr {$n + 1}]
        if { ![winfo exists $next] } { return $w }
        focus $next
        if {$sel} {
            $next icursor 0
            $next selection range 0 end
        }
        return $next
    } else {
        if { $n <= 0 } { return $w }
        set prev [string trimright $w "012345678"][expr {$n - 1}]
        focus $prev
        $prev icursor end
        return $prev
    }
}

# _foreach --
#
# utility for the widget configure command
#
# perform a command on every subwidget of an ipentry frame
#
# ARGS:
#       w       name of the ipentry frame 
#       cmd     command to perform
#       type    one of empty, "entry", or "dot"
#
# RETURNS:
#       nothing
#
proc ::ipentry::_foreach {w cmd {type {}}} {
    if {$type == "" || $type == "entry"} {
        foreach x {0 1 2 3 4 5 6 7} {
            if {![winfo exists $w.$x]} { break }
            eval [list $w.$x] $cmd
        }
    }
    if {$type == "" || $type == "dot"} {
        foreach x {d1 d2 d3 d4 d5 d6 d7} {
            if {![winfo exists $w.$x]} { break }
            eval [list $w.$x] $cmd
        }
     }
}

# cget --
#
# handle the widgetName cget subcommand
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the ipentry widget 
#       cmd     name of a configuration option
#
# RETURNS:
#       the value of the requested option
#
proc ::ipentry::cget {w cmd} {
    upvar #0 [namespace current]::widget_$w state
    switch -exact -- $cmd {
        -bd -
        -borderwidth -
        -relief {
            # for bd and relief return the value from the container frame
            if {!$state(themed)} {
                return [::ipentry::_$w cget $cmd]
            }
        }
        -textvariable {
            if {[info exists ::ipentry::textvars($w)]} {
                return $::ipentry::textvars($w)
            }
            return {}
        }
        -themed { return $state(themed) }
        -takefocus { return 0 }
        default {
            # for all other commands return the value from the first entry
            return [$w.0 cget $cmd]
        }
    }
}

# configure --
#
# handle the widgetName configure subcommand
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the ipentry widget 
#       args    name/value pairs of configuration options
#
# RETURNS:
#       nothing
#
proc ::ipentry::configure {w args} {
    upvar #0 [namespace current]::widget_$w Priv
    while {[set cmd [lindex $args 0]] != ""} {
        switch -exact -- $cmd {
            -state {
                set state [lindex $args 1]
                if {$state == "disabled"} {
                    _foreach $w [list configure -state disabled]
                    if {[set dbg [$w.0 cget -disabledbackground]] == ""} {
                          set dbg [$w.0 cget -bg]
                    }
                    _foreach $w [list configure -bg $dbg] dot
                    if {$Priv(themed)} {
                        ::ipentry::_$w state disabled
                    } else {
                        ::ipentry::_$w configure -background $dbg
                    }
                } elseif {$state == "normal"} {
                    _foreach $w [list configure -state normal]
                    _foreach $w [list configure -bg [$w.0 cget -bg]] dot
                    if {$Priv(themed)} {
                        ::ipentry::_$w state {!readonly !disabled}
                    } else {
                         ::ipentry::_$w configure -background [$w.0 cget -bg]
                    }
                } elseif {$state == "readonly"} {
                    _foreach $w [list configure -state readonly] entry
                    if {[set robg [$w.0 cget -readonlybackground]] == ""} {
                        set robg [$w.0 cget -bg]
                    }
                    _foreach $w [list configure -bg $robg] dot
                    if {$Priv(themed)} {
                        ::ipentry::_$w state !readonly
                    } else {
                        ::ipentry::_$w configure -background $robg
                    }
                }
                set args [lrange $args 2 end]
            }
            -bg - -background {
                set bg [lindex $args 1]
                _foreach $w [list configure -background $bg]
                if {!$Priv(themed)} {
                    ::ipentry::_$w configure -background $bg
                }
                set args [lrange $args 2 end]
            }
            -disabledforeground {
                _foreach $w [list configure -disabledforeground [lindex $args 1]]
                set args [lrange $args 2 end]
            }
            -font -
            -fg - -foreground {
                _foreach $w [list configure $cmd [lindex $args 1]]
                set args [lrange $args 2 end]
            }
            -bd - -borderwidth -
            -relief -
            -highlightcolor -
            -highlightbackground -
            -highlightthickness {
                _$w configure $cmd [lindex $args 1]
                set args [lrange $args 2 end]
            }
            -readonlybackground -
            -disabledbackground -
            -selectforeground   -
            -selectbackground   -
            -selectborderwidth  -
            -insertbackground {
                _foreach $w [list configure $cmd [lindex $args 1]] entry
                set args [lrange $args 2 end]
            }
            -themed {
                # ignored - only used in widget creation
            }
            -textvariable {
                set name [lindex $args 1]
                upvar #0 $name var
                #if {![string match ::* $name]} { set name ::$name }
                if {[info exists ::ipentry::textvars($w)]} {
                    set trace [trace info variable var]
                    trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1]
                }
                set ::ipentry::textvars($w) $name
                if {![info exists var]} { set var "" }
                ::ipentry::traceFired $w $name {} write
                if {[winfo exists $w.4]} {
                    trace add variable var {write unset} [list ::ipentry::traceFired6 $w]
                } else {
                    trace add variable var {write unset} [list ::ipentry::traceFired $w]
                }
                set args [lrange $args 2 end]
            }
            default {
                error "unknown option \"[lindex $args 0]\""
            }
        }
    }
}

# destroyWidget --
#
# bound to the <Destroy> event
# used by both ipentry and ipentry6
#
# ARGS:
#       w       name of the ipentry widget 
#
# RETURNS:
#       nothing
#
proc ::ipentry::destroyWidget {w} {
    upvar #0 [namespace current]::widget_$w state
    if {[info exists ::ipentry::textvars($w)]} {
        upvar #0 $::ipentry::textvars($w) var
        set trace [trace info variable var]
        trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1]
    }
    rename $w {}
    unset state
}

# traceFired --
#
# called by the variable trace on the ipentry textvariable
# used by ipentry only
#
# ARGS:
#       w       name of the ipentry widget 
#       varname name of the variable being traced
#       key     array index of the variable
#       op      operation performed on the variable, read/write/unset
#
# RETURNS:
#       nothing
#
proc ::ipentry::traceFired {w name key op} {
    upvar #0 $name var
    if {[info level] > 1} {
        set caller [lindex [info level -1] 0]
        if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired"} { return }
    }
    if {$op == "write"} {
        _insert $w [split $var .]
        set val [string trim [join [$w get] .] .]
        # allow a dot at the end, but only if we have less than 3 already
        if {[string index $var end] == "." && [regexp -all {\.+} $var] <= 3} { append val . }
        if {$val eq $var} return
        after 0 [list set $name $val]
        set var $val
    } elseif {$op == "unset"} {
        ::ipentry::updateTextvar $w.0
        trace add variable var {write unset} [list ipentry::traceFired $w]
    }
}

# traceFired6 --
#
# called by the variable trace on the ipentry textvariable
# used by ipentry6 only
#
# ARGS:
#       w       name of the ipentry widget 
#       varname name of the variable being traced
#       key     array index of the variable
#       op      operation performed on the variable, read/write/unset
#
# RETURNS:
#       nothing
#
proc ::ipentry::traceFired6 {w name key op} {
    upvar #0 $name var
    if {[info level] > 1} {
        set caller [lindex [info level -1] 0]
        if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired6"} { return }
    }
    if {$op == "write"} {
        _insert6 $w [split $var :]
        set val [string trim [join [$w get] :] :]
        # allow a dot at the end, but only if we have less than 3 already
        if {[string index $var end] == ":" && [regexp -all {\:+} $var] <= 7} { append val : }
        if {$val eq $var} return
        after 0 [list set $name $val]
        set var $val
    } elseif {$op == "unset"} {
        ::ipentry::updateTextvar $w.0
        trace add variable var {write unset} [list ipentry::traceFired6 $w]
    }
}

# updateTextvar --
#
# called by all procs which change the value of the ipentry
# used by both ipentry and ipentry6
#
# update the textvariable if it exists with the new value
#
# ARGS:
#       w       name of the ipentry widget 
#
# RETURNS:
#       nothing
#
proc ::ipentry::updateTextvar {w} {
    set p [winfo parent $w]
    if {![info exists ::ipentry::textvars($p)]} { return }
    set c [$p.d1 cget -text]
    set val [string trim [join [$p get] $c] $c]
    upvar #0 $::ipentry::textvars($p) var
    if {[info exists var] && $var == $val} { return }
    set var $val
}

# _insert --
#
# called by the variable trace on the ipentry textvariable and widget insert cmd
# used by ipentry only
#
# ARGS:
#       w       name of an ipentry widget 
#       val     a list of 4 values to be inserted into the ipentry
#
# RETURNS:
#       nothing
#
proc ::ipentry::_insert {w val} {
    foreach x {0 1 2 3} {
        set n [lindex $val $x]
        if {$n != ""} {
            if {![string is integer -strict $n]} {
                #error "cannot insert non-numeric arguments"
                return
            }
            if {$n > 255} { set n 255 }
            if {$n <= 0}  { set n 0 }
            if {$x == 0 && $n < 1} { set n 1 }
        }
        $w.$x delete 0 end
        $w.$x insert 0 $n
    }
}

# _insert6 --
#
# called by the variable trace on the ipentry textvariable and widget insert cmd
# used by both ipentry6 only
#
# ARGS:
#       w       name of an ipentry widget 
#       val     a list of 8 values to be inserted into the ipentry
#
# RETURNS:
#       nothing
#
proc ::ipentry::_insert6 {w val} {
    foreach x {0 1 2 3 4 5 6 7} {
        set n [lindex $val $x]
        if {![string is xdigit $n]} {
              #error "cannot insert non-hex arguments"
              return
        }
        if {$n != "" } {
            if "$x == 0 && 0x$n < 1" { set n 1 }
            if "0x$n > 0xffff" { set n ffff }
        }
        $w.$x delete 0 end
        $w.$x insert 0 $n
    }
}

# widgetCommand --
#
# handle the widgetName command
# used by ipentry, with some commands passed through from widgetCommand6
#
# ARGS:
#       w       name of the ipentry widget 
#       cmd     the subcommand
#       args    arguments to the subcommand
#
# RETURNS:
#       the results of the invoked subcommand
#
proc ::ipentry::widgetCommand {w cmd args} {
    upvar #0 [namespace current]::widget_$w state
    switch -exact -- $cmd {
        get {
            # return the 4 entry values as a list
            foreach x {0 1 2 3 4 5 6 7} {
                if {![winfo exists $w.$x]} { break }
                set s [$w.$x get]
                if {[string length $s] > 1} {
                    set s [string trimleft $s 0]
                    if {$s == ""} { set s 0 }
                }
                
                lappend r $s
            }
            return $r
        }
        insert {
            _insert $w [join $args]
            ::ipentry::updateTextvar $w.3
        }
        icursor {
            if {![string match $w.* [focus]]} { return }
            set i [lindex $args 0]
            if {![string is integer -strict $i]} { error "argument must be an integer" }
            set s [expr {$i / 4}]
            focus $w.$s
            $w.$s icursor [expr {$i % 4}]
        }
        complete {
            foreach x {0 1 2 3 4 5 6 7} {
                if {![winfo exists $w.$x]} { break }
                if {[$w.$x get] == ""} { return 0 }
            }
            return 1
        }
        configure {
            eval [list ::ipentry::configure $w] $args
        }
        cget {
            return [::ipentry::cget $w [lindex $args 0]]
        }
        default {
            error "bad option \"$cmd\": must be get, insert, complete, cget, or configure"
        }
    }
}

# widgetCommand6 --
#
# handle the widgetName command for ipentry6 widgets
# most subcommands are passed through to widgetCommand by the default case
#
# ARGS:
#       w       name of the ipentry widget 
#       cmd     the subcommand
#       args    arguments to the subcommand
#
# RETURNS:
#       the results of the invoked subcommand
#
proc ::ipentry::widgetCommand6 {w cmd args} {
    upvar #0 [namespace current]::widget_$w state
    switch -exact -- $cmd {
        insert {
            _insert6 $w [join $args]
            ::ipentry::updateTextvar $w.7
        }
        icursor {
            if {![string match $w.* [focus]]} { return }
            set i [lindex $args 0]
            if {![string is integer -strict $i]} { error "argument must be am integer" }
            set s [expr {$i / 8}]
            focus $w.$s
            $w.$s icursor [expr {$i % 8}]
        }
        default {
            return [eval [list ::ipentry::widgetCommand $w $cmd] $args]
        }
    }
}