Import of 0.4 code from http://www.cs.man.ac.uk/~fellowsd/tcl/shapeid…

…x.html

ChangeLog

@@ -0,0 +1,29 @@
+2000-09-13  Donal K. Fellows  <[email protected]>
+
+	* configure.in: Fixed a blooper that assumed that Tcl and Tk were
+	installed in the same directory.
+
+2000-09-11  Donal K. Fellows  <[email protected]>
+
+	* configure.in: Changed to build correctly on Solaris (at least on
+	my workstation...)  Also altered mechanism for guessing whether to
+	support photo image shapes to use configure instead of testing
+	what was defined in tkInt.h...
+
+2000-09-10  Donal K. Fellows  <[email protected]>
+
+	* license.txt: Pulled this out into a single file.  Made all
+	source files reference this one for license.
+
+	* shape.test: Started work on writing a test suite.  Will need to
+	continue on a Unix system so results - particularly of get
+	operations - can be used to help write the suite...
+
+2000-09-09  Donal K. Fellows  <[email protected]>
+
+	* shape.h: Altered KIND_* definitions to have a SHAPE_ prefix.
+
+	* shapeInt.h: Created this file.  Shape_RenderTextAsRectangles now
+	defined throuth this header and made "private" to the extension by
+	changing its name, as its applicability to other domains is really
+	small.  Other files updated to take account of this...

README

@@ -0,0 +1,24 @@
+Shaped Window Extension 0.4 for Tcl/Tk, Source Code Distribution
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+This distribution is made under the terms described in the
+"license.txt" file.
+
+It allows a system that uses the Tk toolkit over the Tcl interpreter
+(of at least version 8.0) to work with windows whose shapes are
+described by other than a simple rectangle.
+
+There is some documentation (both as NROFF source, with the tmac.an
+macro package loaded, and PostScript as generated from that source
+with GROFF) in the shape0.4/doc directory.
+
+There are some demonstrations in the shape0.4/demos directory.
+
+Any bug reports or feature suggestions are welcome; please send them
+to the author at [email protected]  The author does not (at the
+time of writing) provide commercial-level support for this software.
+
+Note that this software should be considered to be of no better than
+beta quality on Unix and alpha quality on Windows.  It is likely that
+there will be a fair number more interim distributions like this one
+before a full release.

demos/dragger.tcl

@@ -0,0 +1,106 @@
+#!/bin/sh
+
+# dragger.tcl ---
+#
+#	Quick demo using the shape library to provide a coloured cursor
+#
+# Copyright (c) 1997 by Donal K. Fellows
+#
+# The author hereby grants permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAS BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHOR AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# $Id: demo.tcl,v 1.1 1997/09/17 21:10:23 donal Exp donal $
+
+# Now we make cunning use of the backslash/shell trick \
+[ -x `dirname $0`/../shapewish ] && exec `dirname $0`/../shapewish $0 ${1+"$@"} || exec wish8.0 $0 ${1+"$@"} || { echo "`basename $0`: couldn't start wish" >&2 ; exit 1; }
+
+set dir [file join [pwd] [file dirname [info script]] ..]
+lappend auto_path [file join $dir ..]
+package require Shape
+
+set images [file join $dir images]
+
+set none [list @[file join $images none.cur] blue]
+
+image create photo redptr   -file [file join $images ptr-red.gif]
+image create photo greenptr -file [file join $images ptr-green.gif]
+image create photo doc      -file [file join $images doc-img.gif]
+set ptrxbm @[file join $images ptr-mask.xbm]
+set docxbm @[file join $images doc-mask.xbm]
+
+pack [label .l -justify l -text "Drag off this window to see a coloured\
+	cursor\n(implemented using a canvas and the non-rectangular\nwindow\
+	extension) in action.\n\nNow it is your turn to take this away and\
+	build a full\ndrag-and-drop system around this.\n\nOther things you\
+	could try include animated cursors,\nXEyes and OClock clones, etc."]
+
+toplevel .cursor
+wm withdraw .cursor
+wm overrideredirect .cursor 1
+pack [canvas .cursor.workarea -bd 0 -highlightthick 0]
+set image(status) [.cursor.workarea create image 0 0 \
+	-anchor nw -image greenptr]
+set image(doc) [.cursor.workarea create image 3 4 \
+	-anchor nw -image doc]
+#pack [label .cursor.ptr -bd 0 -image greenptr]
+update idletasks
+shape set .cursor.workarea -offset 0 0  bitmap $ptrxbm
+shape upd .cursor.workarea + -offset 3 4  bitmap $docxbm
+shape set .cursor  window .cursor.workarea
+
+proc movecursor {x y} {
+    global image
+    wm geometry .cursor +$x+$y
+    update idletasks
+    set w [winfo containing $x $y]
+    if {[string length $w] && [winfo toplevel $w] == "."} {
+	.cursor.workarea itemconf $image(status) -image greenptr
+    } else {
+	.cursor.workarea itemconf $image(status) -image redptr
+    }
+}
+proc showcursor {w x y} {
+    global savedcursor none
+    set savedcursor [list $w conf -cursor [$w cget -cursor]]
+    $w conf -cursor $none
+    movecursor $x $y
+    wm deiconify .cursor
+    raise .cursor
+    after 250 raisewin .cursor
+}
+proc raisewin w {
+    if {[winfo exists $w] && [winfo ismapped $w]} {
+	raise $w
+	after 250 raisewin $w
+    }
+}
+
+proc hidecursor {} {
+    global savedcursor
+    wm withdraw .cursor
+    eval $savedcursor
+}
+
+bind . <1> {showcursor %W %X %Y}
+bind . <B1-Motion> {movecursor %X %Y}
+bind . <ButtonRelease-1> {hidecursor}

