a(Simple)Needle

 

ulis, 2006-01-03. Un package (relativement) rapidement hacké pour afficher une valeur dynamique sur un vieux cadran à aiguille.


Pourquoi

Pour animer Tk.


Comment

Avec le canvas.


Installation


Utilisation

  package require ASimpleNeedle
  needle .n -text U -var ::val

création d'un widget

  needle <path> [<option> <value>]...

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

  needle get <option>

modification d'une valeur par défaut

  needle set [<option> <value>]...
  -background   couleur du fond du widget
  -bg           couleur du fond du widget
  -c:center     couleur du pivot de l'aiguille
  -c:dial       couleur du fond du cadran
  -c:frame      couleur du tour de l'écran
  -c:needle     couleur de l'aiguille
  -c:ridge      couleur de l'arête de l'aiguille
  -centercolor  couleur du pivot de l'aiguille
  -delay        délai entre deux invocation du script
  -dial         couleur du fond du cadran
  -font         police du texte
  -frame        couleur du tour de l'écran
  -max          valeur maximale
  -min          valeur minimale
  -needle       couleur de l'aiguille
  -ridge        couleur de l'arête de l'aiguille
  -script       script
  -size         diamètre du cadran
  -text         texte du cadran
  -variable     variable globale contenant la valeur

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

  <path> cget <option>

modification de la valeur des options

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

récupération de la valeur courante

  <path> get

invocation de la commande

  <path> invoke

positionnement de l'aiguille

  <path> set <value>

démarrage de l'invocation automatique de la commande

  <path> start

arrêt de l'invocation automatique de la commande

  <path> stop

