Playing WIMP

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 [L1 ]) 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.

WikiDbImage mycon.jpg

Icons were probably from the beginning done as bitmaps, and later color pixmaps. Tk provides a few built-in bitmaps, 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, {*} or evalled, 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}