pixmap 0.1 -- a color pixmap editor
Sam Shen
pretty simple right now but it should be of some use. It will be more
useful when Tk allows you to use color bitmaps.
Pixmap was implemented with my simple class system that I posted
earlier to comp.lang.tcl, so it should be of interest to more than
just people who want to draw pretty pixmaps. I think the resulting
code is much cleaner than typical tcl code. See what you think.
I'll put this on harbor.ecn.purdue.edu in case you don't like shar
files.
Man page included.
-Sam
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: Makefile README README.class class.tcl default.pal
# pixmap.1 pixmap.tcl
# Wrapped by sls@batcomputer on Fri Mar 12 02:56:45 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Makefile'\"
else
echo shar: Extracting \"'Makefile'\" \(1341 characters\)
sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X# $Id: Makefile,v 1.1 1993/03/12 02:28:10 sls Exp $
X#
X# Makefile to install pixmap editor.
X#
X
X#
X# BINDIR says where to install the pixmap /bin/sh startup script.
X#
XBINDIR = /usr/local/bin
X
X#
X# LIBDIR tells us where to put the actual tcl scripts that make up
X# pixmap. It should not be the current directory.
X#
XLIBDIR = /usr/local/lib/pixmap
X
X#
X# MANDIR tells us where to install the man page.
X#
XMANDIR = /usr/local/man/man1
X
X#
X# WISH tells us where can we find the wish executable. Pixmap
X# requires Tk3.1 or greater.
X#
XWISH = /usr/local/bin/wish
X
X#
X# Hopefully you don't have to edit anything below this line.
X#
X
Xdefault:
X @echo "Edit the Makefile and do make install to install pixmap."
X
Xinstall: pixmap.sh
X rm -f $(BINDIR)/pixmap
X cp pixmap.sh $(BINDIR)/pixmap
X chmod a+rx $(BINDIR)/pixmap
X if test ! -d $(LIBDIR); then rm -rf $(LIBDIR); mkdir $(LIBDIR); fi
X chmod a+rx $(LIBDIR)
X rm -f $(LIBDIR)/default.pal
X cp default.pal $(LIBDIR)
X rm -f $(LIBDIR)/pixmap.tcl
X cp pixmap.tcl $(LIBDIR)
X rm -f $(LIBDIR)/class.tcl
X cp class.tcl $(LIBDIR)
X chmod a+r $(LIBDIR)/default.pal $(LIBDIR)/pixmap.tcl
X chmod a+r $(LIBDIR)/class.tcl
X rm -rf $(MANDIR)/pixmap.1
X cp pixmap.1 $(MANDIR)
X chmod a+r $(MANDIR)/pixmap.1
X
Xpixmap.sh:
X @echo \#!/bin/sh > pixmap.sh
X @echo exec $(WISH) -f $(LIBDIR)/pixmap.tcl $(LIBDIR) >> pixmap.sh
X @chmod a+rx pixmap.sh
END_OF_FILE
if test 1341 -ne `wc -c <'Makefile'`; then
echo shar: \"'Makefile'\" unpacked with wrong size!
fi
# end of 'Makefile'
fi
if test -f 'README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README'\"
else
echo shar: Extracting \"'README'\" \(869 characters\)
sed "s/^X//" >'README' <<'END_OF_FILE'
X$Id: README,v 1.1 1993/03/12 02:28:10 sls Exp $
X
XThis is Pixmap 0.1, a color pixmap editor written in Tcl/Tk. It's
Xpretty simple right now but it should be of some use. It will be more
Xuseful when Tk allows you to use color bitmaps.
X
XPixmap was implemented with my simple class system that I posted
Xearlier to comp.lang.tcl, so it should be of interest to more than
Xjust people who want to draw pretty pixmaps. I think the resulting
Xcode is much cleaner than typical tcl code. See what you think.
X
XTo install: edit the Makefile and type make install.
X
XPixmap is public domain software (except the color editor probably falls
Xunder the Tk3.1 copyright.)
X
XComments, bug fixes, enhancements, sample pixmaps, sample palettes
Xare welcome.
X
X -Sam Shen (s...@aero.org)
X
X
XHistory:
X
XPixmap 0.1, March 12, 1993
X--------------------------
XFirst version posted on comp.lang.tcl.END_OF_FILE
if test 869 -ne `wc -c <'README'`; then
echo shar: \"'README'\" unpacked with wrong size!
fi
# end of 'README'
fi
if test -f 'README.class' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README.class'\"
else
echo shar: Extracting \"'README.class'\" \(1723 characters\)
sed "s/^X//" >'README.class' <<'END_OF_FILE'
XThis file defines three forms. The first,
X
Xclass <class-name> {
X method <method-name> <method-args> <method-body>
X :
X member <member-name> <initial-value>
X :
X #| comments ...
X :
X #|
X :
X}
X
Xdefines a new type <class-name>. The methods are transformed into
Xproc's with names <class-name>:<method-name>. The functions
X"setmember", "getmember", and "aliasmember" are valid in the methods.
X"setmember" and "getmember" set and get the values of members. The
Xmethods, members, and block comments may come in any order. All
Xclasses automatically have the member class, which is the name of the
Xclass's class.
X
XObjects can be created by writing "<class-name> <object-name>". A new
Xvariable <object-name> is created and set to a handle to the object.
XThe object handles are of the form O_<n> and are actually global
Xarrays. O_<n>(class) contains the class, O_<n>(<member>) contains the
Xmember <member>.
X
XThe second form,
X
Xin <object-handle> <expr>
X
Xevaluates expression inside the object. in creates aliases
X<method-name> for each <class-name>:<method-name>, evaluates <expr>,
Xand finally restores any proc's the aliasing process might have
Xdestroyed.
X
XAnd finally, the third form,
X
Xdelete <object-handle>
X
Xdeletes the state associated with <object-handle>.
X
XThe variable namespace is polluted as follows:
X
XO_<n> - holds the storage of an object.
Xclass_methods(<class-name>) - list of the methods of a class.
Xobject_counter - holds the current <n> in O_<n>
Xin_counter - holds a counter that's used in in's renaming process.
X If there are procs of the form procFoo, procFoo<n> where <n> is
X a number in may fail.
Xin_sti, in_st() - holds a stack used by in the keep track of the current
X scope.
X
END_OF_FILE
if test 1723 -ne `wc -c <'README.class'`; then
echo shar: \"'README.class'\" unpacked with wrong size!
fi
# end of 'README.class'
fi
if test -f 'class.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'class.tcl'\"
else
echo shar: Extracting \"'class.tcl'\" \(3385 characters\)
sed "s/^X//" >'class.tcl' <<'END_OF_FILE'
X#
X# class.tcl -- a simple class system in Tcl.
X#
X# $Id: class.tcl,v 1.1 1993/03/06 01:32:58 sls Exp $
X#
X# $Log: class.tcl,v $
X# Revision 1.1 1993/03/06 01:32:58 sls
X# Initial revision
X#
X#
X
Xset object_counter 0
Xproc class {class_name spec} {
X global class_methods
X set members ""
X for {set i 0} {$i < [llength $spec]} {incr i} {
X case [lindex $spec $i] {
X method {
X set method_body [concat global \$this ";" in \$this]
X lappend method_body [lindex $spec [expr {$i+3}]]
X set ag [linsert [lindex $spec [expr {$i+2}]] 0 this]
X proc $class_name:[lindex $spec [expr {$i+1}]] \
X $ag $method_body
X lappend class_methods($class_name) [lindex $spec [expr {$i+1}]]
X incr i 3
X }
X member {
X lappend members [list [lindex $spec [expr {$i+1}]] \
X [lindex $spec [expr {$i+2}]]]
X incr i 2
X }
X "#|" {
X incr i
X while {[lindex $spec $i] != "#|"} {
X incr i
X }
X }
X default {
X error [format {unknown keyword "%s" in class declaration} \
X [lindex $spec $i]]
X }
X }
X }
X if {$members != ""} {
X set ctor_body [format {
X upvar #0 $_this this
X foreach member {%s} {
X set this([lindex $member 0]) [lindex $member 1]
X }
X } $members]
X proc $class_name:Construct _this $ctor_body
X }
X set body [format {
X global object_counter
X set objects ""
X for {set i 0} {$i < $count} {incr i} {
X set var O_[incr object_counter]
X upvar #0 $var object
X lappend objects $var
X set object(class) %s
X if %d {
X uplevel "%s:Construct $var"
X }
X }
X return $objects
X } $class_name [expr {$members != ""}] $class_name]
X proc $class_name {{count 1}} $body
X}
X
Xset in_counter 0
Xset in_sti 0
Xproc push_scope {on} {
X global in_sti in_st
X set in_st([incr in_sti]) $on
X}
Xproc in_scope? {on} {
X global in_sti in_st
X expr {$in_sti > 0 && $in_st($in_sti) == $on}
X}
Xproc pop_scope {} {
X global in_sti in_st
X unset in_st($in_sti)
X incr in_sti -1
X}
X
Xproc in {_object expr} {
X upvar #0 $_object object
X global in_counter errorInfo class_methods
X set cleanup ""
X if ![in_scope? $_object] {
X push_scope $_object
X set switched_scope 1
X set ctr [incr in_counter]
X set cleanup "pop_scope; "
X set class $object(class)
X foreach method $class_methods($class) {
X if {[info procs $method] != ""} {
X set oldproc $method[set ctr]
X rename $method $oldproc
X append cleanup "rename $method {}; rename $oldproc $method; "
X } else {
X append cleanup "rename $method {}; "
X }
X set method_body [format {
X uplevel [format "%s %s %%s" $args]
X } $class:$method $_object]
X proc $method args $method_body
X }
X }
X if {[set retval [catch {uplevel $expr} result]] == 1} {
X set savedInfo $errorInfo
X }
X eval $cleanup
X if {$retval == 1} {
X error $result $savedInfo
X }
X return $result
X}
X
Xproc getmember var {
X upvar [uplevel "set this"] o
X set o($var)
X}
X
Xproc setmember {var val} {
X set cmd [format {set [set this](%s)} $var]
X lappend cmd $val
X return [uplevel $cmd]
X}
X
Xproc appendmember {var val} {
X set cmd [format {append [set this](%s)} $var]
X lappend cmd $val
X uplevel $cmd
X}
X
Xproc membername {var} {
X set o [uplevel {set this}]
X return [format %s(%s) $o $var]
X}
X
Xproc lappendmember {var val} {
X set cmd [format {lappend [set this](%s)} $var]
X lappend cmd $val
X uplevel $cmd
X}
X
Xproc delete object {
X uplevel "unset $object"
X}
END_OF_FILE
if test 3385 -ne `wc -c <'class.tcl'`; then
echo shar: \"'class.tcl'\" unpacked with wrong size!
fi
# end of 'class.tcl'
fi
if test -f 'default.pal' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'default.pal'\"
else
echo shar: Extracting \"'default.pal'\" \(473 characters\)
sed "s/^X//" >'default.pal' <<'END_OF_FILE'
X# $Id: default.pal,v 1.1 1993/03/12 02:28:10 sls Exp $
X#
X# $Log: default.pal,v $
X# Revision 1.1 1993/03/12 02:28:10 sls
X# Initial revision
X#
X#
X# setup the default colors -- these could probably use some improvement.
X#
X
Xset i 0
Xforeach color {
X black white LightSlateGray DimGray DarkSlateGrey cadetblue
X SaddleBrown tomato goldenrod2 VioletRed2
X SpringGreen SeaGreen4 khaki3 tan2
X DodgerBlue1 MediumPurple3
X} {
X set defaultColors($i) $color
X incr i
X}
END_OF_FILE
if test 473 -ne `wc -c <'default.pal'`; then
echo shar: \"'default.pal'\" unpacked with wrong size!
fi
# end of 'default.pal'
fi
if test -f 'pixmap.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pixmap.1'\"
else
echo shar: Extracting \"'pixmap.1'\" \(4934 characters\)
sed "s/^X//" >'pixmap.1' <<'END_OF_FILE'
X.\" $Id: pixmap.1,v 1.1 1993/03/12 02:32:27 sls Exp $
X.TH pixmap local
X.IX pixmap
X.SH NAME
Xpixmap - edit color pixmaps
X.SH SYNOPSIS
X.B pixmap
X.SH DESCRIPTION
X\fBpixmap\fR creates color pixmaps. It saves its files in its own
Xidionsyncratic file format. It can also write PPM files, but not read
Xthem.
X
XThe screen is divided into four main areas. On top there is a row of
Xbuttons that perform various tasks (such as saving the pixmap, loading
Xa pixmap, etc.) Just below that is a set of entries and check buttons
Xthat control various parameters. On the left is a strip of
Xradio buttons and patches of color.
X.SH BUTTONS
X\fBNew\fR deletes the current pixmap.
X
X\fBSave Pixmap\fR saves the current pixmap. It brings up a dialog
Xasking for a filename. Pressing \fBOk\fR will save the pixmap,
Xpressing \fBCancel\fR will remove the dialog without saving. If the
Xfile cannot be written a message will be displayed and you may try
Xanother filename. I suggest you use the extension \fI.pix\fR for
Xpixmaps.
X
X\fBLoad Pixmap\fR loads a pixmap. The file must be one created by
X\fBpixmap\fR (or in the \fBpixmap\fR file format.)
X
X\fBSave Palette\fR saves the colors in the strip on the left side of
Xthe screen. I suggest you use the extension \fI.pal\fR for palettes.
X
X\fBLoad Palette\fR load the colors in the strip on the left side from a
Xfile.
X
X\fBQuit\fR quits \fBpixmap\fR.
X.SH PARAMETERS
X\fBWidth\fR controls the width of the pixmap. The new value will not
Xtake effect until you press the \fBApply\fR button.
X
X\fBHeight\fR controls the height of the pixmap. The new value will
Xnot take effect until you press the \fBApply\fR button.
X
X\fBZoom\fR controls how many screen pixels should be displayed for
Xeach pixel in the pixmap. For example, at a zoom setting of 10
X\fBpixmap\fR will draw sqaures 10 pixels square for each pixel in the
Xpixmap. Again, the new value of will not take effect until you press
Xthe \fBApply\fR button.
X
X\fBApply\fR applies the new width, height, and zoom values to the
Xcurrent pixmap. \fBWARNING:\fR if the width or height of the pixmap
Xhas changed the current pixmap will be deleted.
X
X\fBGridding\fR controls whether or not a grid is drawn. The grid
Xcolor is always white.
X
X\fBSave in PPM format\fR controls whether or not pixmaps should be
Xsaved in PPM format. Remember that while \fBpixmap\fR can write PPM
Xfiles, in cannot read them.
X
X\fBFile\fR sets the filename of the current pixmap.
X
X\fBX\fR and \fBY\fR display the X and Y coordinates of the pointer
Xwhen the pointer is over the image. The coordinates are in pixmap
Xspace based from 0.
X.SH COLOR PALETTE
XThe color palette is the strip along the left side of the screen. You
Xcan select the current color by clicking a radio button. You can edit
Xthe color of the radio button by clicking on the patch with the word
X\fBEdit\fR in it. The color is edited with code lifted from the
XTk demo program \fBtcolor\fR.
X
XThe topmost color sets the background color.
X.SH PIXMAP
XYou can set pixels in the pixmap to the current color by clicking
Xthe left button (button 1) on the pixmap.
X
XYou can set pixels in the pixmap to the background color (deleting
Xthem) by clicking right button (button 3) on the pixmap.
X.SH FILE FORMAT
X\fI.pal\fR files are just tcl commands that set up the array
XdefaultColors(0...15). The values of array elements are any color
Xacceptable to Tk.
X
X\fI.pix\fR files are also a sequence of tcl commands. The tcl
Xcommands that appear are:
X.IP - 2
XPW <width>, sets the width of the pixmap.
X.IP - 2
XPH <height>, sets the height of the pixmap.
X.IP - 2
XPC <x> <y> <color> <red> <green> <blue>, sets the color of the cell at
Xx, y to color. The red green and blue values are the X server's idea
Xof the red green and blue values of the color. They range in value
Xfrom 0 to 65535.
X
XNote that there probably will not be a PC command for every x,y in the
Xpixmap.
X.SH "SEE ALSO"
XTcl(l), the Tk widgets, ppm(5)
X.SH AUTHOR
XSam Shen (s...@aero.org) -- please send any bugs/fixes/enhancements to me.
X.SH BUGS
XHere's my list of problems/missing features with the code:
X
X1. The mechanism for setting the background color is dumb. There
Xshould be a better way.
X
X2. There's no way to change the grid color.
X
X3. If the height or width changes the current pixmap should not be
Xdeleted.
X
X4. Bad things happen if you set the zoom to 1.
X
X5. There should be a way to view the pixmap at zoom 1 and still edit
Xthe zoomed pixmap.
X
X6. It should read PPM files. It should probably read and write XPM
Xfiles as well (not hard if you just exec ppmtoxpm or xpmtoppm.) If
Xsomeone contributes code to do this I'd be very grateful.
X
X7. The file selection dialogs should be a little friendlier.
X
X8. Drawing tools!!! You ought to be able to draw lines and circles at
Xleast. Also some sort of mirroring would be cool...
X
X9. The list of problems/missing features with the code in the man page
Xis not as long as it could be but honestly I'm getting tired typing.
END_OF_FILE
if test 4934 -ne `wc -c <'pixmap.1'`; then
echo shar: \"'pixmap.1'\" unpacked with wrong size!
fi
# end of 'pixmap.1'
fi
if test -f 'pixmap.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pixmap.tcl'\"
else
echo shar: Extracting \"'pixmap.tcl'\" \(21485 characters\)
sed "s/^X//" >'pixmap.tcl' <<'END_OF_FILE'
X# $Id: pixmap.tcl,v 1.1 1993/03/12 02:28:10 sls Exp $
X#
X# $Log: pixmap.tcl,v $
X# Revision 1.1 1993/03/12 02:28:10 sls
X# Initial revision
X#
X#
X# pixmap -- a color pixmap editor in Tcl.
X#
X# This program is in the public domain. Do what you want with this code.
X# Of course, this code comes with absolutely no warranty.
X#
X# Author: Sam Shen (s...@aero.org)
X#
Xif {$argc != 1} {
X puts stderr "Ooops! pixmap has not been installed correctly."
X exit 1
X}
Xset pixmap_library $argv
Xif {$tkVersion < 3.1} {
X puts stderr "Ooops! pixmap requires Tk3.1 or later."
X puts stderr "You are running Tk[set tkVersion]"
X}
Xsource $pixmap_library/class.tcl
X
Xset fileName none
Xwm title . "Pixmap Editor:$fileName"
Xwm iconname . "Pixmap Editor"
Xwm minsize . 100 100
X
X#
X# FileChooser implements a simple file chooser.
X#
Xclass FileChooser {
X member w .filechooser
X member ok 0
X member read 1
X member write 0
X member file {}
X method run {prompt {read 1} {write 0} {default {}}} {
X set w [getmember w]
X setmember read $read
X setmember write $write
X catch {destroy $w}
X toplevel $w
X frame $w.e
X label $w.e.l -text $prompt -anchor w
X entry $w.e.e -relief sunken -width 40
X if {$default != {}} {
X $w.e.e insert 0 $default
X }
X pack append $w.e \
X $w.e.l "left frame w padx 2" \
X $w.e.e "right fillx expand"
X bind $w.e.e <Return> "FileChooser:ok $this"
X frame $w.buts
X button $w.ok -text "Ok" -command "FileChooser:ok $this"
X button $w.cancel -text "Cancel" -command "FileChooser:cancel $this"
X pack append $w.buts \
X $w.ok "left fillx expand" \
X $w.cancel "left fillx expand"
X label $w.status -anchor w -bd 2 -relief sunken \
X -font -*-Helvetica-Medium-R-*-*-14-*
X pack append $w \
X $w.e "top fillx expand" \
X $w.buts "fillx pady .5c" \
X $w.status "fillx"
X grab set $w
X tkwait window $w
X if [getmember ok] {
X return [getmember file]
X }
X return {}
X }
X method ok {} {
X set w [getmember w]
X set file [$w.e.e get]
X setmember file $file
X if [getmember read] {
X if [file readable $file] {
X setmember ok 1
X destroy $w
X } else {
X $w.status config -text "Can't read file $file"
X }
X return
X }
X if [getmember write] {
X if ![catch {open $file w} f] {
X close $f
X setmember ok 1
X destroy $w
X } else {
X $w.status config -text "Can't write to file $file"
X }
X return
X }
X }
X method cancel {} {
X setmember ok 0
X destroy [getmember w]
X }
X
X}
X
X#
X# Buttons implements the buttons on the main window.
X#
Xclass Buttons {
X member w {}
X method create {w} {
X setmember w $w
X frame $w
X button $w.new -text "New" \
X -command "Buttons:new $this"
X button $w.save -text "Save Pixmap" \
X -command "Buttons:savePixmap $this"
X button $w.load -text "Load Pixmap" \
X -command "Buttons:loadPixmap $this"
X button $w.savep -text "Save Palette" \
X -command "Buttons:savePalette $this"
X button $w.loadp -text "Load Palette" \
X -command "Buttons:loadPalette $this"
X button $w.quit -text "Quit" -command { destroy . }
X pack append $w \
X $w.new "left fill expand" \
X $w.save "left fill expand" \
X $w.load "left fill expand" \
X $w.savep "left fill expand" \
X $w.loadp "left fill expand" \
X $w.quit "left fill expand"
X setmember filechooser [FileChooser]
X return $w
X }
X method new {} {
X global canvas
X EditorCanvas:new $canvas
X }
X method savePixmap {} {
X global fileName
X set file [FileChooser:run [getmember filechooser] \
X "Save pixmap to:" 0 1 $fileName]
X if {$file != {}} {
X global canvas
X set fileName $file
X wm title . "Pixmap Editor:$fileName"
X EditorCanvas:save $canvas $file
X }
X }
X method loadPixmap {} {
X global fileName
X set file [FileChooser:run [getmember filechooser] \
X "Load pixmap from:" 1 0 $fileName]
X if {$file != {}} {
X global canvas
X set fileName $file
X wm title . "Pixmap Editor:$fileName"
X EditorCanvas:load $canvas $file
X }
X }
X method savePalette {} {
X set file [FileChooser:run [getmember filechooser] \
X "Save current palette to:" 0 1]
X if {$file != {}} {
X set f [open $file "w"]
X global palette
X for {set i 0} {$i < 16} {incr i} {
X set color [ColorPalette:getColor $palette $i]
X puts $f "set defaultColors($i) $color"
X }
X close $f
X }
X }
X method loadPalette {} {
X set file [FileChooser:run [getmember filechooser] \
X "Load palette from:"]
X if {$file != {}} {
X global defaultColors
X source $file
X global palette
X ColorPalette:loadDefaultColors $palette
X }
X }
X}
X
Xpack append . [Buttons:create [Buttons] .buttons] "top fillx"
X
X#
X# bindEntry does better bindings for an entry.
X#
Xproc bindEntry args {
X foreach e $args {
X bind $e <Return> "focus none"
X }
X}
X
X#
X# Parameters implements the various entry widgets below the buttons.
X#
Xset _pixmapHeight 20
Xset _pixmapWidth 20
Xset _zoom 15
Xset gridOn 1
Xset savePPM 0
Xclass Parameters {
X member w {}
X method create {w} {
X setmember w $w
X frame $w
X frame $w.1
X label $w.lw -text "Width:"
X entry $w.ew -bd 2 -relief sunken -width 10 -textvariable _pixmapHeight
X label $w.lh -text "Height:"
X entry $w.eh -bd 2 -relief sunken -width 10 -textvariable _pixmapWidth
X label $w.lz -text "Zoom:"
X entry $w.ez -bd 2 -relief sunken -width 10 -textvariable _zoom
X bindEntry $w.ew $w.eh $w.ez
X button $w.apply -text "Apply" \
X -command "Parameters:apply $this"
X pack append $w.1 \
X $w.lw "left" \
X $w.ew "left fillx expand" \
X $w.lh "left pady 5 frame e" \
X $w.eh "left fillx expand" \
X $w.lz "left pady 5 frame e" \
X $w.ez "left fillx expand" \
X $w.apply "right pady 5"
X frame $w.2
X checkbutton $w.gr -variable gridOn -text "Gridding" -relief flat \
X -command "Parameters:toggleGridding $this"
X checkbutton $w.sppm -variable savePPM -text "Save in PPM format" \
X -relief flat
X label $w.fl -text "File:"
X entry $w.fn -bd 2 -width 15 -textvariable fileName -relief sunken
X bind $w.fn <Return> "focus none"
X label $w.x -font *-Courier-Medium-R-Normal-*-120-* \
X -textvariable currentX -width 7
X label $w.y -font *-Courier-Medium-R-Normal-*-120-* \
X -textvariable currentY -width 7
X pack append $w.2 \
X $w.gr "left pady 5 frame w" \
X $w.sppm "left pady 5 frame w" \
X $w.fl "left pady 5 frame e" \
X $w.fn "left pady 5 frame w" \
X $w.y "right pady 5" \
X $w.x "right pady 5"
X pack append $w $w.1 "top fillx" $w.2 "top fillx"
X return $w
X }
X method apply {} {
X global canvas _pixmapHeight _pixmapWidth _zoom
X EditorCanvas:setParameters $canvas $_pixmapHeight $_pixmapWidth \
X $_zoom
X }
X method updateParameters {} {
X global canvas _pixmapHeight _pixmapWidth _zoom
X in $canvas {
X set _pixmapHeight [getHeight]
X set _pixmapWidth [getWidth]
X set _zoom [getZoom]
X }
X }
X method toggleGridding {} {
X global gridOn canvas
X EditorCanvas:setGridding $canvas $gridOn
X }
X
X}
X
Xpack append . [Parameters:create [set params [Parameters]] .params] "top fillx"
X
X#
X# ColorEditor is ripped off from the Tk demo program tcolor.
X#
Xset colorSpace hsb
Xclass ColorEditor {
X member red 65535
X member green 0
X member blue 0
X member color #ffff00000000
X member updating 0
X member name ""
X member w .ceditor
X member ok 0
X method run {{color gray}} {
X set w [getmember w]
X catch {destroy $w}
X toplevel $w
X wm title $w "Color Editor"
X frame $w.buttons
X radiobutton $w.rgb -text "RGB color space" -variable colorSpace \
X -value rgb -relief flat \
X -command "ColorEditor:changeColorSpace $this rgb"
X radiobutton $w.cmy -text "CMY color space" -variable colorSpace \
X -value cmy -relief flat \
X -command "ColorEditor:changeColorSpace $this cmy"
X radiobutton $w.hsb -text "HSB color space" -variable colorSpace \
X -value hsb -relief flat \
X -command "ColorEditor:changeColorSpace $this hsb"
X button $w.ok -text "Ok" -command "ColorEditor:ok $this"
X button $w.cancel -text "Cancel" -command "ColorEditor:cancel $this"
X pack append $w.buttons \
X $w.rgb "left padx 4" \
X $w.cmy "left padx 4" \
X $w.hsb "left padx 4" \
X $w.cancel "right padx 4 pady 2" \
X $w.ok "right padx 4 pady 2"
X frame $w.left
X foreach i {1 2 3} {
X frame $w.left$i
X label $w.label$i
X scale $w.scale$i -from 0 -to 1000 -length 10c -orient horizontal \
X -command "ColorEditor:scaleChanged $this"
X button $w.up$i -width 2 -text + \
X -command "ColorEditor:inc $this $i 1"
X button $w.down$i -width 2 -text - \
X -command "ColorEditor:inc $this $i -1"
X pack append $w.left$i \
X $w.label$i {top frame w} \
X $w.down$i {left padx .5c} \
X $w.scale$i left \
X $w.up$i {left padx .5c}
X pack append $w.left $w.left$i "top expand"
X }
X frame $w.right
X frame $w.swatch -width 2c -height 5c -background $color
X label $w.value -text $color -width 13 \
X -font -Adobe-Courier-Medium-R-Normal-*-120-*
X pack append $w.right \
X $w.swatch {top expand fill} \
X $w.value {bottom pady .5c}
X pack append $w \
X $w.buttons "top fillx" \
X $w.left "left expand filly" \
X $w.right "right padx .5c pady .5c frame s"
X loadNamedColor $color
X changeColorSpace hsb
X grab set $w
X tkwait window $w
X if [getmember ok] {
X return [getmember color]
X } else {
X return {}
X }
X }
X method cancel {} {
X setmember ok 0
X destroy [getmember w]
X }
X method ok {} {
X setmember ok 1
X destroy [getmember w]
X }
X method inc {i inc} {
X set w [getmember w]
X $w.scale$i set [expr [$w.scale$i get]+$inc]
X }
X method scaleChanged args {
X if [getmember updating] {
X return
X }
X global colorSpace
X set w [getmember w]
X if {$colorSpace == "rgb"} {
X set red [format %.0f [expr [$w.scale1 get]*65.535]]
X set green [format %.0f [expr [$w.scale2 get]*65.535]]
X set blue [format %.0f [expr [$w.scale3 get]*65.535]]
X } else {
X if {$colorSpace == "cmy"} {
X set red [format %.0f [expr {65535 - [$w.scale1 get]*65.535}]]
X set green [format %.0f [expr {65535 - [$w.scale2 get]*65.535}]]
X set blue [format %.0f [expr {65535 - [$w.scale3 get]*65.535}]]
X } else {
X set list [hsbToRgb [expr {[$w.scale1 get]/1000.0}] \
X [expr {[$w.scale2 get]/1000.0}] \
X [expr {[$w.scale3 get]/1000.0}]]
X set red [lindex $list 0]
X set green [lindex $list 1]
X set blue [lindex $list 2]
X }
X }
X set color [format "#%04x%04x%04x" $red $green $blue]
X setmember color $color
X setmember red $red
X setmember green $green
X setmember blue $blue
X $w.swatch config -bg $color
X $w.value config -text $color
X update idletasks
X }
X method setScales {} {
X set red [getmember red]
X set blue [getmember blue]
X set green [getmember green]
X set w [getmember w]
X setmember updating 1
X global colorSpace
X if {$colorSpace == "rgb"} {
X $w.scale1 set [format %.0f [expr $red/65.535]]
X $w.scale2 set [format %.0f [expr $green/65.535]]
X $w.scale3 set [format %.0f [expr $blue/65.535]]
X } else {
X if {$colorSpace == "cmy"} {
X $w.scale1 set [format %.0f [expr (65535-$red)/65.535]]
X $w.scale2 set [format %.0f [expr (65535-$green)/65.535]]
X $w.scale3 set [format %.0f [expr (65535-$blue)/65.535]]
X } else {
X set list [rgbToHsv $red $green $blue]
X $w.scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]]
X $w.scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]]
X $w.scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]]
X }
X }
X setmember updating 0
X }
X method loadNamedColor name {
X set w [getmember w]
X if {[string index $name 0] != "#"} {
X set list [winfo rgb $w.swatch $name]
X set red [lindex $list 0]
X set green [lindex $list 1]
X set blue [lindex $list 2]
X } else {
X case [string length $name] {
X 4 {set format "#%1x%1x%1x"; set shift 12}
X 7 {set format "#%2x%2x%2x"; set shift 8}
X 10 {set format "#%3x%3x%3x"; set shift 4}
X 13 {set format "#%4x%4x%4x"; set shift 0}
X default {error "syntax error in color name \"$name\""}
X }
X if {[scan $name $format red green blue] != 3} {
X error "syntax error in color name \"$name\""
X }
X set red [expr $red<<$shift]
X set green [expr $green<<$shift]
X set blue [expr $blue<<$shift]
X }
X setmember red $red
X setmember green $green
X setmember blue $blue
X set color [format "#%04x%04x%04x" $red $green $blue]
X setmember color $color
X setScales
X $w.swatch config -bg $color
X $w.value config -text $name
X }
X method setLabels {l1 l2 l3} {
X set w [getmember w]
X $w.label1 config -text $l1
X $w.label2 config -text $l2
X $w.label3 config -text $l3
X }
X method changeColorSpace space {
X global colorSpace
X set colorSpace $space
X if {$space == "rgb"} {
X setLabels Red Green Blue
X setScales
X return
X }
X if {$space == "cmy"} {
X setLabels Cyan Magenta Yellow
X setScales
X return
X }
X if {$space == "hsb"} {
X setLabels Hue Saturation Brightness
X setScales
X return
X }
X }
X method rgbToHsv {red green blue} {
X if {$red > $green} {
X set max $red.0
X set min $green.0
X } else {
X set max $green.0
X set min $red.0
X }
X if {$blue > $max} {
X set max $blue.0
X } else {
X if {$blue < $min} {
X set min $blue.0
X }
X }
X set range [expr $max-$min]
X if {$max == 0} {
X set sat 0
X } else {
X set sat [expr {($max-$min)/$max}]
X }
X if {$sat == 0} {
X set hue 0
X } else {
X set rc [expr {($max - $red)/$range}]
X set gc [expr {($max - $green)/$range}]
X set bc [expr {($max - $blue)/$range}]
X if {$red == $max} {
X set hue [expr {.166667*($bc - $gc)}]
X } else {
X if {$green == $max} {
X set hue [expr {.166667*(2 + $rc - $bc)}]
X } else {
X set hue [expr {.166667*(4 + $gc - $rc)}]
X }
X }
X }
X return [list $hue $sat [expr {$max/65535}]]
X }
X method hsbToRgb {hue sat value} {
X set v [format %.0f [expr 65535.0*$value]]
X if {$sat == 0} {
X return "$v $v $v"
X } else {
X set hue [expr $hue*6.0]
X if {$hue >= 6.0} {
X set hue 0.0
X }
X scan $hue. %d i
X set f [expr $hue-$i]
X set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]]
X set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]]
X set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]]
X case $i \
X 0 {return "$v $t $p"} \
X 1 {return "$q $v $p"} \
X 2 {return "$p $v $t"} \
X 3 {return "$p $q $v"} \
X 4 {return "$t $p $v"} \
X 5 {return "$v $p $q"}
X error "i value $i is out of range"
X }
X }
X}
X
Xsource $pixmap_library/default.pal
X
X#
X# ColorPalette implements the color palette.
X#
Xclass ColorPalette {
X member w {}
X member editor {}
X method create {w} {
X global defaultColors currentColor
X setmember w $w
X frame $w -bd 2 -relief raised
X for {set i 0} {$i < 16} {incr i} {
X frame $w.$i
X radiobutton $w.$i.button -width 13 \
X -variable currentColor \
X -font *-Courier-Medium-R-Normal-*-120-* \
X -anchor w
X button $w.$i.patch -text Edit \
X -command "ColorPalette:edit $this $i"
X pack append $w.$i \
X $w.$i.button "right frame e" \
X $w.$i.patch "left padx 4 pady 4 frame w"
X pack append $w $w.$i "top fillx"
X }
X loadDefaultColors
X setmember editor [ColorEditor]
X return $w
X }
X method loadDefaultColors {} {
X set w [getmember w]
X global defaultColors currentColor
X for {set i 0} {$i < 16} {incr i} {
X $w.$i.button config -text $defaultColors($i) \
X -value $defaultColors($i)
X $w.$i.patch config -background $defaultColors($i)
X }
X set currentColor $defaultColors(0)
X }
X method edit {i} {
X set w [getmember w]
X set color [ColorEditor:run [getmember editor] \
X [lindex [$w.$i.patch config -background] 4]]
X if {$color != {}} {
X if {$i == 0} {
X global canvas
X EditorCanvas:setBackground $canvas $color
X }
X $w.$i.button config -text $color -value $color
X $w.$i.patch config -background $color
X }
X }
X method getColor {i} {
X set w [getmember w]
X return [lindex [$w.$i.patch config -background] 4]
X }
X}
X
Xpack append . \
X [ColorPalette:create [set palette [ColorPalette]] .palette] "left filly"
X
X
X#
X# EditorCanvas implements the canvas part of the editor.
X#
Xclass EditorCanvas {
X member c {}
X member background {}
X member gridding 1
X member zoom 15
X member width 20
X member height 20
X method create {c} {
X setmember c $c
X set Width [getmember width]
X set Height [getmember height]
X global zoom
X set zoom [getmember zoom]
X global palette
X setmember background [ColorPalette:getColor $palette 0]
X set bg [getmember background]
X canvas $c -width [expr {$zoom*$Width}] \
X -height [expr {$zoom*$Height}] \
X -background $bg
X drawGrid
X bind $c <1> "EditorCanvas:fillCell $this %x %y"
X bind $c <B1-Motion> "EditorCanvas:fillCell $this %x %y"
X bind $c <Motion> {
X global zoom currentX currentY
X set currentX "X: [format %%-3d [expr %x/$zoom]]"
X set currentY "Y: [format %%-3d [expr %y/$zoom]]"
X }
X global palette
X bind $c <3> "EditorCanvas:fillCell $this %x %y background"
X bind $c <B3-Motion> "EditorCanvas:fillCell $this %x %y background"
X return $c
X }
X method new {} {
X set c [getmember c]
X $c delete all
X drawGrid
X }
X method setBackground {color} {
X set c [getmember c]
X setmember background $color
X $c delete $color
X $c config -background $color
X }
X method setParameters {new_width new_height new_zoom} {
X set Width [getmember width]
X set Height [getmember height]
X global zoom
X set zoom [getmember zoom]
X if {$new_width == $Width && $new_height == $Height} {
X set c [getmember c]
X set s [expr 1.1*$new_zoom/$zoom/1.1]
X $c scale all 0 0 $s $s
X setmember zoom $new_zoom
X set zoom $new_zoom
X return
X }
X setmember width $new_width
X setmember height $new_height
X setmember zoom $new_zoom
X set zoom $new_zoom
X new
X }
X method setWidth {w} {
X setmember width $w
X }
X method setHeight {h} {
X setmember height $h
X }
X method getWidth {} {
X getmember width
X }
X method getHeight {} {
X getmember height
X }
X method getZoom {} {
X getmember zoom
X }
X method fillCell {x y {color {}}} {
X set Width [getmember width]
X set Height [getmember height]
X set zoom [getmember zoom]
X global currentColor palette
X if {$color == {}} {
X set color $currentColor
X } elseif {$color == "background"} {
X set color [ColorPalette:getColor $palette 0]
X }
X set x [expr {$x/$zoom}]
X set zx [expr {$x*$zoom}]
X set y [expr {$y/$zoom}]
X set zy [expr {$y*$zoom}]
X if {$x >= $Width || $y >= $Height} return
X set c [getmember c]
X $c delete [list at $x $y]
X if {$color != [getmember background]} {
X $c create rect [expr {$zx+1}] [expr {$zy+1}] \
X [expr {$zx+$zoom}] [expr {$zy+$zoom}] -fill $color \
X -outline $color \
X -tag [list cell $color [list at $x $y]]
X }
X update idletasks
X }
X method drawGrid {} {
X set c [getmember c]
X set Width [getmember width]
X set Height [getmember height]
X set zoom [getmember zoom]
X
X if ![getmember gridding] {
X $c create rect 0 0 [expr $Height*$zoom] [expr $Width*$zoom] \
X -outline white -tag border
X return
X }
X $c delete border
X global palette
X set zy [expr $Height*$zoom]
X for {set x 0} {$x <= $Width} {incr x} {
X set zx [expr $x*$zoom]
X $c create line $zx 0 $zx $zy -tag grid -fill white
X }
X set zx [expr $Width*$zoom]
X for {set y 0} {$y <= $Height} {incr y} {
X set zy [expr $y*$zoom]
X $c create line 0 $zy $zx $zy -tag grid -fill white
X }
X }
X method setGridding {on} {
X set gridding [getmember gridding]
X if {$on == $gridding} return
X setmember gridding $on
X if !$on {
X [getmember c] delete grid
X }
X drawGrid
X }
X method save {file} {
X set f [open $file w]
X set Width [getmember width]
X set Height [getmember height]
X set zoom [getmember zoom]
X set c [getmember c]
X puts $f "PW $Width"
X puts $f "PH $Height"
X foreach cell [$c find withtag cell] {
X set tags [$c gettags $cell]
X set ndx [lsearch $tags "at *"]
X if {$ndx == -1} {
X puts stdout "Hmm, there's a cell with no at tag: cell=$cell"
X continue
X }
X if {[scan [lindex $tags $ndx] "at %f %f" x y] != 2} {
X puts stdout "Can't scan cell=$cell, at=[lindex $tags $ndx]"
X continue
X }
X set color [lindex [$c item $cell -fill] 4]
X puts $f "PC $x $y $color [winfo rgb $c $color]"
X }
X close $f
X global savePPM
X if $savePPM {
X convertPixToPPM $file
X }
X }
X method load {file} {
X set c [getmember c]
X $c delete cell
X global zoom params
X set zoom [getmember zoom]
X uplevel #0 "source $file"
X Parameters:updateParameters $params
X drawGrid
X }
X}
X
Xpack append . \
X [EditorCanvas:create [set canvas [EditorCanvas]] .canvas] \
X "expand fill right frame nw"
X
X#
X# PW, PH, and PC are used to load pixmaps.
X#
Xproc definePixLoadProcs {} {
X proc PW {w} {
X global canvas
X EditorCanvas:setWidth $canvas $w
X }
X proc PH {h} {
X global canvas
X EditorCanvas:setHeight $canvas $h
X }
X proc PC {x y color r g b} {
X global canvas zoom
X EditorCanvas:fillCell $canvas [expr $x*$zoom] [expr $y*$zoom] $color
X }
X}
XdefinePixLoadProcs
X
X#
X# convertPixtoPPM converts our format to PPM format.
X#
Xproc convertPixToPPM {file} {
X proc PW {w} {
X global ppm_width
X set ppm_width $w
X }
X proc PH {h} {
X global ppm_height
X set ppm_height $h
X }
X proc PC {x y color r g b} {
X global ppm_pixels
X set ppm_pixels($x/$y) "[expr $r>>8] [expr $g>>8] [expr $b>>8]"
X }
X global ppm_width ppm_height ppm_pixels
X source $file
X set f [open $file w]
X puts $f "P3"
X puts $f "$ppm_width $ppm_height"
X puts $f "255"
X for {set y 0} {$y < $ppm_height} {incr y} {
X puts $f "# row $y"
X for {set x 0} {$x < $ppm_width} {incr x} {
X if [info exists ppm_pixels($x/$y)] {
X puts $f $ppm_pixels($x/$y)
X } else {
X puts $f "0 0 0"
X }
X }
X }
X close $f
X unset ppm_pixels
X definePixLoadProcs
X}
X
X
END_OF_FILE
if test 21485 -ne `wc -c <'pixmap.tcl'`; then
echo shar: \"'pixmap.tcl'\" unpacked with wrong size!
fi
# end of 'pixmap.tcl'
fi
echo shar: End of shell archive.
exit 0