tklib 0.6-2 / usr / bin / bitmap-editor

#!/bin/sh
# The next line is executed by /bin/sh, but not tcl \
    exec wish $0 ${1+"$@"}

package require Tcl 8.4

# @@ Meta Begin
# Application bitmap-editor 1.0
# Meta platform     tcl
# Meta summary      Bitmap Editor
# Meta description  This application is an editor for bitmaps, read from and
# Meta description  written to files in XBM format (X Bitmap).
# Meta category     Editing bitmaps
# Meta subject      bitmap xbm editor
# Meta require      {Tcl 8.4}
# Meta require      Tk
# Meta author       Keith Vetter
# Meta license      BSD
# @@ Meta End

##+##########################################################################
#
# bitmap.tcl -- simple bitmap editor
# by Keith Vetter (http://wiki.tcl.tk/606)
#
# Revisions:
# KPV Jan 15, 2003 - initial revision
# KPV Mar 06, 2003 - added functions like shift, clear, invert and resize
# KPV Aug 20, 2010 - added mouse stroking, cursor, rename and undo


# Syntax: bitmap-editor ?xbm-file?

package require Tk

# Data Structures :: 3 global arrays.
#
# S - Application state and configuration
#
# * cell  - Size of a pixel cel drawn in the UI
# * prog  - Application name.
# * fname - xbm file currently edited, after loaded/saved

# BM - Bitmap currently being edited.
#
# * b,<row>,<col> - UI cell storage - pixel is set if exists and 1.
# * bits          - XBM Parse Result: hexadecimal bit string of pixels.
# * height        - XBM Parse Result: bitmap height
# * name          - XBM Parse Result: bitmap name
# * raw           - xbm data of the bitmap, suitable for use with option
#                   -data of a Tk bitmap image. Generated from the b,*,*
#                   keys. See UnparseBMP.
# * width         - XBM Parse Result: bitmap width
# * xhot          - XBM Parse Result: column of the hot point
# * yhot          - XBM Parse Result: row of the hot point

# UNDO - Undo information
#
#  * last - last action done
#  * all  - all previous actions

set S(cell) 10
set S(prog) "Bitmap Editor"
set S(fname) ""
set UNDO(last) {}
set UNDO(all) {}

# Table for conversion from hexadecimal nibbles to binary bit
# strings. Used to convert BM(bits) to b,*,* keys in ShowBits.
array set bits {
    0 0000 1 1000 2 0100 3 1100 4 0010 5 1010 6 0110 7 1110
    8 0001 9 1001 a 0101 b 1101 c 0011 d 1011 e 0111 f 1111
}

# Initial bitmap to show upon starting.

set bitmap {
    #define bullet_width  11
    #define bullet_height  9
    static char bullet_bits[] = {
        0x00,0x00, 0x00,0x00, 0x70,0x00, 0xf8,0x00, 0xf8,0x00,
        0xf8,0x00, 0x70,0x00, 0x00,0x00, 0x00,0x00
    }
}

##+##########################################################################
#
# DoDisplay -- sets up our display
#

proc DoDisplay {} {
    wm title . $::S(prog)
    canvas .c -width 500 -height 500 -bd 2 -relief ridge -highlightthickness 0
    .c xview moveto 0 ; .c yview moveto 0
    
    bind .c <2> [bind Text <2>]                 ;# Enable button 2 paning
    bind .c <B2-Motion> [bind Text <B2-Motion>]

    bind .c <1> [list Click down 1 %x %y]
    bind .c <B1-Motion> [list Click move 1 %x %y]
    bind .c <ButtonRelease-1> [list Click up 1 %x %y]
    bind .c <3> [list Click down 0 %x %y]
    bind .c <B3-Motion> [list Click move 0 %x %y]
    bind .c <ButtonRelease-3> [list Click up 0 %x %y]
    bind all <Control-z> Undo
    
    frame .fctrl -bd 2 -relief ridge
    label .info -text "Left button to set    Right button to clear" -anchor c \
        -bd 2 -relief ridge
    
    grid .c .fctrl -sticky news -row 0
    grid .info   ^ -sticky ew
    grid rowconfigure . 0 -weight 1
    grid columnconfigure . 0 -weight 1
    DoControl
    DoMenus
    update
}

