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.
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}