a(Simple)Deck

 

ulis, 2006-01-20. Un package rapidement hacké pour empiler des frames.


Pourquoi

Pour tester les tableaux de widgets et les tableaux de procédures :

  frame ${w}.f($w:id))
  proc ::deck::($w:$index) {} $value

Comment

Avec humour.


Installation


Utilisation

  package require ASimpleDeck
  deck itemset -script {myProc %index%}
  deck .d -bd 1 -relief ridge -padx 10 -pady 10
  foreach {index color row1 col1 row2 col2} \
  {
    0   red     0   0   1   0
    1   green   0   0   0   1
    2   orange  1   0   0   0
    3   blue    0   1   0   0
  } \
  {
    set f($index) [.d create]
    label $f($index).l -text $index
    canvas $f($index).c -bd 1 -relief groove \
      -width 50 -height 50 -bg $color
  }

création d'un widget

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

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

  deck get <option>

modification d'une valeur par défaut

  deck set [<option> <value>]...

récupération de la valeur par défaut d'une option de frame

  deck itemget <option>

modification de la valeur par défaut d'options de frame

  deck itemset [<option> <value>]...
  -bg           couleur de fond
  -background   couleur de fond
  -bd           largeur de bordure
  -borderwidth  largeur de bordure
  -height       hauteur
  -relief       relief
  -width        largeur
  -padx         espacement gauche et droit
  -pady         espacement haut et bas
  -bg           couleur de fond
  -background   couleur de fond
  -height       hauteur
  -padx         espacement gauche et droit
  -pady         espacement haut et bas
  -script       script appelé lors de l'activation du frame
  -sticky       positionnement du frame
  -tags         tags associés au frame

activation d'un frame

  <path> activate index|tag

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 du nombre de frames

  <path> count

création d'un frame

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

destruction d'un frame

  <path> destroy index|tag

paths de frames

  <path> frames [index|tag]...

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

  <path> itemcget <option>

modification de la valeur des options de frame

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

