if 0 {[Richard Suchenwirth] 2004-08-01 - Wheel reinvention can be great
weekend fun. Today I decided to re-live the early 1980s, when (first at
Xerox PARC laboratories [http://en.wikipedia.org/wiki/History_of_the_GUI]) funny things appeared on
computer screens - little images with text below, that you could drag
around, or click on, with an equally strange pointing device, later to be
known as "mouse" :) We all know how that story went on. But how would
one go about to implement the I and P parts of a WIMP (Windows, Icons, Menus,
Pointer) system in plain [Tcl]/[Tk]? Here's my iconry experiments.

[http://mini.net/files/mycon.jpg]

Icons were probably from the beginning done as bitmaps, and later color pixmaps.
Tk provides a few built-in [bitmap]s, but they aren't the most beautiful on
earth... Anyway, I took old ''questhead'' from them and peppered it up a
bit with colors. The ''floppy'' icon was taken from a GIF file that
comes with [BWidget], and
[base64]-encoded so it can reside in this single source file itself.
Other icons are composed from [canvas] items. Icon data
is stored in the namespaced array ''mycon::icondata'', in a form that can
be passed, {expand}ed or [eval]led, with a ''$canvas create'' prefix:
}
 package require Tk
 namespace eval mycon {
    variable icondata
    set icondata(@floppy) [image create photo -data {
        R0lGODlhEAAQALMAAAAAAISEAMbGxv//////////////////////////////
        /////////////////////yH5BAEAAAIALAAAAAAQABAAAAQ3UMhJqwQ4a30D
        sJfwiR4oYt1oASWpVuwYm7NLt6y3YQHe/8CfrLfL+HQcGwmZSXWYKOWpmDSB
        IgA7}]
    set icondata(floppy) {
        {image 5 7 -image $::mycon::icondata(@floppy)}
    }
    set icondata(folder) {
        {poly 2 0 14 0 12 12 0 12 -fill yellow -outline black} 
        {poly -2 0 10 0 12 12 0 12 -fill beige -outline black} 
    }
    set icondata(questhead) {
        {bitmap 5 5 -bitmap questhead -foreground blue
           -activebackground yellow}
    }
    set icondata(text) {
        {rect 0 0 11 15 -fill white}
        {line 2 3 9 3} {line 2 6 9 6} {line 2 9 9 9} {line 2 12 9 12}
    }
    set icondata(copier) {
        {rect -3 0 15 11 -fill grey}
        {line -3 3 15 3}
    }
 }
if 0 {An icon is instantiated by the following proc. As it consists of at
least two canvas items (the text, and the graphics), we have to make up
a unique tag that all of its items receive, so all of this group can be moved
or deleted together - mv:$x, where x is the canvas ID (integer) of the
text. The icon type and text are also tagged, for use at drop time.}
 proc mycon::icon {w x y type text} {
    variable icondata
    set id [$w create text $x $y -text $text]
    set tag [list mv mv:$id ty:$type tx:$text]
    $w itemconfig $id -tags $tag
    foreach item $icondata($type) {
        set id [eval [list $w create] [join $item] [list -tags $tag]]
        $w move $id [expr {$x-5}] [expr {$y-22}]
    }
    $w bind mv <1>         {mycon::click %W %x %y}
    $w bind mv <B1-Motion> {mycon::drag %W %x %y}
    $w bind mv <ButtonRelease-1> {mycon::drop %W}
 }
if 0 {Moving canvas items, or groups of those, requires the
specification of increments in x and y direction. We register the cursor
position when a movable object is clicked on, in namespaced variables:}
 proc mycon::click {w x y} {
    variable X [$w canvasx $x]  Y [$w canvasy $y]
    variable X0 $X Y0 $Y ;#-- good for "undragging"
 }
if 0 {Mouse movement with left button down calls this proc, where we
extract the mv:* group tag from the current item, raise and move the
group, and finally update X and Y:}
 proc mycon::drag {w x y} {
    variable X; variable Y
    set this [lsearch -inline [$w gettags current] mv:*]
    $w raise $this
    $w move $this [expr {$x-$X}] [expr {$y-$Y}]
    set X $x; set Y $y
 }
#-- This undoes a drag operation:
 proc mycon::undrag {w tag} {
    variable X; variable X0; variable Y; variable Y0
    $w move $tag [expr $X0-$X] [expr $Y0-$Y]
 }
if 0 {Dropping an icon, i.e. letting go the mouse button, may lead to
special action, if it happens over another icon, the "target". If the
user has specified one, a callback of the form mycon::callback(type1,type2)
is called. Otherwise, the dragged icon moves back to where it came from.
}
 proc mycon::drop {w} {
    set this [lsearch -inline [$w gettags current] mv:*]
    set ids [eval [list $w find overlapping] [$w bbox $this]]
    foreach id $ids {
        set tags [$w gettags $id]
        if {[lsearch $tags $this]>=0} continue ;#-- own item
        set target [lsearch -inline $tags mv:*]
        set type1 [type $w $this]
        set type2 [type $w $target]
        if {[info command callback($type1,$type2)] ne ""} {
            callback($type1,$type2) $w $this $target
        } else {undrag $w $this}
        break ;#-- there can be only one target
    }
 }
#-- Convenience accessors for icon properties
 proc mycon::_access {prefix w tag} {
    set tag2 [lsearch -inline [$w gettags $tag] $prefix*]
    string map [list $prefix ""] $tag2
 }
 interp alias {} mycon::type {} mycon::_access ty:
 interp alias {} mycon::text {} mycon::_access tx: 

if 0 {Now testing how callbacks work. In a real application, these would
involve additional action on the underlying data, e.g. really moving a
file in the file system. But this is playing only, after all :}
 proc mycon::callback(text,folder) {w from to} {$w delete $from}
 proc mycon::callback(text,floppy) {w from to} {undrag $w $from}

if 0 {With the "copier", I tried to be creative - when you drop a text
on it, it will snap back to the original position, but a copy of it
appears in front of the copier.}
 proc mycon::callback(text,copier) {w from to} {
    variable X; variable Y
    set text "Copy of [text $w $from]"
    icon $w $X [expr $Y+20] [type $w $from] $text
    undrag $w $from ;#-- snap the original back in place
 }
 # Try callback aliasing:
 interp alias {} mycon::callback(folder,copier) {} mycon::callback(text,copier)
 
if 0 {Now to test the whole thing:}
 pack [canvas .c -background white] -fill both -expand 1
 mycon::icon .c 20 30  text      foo.txt
 mycon::icon .c 70 30  text      bargrill.txt
 mycon::icon .c 120 30 floppy    A:
 mycon::icon .c 120 60 floppy    B:
 mycon::icon .c 170 30 folder    myFolder
 mycon::icon .c 220 30 questhead "Huh?"
 mycon::icon .c 300 30 copier    Copier
 
 bind . <Escape> {exec wish $argv0 &; exit} ;# great RAD helper!
 bind . <F1> {console show}