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 }