Package ASimpleDeck.tcl

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

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

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

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

    package provide ASimpleDeck $version

    package require Tk

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

      namespace export deck

    # ====================
    #
    #   global variables
    #
    # ====================
    variable {}
    array set {} \
    {
      -bd         1
      -bg         ""
      -height     100
      -padx       0
      -pady       0
      -relief     groove
      -width      100
      :-bg        ""
      :-padx      0
      :-pady      0
      :-script    {}
      :-sticky    nsew
      :-tags      {}
    }
    set w ._deck_
    canvas $w
    set (bg) [$w cget -bg]
    destroy $w
    unset w

    # ====================
    #
    #   deck proc
    #
    # ====================

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

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

    proc deck:get {get args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { error "use is 'deck get key'" }
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -bg       -
        -bac*     { set (-bg) }
        -bd       -
        -bor*     { set (-bd) }
        -hei*     { set (-height) }
        -rel*     { set (-relief) }
        -wid*     { set (-width) }
        :-bac*    -
        :-bg      { set (:-bg) }
        :-padx    { set (:-padx) }
        :-pady    { set (:-pady) }
        :-scr*    { set (:-script) }
        :-sti*    { set (:-sticky) }
        :-tag*    { set (:-tags) }
        default \
        { error "unknown deck default option '$key'" }
      }
    }

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

    proc deck:set {set args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is 'deck set \[key value]...'" }
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -bg     -
          -bac*   { set (-bg) $value }
          -bd     -
          -bor*   { set (-bd) $value }
          -hei*   { set (-height) $value }
          -rel*   { set (-relief) $value }
          -wid*   { set (-width) $value }
          :-bac*    -
          :-bg    { set (:-bg) $value }
          :-padx  { set (:-padx) $value }
          :-pady  { set (:-pady) $value }
          :-scr*  { set (:-script) $value }
          :-sti*  { set (:-sticky) $value }
          :-tag*  { set (:-tags) $value }
          default \
          { error "unknown deck default option '$key'" }
        }
      }
    }

    # ====================
    #
    #   iget proc
    #
    # ====================

    proc deck:iget {iget args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { error "use is 'deck itemget key'" }
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -bac*    -
        -bg      { set (:-bg) }
        -padx    { set (:-padx) }
        -pady    { set (:-pady) }
        -scr*    { set (:-script) }
        -sti*    { set (:-sticky) }
        -tag*    { set (:-tags) }
        default \
        { error "unknown deck frame default option '$key'" }
      }
    }

    # ====================
    #
    #   iset proc
    #
    # ====================

    proc deck:iset {iset args} \
    {
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is 'deck itemset \[key value]...'" }
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -bac*    -
          -bg    { set (:-bg) $value }
          -padx  { set (:-padx) $value }
          -pady  { set (:-pady) $value }
          -scr*  { set (:-script) $value }
          -sti*  { set (:-sticky) $value }
          -tag*  { set (:-tags) $value }
          default \
          { error "unknown deck frame default option '$key'" }
        }
      }
    }

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

    proc deck:create {w args} \
    {
      variable {}
      # initial options
      set initial [list]
      foreach key [array names {} -*] \
      { lappend initial $key $($key) }
      # create frame & canvas
      frame $w
      canvas $w.c -highlightt 0
      grid $w.c -row 0 -column 0
      after 0 update
      # build reference
      rename ::$w ::deck::_$w
      set ($w:frame) ::deck::_$w
      interp alias {} ::$w {} ::deck::deck:dispatch $w
      # set options
      set ($w:count) 0
      set ($w:id) 0
      if {$initial != ""} { uplevel 1 ::deck::deck:config $w $initial }
      if {$args != ""} { uplevel 1 ::deck::deck:config $w $args }
      # activate first frame
      if {$($w:count) > 0} { ::deck::deck:activate 0 }
      # return reference
      return $w
    }

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

    proc deck:dispatch {w args} \
    {
      puts "deck:dispatch $w {$args}"
      set cmd [lindex $args 0]
      set args [lrange $args 1 end]
      set rc [catch \
      {
        switch -glob -- -$cmd \
        {
          -act*     { return [uplevel 1 ::deck::deck:activate $w $args] }
          -cge*     { return [uplevel 1 ::deck::deck:cget $w $args] }
          -con*     { return [uplevel 1 ::deck::deck:config $w $args] }
          -cou*     { return [uplevel 1 ::deck::deck:count $w $args] }
          -cre*     { return [uplevel 1 ::deck::deck:icreate $w $args] }
          -des*     { return [uplevel 1 ::deck::deck:idestroy $w $args] }
          -fra*     { return [uplevel 1 ::deck::deck:frames $w $args] }
          -itemcg*  { return [uplevel 1 ::deck::deck:icget $w $args] }
          -itemco*  { return [uplevel 1 ::deck::deck:iconfig $w $args] }
          default \
          { error "unknown deck operation '$cmd'. Should be activate, cget, config, count, create, destroy, itemcget or itemconfig." }
        }
      } msg]
      if {$rc == 1} { return -code error $msg } else { return $msg }
    }

    # ====================
    #
    #   count proc
    #
    # ====================

    proc deck:count {w args} \
    {
      variable {}
      if {[llength $args] > 0} \
      { error 'use is 'path count'" }
      return $($w:count)
    }

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

    proc deck:cget {w args} \
    {
      variable {}
      if {[llength $args] != 1} \
      { error "use is 'path cget key'" }
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -bg     -
        -bac*   { set ($w:-bg) }
        -bd     -
        -bor*   { set ($w:-bd) }
        -cou*   { set ($w:-count) }
        -hei*   { set ($w:-height) }
        -padx   { set ($w:-padx) }
        -pady   { set ($w:-pady) }
        -rel*   { set ($w:-relief) }
        -wid*   { set ($w:-width) }
        default \
        { error "unknown deck option '$key'" }
      }
    }

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

    proc deck:config {w args} \
    {
      puts "deck:config $w {$args}"
      variable {}
      if {[llength $args] % 2 != 0} \
      { error "use is 'path config \[key value]...'" }
      set sflag 0
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -bg       -
          -bac*     \
          {
            set ($w:-bg) $value
            if {$value == ""} { set value [$w.c cget -bg] }
            $($w:frame) config -bg $value
          }
          -bd       -
          -bor*     \
          {
            set ($w:-bd) $value
            $($w:frame) config -bd $value
          }
          -hei*     { set ($w:-height) $value; set sflag 1 }
          -padx     { set ($w:-padx) $value; set sflag 1 }
          -pady     { set ($w:-pady) $value; set sflag 1 }
          -rel*     \
          {
            set ($w:-relief) $value
            $($w:frame) config -relief $value
          }
          -wid*     { set ($w:-width) $value; set sflag 1 }
          default \
          { error "unknown deck option '$key'" }
        }
      }
      if {$sflag} \
      {
        set padx $($w:-padx)
        set padx1 [lindex $padx 0]
        set padx2 [lindex $padx 1]
        if {$padx2 == ""} { set padx2 $padx1 }
        set pady $($w:-pady)
        set pady1 [lindex $pady 0]
        set pady2 [lindex $pady 1]
        if {$pady2 == ""} { set pady2 $pady1 }
        set width [expr {$($w:-width) - $padx1 - $padx2}]
        set height [expr {$($w:-height) - $pady1 - $pady2}]
        $w.c config -width $width -height $height
        $($w:frame) config -padx $padx -pady $pady
      }
    }

    # ====================
    #
    #   icget proc
    #
    # ====================

    proc deck:icget {w args} \
    {
      variable {}
      if {[llength $args] != 2} \
      { error "use is 'path itemcget tag|index option'" }
      set index [deck:getIndexes $w [lindex $args 0]]
      if {[llength $index] != 1} \
      { error "itemcget can't get option values for [llength $index] frame(s). But only for one frame." }
      set key [lindex $args 1]
      switch -glob $key \
      {
        -bac*  -
        -bg    { set ($w:$index:-bg) }
        -padx  { set ($w:$index:-padx) }
        -pady  { set ($w:$index:-pady) }
        -scr*  { set ($w:$index:-script) }
        -sti*  { set ($w:$index:-sticky) }
        -tag*  { set ($w:$index:-tags) }
        default \
        { error "unknown deck frame option '$key'" }
      }
    }

    # ====================
    #
    #   iconfig proc
    #
    # ====================

    proc deck:iconfig {w args} \
    {
      variable {}
      set tag [lindex $args 0]
      set args [lrange $args 1 end]
      if {[llength $args] % 2 != 0} \
      { return -code error "use is 'path itemconfig tag|index \[key value]...'" }
      set indexes [deck:getIndexes $w $tag]
      foreach index $indexes \
      {
        foreach {key value} $args \
        {
          switch -glob -- $key \
          {
            -bac*  -
            -bg    \
            {
              set ($w:$index:-bg) $value
              if {$value == ""} { set value [$w.c cget -bg] }
              $($w:$index:frame) config -bg $value
            }
            -padx  \
            {
              set ($w:$index:-padx) $value
              $($w:$index:frame) config -padx $value
            }
            -pady  \
            {
              set ($w:$index:-pady) $value
              $($w:$index:frame) config -pady $value
            }
            -scr*  \
            {
              set ($w:$index:-script) $value
              proc ::deck::($w:$index) {} $value
            }
            -sti*  \
            {
              set ($w:$index:-sticky) $value
              if {[info exists ($w:current)] && $($w:current) == $index} \
              {
                grid $($w:$index:frame) -row 0 -column 0 \
                  -sticky $value
              }
            }
            -tag*  { set ($w:$index:-tags) $value }
            default \
            { error "unknown deck frame option '$key'" }
          }
        }
      }
    }

    # ====================
    #
    #   getIndexes proc
    #
    # ====================

    proc deck:getIndexes {w tag} \
    {
      variable {}
      set indexes [list]
      if {[string is integer -strict $tag]} \
      { lappend indexes $tag } \
      else \
      {
        for {set index 0} {$index < $($w:count)} {incr index} \
        {
          if {[lsearch -exact $($w:$index:tags) $tag] > -1} \
          { lappend indexes $index }
        }
      }
      return $indexes
    }

    # ====================
    #
    #   frames proc
    #
    # ====================

    proc deck:frames {w args} \
    {
      variable {}
      # get ids
      set ids [list]
      foreach tag $args \
      { set indexes [concat $indexes [deck:getIndexes $tag]] }
      # return frames
      set frames [list]
      foreach index $indexes \
      { lappend frames $($w:$index:frame) }
      return $frames
    }

    # ====================
    #
    #   icreate proc
    #
    # ====================

    proc deck:icreate {w args} \
    {
      variable {}
      set count $($w:count)
      set index $count
      if {[llength $args] > 0 && ![string match -* [lindex $args 0]]} \
      {
        set index [lindex $args 0]
        set args [lrange $args 1 end]
      }
      if {$count > 0 && $index < $count} \
      {
        for {set i [expr {$count - 1}]} {$i >= $index} {incr i -1} \
        { set ($w:[expr {$i + 1}]:frame) $($w:$i:frame) }
      }
      set iw ${w}.f([incr ($w:id)])
      set ($w:$index:frame) $iw
      frame $iw
      set initial [list]
      foreach name [array names {} :-*] \
      {
        set key [string range $name 1 end]
        lappend initial $key $($name)
      }
      eval deck:iconfig $w $index $initial
      eval deck:iconfig $w $index $args
      incr ($w:count)
      return $iw
    }

    # ====================
    #
    #   activate proc
    #
    # ====================

    proc deck:activate {w args} \
    {
      variable {}
      if {![string is integer -strict $args]} \
      { error "use is 'path activate index'" }
      set index $args
      if {$index < 0 || $index >= $($w:count)} \
      { error "frame index 'index' is out of range" }
      if {[info exists ($w:current)]} \
      { grid forget $($w:$($w:current):frame) }
      grid $($w:$index:frame) -row 0 -column 0 \
        -sticky $($w:$index:-sticky)
      event generate $w <<DeckSelect>> -serial $index
      deck:invoke $w $index
      set ($w:current) $index
    }

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

    proc deck:invoke {w tag} \
    {
      variable {}
      set indexes [deck:getIndexes $w $tag]
      foreach index $indexes \
      {
        set script $($w:$index:-script)
        if {$script != ""} \
        {
          set map [list %index% $index]
          eval [string map $map $script]
        }
      }
    }

  }

  namespace import ::deck::deck