##+##########################################################################
#
# DoMenus -- sets up our menus
#

proc DoMenus {} {
    . configure -menu [menu .m -tearoff 0]
    .m add cascade -menu [menu .m.file  -tearoff 0] -label "File"  -underline 0
    .m add cascade -menu [menu .m.image -tearoff 0] -label "Image" -underline 0
    .m add cascade -menu [menu .m.help  -tearoff 0] -label "Help"  -underline 0
    
    .m.file add command -label "New"  -under 0 -command NewBMP
    .m.file add command -label "Open" -under 0 -command OpenBMP
    .m.file add command -label "Save" -under 0 -command SaveBMP
    .m.file add separator
    .m.file add command -label "Copy" -under 0 -command CopyBMP
    .m.file add separator
    .m.file add command -label Exit -under 1 -command exit
    
    .m.image add command -label "Clear"       -under 0 -command {BitFunc clear}
    .m.image add command -label "Invert"      -under 0 -command {BitFunc invert}
    .m.image add command -label "Shift left"  -under 6 -command {BitFunc sleft}
    .m.image add command -label "Shift right" -under 6 -command {BitFunc sright}
    .m.image add command -label "Shift up"    -under 6 -command {BitFunc sup}
    .m.image add command -label "Shift down"  -under 6 -command {BitFunc sdown}
    .m.image add separator
    .m.image add command -label "Undo"        -under 0 -command Undo
    .m.image add command -label "Resize"      -under 0 -command ResizeBMP
    
    .m.help add command -label About -under 0 -command About
}

##+##########################################################################
#
# DoControl -- draws the control panel
#

proc DoControl {} {
    grid rowconfigure .fctrl   0 -minsize 10
    grid rowconfigure .fctrl 100 -weight 1
    
    frame .fctop
    grid .fctop - - -in .fctrl -row 1
    set row 0
    foreach a {Name Width Height} {
        set a2 [string map {" " ""} [string tolower $a]]
        label .l$a2 -text "$a:"
        entry .e$a2 -textvariable BM($a2) -width 8 -state disabled
        grid .l$a2 .e$a2 -in .fctop -row [incr row]
    }
    
    image create bitmap ::img::current
    frame .fimg -bd 2 -relief sunken -padx 10 -pady 10
    label .limg -image ::img::current -bg white
    grid rowconfigure .fctrl 40 -minsize 50
    grid .fimg - - -in .fctrl -row 41
    pack .limg -in .fimg -expand 1
}

##+##########################################################################
#
# ShowBMP -- computes grid size then draws in the current bitmap
#

proc ShowBMP {} {
    global S BM
    
    if {! [info exists BM(raw)]} return
    
    set w [winfo width .c] ; set h [winfo height .c]
    set cw [expr {int((($w - 20) / $BM(width)))}]
    set ch [expr {int((($h - 20) / $BM(height)))}]
    set S(cell) [expr {$cw < $ch ? $cw : $ch}]
    if {$S(cell) > 40} { set S(cell) 40}
    if {$S(cell) <  5} { set S(cell) 5}
    
    DrawGrid
    ShowBits
    unset BM(bits)
    ::img::current config -data $BM(raw)        ;# Update current bitmap display
}

##+##########################################################################
#
# ClearBMP -- clears everything for a new bitmap
#

proc ClearBMP {} {
    global BM
    .c delete all
    ::img::current config -data {}
    array unset BM
    foreach arr [array names BM] { set BM($arr) ""}
    set UNDO(last) {}
    set UNDO(all) {}
}

##+##########################################################################
#
# DrawGrid -- draws the grid of rectangles--each one with proper bindings
#

