Version 7 of Bitmap Editor

Updated 2010-07-24 19:23:42 by gold

For other editors of bitmaps, including those useful as .ico Windows icons, see this [L1 ] April 2004 thread, which covers an interesting mix of shareware, Tk-based freeware, ...


Keith Vetter 2002-01-16 : here's a simple utility that lets you create and edit tk bitmap files.

I've written simplified versions of this code at least twice before, so when I found this particular version on my hard drive I thought I'd polish up and put it on wiki so that I, and others, can find it again in the future.

It's not as fancy as Paul Obermeier's poBitmap [L2 ] tool but then again, it's less than 1/25 the size.

KPV 2003-03-06 : added some editing functions like shift, invert, clear and best of all, resize.


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

 ##+##########################################################################
 #
 # bitmap.tcl -- simple bitmap editor
 # by Keith Vetter
 #
 # Revisions:
 # KPV Jan 15, 2003 - initial revision
 # KPV Mar 06, 2003 - added functions like shift, clear, invert and resize
 #
 ##+##########################################################################
 #############################################################################

 package require Tk

 set S(cell) 10
 set S(prog) "Bitmap Editor"
 set S(fname) ""

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

    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 "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) ""}
    update
 }
 ##+##########################################################################
 #
 # 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 bind c($r,$c) <1> [list Click 1 cell $r $c]
            .c bind c($r,$c) <3> [list Click 2 cell $r $c]
        }
    }
    .c config -scrollregion [.c bbox all]
 }
 ##+##########################################################################
 #
 # Click -- handles left and right mouse click in a grid cell
 #
 proc Click {btn what row col} {
    global BM
    if {$btn == 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 cleare
        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)]
    .c bind o($row,$col) <1> [list Click 1 oval $row $col]
    .c bind o($row,$col) <3> [list Click 2 oval $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]
 }
 ##+##########################################################################
 #
 # 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 {} {
    global S

    set types { {{BMP Files} {.bmp}} {{All Files} * }}
    set fname [tk_getOpenFile -defaultextension ".bmp" -initialfile $S(fname) \
                   -filetypes $types]
    if {$fname == ""} return
    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
    ParseBMP $raw
    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 {. nwidth nheight} $n break
    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(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}
    if {$resize} {
        set NEW(name) "xx"
        set widgets {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
 ParseBMP $bitmap
 ShowBMP

http://farm5.static.flickr.com/4122/4824086923_6d4ee771ca.jpg

[ Category Application | Category File | Category Graphics ]