demos/fancytext.tcl

@@ -0,0 +1,87 @@
+#!/bin/sh
+
+# dragger.tcl ---
+#
+#	Quick demo using the shape library to provide a coloured cursor
+#
+# Copyright (c) 1997 by Donal K. Fellows
+#
+# The author hereby grants permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHOR HAS BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHOR AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHOR AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# $Id: demo.tcl,v 1.1 1997/09/17 21:10:23 donal Exp donal $
+
+# Now we make cunning use of the backslash/shell trick \
+[ -x `dirname $0`/../shapewish ] && exec `dirname $0`/../shapewish $0 ${1+"$@"} || exec wish8.0 $0 ${1+"$@"} || { echo "`basename $0`: couldn't start wish" >&2 ; exit 1; }
+
+set dir [file join [pwd] [file dirname [info script]] ..]
+lappend auto_path [file join $dir ..]
+package require Shape
+
+set font {Helvetica 72 bold}
+. conf -bg black
+pack [canvas .c -bg black -bd 0 -highlightthick 0] -fill both -expand 1
+shape set .c text "Some Text" $font
+set bb [shape bound .c]
+set offmax [lindex $bb 3]
+proc moveLine {idx} {
+    global count line inc
+    .c move $idx 0 $inc($idx)
+    incr count($idx) $inc($idx)
+}
+proc moveFwds {idx} {
+    global count offmax delay inc
+    if {$count($idx)<$offmax} {
+	moveLine $idx
+	after $delay($idx) moveFwds $idx
+    } else {
+	set inc($idx) [expr -$inc($idx)]
+	moveBack $idx
+    }
+}
+proc moveBack {idx} {
+    global count offmax delay inc bb
+    if {$count($idx)>[lindex $bb 1]} {
+	moveLine $idx
+	after $delay($idx) moveBack $idx
+    } else {
+	set inc($idx) [expr -$inc($idx)]
+	moveFwds $idx
+    }
+}
+proc move {line delayVal incVal} {
+    global count delay inc
+    set count($line) 0
+    set delay($line) $delayVal
+    set inc($line) $incVal
+    moveFwds $line
+}
+set width  [expr [lindex $bb 0]+[lindex $bb 2]]
+set height [expr [lindex $bb 1]+[lindex $bb 3]]
+wm geometry . ${width}x${height}
+wm sizefrom . user
+update
+move [.c create line 0 0 [lindex $bb 2] 0 -fill blue]   50 2
+move [.c create line 0 0 [lindex $bb 2] 0 -fill green]  50 3
+move [.c create line 0 0 [lindex $bb 2] 0 -fill red]    50 5
+move [.c create line 0 0 [lindex $bb 2] 0 -fill yellow] 50 7

demos/fingerprint.tcl

@@ -0,0 +1,29 @@
+#!/bin/sh
+
+# This little demo (in the splendid tradition of xteddy and xbomb :^)
+# is due to John LoVerso <[email protected]> and I have adapted it
+# a little in order to increase its effectiveness.
+
+# Now we make cunning use of the backslash/shell trick \
+[ -x `dirname $0`/../shapewish ] && exec `dirname $0`/../shapewish $0 ${1+"$@"} || exec wish8.0 $0 ${1+"$@"} || { echo "`basename $0`: couldn't start wish" >&2 ; exit 1; }
+
+set dir [file join [pwd] [file dirname [info script]] ..]
+lappend auto_path [file join $dir ..]
+package require Shape
+
+set images [file join $dir images]
+
+. config -bg tan -cursor dotbox
+wm overrideredirect . 1
+wm withdraw .
+update idle
+shape set . -bound bitmap @[file join $images fingerprint.xbm]
+wm deiconify .
+bind . <1> {
+    regexp {\+(-?[0-9]+)\+(-?[0-9]+)} [winfo geometry .] dummy x y
+    set x [expr $x-%X]
+    set y [expr $y-%Y]
+}
+bind . <B1-Motion> {
+    wm geometry . +[expr %X+$x]+[expr %Y+$y]
+}

demos/images/doc-mask.xbm

@@ -0,0 +1,14 @@
+#define doc-mask_width 32
+#define doc-mask_height 32
+static unsigned char doc-mask_bits[] = {
+   0x00, 0x00, 0x00, 0x00, 0xfe, 0x0f, 0x00, 0x00, 0xfe, 0x1f, 0x00, 0x00,
+   0xfe, 0x3f, 0x00, 0x00, 0xfe, 0x7f, 0x00, 0x00, 0xfe, 0xff, 0x00, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00, 0xfe, 0xff, 0x01, 0x00,
+   0xfe, 0xff, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};

