# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: canvicon.tcl,v 1.21 2006/01/28 19:16:59 jfontain Exp $


class canvasWindowManager {

    class icon {

        # note: all icons must be of identical size
        set (image,gray) [image create photo -data {
            R0lGODlhGAAYAMIEAAAAAHh8eL+/v9jc2P///////////////yH5BAEAAAQALAAAAAAYABgAAANrSLrcviDKSWskQOjNuwdB5o0jKJKoZgZs676wOQzBbNc2
            nc+ynuO33WAFKxZNmkBHyWFykAJncvkJTZvUDlQazT5DxrCrB5yVfTny7nwegsXirff6FXHvVfu8q7XyN3h9FoODAQRwiA+KiwkAOw==
        }]
        set (image,gray,green) [image create photo -data {
            R0lGODlhGAAYAMIFAAAAAHh8eIDAgL//v9j/2P///////////yH5BAEAAAcALAAAAAAYABgAAANweLrcviDKSWs8YOjNuwdB5o0jKJKoZgps676wSRDCbNc2
            nc+ynuO3HWEFKxZNGkFHyWFykANncvkJTZvUDlQazT5DxrCrB5yVfTny7nwegsXirff6FXHvVfu8q7XyN3h9FoODAQcBiImKi4yID4+QCQA7
        }]
        set (image,gray,red) [image create photo -data {
            R0lGODlhGAAYAMIFAAAAAHh8eMCAgP+/v//f3////////////yH5BAEAAAcALAAAAAAYABgAAANweLrcviDKSWs8YOjNuwdB5o0jKJKoZgps676wSRDCbNc2
            nc+ynuO3HWEFKxZNGkFHyWFykANncvkJTZvUDlQazT5DxrCrB5yVfTny7nwegsXirff6FXHvVfu8q7XyN3h9FoODAQcBiImKi4yID4+QCQA7
        }]

        proc icon {this canvas title args} switched {$args} {
            set image [$canvas create image 0 0 -image $(image,gray) -tags icon($this)]
            set text [$canvas create text 0 [expr {([image height $(image,gray)] / 2.0) + 1}]\
                -anchor n -text $title -font $font::(smallNormal) -tags icon($this)\
            ]                                                                                                   ;# place title below
            foreach {left top right bottom} [$canvas bbox icon($this)] {}
            set x [expr {round(($right - $left) / 2.0)}]
            $canvas move $image $x 0
            $canvas move $text $x 0
            set ($this,image) $image
            set ($this,moved) 0                                            ;# whether the icon was moved by the user in its lifetime
            set ($this,canvas) $canvas
            switched::complete $this
        }

        proc ~icon {this} {
            $($this,canvas) delete icon($this)
        }

        proc options {this} {                                                            ;# force default coordinates initialization
            return [list\
                [list -command {} {}]\
                [list -color {} {}]\
                [list -state normal]\
            ]
        }

        proc set-command {this value} {                                                                   ;# invoked on double click
            if {[string length $value] == 0} {
                $($this,canvas) bind icon($this) <Double-Button-1> {}
            } elseif {[string equal $switched::($this,-state) normal]} {
                $($this,canvas) bind icon($this) <Double-Button-1> "uplevel #0 $value"
            }
        }

        proc set-color {this value} {                                                                       ;# default color is gray
            foreach {red green blue} [winfo rgb $($this,canvas) $value] {}
            if {($green > ($red * 1.1)) && ($green > ($blue * 1.1))} {                                               ;# rather green
                $($this,canvas) itemconfigure $($this,image) -image $(image,gray,green)
            } elseif {($red > ($green * 1.1)) && ($red > ($blue * 1.1))} {                                             ;# rather red
                $($this,canvas) itemconfigure $($this,image) -image $(image,gray,red)
            } else {                                                                                                      ;# default
                $($this,canvas) itemconfigure $($this,image) -image $(image,gray)
            }
        }

        proc set-state {this value} {
            set canvas $($this,canvas)
            switch $value {
                disabled {
                    $canvas bind icon($this) <Double-Button-1> {}
                    $canvas bind icon($this) <ButtonPress-1> {}
                    $canvas bind icon($this) <Button1-Motion> {}
                    $canvas bind icon($this) <ButtonRelease-1> {}
                }
                normal {
                    if {[string length $switched::($this,-command)] == 0} {
                        $canvas bind icon($this) <Double-Button-1> {}
                    } else {
                        $canvas bind icon($this) <Double-Button-1> "uplevel #0 $switched::($this,-command)"
                    }
                    $canvas bind icon($this) <ButtonPress-1> "canvasWindowManager::icon::select $this %x %y"
                    $canvas bind icon($this) <Button1-Motion> "canvasWindowManager::icon::moving $this %x %y"
                    $canvas bind icon($this) <ButtonRelease-1> "lifoLabel::pop $global::messenger"
                }
                default {error "invalid value: $value"}
            }
        }

        proc select {this x y} {
            set (xLast) $x; set (yLast) $y
            lifoLabel::push $global::messenger {}    ;# in case no other string is pushed before button release event pops messenger
        }

        proc moving {this x y} {
            set canvas $($this,canvas)
            $canvas move icon($this) [expr {$x - $(xLast)}] [expr {$y - $(yLast)}]
            set (xLast) $x; set (yLast) $y
            set ($this,moved) 1                                                                      ;# remember user initiated move
            fence $canvas icon($this)
            foreach {x y} [$canvas coords icon($this)] break
            lifoLabel::pop $global::messenger                                                 ;# remove previous coordinates or size
            lifoLabel::push $global::messenger "[expr {round($x) - [lindex [$canvas cget -scrollregion] 0]}] [expr {round($y)}]"
        }

        proc fromTag {tag} {                                      ;# return object identifier from a canvas tag or 0 if unrecognized
            set identifier 0
            scan $tag icon(%u) identifier
            return $identifier
        }

        proc coordinates {this {x {}} {y {}}} {
            set canvas $($this,canvas)
            foreach {xCurrent yCurrent} [$canvas coords icon($this)] {}
            if {[string length $x] == 0} {return [list $xCurrent $yCurrent]}                                              ;# inquiry
            $canvas move icon($this) [expr {$x - $xCurrent}] [expr {$y - $yCurrent}]
            fence $canvas icon($this)
        }

    }

}
