| 1 | # This program is under CECILL_B licence. See footer for details. |
|---|
| 2 | |
|---|
| 3 | |
|---|
| 4 | |
|---|
| 5 | |
|---|
| 6 | # ENTRY CREATION |
|---|
| 7 | |
|---|
| 8 | proc viewer_create { args } { |
|---|
| 9 | set mandatory_arguments { path_father address } |
|---|
| 10 | |
|---|
| 11 | # Initializes the widget |
|---|
| 12 | initWidget |
|---|
| 13 | |
|---|
| 14 | # case when the folders are known beforehand |
|---|
| 15 | set folders "" |
|---|
| 16 | if {[dTree_attrExists $XMLtree $full_address_XML_clean "folders"]==1} { |
|---|
| 17 | set list_folder_names [split [dTree_getAttribute $XMLtree $full_address_XML_clean "folders"] "#"] |
|---|
| 18 | foreach group $list_folder_names { |
|---|
| 19 | lappend folders [file join {*}[split $group ";"] ] |
|---|
| 20 | } |
|---|
| 21 | } |
|---|
| 22 | |
|---|
| 23 | #inits |
|---|
| 24 | set widgetInfo($address-folders) $folders |
|---|
| 25 | set widgetInfo($address-zoom) "50%" |
|---|
| 26 | set widgetInfo($address-selimg) "" |
|---|
| 27 | set widgetInfo($address-status) 1 |
|---|
| 28 | |
|---|
| 29 | |
|---|
| 30 | |
|---|
| 31 | set lightboxcolorbg [ThemeColor 1.0] |
|---|
| 32 | set lightboxcolorfg [ThemeColor 0.3] |
|---|
| 33 | |
|---|
| 34 | set hsize [getcharsize [expr 0.6*$widgetInfo(guiBigWidgetWidth)]] |
|---|
| 35 | |
|---|
| 36 | frame $win -bg white |
|---|
| 37 | eval $widgetInfo(packme-$win) |
|---|
| 38 | |
|---|
| 39 | ############### |
|---|
| 40 | # Canvas part |
|---|
| 41 | ############### |
|---|
| 42 | |
|---|
| 43 | frame $win.img -bg $lightboxcolorbg |
|---|
| 44 | canvas $win.img.c -width [expr 0.7*$widgetInfo(guiBigWidgetWidth)] -height [expr 0.4*$widgetInfo(guiBigWidgetWidth)] -background $lightboxcolorbg -highlightthickness 1 -highlightbackground $lightboxcolorbg |
|---|
| 45 | pack $win.img.c |
|---|
| 46 | bind $win.img.c <ButtonPress> [subst { |
|---|
| 47 | $win.img.c scan mark %x %y |
|---|
| 48 | }] |
|---|
| 49 | bind $win.img.c <B1-Motion> [subst { |
|---|
| 50 | $win.img.c scan dragto %x %y 1 |
|---|
| 51 | }] |
|---|
| 52 | image create photo $address-img |
|---|
| 53 | $address-img blank |
|---|
| 54 | $win.img.c create image [expr 0.35*$widgetInfo(guiBigWidgetWidth)] [expr 0.2*$widgetInfo(guiBigWidgetWidth)] -image $address-img |
|---|
| 55 | |
|---|
| 56 | ############### |
|---|
| 57 | #list of images part |
|---|
| 58 | ############### |
|---|
| 59 | |
|---|
| 60 | frame $win.l -bg $lightboxcolorbg |
|---|
| 61 | listbox $win.l.lb -listvariable widgetInfo($address-listimg) -yscrollcommand [list $win.l.sb set] -bd 0 -height 6 -width $hsize -selectmode browse -foreground $lightboxcolorfg -background $lightboxcolorbg -selectbackground $lightboxcolorfg -selectforeground $lightboxcolorbg |
|---|
| 62 | |
|---|
| 63 | bind $win.l.lb <<ListboxSelect>> [subst { viewer_curimage $win $address}] |
|---|
| 64 | |
|---|
| 65 | grid $win.l.lb -column 0 -row 0 -columnspan 2 -sticky news -padx {10 0} -pady {10 0} |
|---|
| 66 | scrollbar $win.l.sb -command [list $win.l.lb yview] |
|---|
| 67 | grid $win.l.sb -column 2 -row 0 -sticky news -padx {0 10} -pady {10 0} |
|---|
| 68 | |
|---|
| 69 | label $win.l.space -text "Image selected:" -foreground $lightboxcolorfg -background $lightboxcolorbg |
|---|
| 70 | grid $win.l.space -column 0 -row 1 -sticky news |
|---|
| 71 | label $win.l.sel -textvariable widgetInfo($address-selimg) -wraplength [expr 0.6*$widgetInfo(guiBigWidgetWidth)] -foreground $lightboxcolorfg -background $lightboxcolorbg |
|---|
| 72 | grid $win.l.sel -column 1 -row 1 -sticky news |
|---|
| 73 | |
|---|
| 74 | |
|---|
| 75 | ############### |
|---|
| 76 | # text part |
|---|
| 77 | ############### |
|---|
| 78 | |
|---|
| 79 | #text $win.txt -width $hsize -height 6 -wrap word -background khaki1 -highlightcolor black -highlightbackground [ThemeColor 0.9] -selectbackground skyblue1 |
|---|
| 80 | text $win.txt -width $hsize -height 6 -wrap word -foreground $lightboxcolorfg -background $lightboxcolorbg -highlightcolor white -highlightbackground $lightboxcolorbg -selectbackground skyblue1 |
|---|
| 81 | #label $win.txt.corner -image icon_corner -compound left -background khaki1 -borderwidth 0 |
|---|
| 82 | #place $win.txt.corner -relx 1.0 -rely 1.0 -anchor se |
|---|
| 83 | |
|---|
| 84 | |
|---|
| 85 | ############### |
|---|
| 86 | # buttons part |
|---|
| 87 | ############### |
|---|
| 88 | |
|---|
| 89 | ttk::frame $win.b |
|---|
| 90 | |
|---|
| 91 | ttk::button $win.b.del -text "Delete image" -command [subst {viewer_delimage $win $address }] |
|---|
| 92 | #pack $win.b.del -side left -fill x -padx 4 |
|---|
| 93 | grid $win.b.del -column 0 -row 0 -sticky news -padx 4 -pady 4 |
|---|
| 94 | |
|---|
| 95 | ttk::button $win.b.save -text "Save Comment" -command [subst {viewer_savecomment $win $address }] |
|---|
| 96 | #pack $win.b.save -side left -fill x -padx 4 |
|---|
| 97 | grid $win.b.save -column 1 -row 0 -sticky news -padx 4 -pady 4 |
|---|
| 98 | |
|---|
| 99 | ttk::button $win.b.reset -text "Update image list" -command [subst {viewer_update $win $address }] |
|---|
| 100 | #pack $win.b.reset -side left -fill x -padx 4 |
|---|
| 101 | grid $win.b.reset -column 2 -row 0 -sticky news -padx 4 -pady 4 |
|---|
| 102 | |
|---|
| 103 | |
|---|
| 104 | ttk::button $win.b.zoomp -image icon_magnifierplus -command [subst { |
|---|
| 105 | viewer_zoom $win $address "+" |
|---|
| 106 | }] |
|---|
| 107 | ttk::button $win.b.zoomm -image icon_magnifierminus -command [subst { |
|---|
| 108 | viewer_zoom $win $address "-" |
|---|
| 109 | }] |
|---|
| 110 | |
|---|
| 111 | grid $win.b.zoomp -column 3 -row 0 -sticky news -padx 4 -pady 4 |
|---|
| 112 | grid $win.b.zoomm -column 4 -row 0 -sticky news -padx 4 -pady 4 |
|---|
| 113 | |
|---|
| 114 | ########################################## |
|---|
| 115 | # case where folder is not known beforehand |
|---|
| 116 | if {$widgetInfo($address-folders) ==""} { |
|---|
| 117 | ttk::button $win.b.browsebut -image icon_folder -compound right -text "Set folder" -command [subst { |
|---|
| 118 | set widgetInfo($address-folders) \[tk_chooseDirectory -title "Choose gif images folder" \] |
|---|
| 119 | viewer_update $win $address |
|---|
| 120 | }] |
|---|
| 121 | grid $win.b.browsebut -column 5 -row 0 -sticky news -padx 4 -pady 4 |
|---|
| 122 | } |
|---|
| 123 | ########################################## |
|---|
| 124 | |
|---|
| 125 | set framewidth 0 |
|---|
| 126 | # stacking |
|---|
| 127 | pack $win.b -side top -fill x -pady 0 -ipadx $framewidth |
|---|
| 128 | pack $win.l -side top -fill x -pady "$framewidth 0" -padx $framewidth |
|---|
| 129 | pack $win.img -side top -fill x -pady 0 -padx $framewidth |
|---|
| 130 | pack $win.txt -side top -fill x -pady "0 $framewidth" -padx $framewidth |
|---|
| 131 | |
|---|
| 132 | finishWidget |
|---|
| 133 | |
|---|
| 134 | # clean the widget callBack on dstruction |
|---|
| 135 | bind $win <Destroy> [ subst {widget_destroy $win $address}] |
|---|
| 136 | |
|---|
| 137 | return $win |
|---|
| 138 | } |
|---|
| 139 | |
|---|
| 140 | |
|---|
| 141 | # to update the list of images |
|---|
| 142 | proc viewer_update {win address} { |
|---|
| 143 | global widgetInfo |
|---|
| 144 | |
|---|
| 145 | set widgetInfo($address-listimg) "" |
|---|
| 146 | foreach folder $widgetInfo($address-folders) { |
|---|
| 147 | set widgetInfo($address-listimg) [concat $widgetInfo($address-listimg) [glob -nocomplain [file join $folder *.gif]]] |
|---|
| 148 | } |
|---|
| 149 | if {$widgetInfo($address-listimg) == ""} { |
|---|
| 150 | log "No images to show..." |
|---|
| 151 | viewer_cleanimg $win $address |
|---|
| 152 | return |
|---|
| 153 | } |
|---|
| 154 | |
|---|
| 155 | foreach imgfile $widgetInfo($address-listimg) { |
|---|
| 156 | set rootname [file rootname $imgfile] |
|---|
| 157 | set name [file tail $rootname] |
|---|
| 158 | set txtfile "$rootname.txt" |
|---|
| 159 | if {![file exists $txtfile]} { |
|---|
| 160 | set fout [open $txtfile w] |
|---|
| 161 | puts $fout "$name \n no specific comment" |
|---|
| 162 | close $fout |
|---|
| 163 | } |
|---|
| 164 | |
|---|
| 165 | } |
|---|
| 166 | |
|---|
| 167 | |
|---|
| 168 | } |
|---|
| 169 | |
|---|
| 170 | # to get the current image |
|---|
| 171 | proc viewer_curimage {win address} { |
|---|
| 172 | global widgetInfo |
|---|
| 173 | if {$widgetInfo($address-listimg) == ""} {return} |
|---|
| 174 | set index [$win.l.lb curselection] |
|---|
| 175 | set widgetInfo($address-selimg) [lindex $widgetInfo($address-listimg) $index] |
|---|
| 176 | |
|---|
| 177 | viewer_setimage $win $address |
|---|
| 178 | |
|---|
| 179 | return |
|---|
| 180 | } |
|---|
| 181 | |
|---|
| 182 | |
|---|
| 183 | proc viewer_zoom {win address zoom} { |
|---|
| 184 | global widgetInfo |
|---|
| 185 | |
|---|
| 186 | set list_zoom "" |
|---|
| 187 | lappend list_zoom "25%" |
|---|
| 188 | lappend list_zoom "33%" |
|---|
| 189 | lappend list_zoom "50%" |
|---|
| 190 | lappend list_zoom "100%" |
|---|
| 191 | |
|---|
| 192 | set max [llength $list_zoom] |
|---|
| 193 | set pos [lsearch $list_zoom $widgetInfo($address-zoom)] |
|---|
| 194 | |
|---|
| 195 | |
|---|
| 196 | switch $zoom { |
|---|
| 197 | "+" { |
|---|
| 198 | incr pos |
|---|
| 199 | if {$pos == $max } {return} |
|---|
| 200 | } |
|---|
| 201 | "-" { |
|---|
| 202 | incr pos -1 |
|---|
| 203 | if {$pos == -1 } {return} |
|---|
| 204 | } |
|---|
| 205 | } |
|---|
| 206 | set widgetInfo($address-zoom) [lindex $list_zoom $pos] |
|---|
| 207 | viewer_setimage $win $address |
|---|
| 208 | |
|---|
| 209 | } |
|---|
| 210 | # to save a comment done on an image |
|---|
| 211 | proc viewer_savecomment {win address} { |
|---|
| 212 | global widgetInfo |
|---|
| 213 | if {$widgetInfo($address-selimg) == ""} { |
|---|
| 214 | log "no image selected" |
|---|
| 215 | return |
|---|
| 216 | } |
|---|
| 217 | set rootname [file rootname $widgetInfo($address-selimg)] |
|---|
| 218 | set txtfile "$rootname.txt" |
|---|
| 219 | set fout [open $txtfile w] |
|---|
| 220 | set txt [string trim [$win.txt get 0.0 end]] |
|---|
| 221 | puts $fout $txt |
|---|
| 222 | close $fout |
|---|
| 223 | |
|---|
| 224 | } |
|---|
| 225 | |
|---|
| 226 | # to kill an image and its comment |
|---|
| 227 | proc viewer_delimage {win address} { |
|---|
| 228 | global widgetInfo |
|---|
| 229 | if {$widgetInfo($address-selimg) == ""} { |
|---|
| 230 | log "No image to delete" |
|---|
| 231 | return |
|---|
| 232 | } |
|---|
| 233 | log "Deleting file $widgetInfo($address-selimg)." |
|---|
| 234 | |
|---|
| 235 | # keep the line of the last selection |
|---|
| 236 | set index [$win.l.lb curselection] |
|---|
| 237 | |
|---|
| 238 | #delete files |
|---|
| 239 | set rootname [file rootname $widgetInfo($address-selimg)] |
|---|
| 240 | file delete -force $widgetInfo($address-selimg) |
|---|
| 241 | file delete -force "$rootname.txt" |
|---|
| 242 | |
|---|
| 243 | #update list |
|---|
| 244 | viewer_update $win $address |
|---|
| 245 | |
|---|
| 246 | # exception when the last element is deleted |
|---|
| 247 | if {$index == [llength $widgetInfo($address-listimg)]} { |
|---|
| 248 | incr index -1 |
|---|
| 249 | } |
|---|
| 250 | # switch to next image if any |
|---|
| 251 | $win.l.lb selection clear 0 end |
|---|
| 252 | $win.l.lb selection set $index |
|---|
| 253 | viewer_curimage $win $address |
|---|
| 254 | } |
|---|
| 255 | |
|---|
| 256 | #to clean the lightbox from an image |
|---|
| 257 | proc viewer_cleanimg {win address} { |
|---|
| 258 | global widgetInfo |
|---|
| 259 | $address-img blank |
|---|
| 260 | $win.txt delete 0.0 end |
|---|
| 261 | set widgetInfo($address-selimg) "" |
|---|
| 262 | } |
|---|
| 263 | |
|---|
| 264 | |
|---|
| 265 | # to show the curent image |
|---|
| 266 | proc viewer_setimage {win address} { |
|---|
| 267 | global widgetInfo |
|---|
| 268 | if {$widgetInfo($address-selimg) == ""} { |
|---|
| 269 | log "No image to show" |
|---|
| 270 | viewer_cleanimg $win $address |
|---|
| 271 | return |
|---|
| 272 | } |
|---|
| 273 | |
|---|
| 274 | # get caption |
|---|
| 275 | set rootname [file rootname $widgetInfo($address-selimg)] |
|---|
| 276 | set txtfile "$rootname.txt" |
|---|
| 277 | set fin [open $txtfile r] |
|---|
| 278 | set caption [read $fin] |
|---|
| 279 | close $fin |
|---|
| 280 | |
|---|
| 281 | # show caption in text |
|---|
| 282 | $win.txt delete 0.0 end |
|---|
| 283 | $win.txt insert end "$caption" |
|---|
| 284 | |
|---|
| 285 | # show image |
|---|
| 286 | $address-img blank |
|---|
| 287 | image create photo tmp-img -file $widgetInfo($address-selimg) |
|---|
| 288 | switch $widgetInfo($address-zoom) { |
|---|
| 289 | "25%" { |
|---|
| 290 | $address-img copy tmp-img -subsample 4 4 |
|---|
| 291 | } |
|---|
| 292 | "33%" { |
|---|
| 293 | $address-img copy tmp-img -subsample 3 3 |
|---|
| 294 | } |
|---|
| 295 | "50%" { |
|---|
| 296 | $address-img copy tmp-img -subsample 2 2 |
|---|
| 297 | } |
|---|
| 298 | "100%" { |
|---|
| 299 | $address-img copy tmp-img -subsample 1 1 |
|---|
| 300 | } |
|---|
| 301 | } |
|---|
| 302 | |
|---|
| 303 | # resize canvas after image (not used for the moment) |
|---|
| 304 | #$win.img.c configure -width [image width $address-img] -height [image height $address-img] |
|---|
| 305 | #$win.img.c configure -scrollregion [ $win.img.c bbox all] |
|---|
| 306 | } |
|---|
| 307 | |
|---|
| 308 | |
|---|
| 309 | # Copyright CERFACS 2014 |
|---|
| 310 | # |
|---|
| 311 | # antoine.dauptain@cerfacs.fr |
|---|
| 312 | # |
|---|
| 313 | # This software is a computer program whose purpose is to ensure technology |
|---|
| 314 | # transfer between academia and industry. |
|---|
| 315 | # |
|---|
| 316 | # This software is governed by the CeCILL-B license under French law and |
|---|
| 317 | # abiding by the rules of distribution of free software. You can use, |
|---|
| 318 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
|---|
| 319 | # license as circulated by CEA, CNRS and INRIA at the following URL |
|---|
| 320 | # "http://www.cecill.info". |
|---|
| 321 | # |
|---|
| 322 | # As a counterpart to the access to the source code and rights to copy, |
|---|
| 323 | # modify and redistribute granted by the license, users are provided only |
|---|
| 324 | # with a limited warranty and the software's author, the holder of the |
|---|
| 325 | # economic rights, and the successive licensors have only limited |
|---|
| 326 | # liability. |
|---|
| 327 | # |
|---|
| 328 | # In this respect, the user's attention is drawn to the risks associated |
|---|
| 329 | # with loading, using, modifying and/or developing or reproducing the |
|---|
| 330 | # software by the user in light of its specific status of free software, |
|---|
| 331 | # that may mean that it is complicated to manipulate, and that also |
|---|
| 332 | # therefore means that it is reserved for developers and experienced |
|---|
| 333 | # professionals having in-depth computer knowledge. Users are therefore |
|---|
| 334 | # encouraged to load and test the software's suitability as regards their |
|---|
| 335 | # requirements in conditions enabling the security of their systems and/or |
|---|
| 336 | # data to be ensured and, more generally, to use and operate it in the |
|---|
| 337 | # same conditions as regards security. |
|---|
| 338 | # |
|---|
| 339 | # The fact that you are presently reading this means that you have had |
|---|
| 340 | # knowledge of the CeCILL-B license and that you accept its terms. |
|---|
