00001 # TKE - Advanced Programmer's Editor
00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com)
00003 #
00004 # This program is free software; you can redistribute it and/or modify
00005 # it under the terms of the GNU General Public License as published by
00006 # the Free Software Foundation; either version 2 of the License, or
00007 # (at your option) any later version.
00008 #
00009 # This program is distributed in the hope that it will be useful,
00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of
00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
00012 # GNU General Public License for more details.
00013 #
00014 # You should have received a copy of the GNU General Public License along
00015 # with this program; if not, write to the Free Software Foundation, Inc.,
00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
00017
00018 ######################################################################
00019 # Name: bitmap.tcl
00020 # Author: Trevor Williams (trevorw@sgi.com)
00021 # Date: 05/21/2013
00022 # Brief: Widget tool to create a two-color bitmap.
00023 ######################################################################
00024
00025 # msgcat::note Strings are found in the theme editor for a bitmapped image
00026
00027 if {0} {
00028 set tke_dir [file join ~ projects tke-code]
00029 source [file join $::tke_dir lib utils.tcl]
00030 }
00031
00032 namespace eval bitmap {
00033
00034 array set data {}
00035
00036 set data(bg) [utils::get_default_background]
00037 set data(fg) [utils::get_default_foreground]
00038
00039 if {[catch { ttk::spinbox .__tmp }]} {
00040 set data(sb) "spinbox"
00041 set data(sb_opts) "-relief flat -buttondownrelief flat -buttonuprelief flat -background $data(bg) -foreground $data(fg)"
00042 set data(sb_normal) "configure -state normal"
00043 set data(sb_disabled) "configure -state disabled"
00044 set data(sb_readonly) "configure -state readonly"
00045 } else {
00046 set data(sb) "ttk::spinbox"
00047 set data(sb_opts) "-justify center"
00048 set data(sb_normal) "state !disabled"
00049 set data(sb_disabled) "state disabled"
00050 set data(sb_readonly) "state readonly"
00051 destroy .__tmp
00052 }
00053
00054 ######################################################################
00055 # Creates a bitmap widget and returns the widget name.
00056 proc create {w type args} {
00057
00058 variable data
00059
00060 array set opts {
00061 -color1 blue
00062 -color2 green
00063 -size 10
00064 -width 32
00065 -height 32
00066 -swatches {}
00067 }
00068
00069 array set opts $args
00070
00071 # Initialize variables
00072 set data($w,type) $type
00073 set data($w,-size) $opts(-size)
00074 set data($w,-width) $opts(-width)
00075 set data($w,-height) $opts(-height)
00076 set data($w,-swatches) $opts(-swatches)
00077
00078 if {$type eq "mono"} {
00079 set data($w,colors) [list $data(bg) $opts(-color1)]
00080 } else {
00081 set data($w,colors) [list $data(bg) $opts(-color1) $opts(-color2)]
00082 }
00083
00084 ttk::frame $w
00085
00086 # Create the bitmap canvas
00087 set width [expr ($data($w,-size) * 32) + 1]
00088 set height [expr ($data($w,-size) * 32) + 1]
00089 set data($w,grid) [canvas $w.c -background $data(bg) -width $width -height $height]
00090
00091 bind $data($w,grid) <B1-Motion> [list bitmap::change_square_motion $w %x %y]
00092 bind $data($w,grid) <B$::right_click-Motion> [list bitmap::change_square_motion $w %x %y]
00093
00094 # Create the right frame
00095 ttk::frame $w.rf
00096 set data($w,plabel) [ttk::label $w.rf.p -relief solid -padding 10 -anchor center]
00097 ttk::labelframe $w.rf.mf -text [msgcat::mc "Transform Tools"]
00098 grid columnconfigure $w.rf.mf 0 -weight 1
00099 grid columnconfigure $w.rf.mf 4 -weight 1
00100 grid [ttk::button $w.rf.mf.up -style BButton -text "\u25b2" -command [list bitmap::move $w up]] -row 0 -column 2 -sticky news -padx 2 -pady 2
00101 grid [ttk::button $w.rf.mf.left -style BButton -text "\u25c0" -command [list bitmap::move $w left]] -row 1 -column 1 -sticky news -padx 2 -pady 2
00102 grid [ttk::button $w.rf.mf.center -style BButton -text "\u25fc" -command [list bitmap::move $w center]] -row 1 -column 2 -sticky news -padx 2 -pady 2
00103 grid [ttk::button $w.rf.mf.right -style BButton -text "\u25b6" -command [list bitmap::move $w right]] -row 1 -column 3 -sticky news -padx 2 -pady 2
00104 grid [ttk::button $w.rf.mf.down -style BButton -text "\u25bc" -command [list bitmap::move $w down]] -row 2 -column 2 -sticky news -padx 2 -pady 2
00105 grid [ttk::button $w.rf.mf.flipv -style BButton -text "\u2b0c" -command [list bitmap::flip $w vertical]] -row 3 -column 1 -sticky news -padx 2 -pady 2
00106 grid [ttk::button $w.rf.mf.rot -style BButton -text "\u21ba" -command [list bitmap::rotate $w]] -row 3 -column 2 -sticky news -padx 2 -pady 2
00107 grid [ttk::button $w.rf.mf.fliph -style BButton -text "\u2b0d" -command [list bitmap::flip $w horizontal]] -row 3 -column 3 -sticky news -padx 2 -pady 2
00108 set data($w,c1_lbl) [ttk::label $w.rf.l1 -text "Color-1:" -background [lindex $data($w,colors) 1]]
00109 set data($w,color1) [ttk::menubutton $w.rf.sb1 -text [lindex $data($w,colors) 1] -menu [set data($w,color1_mnu) [menu $w.rf.mnu1 -tearoff 0]]]
00110 if {$type eq "mono"} {
00111 $data($w,c1_lbl) configure -text "Color:"
00112 } else {
00113 set data($w,c2_lbl) [ttk::label $w.rf.l2 -text "Color-2:" -background [lindex $data($w,colors) 2]]
00114 set data($w,color2) [ttk::menubutton $w.rf.sb2 -text [lindex $data($w,colors) 2] -menu [set data($w,color2_mnu) [menu $w.rf.mnu2 -tearoff 0]]]
00115 }
00116 ttk::label $w.rf.l3 -text "Width:"
00117 set data($w,width) [$data(sb) $w.rf.width {*}$data(sb_opts) -width 2 -values [list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16] -command [list bitmap::set_grid_size $w width]]
00118 ttk::label $w.rf.l4 -text "Height:"
00119 set data($w,height) [$data(sb) $w.rf.height {*}$data(sb_opts) -width 2 -values [list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16] -command [list bitmap::set_grid_size $w height]]
00120
00121 $data($w,width) set $data($w,-width)
00122 $data($w,height) set $data($w,-height)
00123 $data($w,width) {*}$data(sb_readonly)
00124 $data($w,height) {*}$data(sb_readonly)
00125
00126 tooltip::tooltip $w.rf.mf.up [msgcat::mc "Move image up"]
00127 tooltip::tooltip $w.rf.mf.left [msgcat::mc "Move image left"]
00128 tooltip::tooltip $w.rf.mf.center [msgcat::mc "Center image"]
00129 tooltip::tooltip $w.rf.mf.right [msgcat::mc "Move image right"]
00130 tooltip::tooltip $w.rf.mf.down [msgcat::mc "Move image down"]
00131 tooltip::tooltip $w.rf.mf.flipv [msgcat::mc "Flip image vertically"]
00132 tooltip::tooltip $w.rf.mf.rot [msgcat::mc "Rotate image 90 degrees"]
00133 tooltip::tooltip $w.rf.mf.fliph [msgcat::mc "Flip image horizontally"]
00134
00135 grid rowconfigure $w.rf 1 -weight 1
00136 grid rowconfigure $w.rf 3 -weight 1
00137 grid columnconfigure $w.rf 1 -weight 1
00138 grid $data($w,plabel) -row 0 -column 0 -padx 2 -pady 2 -columnspan 2
00139 grid $w.rf.mf -row 2 -column 0 -padx 2 -pady 2 -columnspan 2
00140 grid $data($w,c1_lbl) -row 4 -column 0 -sticky news -padx 2 -pady 2
00141 grid $data($w,color1) -row 4 -column 1 -sticky news -padx 2 -pady 2
00142 if {$type ne "mono"} {
00143 grid $data($w,c2_lbl) -row 5 -column 0 -sticky news -padx 2 -pady 2
00144 grid $data($w,color2) -row 5 -column 1 -sticky news -padx 2 -pady 2
00145 }
00146 grid $w.rf.l3 -row 6 -column 0 -sticky news -padx 2 -pady 2
00147 grid $data($w,width) -row 6 -column 1 -sticky news -padx 2 -pady 2
00148 grid $w.rf.l4 -row 7 -column 0 -sticky news -padx 2 -pady 2
00149 grid $data($w,height) -row 7 -column 1 -sticky news -padx 2 -pady 2
00150
00151 pack $w.c -side left -padx 2 -pady 2
00152 pack $w.rf -side left -padx 2 -pady 2 -fill y
00153
00154 # Draw the bitmap
00155 draw_grid $w $data($w,-width) $data($w,-height)
00156
00157 # Update the menus
00158 update_menus $w
00159
00160 # Create the preview image
00161 array set info [get_info $w]
00162 if {$type eq "mono"} {
00163 set data($w,preview) [image create bitmap -data $info(dat) -maskdata $info(msk) -foreground $info(fg)]
00164 } else {
00165 set data($w,preview) [image create bitmap -data $info(dat) -maskdata $info(msk) -foreground $info(fg) -background $info(bg)]
00166 }
00167 $data($w,plabel) configure -image $data($w,preview)
00168
00169 rename ::$w $w
00170 interp alias {} ::$w {} bitmap::widget_cmd $w
00171
00172 return $w
00173
00174 }
00175
00176 ######################################################################
00177 # Runs the specified widget command.
00178 proc widget_cmd {w args} {
00179
00180 set args [lassign $args cmd]
00181
00182 switch -exact $cmd {
00183 cget { return [cget $w {*}$args] }
00184 configure { return [configure $w {*}$args] }
00185 default { return -code error "Unknown bitmap command ($cmd)" }
00186 }
00187
00188 }
00189
00190 ######################################################################
00191 # Returns the specified bitmap option value.
00192 proc cget {w args} {
00193
00194 variable data
00195
00196 if {[llength $args] != 1} {
00197 return -code error "Illegal number of arguments to bitmap::cget"
00198 }
00199
00200 if {![info exists data($w,[lindex $args 0])]} {
00201 return -code error "Unknown bitmap option [lindex $args 0]"
00202 }
00203
00204 return $data($w,[lindex $args 0])
00205
00206 }
00207
00208 ######################################################################
00209 # Sets options in the bitmap widget.
00210 proc configure {w args} {
00211
00212 variable data
00213
00214 if {[llength $args] % 2} {
00215 return -code error "Illegal number of arguments to bitmap::configure"
00216 }
00217
00218 array set opts {
00219 -background {}
00220 -swatches {}
00221 }
00222 array set opts $args
00223
00224 # Store the options
00225 set data($w,-swatches) $opts(-swatches)
00226
00227 # If a background color was specified, change the color in the widget
00228 if {$opts(-background) ne ""} {
00229 lset data($w,colors) 0 $opts(-background)
00230 $data($w,grid) configure -background $opts(-background)
00231 $data($w,plabel) configure -background $opts(-background)
00232 }
00233
00234 # Update the UI
00235 update_menus $w
00236
00237 }
00238
00239 ######################################################################
00240 # Draws the bitmap grid.
00241 proc draw_grid {w width height {fg ""}} {
00242
00243 variable data
00244
00245 # Calculate the background and foreground colors, if necessary
00246 set bg [lindex $data($w,colors) 0]
00247 set fg [expr {($fg eq "") ? $data(fg) : $fg}]
00248
00249 # Clear the grid
00250 $data($w,grid) delete all
00251
00252 # Calculate the x and y adjustment
00253 set x_adjust [expr ((32 - $width) * ($data($w,-size) / 2)) + 1]
00254 set y_adjust [expr ((32 - $height) * ($data($w,-size) / 2)) + 1]
00255
00256 for {set row 0} {$row < $height} {incr row} {
00257
00258 for {set col 0} {$col < $width} {incr col} {
00259
00260 # Calculate the square positions
00261 set x1 [expr ($col * $data($w,-size)) + $x_adjust]
00262 set y1 [expr ($row * $data($w,-size)) + $y_adjust]
00263 set x2 [expr (($col + 1) * $data($w,-size)) + $x_adjust]
00264 set y2 [expr (($row + 1) * $data($w,-size)) + $y_adjust]
00265
00266 # Create the square
00267 set data($w,$row,$col) [$data($w,grid) create rectangle $x1 $y1 $x2 $y2 -fill $bg -outline $fg -width 1 -tags s0]
00268
00269 # Create the square bindings
00270 $data($w,grid) bind $data($w,$row,$col) <ButtonPress-1> [list bitmap::change_square $w $row $col 1]
00271 $data($w,grid) bind $data($w,$row,$col) <ButtonPress-$::right_click> [list bitmap::change_square $w $row $col -1]
00272
00273 }
00274
00275 }
00276
00277 }
00278
00279 ######################################################################
00280 # Set the size of the grid.
00281 proc set_grid_size {w type} {
00282
00283 variable data
00284
00285 # Get the spinbox value
00286 set data($w,-$type) [$data($w,$type) get]
00287
00288 # Update the grid
00289 set_from_info $w [set info [get_info $w]] 0
00290
00291 # Generate the event
00292 event generate $w <<BitmapChanged>> -data $info
00293
00294 }
00295
00296 ######################################################################
00297 # Changes the fill color of the selected square to the color indicated
00298 # by the current color
00299 proc change_square {w row col dir} {
00300
00301 variable data
00302
00303 # Get the current color
00304 set curr_tag [string index [$data($w,grid) itemcget $data($w,$row,$col) -tags] 1]
00305
00306 # If this is the initial press, save the replace color
00307 set data($w,replace) $curr_tag
00308 set data($w,replace_with) [expr ($curr_tag + $dir) % [llength $data($w,colors)]]
00309
00310 # Set the square fill color
00311 $data($w,grid) itemconfigure $data($w,$row,$col) -fill [lindex $data($w,colors) $data($w,replace_with)] -tags s$data($w,replace_with)
00312
00313 # Update the preview
00314 array set info [get_info $w]
00315 $data($w,preview) configure -data $info(dat) -maskdata $info(msk)
00316
00317 # Generate the event
00318 event generate $w <<BitmapChanged>> -data [array get info]
00319
00320 }
00321
00322 ######################################################################
00323 # Specifies that the current change is done.
00324 proc change_square_motion {w x y} {
00325
00326 variable data
00327
00328 set id [$data($w,grid) find closest $x $y]
00329
00330 # Get the current color
00331 set tag [string index [$data($w,grid) itemcget $id -tags] 1]
00332
00333 if {$data($w,replace) eq $tag} {
00334
00335 # Configure the square color
00336 $data($w,grid) itemconfigure $id -fill [lindex $data($w,colors) $data($w,replace_with)] -tags s$data($w,replace_with)
00337
00338 # Update the preview
00339 array set info [get_info $w]
00340 $data($w,preview) configure -data $info(dat) -maskdata $info(msk)
00341
00342 # Generate the event
00343 event generate $w <<BitmapChanged>> -data [array get info]
00344
00345 }
00346
00347 }
00348
00349 ######################################################################
00350 # Returns the bitmap information in the form of an array.
00351 proc get_info {w} {
00352
00353 variable data
00354
00355 set dat "#define img_width $data($w,-width)\n#define img_height $data($w,-height)\nstatic char img_bits\[\] = {\n"
00356 set msk "#define img_width $data($w,-width)\n#define img_height $data($w,-height)\nstatic char img_bits\[\] = {\n"
00357
00358 lassign $data($w,colors) dummy color1 color2
00359
00360 for {set row 0} {$row < $data($w,-height)} {incr row} {
00361 set dat_val 0
00362 set msk_val 0
00363 for {set col 0} {$col < $data($w,-width)} {incr col} {
00364 set color [$data($w,grid) itemcget $data($w,$row,$col) -fill]
00365 if {$color eq $color1} {
00366 set dat_val [expr $dat_val | (0x1 << $col)]
00367 set msk_val [expr $msk_val | (0x1 << $col)]
00368 } elseif {$color eq $color2} {
00369 set msk_val [expr $msk_val | (0x1 << $col)]
00370 }
00371 }
00372 for {set i 0} {$i < [expr $data($w,-width) / 8]} {incr i } {
00373 append dat [format {0x%02x, } [expr ($dat_val >> ($i * 8)) & 0xff]]
00374 append msk [format {0x%02x, } [expr ($msk_val >> ($i * 8)) & 0xff]]
00375 }
00376 if {[expr $data($w,-width) % 8]} {
00377 set byte [expr $data($w,-width) / 8]
00378 append dat [format {0x%02x, } [expr ($dat_val >> ($byte * 8)) & 0xff]]
00379 append msk [format {0x%02x, } [expr ($msk_val >> ($byte * 8)) & 0xff]]
00380 }
00381 }
00382
00383 set dat "[string range $dat 0 end-2]};"
00384 set msk "[string range $msk 0 end-2]};"
00385
00386 if {$data($w,type) eq "mono"} {
00387 return [list dat $dat msk $msk fg $color1]
00388 } else {
00389 return [list dat $dat msk $msk fg $color1 bg $color2]
00390 }
00391
00392 }
00393
00394 ######################################################################
00395 # Update the widget from the information.
00396 proc set_from_info {w info_list {resize 1}} {
00397
00398 variable data
00399
00400 array set info $info_list
00401
00402 # Set the background color if it does not exist
00403 if {($data($w,type) ne "mono") && ![info exists info(bg)]} {
00404 set info(bg) $data(bg)
00405 }
00406
00407 # Set the grid foreground
00408 set grid_fg [expr {($info(fg) eq "black") ? "grey" : "black"}]
00409
00410 # Parse the data and mask BMP strings
00411 if {[catch {
00412 array set dat_info [parse_bmp $info(dat)]
00413 if {$data($w,type) eq "mono"} {
00414 array set msk_info [array get dat_info]
00415 } else {
00416 array set msk_info [parse_bmp $info(msk)]
00417 }
00418 } rc]} {
00419 return -code error "Error parsing BMP file ($rc)"
00420 }
00421
00422 # Set the variables
00423 if {$resize} {
00424 set data($w,-width) $dat_info(width)
00425 set data($w,-height) $dat_info(height)
00426 }
00427 if {$data($w,type) eq "mono"} {
00428 lset data($w,colors) 1 $info(fg)
00429 } else {
00430 lset data($w,colors) 1 $info(fg)
00431 lset data($w,colors) 2 $info(bg)
00432 }
00433
00434 # Update the preview
00435 if {$data($w,type) eq "mono"} {
00436 $data($w,preview) configure -foreground $info(fg) -data $info(dat) -maskdata $info(msk)
00437 } else {
00438 $data($w,preview) configure -foreground $info(fg) -background $info(bg) -data $info(dat) -maskdata $info(msk)
00439 }
00440
00441 # Redraw the grid
00442 draw_grid $w $data($w,-width) $data($w,-height) $grid_fg
00443
00444 # Update the widgets
00445 $data($w,c1_lbl) configure -background $info(fg) -foreground [utils::get_complementary_mono_color $info(fg)]
00446 $data($w,color1) configure -text $info(fg)
00447 if {$data($w,type) ne "mono"} {
00448 $data($w,c2_lbl) configure -background $info(bg) -foreground [utils::get_complementary_mono_color $info(bg)]
00449 $data($w,color2) configure -text $info(bg)
00450 }
00451 $data($w,width) set $dat_info(width)
00452 $data($w,height) set $dat_info(height)
00453
00454 for {set row 0} {$row < $data($w,-height)} {incr row} {
00455 set dat_val [lindex $dat_info(rows) $row]
00456 set msk_val [lindex $msk_info(rows) $row]
00457 for {set col 0} {$col < $data($w,-width)} {incr col} {
00458 if {[expr $dat_val & (0x1 << $col)]} {
00459 $data($w,grid) itemconfigure $data($w,$row,$col) -fill $info(fg) -tags s1
00460 } elseif {[expr $msk_val & (0x1 << $col)]} {
00461 $data($w,grid) itemconfigure $data($w,$row,$col) -fill $info(bg) -tags s2
00462 } else {
00463 $data($w,grid) itemconfigure $data($w,$row,$col) -tags s0
00464 }
00465 }
00466 }
00467
00468 }
00469
00470 ######################################################################
00471 # Parses the given BMP file contents and returns a more usable format
00472 # of the data.
00473 proc parse_bmp {bmp_str} {
00474
00475 array set bmp_data [list]
00476
00477 # Parse out the width and height
00478 if {[regexp {#define\s+\w+\s+(\d+).*#define\s+\w+\s+(\d+).*\{(.*)\}} [string map {\n { }} $bmp_str] -> bmp_data(width) bmp_data(height) values]} {
00479 if {$bmp_data(width) > 32} {
00480 return -code error "BMP data width is greater than 32"
00481 }
00482 if {$bmp_data(height) > 32} {
00483 return -code error "BMP data height is greater than 32"
00484 }
00485 set values [string map {{,} {}} [string trim $values]]
00486 switch [expr ($bmp_data(width) - 1) / 8] {
00487 0 {
00488 foreach val $values {
00489 lappend bmp_data(rows) $val
00490 }
00491 }
00492 1 {
00493 foreach {val1 val2} $values {
00494 lappend bmp_data(rows) [expr ($val2 << 8) | $val1]
00495 }
00496 }
00497 2 {
00498 foreach {val1 val2 val3} $values {
00499 lappend bmp_data(rows) [expr ($val3 << 16) | ($val2 << 8) | $val1]
00500 }
00501 }
00502 3 {
00503 foreach {val1 val2 val3 val4} $value {
00504 lappend bmp_data(rows) [expr ($val4 << 24) | ($val3 << 16) | ($val2 << 8) | $val1]
00505 }
00506 }
00507 }
00508 return [array get bmp_data]
00509 }
00510
00511 return -code error "Illegal BMP data string specified"
00512
00513 }
00514
00515 ######################################################################
00516 # Updates the color menus
00517 proc update_menus {w} {
00518
00519 variable data
00520
00521 for {set i 1} {$i <= [expr {($data($w,type) eq "mono") ? 1 : 2}]} {incr i} {
00522 set mnu $data($w,color${i}_mnu)
00523 $mnu delete 0 end
00524 $mnu add command -label "Custom color..." -command [list bitmap::set_custom_color $w $i]
00525 if {[llength $data($w,-swatches)] > 0} {
00526 $mnu add separator
00527 $mnu add command -label "Swatch Colors" -state disabled
00528 foreach swatch $data($w,-swatches) {
00529 $mnu add command -label $swatch -command [list bitmap::set_color $w $i $swatch]
00530 }
00531 }
00532 }
00533
00534 }
00535
00536 ######################################################################
00537 # Set a custom color
00538 proc set_custom_color {w index} {
00539
00540 variable data
00541
00542 if {[set color [tk_chooseColor -initialcolor [lindex $data($w,colors) $index]]] ne ""} {
00543 set_color $w $index $color
00544 }
00545
00546 }
00547
00548 ######################################################################
00549 # Sets the specified color index with the given color and updates the
00550 # widget.
00551 proc set_color {w index color} {
00552
00553 variable data
00554
00555 # Set the color
00556 lset data($w,colors) $index $color
00557
00558 # Set the preview color
00559 if {$index == 1} {
00560 $data($w,preview) configure -foreground $color
00561 } else {
00562 $data($w,preview) configure -background $color
00563 }
00564
00565 # Set the label background color
00566 $data($w,c${index}_lbl) configure -background $color
00567
00568 # Set the menubutton label
00569 $data($w,color$index) configure -text $color
00570
00571 # Update the colors
00572 foreach id [$data($w,grid) find withtag s$index] {
00573 $data($w,grid) itemconfigure $id -fill $color
00574 }
00575
00576 # Generate a BitmapChanged event
00577 event generate $w <<BitmapChanged>> -data [get_info $w]
00578
00579 }
00580
00581 ######################################################################
00582 # Prompts the user for a file to import and updates the UI based on
00583 # the read in file and type specified.
00584 proc import {w vec} {
00585
00586 variable data
00587
00588 # Prompt the user for a BMP filename
00589 if {[set fname [tk_getOpenFile -parent $w -filetypes {{{Bitmap files} {.bmp}}}]] ne ""} {
00590
00591 # Open the file for reading
00592 if {[catch { open $fname r } rc]} {
00593 return -code error "Unable to open $fname for reading"
00594 }
00595
00596 # Get the file content
00597 set content [read $rc]
00598 close $rc
00599
00600 # Update the UI
00601 array set info [get_info $w]
00602 if {$vec & 0x1} {
00603 set info(dat) $content
00604 }
00605 if {$vec & 0x2} {
00606 set info(msk) $content
00607 }
00608 if {[catch { set_from_info $w [array get info] } rc]} {
00609 tk_messageBox -parent $w -icon error -message "Unable to parse BMP file $fname"
00610 }
00611
00612 # Generate the event
00613 event generate $w <<BitmapChanged>> -data [array get info]
00614
00615 }
00616
00617 }
00618
00619 ######################################################################
00620 # Exports the current bitmap information to a file. The value of type
00621 # can be 'data' or 'mask'.
00622 proc export {w type} {
00623
00624 # Prompt the user for a BMP filename to save to
00625 if {[set fname [tk_getSaveFile -parent $w -filetypes {{{Bitmap files} {.bmp}}}]] ne ""} {
00626
00627 # Open the file for writing
00628 if {[catch { open $fname w } rc]} {
00629 return -code error "Unable to open $fname for writing"
00630 }
00631
00632 # Get the bitmap information
00633 array set info [get_info $w]
00634
00635 # Write the information
00636 if {$type eq "data"} {
00637 puts $rc $info(dat)
00638 } else {
00639 puts $rc $info(msk)
00640 }
00641
00642 # Close the file
00643 close $rc
00644
00645 }
00646
00647 }
00648
00649 ######################################################################
00650 # Counts the number of blanks for the given orientation.
00651 proc count_blanks {w orient rows cols} {
00652
00653 variable data
00654
00655 set blanks 0
00656
00657 if {$orient eq "row"} {
00658 foreach row $rows {
00659 foreach col $cols {
00660 if {[$data($w,grid) itemcget $data($w,$row,$col) -tags] ne "s0"} {
00661 return $blanks
00662 }
00663 }
00664 incr blanks
00665 }
00666 } else {
00667 foreach col $cols {
00668 foreach row $rows {
00669 if {[$data($w,grid) itemcget $data($w,$row,$col) -tags] ne "s0"} {
00670 return $blanks
00671 }
00672 }
00673 incr blanks
00674 }
00675 }
00676
00677 return $blanks
00678
00679 }
00680
00681 ######################################################################
00682 # Moves all of the pixels in the canvas in the given direction by one
00683 # pixel.
00684 proc move {w dir} {
00685
00686 variable data
00687
00688 set row_adjust 0
00689 set col_adjust 0
00690
00691 for {set i 0} {$i < $data($w,-height)} {incr i} { lappend rows $i }
00692 for {set i 0} {$i < $data($w,-width)} {incr i} { lappend cols $i }
00693
00694 switch $dir {
00695 up { set row_adjust 1 }
00696 down { set row_adjust -1; set rows [lreverse $rows] }
00697 left { set col_adjust 1 }
00698 right { set col_adjust -1; set cols [lreverse $cols] }
00699 center {
00700 set top [count_blanks $w row $rows $cols]
00701 set bottom [count_blanks $w row [lreverse $rows] $cols]
00702 set left [count_blanks $w col $rows $cols]
00703 set right [count_blanks $w col $rows [lreverse $cols]]
00704 if {[set row_adjust [expr $top - (($top + $bottom) / 2)]] < 0} {
00705 set rows [lreverse $rows]
00706 }
00707 if {[set col_adjust [expr $left - (($left + $right) / 2)]] < 0} {
00708 set cols [lreverse $cols]
00709 }
00710 if {($row_adjust == 0) && ($col_adjust == 0)} {
00711 return
00712 }
00713 }
00714 }
00715
00716 foreach row $rows {
00717 set old_row [expr $row + $row_adjust]
00718 foreach col $cols {
00719 set old_col [expr $col + $col_adjust]
00720 if {($old_row < 0) || ($old_row >= $data($w,-height)) || ($old_col < 0) || ($old_col >= $data($w,-width))} {
00721 $data($w,grid) itemconfigure $data($w,$row,$col) -fill "" -tags s0
00722 } else {
00723 $data($w,grid) itemconfigure $data($w,$row,$col) \
00724 -fill [$data($w,grid) itemcget $data($w,$old_row,$old_col) -fill] \
00725 -tags [$data($w,grid) itemcget $data($w,$old_row,$old_col) -tags]
00726 }
00727 }
00728 }
00729
00730 # Update the preview
00731 array set info [get_info $w]
00732 $data($w,preview) configure -data $info(dat) -maskdata $info(msk)
00733
00734 # Generate the event
00735 event generate $w <<BitmapChanged>> -data [array get info]
00736
00737 }
00738
00739 ######################################################################
00740 # Flips the image horizontally or vertically.
00741 proc flip {w orient} {
00742
00743 variable data
00744
00745 for {set i 0} {$i < $data($w,-height)} {incr i} { lappend rows $i }
00746 for {set i 0} {$i < $data($w,-width)} {incr i} { lappend cols $i }
00747
00748 if {$orient eq "vertical"} {
00749 foreach row $rows {
00750 foreach lcol $cols rcol [lreverse $cols] {
00751 if {$lcol >= $rcol} {
00752 break
00753 } else {
00754 set fill [$data($w,grid) itemcget $data($w,$row,$lcol) -fill]
00755 set tags [$data($w,grid) itemcget $data($w,$row,$lcol) -tags]
00756 $data($w,grid) itemconfigure $data($w,$row,$lcol) \
00757 -fill [$data($w,grid) itemcget $data($w,$row,$rcol) -fill] \
00758 -tags [$data($w,grid) itemcget $data($w,$row,$rcol) -tags]
00759 $data($w,grid) itemconfigure $data($w,$row,$rcol) -fill $fill -tags $tags
00760 }
00761 }
00762 }
00763 } else {
00764 foreach col $cols {
00765 foreach trow $rows brow [lreverse $rows] {
00766 if {$trow >= $brow} {
00767 break
00768 } else {
00769 set fill [$data($w,grid) itemcget $data($w,$trow,$col) -fill]
00770 set tags [$data($w,grid) itemcget $data($w,$trow,$col) -tags]
00771 $data($w,grid) itemconfigure $data($w,$trow,$col) \
00772 -fill [$data($w,grid) itemcget $data($w,$brow,$col) -fill] \
00773 -tags [$data($w,grid) itemcget $data($w,$brow,$col) -tags]
00774 $data($w,grid) itemconfigure $data($w,$brow,$col) -fill $fill -tags $tags
00775 }
00776 }
00777 }
00778 }
00779
00780 # Update the preview
00781 array set info [get_info $w]
00782 $data($w,preview) configure -data $info(dat) -maskdata $info(msk)
00783
00784 # Generate the event
00785 event generate $w <<BitmapChanged>> -data [array get info]
00786
00787 }
00788
00789 ######################################################################
00790 # Rotates the image by 90 degrees.
00791 proc rotate {w} {
00792
00793 variable data
00794
00795 for {set i 0} {$i < $data($w,-height)} {incr i} { lappend rows $i }
00796 for {set i 0} {$i < $data($w,-width)} {incr i} { lappend cols $i }
00797
00798 # Copy the image to a source array and clear the destination
00799 foreach row $rows {
00800 set src_row [list]
00801 foreach col $cols {
00802 lappend src_row [list -fill [$data($w,grid) itemcget $data($w,$row,$col) -fill] -tags [$data($w,grid) itemcget $data($w,$row,$col) -tags]]
00803 $data($w,grid) itemconfigure $data($w,$row,$col) -fill "" -tags ""
00804 }
00805 lappend src $src_row
00806 }
00807
00808 foreach col $cols src_row $rows {
00809 if {($col eq "") || ($src_row eq "")} {
00810 return
00811 }
00812 foreach row [lreverse $rows] src_col $cols {
00813 if {($row eq "") || ($src_col eq "")} {
00814 break
00815 }
00816 $data($w,grid) itemconfigure $data($w,$row,$col) {*}[lindex $src $src_row $src_col]
00817 }
00818 }
00819
00820 # Update the preview
00821 array set info [get_info $w]
00822 $data($w,preview) configure -data $info(dat) -maskdata $info(msk)
00823
00824 # Generate the event
00825 event generate $w <<BitmapChanged>> -data [array get info]
00826
00827 }
00828
00829 }
00830
00831 if {0} {
00832 pack [bitmap::create .bm] -side left
00833 if {![catch { open images/sopen.bmp r } rc]} {
00834 set content [read $rc]
00835 close $rc
00836 bitmap::set_from_info .bm [list fg black bg white dat $content msk $content]
00837 }
00838 }
