Paquet compteur

 

ulis 2008-01-20. Un paquet rapidement fait pour afficher un compteur qui défile (ou autre chose).


Pourquoi

J'en ai eu besoin pour un jeu.


Comment

Heu, faut vraiment le dire ???

Bin avec un canvas...


Description

  # ######################
  #
  # paquet compteur
  #
  set version 1.0
  #
  # (C) ulis, 2008
  #
  # Licence NOL (No Obligation Licence)
  #
  # ----------------------
  # commands:
  #   compteur ?create? $w ?-option value?...
  #     create widget
  #   compteur get ?-option?
  #     get default value (or get default names list)
  #   compteur set ?-option value?...
  #     set default values (or get default values list)
  # ----------------------
  # operations:
  #   $w cget ?-option?
  #     get option value (or get option names list)
  #   $w config ?-option value?...
  #     set option values (or get option values list)
  #   $w value ?value?
  #     set value (or get value)
  # ----------------------
  # options:
  #   -bg         couleur d'arrière-plan d'un digit
  #   -count      nombre de digits
  #   -delay      délai de défilement
  #   -fg         couleur d'avant-plan d'un digit
  #   -font       police d'un digit
  #   -height     hauteur du compteur
  #   -value      valeurs du compteur (digits)
  #   -width      largeur du compteur
  # ######################

Configuration

Installation

Utilisation

  package require compteur

Script pkgIndex.tcl

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