demos/images/fingerprint.xbm

@@ -0,0 +1,32 @@
+#define fingerprint_width 48
+#define fingerprint_height 56
+static char fingerprint_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0xc0, 0xff, 0x01, 0x00, 0x00, 0x00, 0x60, 0x00, 0x07, 0x00,
+ 0x00, 0x00, 0x18, 0xff, 0x04, 0x00, 0x00, 0x00, 0xe4, 0x81, 0x1f, 0x00,
+ 0x00, 0x00, 0xb6, 0x1f, 0x1c, 0x00, 0x00, 0x00, 0xfd, 0xf0, 0x38, 0x00,
+ 0x00, 0x80, 0x14, 0x80, 0x53, 0x00, 0x00, 0xc0, 0x12, 0x3f, 0x76, 0x00,
+ 0x00, 0x60, 0xcb, 0x60, 0xac, 0x00, 0x00, 0x20, 0x6d, 0x98, 0xb9, 0x01,
+ 0x00, 0xa0, 0x35, 0x34, 0x53, 0x01, 0x00, 0xb0, 0x12, 0x6b, 0xb6, 0x01,
+ 0x00, 0xd0, 0xb2, 0x51, 0xa4, 0x06, 0x00, 0x50, 0xaf, 0x90, 0x2c, 0x05,
+ 0x00, 0x58, 0xab, 0xa0, 0x28, 0x05, 0x00, 0x68, 0xeb, 0x20, 0x69, 0x05,
+ 0x00, 0xe8, 0x6a, 0x20, 0x4b, 0x0d, 0x00, 0xa8, 0x77, 0x4e, 0x52, 0x09,
+ 0x00, 0xd8, 0x35, 0x53, 0x4a, 0x0a, 0x00, 0xb4, 0xb5, 0x51, 0x4a, 0x1a,
+ 0x00, 0x64, 0xb5, 0x56, 0x56, 0x12, 0x00, 0x74, 0xbd, 0x56, 0x50, 0x14,
+ 0x00, 0xdc, 0xaf, 0x56, 0x96, 0x14, 0x00, 0xec, 0xaa, 0x5a, 0x9e, 0x1d,
+ 0x00, 0xa4, 0x9e, 0x4a, 0x1a, 0x11, 0x00, 0x74, 0x57, 0x6b, 0x2a, 0x11,
+ 0x00, 0x5c, 0x55, 0x2d, 0x52, 0x13, 0x00, 0x24, 0x4b, 0x24, 0x52, 0x24,
+ 0x00, 0xb8, 0x6b, 0x24, 0xb1, 0x24, 0x00, 0x98, 0x2b, 0x92, 0x24, 0x29,
+ 0x00, 0x44, 0x2d, 0x92, 0x26, 0x03, 0x00, 0x30, 0x36, 0x9a, 0x4e, 0x04,
+ 0x00, 0x0c, 0x1b, 0x8b, 0x4a, 0x28, 0x00, 0xc4, 0x06, 0x25, 0xca, 0x21,
+ 0x00, 0x64, 0xc3, 0x25, 0x1a, 0x27, 0x00, 0x18, 0x78, 0x12, 0x23, 0x2c,
+ 0x00, 0x08, 0x8f, 0xcb, 0xd9, 0x2f, 0x00, 0xf8, 0xe1, 0x60, 0x38, 0x26,
+ 0x00, 0x88, 0x3d, 0x18, 0xe6, 0x09, 0x00, 0x18, 0x07, 0x86, 0x01, 0x37,
+ 0x00, 0x68, 0xf9, 0x73, 0xfe, 0x11, 0x00, 0x90, 0x05, 0x9e, 0x03, 0x0b,
+ 0x00, 0x10, 0x8f, 0x79, 0xfc, 0x00, 0x00, 0x20, 0xf0, 0x0f, 0x03, 0x04,
+ 0x00, 0xe0, 0x07, 0x80, 0x7f, 0x00, 0x00, 0x00, 0xf8, 0x7f, 0x80, 0x04,
+ 0x00, 0x80, 0x07, 0x80, 0x3e, 0x02, 0x00, 0x00, 0x84, 0x7f, 0x00, 0x01,
+ 0x00, 0x00, 0x30, 0x00, 0x00, 0x03, 0x00, 0x00, 0x80, 0x85, 0x83, 0x00,
+ 0x00, 0x00, 0x00, 0x34, 0x34, 0x00, 0x00, 0x00, 0x00, 0x90, 0x03, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
+ };

demos/images/none.cur

@@ -0,0 +1,6 @@
+#define none_width 1
+#define none_height 1
+#define none_x_hot 0
+#define none_y_hot 0
+static unsigned char none_bits[] = {
+   0x00};

demos/images/ptr-mask.xbm

@@ -0,0 +1,4 @@
+#define ptr-mask_width 8
+#define ptr-mask_height 8
+static unsigned char ptr-mask_bits[] = {
+  0x00, 0x07, 0x1e, 0x7e, 0x06, 0x06, 0x04, 0x04, };