proc DrawGrid {} {
    global BM
    
    .c delete all
    foreach {l t} [CellXY 0 0] break
    foreach {b r} [CellXY $BM(height) $BM(width)] break
    .c create rect $l $t $b $r -tag outline -width 2
    
    set bg [.c cget -bg]
    for {set r 0} {$r < $BM(height)} {incr r} {
        for {set c 0} {$c < $BM(width)} {incr c} {
            .c create rect [CellXY $r $c] -tag [list grid c($r,$c)] -fill $bg
        }
    }
    .c config -scrollregion [.c bbox all]
}

##+##########################################################################
#
# Click -- handles left and right mouse click in a grid cell
#

proc Click {action onoff x y} {
    global BM UNDO

    if {$action eq "up"} {
	.c config -cursor [lindex [.c config -cursor] 3]
	return
    }
    if {$action eq "down"} {
	.c config -cursor pencil
        if {$UNDO(last) ne ""} {
            lappend UNDO(all) $UNDO(last)
        }
        set UNDO(last) [list $onoff ":"]
    }
    foreach {row col} [XY2Cell [.c canvasx $x] [.c canvasy $y]] break
    if {$row < 0 || $row >= $BM(height) || $col < 0 || $col >= $BM(width)} return
    
    if {$onoff == 1} {                           ;# Set the pixel
        if {$BM(b,$row,$col)} return             ;# Already set
        set BM(b,$row,$col) 1
        ShowBitCell $row $col
    } else {                                     ;# Clear the pixel
        if {! $BM(b,$row,$col)} return           ;# Already cleared
        set BM(b,$row,$col) 0
        .c delete o($row,$col)
    }
    lappend UNDO(last) $row $col
    set BM(raw) [UnparseBMP]
    ::img::current config -data $BM(raw)
}

##+##########################################################################
# 
# Undo -- Implements undo
# 

proc Undo {} {
    global UNDO BM

    set what $UNDO(last)
    set UNDO(last) ""
    if {$what eq ""} {
	set what [lindex $UNDO(all) end]
	set UNDO(all) [lrange $UNDO(all) 0 end-1]
    }
    if {$what eq ""} return
    set onoff [lindex $what 0]
    set what [lrange $what 2 end]
    set onoff [expr {! $onoff}]
    
    foreach {row col} $what {
	if {$onoff == 1} {                           ;# Set the pixel
	    if {$BM(b,$row,$col)} continue           ;# Already set
	    set BM(b,$row,$col) 1
	    ShowBitCell $row $col
	} else {                                     ;# Clear the pixel
	    if {! $BM(b,$row,$col)} continue         ;# Already cleared
	    set BM(b,$row,$col) 0
	    .c delete o($row,$col)
	}
    }
    set BM(raw) [UnparseBMP]
    ::img::current config -data $BM(raw)
}

##+##########################################################################
#
# ShowBits -- draws dots in all "on" cells in the current bitmap, 
# only valid after ParseBMP fills in the BM(bits) variable.
#

proc ShowBits {} {
    global BM bits
    
    set row 0
    set col 0
    foreach byte $BM(bits) {
        foreach {n1 n2} [split $byte ""] break  ;# Get each nibble
        foreach bit [split "$bits($n2)$bits($n1)" ""] { ;# Note the endian
            set BM(b,$row,$col) $bit
            if {$bit} {
                ShowBitCell $row $col
            }
            if {[incr col] >= $BM(width)} {     ;# Do we past the last column?
                incr row
                set col 0
                break
            }
        }
    }
}

##+##########################################################################
#
# ShowBitCell -- draws the "on" bit in a specified cell
#

proc ShowBitCell {row col} {
    .c create oval [CellXY $row $col] -fill black -tag [list bit o($row,$col)]
}

##+##########################################################################
#
# CellXY -- returns the coordinates of a grid cell
#

proc CellXY {r c} {
    global S
    set x1 [expr {10 + $c * $S(cell)}]
    set y1 [expr {10 + $r * $S(cell)}]
    set x2 [expr {$x1 + $S(cell)}]
    set y2 [expr {$y1 + $S(cell)}]
    
    return [list $x1 $y1 $x2 $y2]
}