Paquet

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

  namespace eval compteur \
  {
  # ######################
  #
  # paquet compteur
  #
  set version 1.0
  #
  # (C) ulis, 2008
  #
  # Licence NOL (No Obligation Licence)
  #
  # ----------------------
  # commands:
  #   compteur ?create? $w ?-option value?...
  #     create widget
  #   compteur get ?-option?
  #     get default value (or get default names list)
  #   compteur set ?-option value?...
  #     set default values (or get default values list)
  # ----------------------
  # operations:
  #   $w cget ?-option?
  #     get option value (or get option names list)
  #   $w config ?-option value?...
  #     set option values (or get option values list)
  #   $w value ?value?
  #     set value (or get value)
  # ----------------------
  # options:
  #   -bg         couleur d'arrière-plan d'un digit
  #   -count      nombre de digits
  #   -delay      délai de défilement
  #   -fg         couleur d'avant-plan d'un digit
  #   -font       police d'un digit
  #   -height     hauteur du compteur
  #   -value      valeurs du compteur (digits)
  #   -width      largeur du compteur
  # ######################

    namespace export compteur

    package require Tk
    package provide compteur $version

    variable {}
    array set {} \
    {
      -bg         red
      -count      10
      -delay      5
      -fg         gold
      -font       {Courier -38 bold}
      -height     40
      -value      0
      -width      240
    }

    proc compteur {{oper ""} args} \
    {
      if {[string match .* $oper]} \
      {
        set args [linsert $args 0 $oper]
        set oper create
      }
      set code [catch \
      {
        switch -glob -- $oper \
        {
          get     { uplevel 1 ::compteur::compteur:get    $args }
          set     { uplevel 1 ::compteur::compteur:set    $args }
          cre*    { uplevel 1 ::compteur::compteur:create $args }
          default { error "use is 'compteur create|get|set|\$w ...'" }
        }
      } result]
      return -code $code $result
    }

    proc compteur:get {args} \
    {
      variable {}
      set count [llength $args]
      if {$count > 1} { error "use is 'compteur get ?-option?" }
      switch $count \
      {
        0   \
        {
          return [lsort [array names {} -*]]
        }
        1   \
        {
          set option [lindex $args 0]
          switch -glob -- $option \
          {
            -bac*   -
            -bg     { set (-bg) }
            -cou*   { set (-count) }
            -del*   { set (-delay) }
            -for*   -
            -fg     { set (-fg) }
            -fon*   { set (-font) }
            -hei*   { set (-height) }
            -val*   { set (-value) }
            -wid*   { set (-width) }
            default { error "unknown compteur option '$option'" }
          }
        }
      }
    }

    proc compteur:set {args} \
    {
      variable {}
      set count [llength $args]
      if {$count % 2 != 0} { error "use is 'compteur set ?-option value?..." }
      if {$count == 0} \
      {
        set result [list]
        foreach name [lsort [array names {} -*]] \
        { lappend result $name $($name) }
        return $result
      } \
      else \
      {
        foreach {key value} $args \
        {
          switch -glob -- $key \
          {
            -bac*   -
            -bg     { set (-bg) $value }
            -cou*   { set (-count) $value }
            -del*   { set (-delay) $value }
            -for*   -
            -fg     { set (-fg) $value }
            -fon*   { set (-font) $value }
            -hei*   { set (-height) $value }
            -val*   { set (-value) $value }
            -wid*   { set (-width) $value }
            default { error "unknown compteur option '$option'" }
          }
        }
      }
    }

    proc compteur:create {w args} \
    {
      variable {}
      # create widget
      canvas $w -bd 0 -highlightt 0
      # create megawidget reference
      rename $w ::compteur::_$w
      eval [format \
      {
        proc ::%s {args} \
        { uplevel 1 ::compteur::compteur:dispatch %s $args }
      } $w $w]
      # configure
      set ($w:-width) 1
      set ($w:-count) 1
      set defaults [list]
      foreach key [array names {} -*] { lappend defaults $key $($key) }
      uplevel 1 ::compteur::compteur:config $w $defaults $args
      # return reference
      return $w
    }

    proc compteur:dispatch {w {oper ""} args} \
    {
      set code [catch \
      {
        switch -glob -- $oper \
        {
          cge*    { uplevel 1 ::compteur::compteur:cget $w $args }
          con*    { uplevel 1 ::compteur::compteur:config $w $args }
          val*    { uplevel 1 ::compteur::compteur:value $w $args }
          default { error "use is '\$w cget|config ...'" }
        }
      } result]
      return -code $code $result
    }

    proc compteur:cget {w args} \
    {
      variable {}
      set count [llength $args]
      if {$count > 1} { error "use is '$w cget ?-option?" }
      switch $count \
      {
        0   \
        {
          return [lsort [array names {} -*]]
        }
        1   \
        {
          set option [lindex $args 0]
          switch -glob -- $option \
          {
            -bac*   -
            -bg     { set ($w:-bg) }
            -cou*   { set ($w:-count) }
            -del*   { set ($w:-delay) }
            -for*   -
            -fg     { set ($w:-fg) }
            -fon*   { set ($w:-font) }
            -hei*   { set ($w:-height) }
            -val*   { set ($w:-value) }
            -wid*   { set ($w:-width) }
            default { error "unknown compteur option '$option'" }
          }
        }
      }
    }

    proc compteur:config {w args} \
    {
      variable {}
      set count [llength $args]
      if {$count % 2 != 0} { error "use is '$w config ?-option value?..." }
      if {$count == 0} \
      {
        set result [list]
        foreach name [lsort [array names {} -*]] \
        { lappend result $name $($w:$name) }
        return $result
      } \
      else \
      {
        set flag1 0
        set flag2 0
        set flag3 0
        set _w ::compteur::_$w
        foreach {key value} $args \
        {
          switch -glob -- $key \
          {
            -bac*   -
            -bg     { set:color $w -bg $value; set flag1 1 }
            -cou*   { set:positive $w -count $value; set flag2 1 }
            -del*   { set:positive $w -delay $value }
            -for*   -
            -fg     { set:color $w -fg $value; set flag1 1 }
            -fon*   { set:font $w -font $value; set flag2 1 }
            -hei*   { set:pixels $w -height $value; set flag2 1 }
            -val*   { set ($w:-value) $value; set flag3 1 }
            -wid*   { set:pixels $w -width $value; set flag2 1 }
            default { error "unknown compteur option '$option'" }
          }
        }
        # checks
        if {$flag1} { fix:aspect $w }
        if {$flag2} { fix:geometry $w }
        if {$flag3} { fix:value $w }
      }
    }

    proc compteur:value {w args} \
    {
      variable {}
      set count [llength $args]
      if {$count > 1} { error "use is '$w value ?value?..." }
      if {$count == 0} \
      {
        return $($w:-value)
      } \
      else \
      {
        set value [lindex $args 0]
        set ($w:-value) $value
        fix:value $w
      }
    }

    proc fix:aspect {w} \
    {
      variable {}
      # fix digits
      set _w ::compteur::_$w
      $_w itemconf rect -fill $($w:-bg)
      $_w itemconf text -fill $($w:-fg)
    }

    proc fix:geometry {w} \
    {
      variable {}
      # compute digit width
      set ($w:digit:width) [expr {$($w:-width) / $($w:-count)}]
      # check for overflow
      if {[string length $($w:-value)] > $($w:-count)} \
      { error "compteur overflow: '$($w:-value)' ($($w:-count) digits max)" }
      # fix canvas sizes
      set _w ::compteur::_$w
      $_w config -width $($w:-width) -height $($w:-height)
      # fix digits
      set dw $($w:digit:width)
      set dh $($w:-height)
      set x $($w:-width)
      for {set i 0} {$i < $($w:-count)} {incr i} \
      {
        incr x -$dw
        set x0 [expr {$x + 1}]
        set x1 [expr {$x + 2}]
        set x2 [expr {$x + $dw - 2}]
        set x3 [expr {$x + $dw - 1}]
        set y0 0
        set y1 2
        set y2 [expr {$dh - 2}]
        set y3 $dh
        lappend list $x1 $y3 $x0 $y2
        lappend list $x0 [expr {$y1 - 1}] $x1 $y0
        lappend list $x2 $y0 $x3 $y1
        incr x1
        incr x2 -1
        incr y2 -1
        incr y3
        lappend list $x3 $y2 $x2 $y3
        $_w coords digit$i-rect $list
        set x0 [expr {$x + 1}]
        $_w coords digit$i-text1 $x0 0
        $_w coords digit$i-text2 $x0 $($w:-height)
      }
    }

    proc fix:value {w} \
    {
      variable {}
      # check for overflow
      set value $($w:-value)
      if {[string length $value] > $($w:-count)} \
      { error "compteur overflow: '$value' ($($w:-count) digits max)" }
      # set value
      set i 0
      while {$value ne ""} \
      {
        set digit [string index $value end]
        set value [string range $value 0 end-1]
        set:digit $w $i $digit
        incr i
      }
    }

    proc set:color {w option value} \
    {
      variable {}
      set code [catch {winfo rgb . $value}]
      if {$code == 1} { error "bad color '$value'" }
      set ($w:$option) $value
    }

    proc set:positive {w option value} \
    {
      variable {}
      if {![string is integer -strict $value]} { error "invalid value: '$value'" }
      if {$value < 0} { error "negative value: '$value'" }
      set ($w:$option) $value
    }

    proc set:pixels {w option value} \
    {
      variable {}
      set code [catch {winfo pixels . $value}]
      if {$code == 1} { error "bad pixels distance value '$value'" }
      set ($w:$option) $value
    }

    proc set:font {w option value} \
    {
      variable {}
      set code [catch {font actual $value}]
      if {$code == 1} { error "bad font '$value'" }
      set ($w:$option) $value
    }

    proc set:digit {w i digit} \
    {
      variable {}
      if {![info exists ($w:digit:$i)]} { create:digit $w $i }
      if {$($w:actual:$i) != $digit} \
      {
        set ($w:final:$i) $digit
        roll:digit $w $i
      }
    }

    proc create:digit {w i} \
    {
      variable {}
      set _w ::compteur::_$w
      set dw $($w:digit:width)
      set dh $($w:-height)
      set x [expr {$($w:-width) - $($w:digit:width) * ($i + 1)}]
      set x0 [expr {$x + 1}]
      set x1 [expr {$x + 2}]
      set x2 [expr {$x + $dw - 2}]
      set x3 [expr {$x + $dw - 1}]
      set y0 0
      set y1 2
      set y2 [expr {$dh - 2}]
      set y3 $dh
      lappend list $x1 $y3 $x0 $y2
      lappend list $x0 [expr {$y1 - 1}] $x1 $y0
      lappend list $x2 $y0 $x3 $y1
      incr x1
      incr x2 -1
      incr y2 -1
      incr y3
      lappend list $x3 $y2 $x2 $y3
      $_w create polygon $list -fill $($w:-bg) \
        -tags [list digit$i digit$i-rect rect]
      $_w create text $x 0 -anchor nw \
        -tags [list digit$i digit$i-text1 text] \
        -text "" -font $($w:-font) -fill $($w:-fg)
      $_w create text $x $dh -anchor nw \
        -tags [list digit$i digit$i-text2 text] \
        -text "" -font $($w:-font) -fill $($w:-fg)
      set ($w:digit:$i) 1
      set ($w:actual:$i) 0
      set ($w:rolling:$i) 0
    }

    proc roll:digit {w i {recurse 0}} \
    {
      variable {}
      set _w ::compteur::_$w
      set actual $($w:actual:$i)
      set final $($w:final:$i)
      if {$actual == $final} \
      {
        set ($w:rolling:$i) 0
        return
      } \
      else \
      {
        if {$recurse || !$($w:rolling:$i)} \
        {
          set ($w:rolling:$i) 1
          $_w itemconfig digit$i-text2 -text $final
          set ($w:actual:$i) $final
          set ($w:position:$i) 0
          after 1 ::compteur::_roll:digit $w $i
        }
      }
    }

    proc _roll:digit {w i} \
    {
      variable {}
      set _w ::compteur::_$w
      if {$($w:position:$i) < $($w:-height)} \
      {
        $_w move digit$i-text1 0 -1
        $_w move digit$i-text2 0 -1
        incr ($w:position:$i)
        after $($w:-delay) ::compteur::_roll:digit $w $i
        update
      } \
      else \
      {
        set actual [$_w itemcget digit$i-text2 -text]
        $_w itemconf digit$i-text1 -text $actual
        $_w move digit$i-text1 0 $($w:-height)
        $_w move digit$i-text2 0 $($w:-height)
        after $($w:-delay) ::compteur::roll:digit $w $i 1
      }
    }
  }
  namespace import ::compteur::*

Demo

  # ###################
  #   demo
  # ###################

  package require compteur

  grid [compteur .cp -value "      " -width 138 -count 6]

  set ::value 0
  proc repeat {} \
  {
    set incr [expr {int(100 * rand())}]
    incr ::value $incr
    .cp value $::value
    after [expr {int(1000 * rand())}] repeat
  }
  repeat

Voir aussi


Discussion


Catégorie Paquet