a(Simple)Twinkler

 

ulis, 2005-12-31. En ces temps de Noël et de neige, un package rapidement hacké pour faire scintiller les widgets.


Pourquoi

Pour faire scintiller Tk.


Comment

En calculant les nuances entre deux couleurs.


Utilisation

  package require ASimpleTwinkler
  twinkle create <name> [<options>]...
  <name> start
  ...
  <name> stop

création d'un scintillement

  twinkle create <name> [<option> <value>]...

récupération d'une valeur par défaut

  twinkle get <option>

modification d'une valeur par défaut

  twinkle set [<option> <value>]...
  -alternate    deuxième couleur facultative, calculée si absente
  -delay        délai entre chaque changement de nuance
  -color        couleur initiale
  -count        nombre de nuances
  -script       script appelé pour modifier les couleurs
                le script peut référencer des valeurs :
                  %shade% est la couleur courante
                  %n% est le numéro de la nuance

récupération de la valeur d'une option

  <name> cget <option>

modification de la valeur des options

  <name> config [<option> <value>]...

récupération d'une nuance

  <name> shade <numéro de nuance>

démarrage du scintillement

  <name> start

arrêt du scintillement

  <name> stop

Installation


Package ASimpleTwinkler.tcl

  if {[info exists ::twinkle::version]} { return }

  namespace eval ::twinkle \
  {
  # beginning of ::twinkle namespace definition

  # ####################################
  #
  #   twinkle widget
  #
    variable version 1.0
  #
  #   ulis, (C) 2005
  #
  # ------------------------------------
  # ####################################

    # ==========================
    #
    # package
    #
    # ==========================

    package provide ASimpleTwinkler $version

    package require Tk

    # ====================
    #
    # entry point
    #
    # ====================

    namespace export twinkle

    # ====================
    #
    #   global variables
    #
    # ====================
    variable {}
    array set {} \
    {
      count       0
      -alternate  ""
      -delay      50
      -count      10
      -color      orange
      -script     ""
    }

    # ====================
    #
    #   twinkle proc
    #
    # ====================

    proc twinkle {args} \
    {
      set rc [catch \
      {
        set cmd [lindex $args 0]
        switch -glob -- -$cmd \
        {
          -cre*   { return [uplevel 1 ::twinkle::twinkle:create $args] }
          -get    { return [uplevel 1 ::twinkle::twinkle:dget $args] }
          -set    { return [uplevel 1 ::twinkle::twinkle:dset $args] }
          default \
          {
            error "use is 'twinkle create [name] options' or 'twinkle set options' or 'twinkle get key'"
          }
        }
      } msg]
      if {$rc == 1} { return -code error $msg } else { return $msg }
    }

    # ====================
    #
    #   get proc
    #
    # ====================

    proc twinkle:dget {get args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { return -code error "use is 'twinkle get key'" }
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -alt*   { set (-alternate) }
        -del*   { set (-delay) }
        -col*   { set (-color) }
        -cou*   { set (-count) }
        -scr*   { set (-script) }
        default \
        { error "unknown twinkle default option '$key'" }
      }
    }

    # ====================
    #
    #   set proc
    #
    # ====================

    proc twinkle:dset {set args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { return -code error "use is 'twinkle set \[key value]...'" }
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -alt*   { set (-alternate) $value }
          -del*   { set (-delay) $value }
          -col*   { set (-color) $value }
          -cou*   { set (-count) $value }
          -scr*   { set (-script) $value }
          default \
          { error "unknown twinkle default option '$key'" }
        }
      }
    }

    # ====================
    #
    #   create proc
    #
    # ====================

    proc twinkle:create {create w args} \
    {
      variable {}
      # initial options
      set initial [list]
      foreach key [array names {} -*]  { lappend initial $key $($key) }
      # create twinkle reference
      if {[llength $args] == 0 || [string match -* $w]} \
      {
        set w twinkle[incr (count)]
        set args [linsert $args 0 $w]
      }
      interp alias {} ::$w {} ::twinkle::twinkle:dispatch $w
      # set options
      twinkle:stop $w
      if {$initial != ""} { uplevel 1 ::twinkle::twinkle:config $w $initial }
      if {$args != ""} { uplevel 1 ::twinkle::twinkle:config $w $args }
      # return reference
      return $w
    }

    # ====================
    #
    #   dispatch proc
    #
    # ====================

    proc twinkle:dispatch {w args} \
    {
      set cmd [lindex $args 0]
      set args [lrange $args 1 end]
      set rc [catch \
      {
        switch -glob -- -$cmd \
        {
          -cge*     { return [uplevel 1 ::twinkle::twinkle:cget $w $args] }
          -con*     { return [uplevel 1 ::twinkle::twinkle:config $w $args] }
          -sha*     { return [uplevel 1 ::twinkle::twinkle:shade $w $args] }
          -sta*     { return [uplevel 1 ::twinkle::twinkle:start $w $args] }
          -sto*     { return [uplevel 1 ::twinkle::twinkle:stop $w $args] }
          default \
          { error "unknown twinkle operation '$cmd'" }
        }
      } msg]
      if {$rc == 1} { return -code error $msg } else { return $msg }
    }

    # ====================
    #
    #   cget proc
    #
    # ====================

    proc twinkle:cget {w args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { error "use is 'path cget key'" }
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -alt*   { set ($w:-alternate) }
        -del*   { set ($w:-delay) }
        -col*   { set ($w:-color) }
        -cou*   { set ($w:-count) }
        -scr*   { set ($w:-script) }
        default \
        { error "unknown twinkle option '$key'" }
      }
    }

    # ====================
    #
    #   config proc
    #
    # ====================

    proc twinkle:config {w args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is 'path config \[key value]...'" }
      set cflag 0
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -alt*   \
          {
            set ($w:-alternate) $value
            if {$value != ""} \
            {
              foreach {r g b} [winfo rgb . $value] break
              foreach c {r g b} \
              {
                set v [set $c]
                set v [expr {round($v / 256)}]
                if {$v < 0} { set v 0 }
                if {$v > 255} { set v 255}
                set ($w:${c}2) $v
              }
            }
          }
          -del*   { set ($w:-delay) $value }
          -col*   \
          {
            set ($w:-color) $value
            foreach {r g b} [winfo rgb . $value] break
            foreach c {r g b} \
            {
              set v [set $c]
              set v [expr {round($v / 256)}]
              if {$v < 0} { set v 0 }
              if {$v > 255} { set v 255}
              set ($w:$c) $v
            }
            set cflag 1
          }
          -cou*   { set ($w:-count) $value }
          -scr*   { set ($w:-script) $value }
          default \
          { error "unknown twinkle option '$key'" }
        }
      }
      if {$cflag && $($w:-alternate) == ""} \
      { twinkle:alternate $w }
    }

    # ====================
    #
    #   alternate proc
    #
    # ====================

    proc twinkle:alternate {w} \
    {
      variable {}
      set max 0
      foreach c {r g b} { incr max $($w:$c) }
      if {$max > 3 * 255 * 0.75} \
      {
        # bright color
        foreach c {r g b} \
        {
          set ($w:${c}2) [expr {$($w:$c) / 2}]
        }
      } \
      else \
      {
        # dark color
        foreach c {r g b} \
        {
          set v $($w:$c)
          set ($w:${c}2) [expr {$v + (255 - $v) / 2}]
        }
      }
    }

    # ====================
    #
    #   shade proc
    #
    # ====================

    proc twinkle:shade {w n} \
    {
      variable {}
      foreach c {r g b} \
      {
        set v1 $($w:$c)
        set v2 $($w:${c}2)
        set n1 $n
        set n2 [expr {$($w:-count) - $n1}]
        set v [expr {int(($n1 * $v1 + $n2 * $v2) / double($($w:-count)))}]
        set $c $v
      }
      format #%2.2x%2.2x%2.2x $r $g $b
    }

    # ====================
    #
    #   stop proc
    #
    # ====================

    proc twinkle:stop {w} \
    {
      variable {}
      set ($w:stop) 1
    }

    # ====================
    #
    #   start proc
    #
    # ====================

    proc twinkle:start {w} \
    {
      variable {}
      set ($w:stop) 0
      twinkle:invoke $w 0 1
    }

    # ====================
    #
    #   invoke proc
    #
    # ====================

    proc twinkle:invoke {w n d} \
    {
      variable {}
      if {$($w:stop)} { return }
      set script $($w:-script)
      if {$script != ""} \
      {
        set shade [::twinkle::twinkle:shade $w $n]
        eval [string map [list %shade% $shade %n% $n] $script]
      }
      incr n $d
      if {$n < 0} \
      {
        set n 1
        set d 1
      } \
      elseif {$n > $($w:-count)} \
      {
        set n $($w:-count)
        incr n -1
        set d -1
      }
      after $($w:-delay) ::twinkle::twinkle:invoke $w $n $d
    }

  }

  namespace import ::twinkle::twinkle

Script de description pkgIndex.tcl

  package ifneeded ASimpleTwinkler 1.0 [list source [file join $dir ASimpleTwinkler.tcl]]

Demo

    package require ASimpleTwinkler

    set size 24
    wm protocol . WM_DELETE_WINDOW exit
    canvas .c -width $size -height $size
    .c create oval 2 2 $size $size -outline ""
    pack .c -pady 5
    button .b -width 10 -text stop -command exit
    pack .b -pady 5 -padx 25
    twinkle create tw1 -script \
    {
      # widget with the current twinkle: using %shade%
      .c itemconfig all -fill %shade%
      # widget with an other twinkle: computing shade from %n%
      .b config -fg [tw2 shade %n%]
    }
    twinkle create tw2 -color black
    tw1 start
    focus -force .
    raise .

Voir Aussi


Discussion


Catégorie Paquet | Catégorie Interface utilisateur