Script pkgIndex.tcl

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

Demo

  package require ASimpleDeck

  button .l -width 3 -text < -command left
  label .c -width 5 -text 1
  button .r -width 3 -text > -command right
  grid .l .c .r
  deck itemset -script {.c config -text %index%}
  deck .d -bd 1 -relief ridge -padx 10 -pady 10
  grid .d -padx 10 -pady 10 -columnspan 3
  foreach {index color row1 col1 row2 col2} \
  {
    0   red     0   0   1   0
    1   green   0   0   0   1
    2   orange  1   0   0   0
    3   blue    0   1   0   0
  } \
  {
    set f($index) [.d create]
    label $f($index).l -text $index
    canvas $f($index).c -bd 1 -relief groove \
      -width 50 -height 50 -bg $color
    grid $f($index).l -row $row1 -column $col1 -sticky ew
    grid $f($index).c -row $row2 -column $col2 -sticky nsew
    grid rowconfigure $f($index) $row2 -weight 1
    grid columnconfigure $f($index) $col2 -weight 1
    after [expr {$index * 1000}] .d activate $index
  }
  set count 4
  proc left {} \
  {
    set current [.c cget -text]
    if {$current < 1} { return }
    .d activate [incr current -1]
  }
  proc right {} \
  {
    set current [.c cget -text]
    if {$current >= $::count - 1} { return }
    .d activate [incr current +1]
  }
  focus -force .
  raise .

Voir aussi


Discussion

ulis Les tableaux de widgets et les tableaux de procédures peuvent être utiles. En tout cas, ça marche très bien.


Catégorie Paquet | Catégorie Interface utilisateur