Package ASimpleNeedle.tcl

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

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

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

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

    package provide ASimpleNeedle $version

    package require Tk

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

      namespace export needle

    # ====================
    #
    #   global variables
    #
    # ====================
    variable {}
    array set {} \
    {
      pi          3.14159265
      -bg         ""
      -center     gray50
      -delay      100
      -dial       gray95
      -frame      gray50
      -font       ""
      -min        0
      -max        100
      -needle     red
      -ridge      #a00000
      -script     ""
      -size       100
      -text       ""
    }

    # ====================
    #
    #   needle proc
    #
    # ====================

    proc needle {args} \
    {
      set rc [catch \
      {
        set cmd [lindex $args 0]
        switch -glob -- -$cmd \
        {
          -get    { return [uplevel 1 ::needle::needle:dget $args] }
          -set    { return [uplevel 1 ::needle::needle:dset $args] }
          default \
          {
            if {[string index $cmd 0] != "."} \
            { error "use is 'needle path options' or 'needle set options' or 'needle get key'" }
            return [uplevel 1 ::needle::needle:create $args]
          }
        }
      } msg]
      if {$rc == 1} { return -code error $msg } else { return $msg }
    }

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

    proc needle:dget {get args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { return -code error "use is 'needle get key'" }
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -bg     -
        -bac*   { set (-bg) }
        -cen*   -
        -c:c*   { set (-center) }
        -dia*   -
        -c:d*   { set (-dial) }
        -fra*   -
        -c:f*   { set (-frame) }
        -nee*   -
        -c:n*   { set (-needle) }
        -rid*   -
        -c:r*   { set (-ridge) }
        -del*   { set (-delay) }
        -fon*   { set (-font) }
        -max*   { set (-max) }
        -min*   { set (-min) }
        -scr*   { set (-script) }
        -siz*   { set (-size) }
        -tex*   { set (-text) }
        default \
        { error "unknown needle default key '$key'" }
      }
    }

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

    proc needle:dset {set args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is 'needle set \[key value]...'" }
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -bg     -
          -bac*   { set (-bg) $value }
          -cen*   -
          -c:d*   { set (-center) $value }
          -dia*   -
          -c:d*   { set (-dial) $value }
          -fra*   -
          -c:f*   { set (-frame) $value }
          -nee*   -
          -c:n*   { set (-needle) $value }
          -rid*   -
          -c:r*   { set (-ridge) $value }
          -del*   { set (-delay) $value }
          -fon*   { set (-font) $value }
          -max*   { set (-max) $value }
          -min*   { set (-min) $value }
          -scr*   { set (-script) $value }
          -siz*   { set (-size) $value }
          -tex*   { set (-text) $value }
          default \
          { error "unknown needle default key '$key'" }
        }
      }
    }

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

    proc needle:create {w args} \
    {
      variable {}
      # initial options
      set initial [list]
      foreach key [array names {} -*] \
      { lappend initial $key $($key) }
      # create canvas
      canvas $w -highlightt 1
      $w create oval 0 0 0 0 -tags frame0
      $w create text 0 0 -anchor s -tags frame1
      $w create arc 0 0 0 0 -style arc -start 45 -extent 90 -tags frame2
      $w create line 0 0 0 0 -tags frame3
      $w create line 0 0 0 0 -tags frame4
      $w create line 0 0 0 0 -tags frame5
      $w create line 0 0 0 0 -tags frame6
      $w create line 0 0 0 0 -tags frame7
      $w create polygon 0 0 0 0 0 0 -tags {left needle}
      $w create polygon 0 0 0 0 0 0 -tags {right needle}
      $w create line 0 0 0 0 -tags middle
      $w create oval 0 0 0 0 -outline "" -tags center
      # build reference
      rename $w ::needle::_$w
      interp alias {} ::$w {} ::needle::needle:dispatch $w
      # set options
      needle:stop $w
      if {$initial != ""} { uplevel 1 ::needle::needle:config $w $initial }
      if {$args != ""} { uplevel 1 ::needle::needle:config $w $args }
      # return reference
      return $w
    }

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

    proc needle:dispatch {w args} \
    {
      set cmd [lindex $args 0]
      set args [lrange $args 1 end]
      set rc [catch \
      {
        switch -glob -- -$cmd \
        {
          -cge*     { return [uplevel 1 ::needle::needle:cget $w $args] }
          -con*     { return [uplevel 1 ::needle::needle:config $w $args] }
          -get      { return [uplevel 1 ::needle::needle:vget $w $args] }
          -inv*     { return [uplevel 1 ::needle::needle:invoke $w $args] }
          -set      { return [uplevel 1 ::needle::needle:vset $w $args] }
          -sta*     { return [uplevel 1 ::needle::needle:start $w $args] }
          -sto*     { return [uplevel 1 ::needle::needle:stop $w $args] }
          default \
          { return [uplevel 1 ::needle::_$w $cmd $args] }
        }
      } msg]
      if {$rc == 1} { return -code error $msg } else { return $msg }
    }

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

    proc needle:cget {w args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { error "use is 'needle cget path key'" }
      set _w ::needle::_$w
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -del*   { set ($w:-delay) }
        -cen*   -
        -c:c*   { set ($w:-dial) }
        -dia*   -
        -c:d*   { set ($w:-dial) }
        -fra*   -
        -c:f*   { set ($w:-frame) }
        -nee*   -
        -c:n*   { set ($w:-needle) }
        -rid*   -
        -c:r*   { set ($w:-ridge) }
        -fon*   { set ($w:-font) }
        -max*   { set ($w:-max) }
        -min*   { set ($w:-min) }
        -scr*   { set ($w:-size) }
        -siz*   { set ($w:-size) }
        -tex*   { set ($w:-text) }
        -var*   \
        {
          set rc [catch { set ($w:-variable) }]
          if {$rc == 1} { error "needle option -variable value is not defined" }
        }
        default { $_w cget $key }
      }
    }

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

    proc needle:config {w args} \
    {
      puts "needle:config $w {$args}"
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is 'needle config path \[key value]...'" }
      set _w ::needle::_$w
      set mflag 0
      set cflag 0
      set sflag 0
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -bg     -
          -bac*   \
          {
            if {$value == ""} { set value [$_w cget -bg] }
            $_w config $key $value
            $_w itemconfig bottom -fill $value
          }
          -cen*   -
          -c:c*   \
          {
            set ($w:-center) $value
            $_w itemconfig center -fill $value
          }
          -dia*   -
          -c:d*   \
          {
            set ($w:-dial) $value
            $_w itemconfig frame0 -fill $value
          }
          -fra*   -
          -c:f*   \
          {
            set ($w:-frame) $value
            $_w itemconfig frame0 -outline $value
          }
          -nee*   -
          -c:n*   \
          {
            set ($w:-needle) $value
            $_w itemconfig needle -fill $value -outline $value
          }
          -rid*   -
          -c:r*   \
          {
            set ($w:-ridge) $value
            $_w itemconfig middle -fill $value
          }
          -del*   { set ($w:-delay) $value }
          -fon*   \
          {
            set ($w:-font) $value
            if {$value != ""} { $_w itemconfig frame1 -font $font }
          }
          -max*   { set ($w:-max) $value; set mflag 1 }
          -min*   { set ($w:-min) $value; set mflag 1 }
          -scr*   { set ($w:-script) $value }
          -siz*   { set ($w:-size) $value; set sflag 1 }
          -tex*   \
          {
            set ($w:-text) $value
            $_w itemconfig frame1 -text $value
          }
          -var*   \
          {
            set ($w:-variable) $value
            trace add variable $value write [list ::needle::needle:change $w]
          }
          default \
          { $_w config $key $value }
        }
      }
      if {$mflag} \
      {
        set ($w:value) $($w:-min)
        set alpha [expr {135 * 90.0 / ($($w:-max) - $($w:-min))}]
        set ro [expr {$alpha * $(pi) / 180.0}]
        set ($w:current) $ro
      }
      if {$mflag || $cflag} \
      {
        set ($w:coef) [expr {90.0 / ($($w:-max) - $($w:-min))}]
      }
      if {$sflag} \
      {
        set pi $(pi)
        set size $($w:-size)
        set size1 [expr {$size * 0.6}]
        set size2 [expr {$size * 0.1}]
        set size3 [expr {$size * 0.02}]
        set size4 [expr {$size * 0.04}]
        set size5 [expr {$size - $size3}]
        set size6 [expr {$size * 0.5}]
        set sizeb [expr {round($size * 0.25)}]
        set xc [expr {$size * 0.5}]
        set yc [expr {$size * 0.8}]
        set x0 [expr {$xc - $size4}]
        set y0 [expr {$yc - $size4}]
        set x1 [expr {$xc + $size4}]
        set y1 [expr {$yc + $size4}]
        set x2 [expr {$xc - $size6}]
        set y2 [expr {$yc - $size6}]
        set x3 [expr {$xc + $size6}]
        set y3 [expr {$yc + $size6}]
        $_w config -width $size -height $size
        $_w coords frame0 $size3 $size3 $size5 $size5
        $_w itemconfig frame0 -width $size3
        $_w coords frame1 $xc [expr {$yc - $size4}]
        $_w coords frame2 $x2 $y2 $x3 $y3
        $_w itemconfig frame2 -width $size4
        set y4 [expr {$y2 - 2 * $size4}]
        set y5 [expr {$y2 - 2 * $size3}]
        $_w coords frame3 $xc $y2 $xc $y4
        $_w itemconfig frame3 -width $size3
        set ro6 [expr {46 * $pi / 180.0}]
        set cos6 [expr {cos($ro6)}]
        set sin6 [expr {sin($ro6)}]
        set x6 [expr {$xc + $size6 * $cos6}]
        set y6 [expr {$yc - $size6 * $sin6}]
        set x7 [expr {$xc + ($size6 + 2 * $size4) * $cos6}]
        set y7 [expr {$yc - ($size6 + 2 * $size4) * $sin6}]
        $_w coords frame4 $x6 $y6 $x7 $y7
        $_w itemconfig frame4 -width $size3
        set ro8 [expr {134 * $pi / 180.0}]
        set cos8 [expr {cos($ro8)}]
        set sin8 [expr {sin($ro8)}]
        set x8 [expr {$xc + $size6 * $cos8}]
        set y8 [expr {$yc - $size6 * $sin8}]
        set x9 [expr {$xc + ($size6 + 2 * $size4) * $cos8}]
        set y9 [expr {$yc - ($size6 + 2 * $size4) * $sin8}]
        $_w coords frame5 $x8 $y8 $x9 $y9
        $_w itemconfig frame5 -width $size3
        set ro10 [expr {(46 + 21.5) * $pi / 180.0}]
        set cos10 [expr {cos($ro10)}]
        set sin10 [expr {sin($ro10)}]
        set x10 [expr {$xc + $size6 * $cos10}]
        set y10 [expr {$yc - $size6 * $sin10}]
        set x11 [expr {$xc + ($size6 + 2 * $size4) * $cos10}]
        set y11 [expr {$yc - ($size6 + 2 * $size4) * $sin10}]
        $_w coords frame6 $x10 $y10 $x11 $y11
        $_w itemconfig frame6 -width $size3
        set ro12 [expr {(134 - 21.5) * $pi / 180.0}]
        set cos12 [expr {cos($ro12)}]
        set sin12 [expr {sin($ro12)}]
        set x12 [expr {$xc + $size6 * $cos12}]
        set y12 [expr {$yc - $size6 * $sin12}]
        set x13 [expr {$xc + ($size6 + 2 * $size4) * $cos12}]
        set y13 [expr {$yc - ($size6 + 2 * $size4) * $sin12}]
        $_w coords frame7 $x12 $y12 $x13 $y13
        $_w itemconfig frame7 -width $size3
        $_w coords center $x0 $y0 $x1 $y1
        if {$($w:-font) == ""} \
        {
          set actual "[font actual [$_w itemcget frame1 -font]] -size -$sizeb"
          set font [eval font create $actual]
          $_w itemconfig frame1 -font $font
        }
        set ($w:xc) $xc
        set ($w:yc) $yc
        set ($w:size1) $size1
        set ($w:size2) $size2
        set ($w:size3) $size3
      }
      if {$mflag || $cflag || $sflag} \
      {
        needle:vset $w $($w:value)
      }
    }

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

    proc needle:vget {w} \
    {
      variable {}
      return $($w:value)
    }

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

    proc needle:vset {w value} \
    {
      variable {}
      catch { after cancel $($w:id) }
      set ($w:value) $value
      set min $($w:-min)
      set max $($w:-max)
      set alpha [expr {45 + ($value - $min) * 90.0 / ($max - $min)}]
      set ro [expr {$alpha * $(pi) / 180.0}]
      set current $($w:current)
      set diff [expr {abs($current - $ro)}]
      if {$diff < 1.e-7} { return }
      set incr [expr {$ro > $current ? 1 : -1}]
      set current [expr {$current + $incr * $diff / 2.5}]
      set ($w:current) $current
      set xc $($w:xc)
      set yc $($w:yc)
      set size1 $($w:size1)
      set size2 $($w:size2)
      set size3 $($w:size3)
      set cos [expr {cos($current)}]
      set sin [expr {sin($current)}]
      set xt [expr {$xc - $size1 * $cos}]
      set yt [expr {$yc - $size1 * $sin}]
      set xb [expr {$xc + $size2 * $cos}]
      set yb [expr {$yc + $size2 * $sin}]
      set xl [expr {$xc - $size3 * $sin}]
      set yl [expr {$yc + $size3 * $cos}]
      set xr [expr {$xc + $size3 * $sin}]
      set yr [expr {$yc - $size3 * $cos}]
      $w coords left $xt $yt $xl $yl $xb $yb
      $w coords right $xt $yt $xr $yr $xb $yb
      $w coords middle $xt $yt $xb $yb
      update
      set ($w:id) [after 20 ::needle::needle:vset $w $value]
    }

    # ====================
    #
    #   change proc
    #
    # ====================

    proc needle:change {w args} \
    {
      variable {}
      ::needle::needle:vset $w [set $($w:-variable)]
    }

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

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

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

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

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

    proc needle:invoke {w} \
    {
      variable {}
      if {$($w:stop)} { return }
      set script $($w:-script)
      if {$script != ""} \
      {
        set map [list]
        foreach name [array names {} $w%] \
        {
          set param [lindex [split $name %] 1]
          lappend map %$param% $($name)
        }
        eval [string map $map $script]
      }
      after $($w:-delay) ::needle::needle:invoke $w
    }

  }

  namespace import ::needle::needle

Script pkgIndex.tcl

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

Demo

  package require ASimpleNeedle

  wm title . "needle"
  wm protocol . WM_DELETE_WINDOW exit
  needle .n -text U -var ::val
  pack .n -padx 10 -pady 10
  proc setNeedle {} \
  {
    set ::val [expr {rand() * 100.0}]
    after [expr {500 + int(500 * rand())}] setNeedle
  }
  setNeedle
  focus -force .
  raise .

Voir aussi


Discussion


Catégorie Paquet | Catégorie Interface utilisateur