##+##########################################################################
# 
# XY2Cell -- returns cell based on canvas position
# 

proc XY2Cell {x y} {
    set c [expr {(int($x) - 10) / $::S(cell)}]
    set r [expr {(int($y) - 10) / $::S(cell)}]
    return [list $r $c]
}


##+##########################################################################
#
# ParseBMP -- reads the raw bitmap data into our BM data structure
# NB. face.bmp in demo directory had defines for x_hot and y_hot
#

proc ParseBMP {raw} {
    global S BM
    
    ClearBMP
    set BM(raw) $raw
    
    while {1} {
        if {! [regexp {\#define\s+(.*)_width}        $raw => BM(name)]} break
        if {! [regexp {\#define\s+.*_width\s*(\d*)}  $raw => BM(width)]} break
        if {! [regexp {\#define\s+.*_height\s*(\d*)} $raw => BM(height)]} break
        regexp {\#define\s+.*_x_hot\s*(\d*)}  $raw => BM(xhot)
        regexp {\#define\s+.*_y_hot\s*(\d*)}  $raw => BM(yhot)
	
        if {! [regexp {(0x.*)\}}                     $raw => BM(bits)]} break
        if {! [regsub -all {0x|,} $BM(bits) { }              BM(bits)]} break
        if {! [regsub -all {\s+}  $BM(bits) { }              BM(bits)]} break
        set BM(bits) [string tolower $BM(bits)]
        return                                  ;# Everything ok, get out
    }
    ERROR "$S(fname) is not a proper bmp file"
    ClearBMP
}

##+##########################################################################
#
# OpenBMP -- opens and reads a BMP file
#

proc OpenBMP {} {
    set types { {{BMP Files} {.bmp}} {{All Files} * }}
    set fname [tk_getOpenFile -defaultextension ".bmp" -initialfile $S(fname) \
                   -filetypes $types]
    if {$fname == ""} return
    DisplayBMPFile $fname
}

proc DisplayBMPFile {file} {
    global S

    if {[catch {set FIN [open $fname r]} emsg]} {
        ERROR "Cannot open $fname\n$emsg"
        return
    }
    set raw [read $FIN]
    close $FIN
    set S(fname) $fname
    DisplayBMP $raw
}

proc DisplayBMP {data} {
    ParseBMP $data
    ShowBMP
}


##+##########################################################################
#
# SaveBMP -- saves the current bitmap to a file
#

proc SaveBMP {} {
    global S BM
    
    if {! [info exists BM(raw)]} return
    set types {{{BMP Files} {.bmp}} {{All Files} *}}
    set fname [tk_getSaveFile -defaultextension ".bmp" -initialfile $S(fname) \
                   -filetypes $types]
    if {$fname == ""} return
    if {[catch {set FOUT [open $fname w]} emsg]} {
        ERROR "Cannot open $fname\n$emsg"
        return
    }
    puts $FOUT $BM(raw)
    close $FOUT
    set S(fname) $fname
}

##+##########################################################################
#
# UnparseBMP -- converts our internal BM into a proper bitmap data string
#

proc UnparseBMP {} {
    global BM
    set name $BM(name)
    
    set bmp "\#define ${name}_width $BM(width)\n"
    append bmp "\#define ${name}_height $BM(height)\n"
    if {[info exists BM(xhot)]} {
        append bmp "\#define ${name}_x_hot $BM(xhot)\n"
        append bmp "\#define ${name}_y_hot $BM(yhot)\n"
    }
    append bmp "static char ${name}_bits[] = \{\n"
    
    set bytes {}
    for {set r 0} {$r < $BM(height)} {incr r} {
        for {set c 0} {$c < $BM(width)} {incr c 8} {
            set byte 0
            for {set cc [expr {$c + 7}]} {$cc >= $c} {incr cc -1} {
                set byte [expr {2 * $byte}]
                if {[info exists BM(b,$r,$cc)] && $BM(b,$r,$cc)} {
                    incr byte
                }
            }
            lappend bytes [format 0x%02x $byte]
        }
    }
    append bmp "    " [join $bytes ", "]
    append bmp "\n\}"
    
    return $bmp
}

##+##########################################################################
#
# CopyBMP -- copies current bitmap to the clipboard
#

proc CopyBMP {} {
    global BM S
    
    if {! [info exists BM(raw)]} return
    clipboard clear
    clipboard append $BM(raw)
    tk_messageBox -icon info -title "$S(prog) Info" \
        -message "Bitmap copied to the clipboard"
    
}

##+##########################################################################
#
# NewBMP -- creates a blank, new bitmap with sizes specified by the user
#

proc NewBMP {} {
    global BM
    
    set n [NewDlg]
    if {$n == {}} return
    foreach {name width height} $n break
    
    ClearBMP
    set BM(name)   $name
    set BM(width)  $width
    set BM(height) $height
    
    for {set r 0} {$r < $BM(height)} {incr r} {
        for {set c 0} {$c < $BM(width)} {incr c} {
            set BM(b,$r,$c) 0
        }
    }
    ParseBMP [UnparseBMP]
    ShowBMP
}

proc ResizeBMP {} {
    global BMP
    set n [NewDlg 1]
    if {$n == {}} return
    
    foreach {nName nwidth nheight} $n break
    if {$nName ne ""} { set ::BM(name) $nName }
    WidenBMP $nwidth
    HeightenBMP $nheight
    
    ParseBMP [UnparseBMP]
    ShowBMP
}

proc WidenBMP {nwidth} {
    global BM
    if {$BM(width) == $nwidth} return
    if {$nwidth > $BM(width)} {
        foreach {low high delete} [list $BM(width) $nwidth 0] break
    } else {
        foreach {low high delete} [list $nwidth $BM(width) 1] break
    }
    for {set row 0} {$row < $BM(height)} {incr row} {
        for {set col $low} {$col < $high} {incr col} {
            set BM(b,$row,$col) 0
            if {$delete} {
                unset BM(b,$row,$col)
            }
        }
    }
    set BM(width) $nwidth
}

proc HeightenBMP {nheight} {
    global BM
    if {$BM(height) == $nheight} return
    if {$nheight > $BM(height)} {
        foreach {low high delete} [list $BM(height) $nheight 0] break
    } else {
        foreach {low high delete} [list $nheight $BM(height) 1] break
    }
    for {set col 0} {$col < $BM(width)} {incr col} {
        for {set row $low} {$row < $high} {incr row} {
            set BM(b,$row,$col) 0
            if {$delete} {
                unset BM(b,$row,$col)
            }
        }
    }
    set BM(height) $nheight
}

##+##########################################################################
#
# NewDlg -- asks the user for bitmap parameters
#

proc NewDlg {{resize 0}} {
    global S NEW BM
    
    destroy  .new
    toplevel .new -padx 10 -pady 5
    wm title .new "New Bitmap"
    if {$resize} {wm title .new "Resize Bitmap"}
    wm geom .new "+[expr {[winfo x .] + 150}]+[expr {[winfo y .] + 100}]"
    
    set NEW(ok) 0
    set NEW(name) $BM(name)
    set NEW(width) $BM(width)
    set NEW(height) $BM(height)
    
    frame .new.top -bd 2 -relief raised -padx 10 -pady 10
    grid columnconfigure .new.top 1 -weight 1
    set widgets {name width height}
    foreach a $widgets {
        set a1 [string totitle $a]
        label .new.l$a -text "$a1:"
        entry .new.e$a -textvariable NEW($a)
        grid  .new.l$a .new.e$a -in .new.top -sticky ew
    }
    
    frame  .new.buttons
    button .new.ok     -text Ok     -width 10 -command ValidForm
    button .new.cancel -text Cancel -width 10 -command {destroy .new}
    
    pack .new.buttons -side bottom -pady 10
    pack .new.top -side top -fill x
    pack .new.cancel .new.ok -in .new.buttons -side right -padx 10 -expand 1
    
    raise .new
    set w ".new.e[lindex $widgets 0]"
    focus $w
    $w icursor end
    $w selection range 0 end
    tkwait window .new
    if {$NEW(ok)} {
        return [list $NEW(name) $NEW(width) $NEW(height)]
    }
    return {}
}

##+##########################################################################
#
# ValidForm -- validates the NewDlg and then destroys it if it is ok
#

proc ValidForm {} {
    global NEW
    
    foreach n {name width height} {
        set NEW($n) [string trim $NEW($n)]
        if {$NEW($n) == ""} return
    }
    if {![string is integer $NEW(width)]} return
    if {![string is integer $NEW(height)]} return
    
    set NEW(ok) 1
    destroy .new
}

proc ERROR {msg} {
    tk_messageBox -icon error -title "$::S(prog) Error" -message $msg
}

proc About {} {
    set msg "$::S(prog)\n\nby Keith Vetter\nJanuary 2003"
    tk_messageBox -title "About $::S(prog)" -message $msg -icon info
}

proc BitFunc {what} {
    global BM
    
    if {$what == "clear"} {
        foreach arr [array names BM b,*] {
            set BM($arr) 0
        }
    } elseif {$what == "invert"} {
        foreach arr [array names BM b,*] {
            set BM($arr) [expr {! $BM($arr)}]
        }
    } elseif {$what == "sleft"} {               ;# Shift left
        for {set col 0} {$col < $BM(width)} {incr col} {
            set col2 [expr {$col + 1}]
            for {set row 0} {$row < $BM(height)} {incr row} {
                if {[info exists BM(b,$row,$col2)]} {
                    set BM(b,$row,$col) $BM(b,$row,$col2)
                } else {
                    set BM(b,$row,$col) 0
                }
            }
        }
    } elseif {$what == "sright"} {              ;# Shift right
        for {set col [expr {$BM(width) - 1}]} {$col >= 0} {incr col -1} {
            set col2 [expr {$col - 1}]
            for {set row 0} {$row < $BM(height)} {incr row} {
                if {[info exists BM(b,$row,$col2)]} {
                    set BM(b,$row,$col) $BM(b,$row,$col2)
                } else {
                    set BM(b,$row,$col) 0
                }
            }
        }
    } elseif {$what == "sup"} {                 ;# Shift up
        for {set row 0} {$row < $BM(height)} {incr row} {
            set row2 [expr {$row + 1}]
            for {set col 0} {$col < $BM(width)} {incr col} {
                if {[info exists BM(b,$row2,$col)]} {
                    set BM(b,$row,$col) $BM(b,$row2,$col)
                } else {
                    set BM(b,$row,$col) 0
                }
            }
        }
    } elseif {$what == "sdown"} {               ;# Shift down
        for {set row [expr {$BM(height) - 1}]} {$row >= 0} {incr row -1} {
            set row2 [expr {$row - 1}]
            for {set col 0} {$col < $BM(width)} {incr col} {
                if {[info exists BM(b,$row2,$col)]} {
                    set BM(b,$row,$col) $BM(b,$row2,$col)
                } else {
                    set BM(b,$row,$col) 0
                }
            }
        }
    }
    set BM(raw) [UnparseBMP]
    RedrawBits
    ::img::current config -data $BM(raw)
    
}

proc RedrawBits {} {
    global BM
    
    .c delete bit
    for {set row 0} {$row < $BM(height)} {incr row} {
        for {set col 0} {$col < $BM(width)} {incr col} {
            if {$BM(b,$row,$col)} {ShowBitCell $row $col}
        }
    }
}

################################################################
################################################################
################################################################

DoDisplay

if {[llength $argv] > 1} {
    DisplayBMP $bitmap
    ERROR "Too many files specified, expected only one"
} elseif {[llength $argv] == 1} {
    DisplayBMPFile [lindex $argv 0]
} else {
    DisplayBMP $bitmap
}