gui/implementation/Choice.tcl


@implementation Choice {
  - init {} {
      $super init
      set value 0
      set type radio
      set imageOn [@image radioOn]
      set imageOff [@image radioOff]

      grid rowconfigure $path 0 -weight 1
      grid columnconfigure $path 0 -weight 1
      grid [set label [label $path.label -text {} -anchor e]] \
        -row 0 -column 0 -sticky snew
      grid [set image [label $path.image -image $imageOff -bd 1 -relief flat]] \
        -row 0 -column 1 -sticky ew -padx 2 -pady 2

      $self enableEvent: ButtonPress-1 on: [list $image $label]
      $self on: ButtonPress-1 do: {$self toogle}

      set callbacks(Change) {}
    }
  - toogle {} {
      if {$value} {
        $self value: 0
      } else {
        $self value: 1
      }
    }
  - value {} {
      return $value
    }
  - value: boolean {
      set value $boolean
      if {$value} {
        $image configure -image $imageOn
      } else {
        $image configure -image $imageOff
      }
      $self valueChange
    }
  - label {} {
      return [$label cget -text]
    }
  - label: aLabel {
      $label configure -text $aLabel
    }
  - type {} {
      return $type
    }
  - type: radioOrSwitch {
      switch -- [string tolower $radioOrSwitch] {
        radio {
          set type radio
          set imageOn [@image radioOn]
          set imageOff [@image radioOff]
          $image configure -relief flat -bd 1
          $self value: [$self value]
        }
        switch {
          set type switch
          set imageOn [@image switchOn]
          set imageOff [@image switchOff]
          $image configure -relief raised -bd 1
          $self value: [$self value]
        }
        * { return [error "$self: unknown type :\"$radioOrSwitch\""] }
      }
    }

  - onChange: aCallback {
      set callbacks(Change) $aCallback
    }
  - onChange {} {
      return $callbacks(Change)
    }
  - valueChange {} {
      if [string length $callbacks(Change)] {
        catch {eval $callbacks(Change)}
      }
    }

  - dealloc {} {
      catch {destroy $label $image}
      return [$super dealloc]
    }
}