tk 0.1.0

data/sample/tktimer.rb

@@ -0,0 +1,51 @@
+#!/usr/bin/env ruby
+# frozen_string_literal: false
+# This script generates a counter with start and stop buttons.
+
+require "tk"
+$label = TkLabel.new {
+  text '0.00'
+  relief 'raised'
+  width 10
+  pack('side'=>'bottom', 'fill'=>'both')
+}
+
+TkButton.new {
+  text 'Start'
+  command proc {
+    if $stopped
+      $stopped = false
+      tick
+    end
+  }
+  pack('side'=>'left','fill'=>'both','expand'=>'yes')
+}
+TkButton.new {
+  text 'Stop'
+  command proc{
+    exit if $stopped
+    $stopped = true
+  }
+  pack('side'=>'right','fill'=>'both','expand'=>'yes')
+}
+
+$seconds=0
+$hundredths=0
+$stopped=true
+
+def tick
+  if $stopped then return end
+  Tk.after 50, proc{tick}
+  $hundredths+=5
+  if $hundredths >= 100
+    $hundredths=0
+    $seconds+=1
+  end
+  $label.text format("%d.%02d", $seconds, $hundredths)
+end
+
+root = Tk.root
+root.bind "Control-c", proc{root.destroy}
+root.bind "Control-q", proc{root.destroy}
+Tk.root.focus
+Tk.mainloop

data/sample/tktimer2.rb

@@ -0,0 +1,48 @@
+#!/usr/bin/env ruby
+# frozen_string_literal: false
+# This script is a re-implementation of tktimer.rb with TkTimer(TkAfter) class.
+
+require "tk"
+
+# new notation :
+#   * symbols are acceptable as keys or values of the option hash
+#   * the parent widget can be given by :parent key on the option hash
+root = TkRoot.new(:title=>'timer sample')
+label = TkLabel.new(:parent=>root, :relief=>:raised, :width=>10) \
+               .pack(:side=>:bottom, :fill=>:both)
+
+# define the procedure repeated by the TkTimer object
+tick = proc{|aobj| #<== TkTimer object
+  cnt = aobj.return_value + 5 # return_value keeps a result of the last proc
+  label.text format("%d.%02d", *(cnt.divmod(100)))
+  cnt #==> return value is kept by TkTimer object
+      #    (so, can be send to the next repeat-proc)
+}
+
+timer = TkTimer.new(50, -1, tick).start(0, proc{ label.text('0.00'); 0 })
+        # ==> repeat-interval : (about) 50 ms,
+        #     repeat : infinite (-1) times,
+        #     repeat-procedure : tick (only one, in this case)
+        #
+        # ==> wait-before-call-init-proc : 0 ms,
+        #     init_proc : proc{ label.text('0.00'); 0 }
+        #
+        # (0ms)-> init_proc ->(50ms)-> tick ->(50ms)-> tick ->....
+
+TkButton.new(:text=>'Start') {
+  command proc{ timer.continue unless timer.running? }
+  pack(:side=>:left, :fill=>:both, :expand=>true)
+}
+TkButton.new(:text=>'Restart') {
+  command proc{ timer.restart(0, proc{ label.text('0.00'); 0 }) }
+  pack(:side=>:left, :fill=>:both, :expand=>true)
+}
+TkButton.new(:text=>'Stop') {
+  command proc{ timer.stop if timer.running? }
+  pack('side'=>'right','fill'=>'both','expand'=>'yes')
+}
+
+ev_quit = TkVirtualEvent.new('Control-c', 'Control-q')
+Tk.root.bind(ev_quit, proc{Tk.exit}).focus
+
+Tk.mainloop

data/sample/tktimer3.rb

@@ -0,0 +1,60 @@
+#!/usr/bin/env ruby
+# frozen_string_literal: false
+# This script is a re-implementation of tktimer.rb with TkTimer(TkAfter) class.
+
+require "tk"
+
+# new notation :
+#   * symbols are acceptable as keys or values of the option hash
+#   * the parent widget can be given by :parent key on the option hash
+root = TkRoot.new(:title=>'timer sample')
+label = TkLabel.new(:parent=>root, :relief=>:raised, :width=>10) \
+               .pack(:side=>:bottom, :fill=>:both)
+
+# define the procedure repeated by the TkTimer object
+tick = proc{|aobj| #<== TkTimer object
+  cnt = aobj.return_value + 5 # return_value keeps a result of the last proc
+  label.text format("%d.%02d", *(cnt.divmod(100)))
+  cnt #==> return value is kept by TkTimer object
+      #    (so, can be send to the next repeat-proc)
+}
+
+timer = TkTimer.new(50, -1, tick).start(0, proc{ label.text('0.00'); 0 })
+        # ==> repeat-interval : (about) 50 ms,
+        #     repeat : infinite (-1) times,
+        #     repeat-procedure : tick (only one, in this case)
+        #
+        # ==> wait-before-call-init-proc : 0 ms,
+        #     init_proc : proc{ label.text('0.00'); 0 }
+        #
+        # (0ms)-> init_proc ->(50ms)-> tick ->(50ms)-> tick ->....
+
+b_start = TkButton.new(:text=>'Start', :state=>:disabled) {
+  pack(:side=>:left, :fill=>:both, :expand=>true)
+}
+
+b_stop  = TkButton.new(:text=>'Stop', :state=>:normal) {
+  pack('side'=>'left', 'fill'=>'both', 'expand'=>'yes')
+}
+
+b_start.command {
+  timer.continue
+  b_stop.state(:normal)
+  b_start.state(:disabled)
+}
+
+b_stop.command {
+  timer.stop
+  b_start.state(:normal)
+  b_stop.state(:disabled)
+}
+
+TkButton.new(:text=>'Reset', :state=>:normal) {
+  command { timer.reset }
+  pack(:side=>:right, :fill=>:both, :expand=>:yes)
+}
+
+ev_quit = TkVirtualEvent.new('Control-c', 'Control-q')
+Tk.root.bind(ev_quit, proc{Tk.exit}).focus
+
+Tk.mainloop

data/sample/tktree.rb

@@ -0,0 +1,104 @@
+# frozen_string_literal: false
+##########################################################################
+# TkTree widget class
+#
+#    see <http://wiki.tcl.tk/10615>
+#
+#  Note:  optional argument '-font' of the Tcl library is changed to
+#         'itemfont' on this Ruby library, because of avoiding font
+#         operation trouble in 'initialize' method  ( see the following
+#         test script ).
+#
+##########################################################################
+require 'tk'
+
+class TkTree < TkCanvas
+  TCL_SCRIPT_PATH = File.join(File.dirname(__FILE__), 'tktree.tcl')
+
+  def create_self(keys)
+    args = [@path]
+    if keys.kind_of?(Hash)
+      font = keys.delete('itemfont')
+#      font = hash_kv(font) if font.kind_of?(Hash)
+      keys['font'] = font if font
+#      args.concat(hash_kv(keys))
+      args << keys
+    end
+    begin
+      tk_call('::tktree::treecreate', *args)
+    rescue NameError, RuntimeError
+      Tk.load_tclscript(TkTree::TCL_SCRIPT_PATH)
+      tk_call('::tktree::treecreate', *args)
+    end
+  end
+
+  def newitem(itempath, keys = nil)
+    if keys.kind_of?(Hash)
+      keys = _symbolkey2str(keys)
+      font = keys.delete('itemfont')
+#      font = hash_kv(font) if font.kind_of?(Hash)
+      keys['font'] = font if font
+#      tk_call('::tktree::newitem', @path, itempath, *hash_kv(keys))
+      tk_call('::tktree::newitem', @path, itempath, keys)
+    else
+      tk_call('::tktree::newitem', @path, itempath)
+    end
+  end
+
+  def delitem(itempath)
+    tk_call('::tktree::delitem', @path, itempath)
+  end
+
+  def labelat(xpos, ypos)
+    tk_call('::tktree::delitem', @path, xpos, ypos)
+  end
+
+  def getselection
+    tk_call('::tktree::getselection', @path)
+  end
+
+  def setselection(itempath)
+    tk_call('::tktree::getselection', @path, itempath)
+  end
+end
+
+
+##########################################################################
+# test script
+##########################################################################
+if __FILE__ == $0
+  TkLabel.new(:text=><<EOL, :relief=>:ridge, :justify=>:left).pack
+
+ This is a sample to use a Tcl library script on Ruby/Tk.
+ This sample loads tktree.tcl (see <http://wiki.tcl.tk/10615>)
+ and calls functions of the Tcl script.
+EOL
+
+  items = %w(/group1/item1 /group1/item2 /group1/subgroup/item1 /group2/item1 /item1)
+
+  tr1 = TkTree.new.pack(:expand=>true, :fill=>:both)
+  tr1.focus
+
+  items.each{|item|
+    tr1.newitem(item,
+                :command=>proc{Tk.messageBox(:message=>"#{item} executed")})
+  }
+
+  f = TkFrame.new.pack(:expand=>true, :fill=>:both)
+  tr2 = TkTree.new(f, :bg=>'black', #:itemfont=>{:family=>'Times', :size=>14},
+                   :textcolor=>'red', :bd=>4, :relief=>:ridge,
+                   :selectbackground=>'darkBlue', :selectforeground=>'yellow',
+                   :selectborderwidth=>3, :linecolor=>'yellow') {
+    yscrollbar(TkScrollbar.new(f, :width=>10).pack(:side=>:right, :fill=>:y))
+    xscrollbar(TkScrollbar.new(f, :width=>10).pack(:side=>:bottom, :fill=>:x))
+    pack(:expand=>true, :fill=>:both)
+  }
+
+  items.each{|item|
+    tr2.newitem(item, :textcolor=>'green', :image=>'',
+                :itemfont=>{:family=>'Times', :size=>10},
+                :command=>proc{Tk.messageBox(:message=>"#{item} executed")})
+  }
+
+  Tk.mainloop
+end

data/sample/tktree.tcl

@@ -0,0 +1,305 @@
+#
+#  This Tcl/Tk script is quoted from <http://wiki.tcl.tk/10615>.
+#
+ package require Tk
+  namespace eval ::tktree {
+
+    # Images used for open and close state of subgroups
+    set ::tktree::imgcollapse [image create photo .tktreeopenbm -data {
+      R0lGODdhCQAJAIAAAAEBAf///ywAAAAACQAJAAACEISPoRvG614D80x5ZXyogwIAOw==}]
+    set ::tktree::imgexpand [image create photo .tktreeclosebm -data {
+      R0lGODdhCQAJAIAAAAEBAf///ywAAAAACQAJAAACEYSPoRu28KCSDSJLc44s3lMAADs=}]
+    ###Default images for groups and children
+    set ::tktree::imgsubgroups [image create photo .tktreeimgfolder -data {
+                R0lGODlhEAANAKIAANnZ2Xh4eLi4uPj4APj4+AAAAP///////yH5BAEAAAAA
+                LAAAAAAQAA0AAANkCIChiqDLITgyEgi6GoIjIyMYugCBpMsaWBA0giMjIzgy
+                UYBBMjIoIyODEgVBODIygiMjE1gQJIMyMjIoI1GAQSMjODIyghMFQSgjI4My
+                MhJYEDSCIyMjODJRgKHLXAiApcsMmAA7}]
+    set ::tktree::imgchildren [image create photo .tktreeimgfile -data {
+                R0lGODlhDQAQAKIAANnZ2Xh4ePj4+Li4uAAAAP///////////yH5BAEAAAAA
+                LAAAAAANABAAAANSGLoLgACBoqsRCBAoujqCASGDojtESCEihCREIjgUKLo8
+                hCGCpCsySIGiy0MYIki6IoMUKLo8hCGCpCsySIGiy0MYKLo8hIGiy0MYOLo8
+                SLrMCQA7}]
+
+    #### Swtich all subgroups of a layer to open or close
+    proc ::tktree::switchlayer {win opn {layer /}} {
+      variable cfg
+      foreach child $cfg($win,$layer:subgroups) {
+        set cfg($win,$child:open) $opn
+        switchlayer $win $opn $child
+      }
+      buildwhenidle $win
+    }
+
+    ####  will open or close the item given
+    proc ::tktree::switchstate {win item} {
+      set ::tktree::cfg($win,$item:open) [expr ! $::tktree::cfg($win,$item:open)]
+      buildwhenidle $win
+    }
+
+    #### Select the next item up or down
+    proc ::tktree::updown {win down} {
+      variable cfg
+      set index [lsearch -exact $cfg($win,sortlist) $cfg($win,selection)]
+      if {$down} {incr index} {incr index -1}
+      if {$index < 0} {set index end} elseif {$index >= [llength $cfg($win,sortlist)]} {set index 0}
+      setselection $win [lindex $cfg($win,sortlist) $index]
+    }
+
+    #### left-right button binding commands
+    proc ::tktree::leftright {win right} {
+      variable cfg
+      set item $cfg($win,selection)
+      set index [lsearch -exact $cfg($win,sortlist) $item]
+      set parentindex [lsearch -exact $cfg($win,sortlist) [file dirname $item]]
+      if {$parentindex == -1} {set parentindex [expr $index - 1]}
+      if {$cfg($win,$item:group)} {
+        if {$right} {
+          if {$cfg($win,$item:open)} {incr index} {set cfg($win,$item:open) 1}
+        } else {
+          if {$cfg($win,$item:open)} {set cfg($win,$item:open) 0} {set index $parentindex}
+        }
+      } else {
+        if {$right} {incr index} {set index $parentindex}
+      }
+      if {$index < 0} {set index end} elseif {$index >= [llength $cfg($win,sortlist)]} {set index 0}
+      setselection $win [lindex $cfg($win,sortlist) $index]
+      buildwhenidle $win
+    }
+
+    #### will return the pathname of the item at x and y cooridinates
+    proc ::tktree::labelat {win x y} {
+      set x [$win canvasx $x]; set y [$win canvasy $y]
+      foreach m [$win find overlapping $x $y $x $y] {
+        if {[info exists ::tktree::cfg($win,tag:$m)]} {return $::tktree::cfg($win,tag:$m)}
+      }
+      return ""
+    }
+
+    #### will return the path of the current selection in the given tree widget
+    proc ::tktree::getselection {win} {
+      return $::tktree::cfg($win,selection)
+    }
+
+    #### adjust the scrollview to show the selected item as needed
+    proc ::tktree::scrolladjust {win tag} {
+      update
+      set item [$win bbox $tag]
+      set region [$win cget -scrollregion]
+      foreach {axis idx1 idx2} {yview 1 3 xview 0 2} {
+        set range [expr abs([lindex $region $idx2]) - abs([lindex $region $idx1])]
+        set itemtop [lindex $item $idx1];  set itembot [lindex $item $idx2]
+        set viewtop [expr $range * [lindex [$win $axis] 0]]
+        set viewbot [expr $range * [lindex [$win $axis] 1]]
+        if {$itembot > $viewbot} {$win $axis moveto [expr ($itembot. - $viewbot + $viewtop) / $range]}
+        if {$itemtop < $viewtop} {$win $axis moveto [expr $itemtop. / $range]}
+      }
+    }
+
+    #### will set the current selection to the given item on the given tree
+    proc ::tktree::setselection {win item} {
+      variable cfg
+      if {![llength $cfg($win,sortlist)]} {return}
+      if {$item eq ""} {set item [lindex $cfg($win,sortlist) 0]}
+      if {![info exists cfg($win,$item:tag)]} {set item [lindex $cfg($win,sortlist) 0]}
+      if {[$win gettags $cfg($win,$item:tag)] ne ""} {
+        $win select from $cfg($win,$item:tag) 0
+        $win select to $cfg($win,$item:tag) end
+        set cfg($win,selection) $item
+        scrolladjust $win $cfg($win,$item:tag)
+      } {
+        setselection $win "/[lindex $cfg($win,/:sortlist) 0]"
+      }
+    }
+
+    #### will delete the item given from the tree given
+    proc ::tktree::delitem {win item} {
+      variable cfg
+      if {$item eq "/"} {
+        array unset cfg $win,* ; catch {destroy $win}
+      } {
+        set group [file dirname $item]
+        if {$cfg($win,$item:group)} {set type subgroups} {set type children}
+        set index [lsearch -exact $cfg($win,$group:$type) $item]
+        set cfg($win,$group:$type) [lreplace $cfg($win,$group:$type) $index $index]
+        array unset cfg $win,$item*
+        buildwhenidle $win
+      }
+    }
+
+    #### create a new item in the tree and rebuild the widget
+    proc ::tktree::newitem {win item args} {
+      variable cfg
+      if {[string index $item 0] ne "/"} {set item /$item}
+      if {[string index $item end] eq "/"} {
+        set subgroup 1
+        set type subgroups
+        set item [string range $item 0 end-1]
+        set cfg($win,$item:command) [list ::tktree::switchstate $win $item]
+      } {
+        set subgroup 0
+        set type children
+        set cfg($win,$item:command) {}
+      }
+      #Build parent group if needed
+      set group [file dirname $item]
+      if {![info exists cfg($win,$group:open)]} {newitem $win "$group\/"}
+      lappend cfg($win,$group:$type) $item
+      #Configure the new item
+      set cfg($win,$item:group) $subgroup
+      set cfg($win,$item:subgroups) {}
+      set cfg($win,$item:children) {}
+      set cfg($win,$item:sortlist) {}
+      set cfg($win,$item:tags) {}
+      set cfg($win,$item:open) 0
+      set cfg($win,$item:image) {}
+      set cfg($win,$item:textcolor) $cfg($win,textcolor)
+      set cfg($win,$item:font) $cfg($win,font)
+      if {$cfg($win,images)} {set cfg($win,$item:image) [eval list \$::tktree::img$type]}
+      foreach {confitem confval} $args {
+        switch -exact -- $confitem {
+          -textcolor  {set cfg($win,$item:textcolor) $confval}
+          -command    {set cfg($win,$item:command)   $confval}
+          -image      {set cfg($win,$item:image)     $confval}
+          -font       {set cfg($win,$item:font)      $confval}
+        }
+      }
+      buildwhenidle $win
+    }
+
+    #### Draw the given layer of the tree on the canvas starting at xposition
+    proc ::tktree::buildlayer {win layer xpos} {
+      variable cfg
+      #Record y positions for vertical line later on
+      set ystart $cfg($win,y); set yend $cfg($win,y)
+      if {$layer eq "/"} {set cfg($win,sortlist) ""}
+      foreach child $cfg($win,$layer:sortlist) {
+        lappend cfg($win,sortlist) $child
+        #Check spacing required for images
+        set imgwidth 0; set imgheight 0
+        if {[string length $cfg($win,$child:image)]} {
+          set imgwidth [expr  ([image width $cfg($win,$child:image)] + 2) / 2]
+          set imgheight [expr ([image height $cfg($win,$child:image)] + 2) / 2]
+        }
+        #find X-axis points for image, horiz line, and text
+        if {$imgwidth} {
+          set centerX [expr $imgwidth + $xpos + 7]
+          set rightX  [expr $xpos + 7]
+          set textX   [expr ($imgwidth * 2) + $xpos + 10]
+        } {
+          set centerX [expr $xpos + 10]
+          set rightX  [expr $centerX + 4]
+          set textX   [expr $rightX + 1]
+        }
+        #Find the proper amount to increment the y axis
+        set fontheight [lindex [font metrics $cfg($win,$child:font)] 5]
+        set yincr [expr ($fontheight + 1) / 2]
+        if {$imgheight > $yincr} {set yincr $imgheight}
+        incr cfg($win,y) $yincr
+        #Draw the horizonal line
+        $win create line $xpos $cfg($win,y) $rightX $cfg($win,y) -fill $cfg($win,linecolor)
+        set yend $cfg($win,y)
+        #Draw the image, if it exists
+        if {$imgwidth} {
+          set it [$win create image $centerX $cfg($win,y) -image $cfg($win,$child:image)]
+          $win bind $it <1> [list ::tktree::setselection $win $child]
+        }
+        #Draw text and store tags for reference
+        set cfg($win,$child:tag) [$win create text $textX $cfg($win,y) \
+            -text [file tail $child] -font $cfg($win,$child:font) -anchor w -tags x -fill $cfg($win,$child:textcolor)]
+        set cfg($win,tag:$cfg($win,$child:tag)) $child
+        #Command binding
+        $win bind $cfg($win,$child:tag) <1> [list ::tktree::setselection $win $child]
+        $win bind $cfg($win,$child:tag) <Double-1> $cfg($win,$child:command)
+        #next step up on the y axis
+        incr cfg($win,y) $yincr
+        #If its a group, add open-close functionality
+        if {$cfg($win,$child:group)} {
+          if {$cfg($win,$child:open)} {set img collapse} {set img expand}
+          set ocimg [$win create image $xpos [expr $cfg($win,y) - $yincr] -image [eval list \$::tktree::img$img]]
+          $win bind $ocimg <1> [list ::tktree::switchstate $win $child]
+          if {$cfg($win,$child:open)} {buildlayer $win $child $centerX}
+        }
+      }
+      #Vertical line
+      $win lower [$win create line $xpos [expr $ystart - 7] $xpos $yend -fill $cfg($win,linecolor)]
+    }
+
+    #### sort the layer by subgroups then children
+    proc ::tktree::sortlayer {win {layer /}} {
+      variable cfg
+      set cfg($win,$layer:subgroups) [lsort -dictionary $cfg($win,$layer:subgroups)]
+      set cfg($win,$layer:children) [lsort -dictionary $cfg($win,$layer:children)]
+      set cfg($win,$layer:sortlist) [join [list $cfg($win,$layer:subgroups) $cfg($win,$layer:children)]]
+      foreach group $cfg($win,$layer:subgroups) {sortlayer $win $group}
+    }
+
+    #### build the tree at the given path
+    proc ::tktree::buildtree {win} {
+      variable cfg
+      $win delete all
+      sortlayer $win
+      set xpos 5
+      set cfg($win,y) 5
+      #Draw global expand/contract button, if needed
+      if {[string length $cfg($win,/:subgroups)] && $cfg($win,expandall)} {
+        set exp 0
+        foreach subgroup $cfg($win,/:subgroups) {incr exp $cfg($win,$subgroup:open)}
+        if {$exp} {set type collapse} {set type expand}
+        set ocimg [$win create image 1 1 -image [eval list \$::tktree::img$type] -anchor w]
+        $win bind $ocimg <1> [list ::tktree::switchlayer $win [expr ! $exp]]
+      }
+      #Build the layers and set initial selection
+      buildlayer $win / $xpos
+      $win config -scrollregion [$win bbox all]
+      setselection $win $cfg($win,selection)
+    }
+
+    #### internal use - set up a handle to build the tree when everything is idle
+    proc ::tktree::buildwhenidle {win} {
+      catch {after cancel $::tktree::cfg($win,buildHandle)}
+      set ::tktree::cfg($win,buildHandle) [after idle [list ::tktree::buildtree $win]]
+    }
+
+    #### will create a new tree widget at the given path
+    proc ::tktree::treecreate {win args} {
+      variable cfg
+      #Default configuration for new tree
+      set cfg($win,selection) {}
+      set cfg($win,selidx) {}
+      set cfg($win,/:subgroups) {}
+      set cfg($win,/:children) {}
+      set cfg($win,/:open) 1
+      set cfg($win,images) 1
+      set cfg($win,expandall) 1
+      set cfg($win,linecolor)  black
+      set cfg($win,textcolor)  black
+      set cfg($win,font) {-family Helvetica -size 10}
+      #Parse and setup custom configuration options
+      set canvascfg ""
+      foreach {item val} $args {
+        switch -- $item {
+          -linecolor            {set cfg($win,linecolor) $val}
+          -textcolor            {set cfg($win,textcolor) $val}
+          -font                 {set cfg($win,font) $val}
+          -images               {set cfg($win,images) $val}
+          -expandall            {set cfg($win,expandall) $val}
+          default               {lappend canvascfg $item $val}
+        }
+      }
+      #Build the canvas
+      eval {canvas $win -takefocus 1} $canvascfg
+      bind $win <Destroy> [list ::tktree::delitem $win /]
+      bind $win <1>  [list focus $win]
+      bind $win <Return> {eval $::tktree::cfg(%W,[::tktree::getselection %W]:command)}
+      bind $win <space> {eval $::tktree::cfg(%W,[::tktree::getselection %W]:command)}
+      bind $win <Up>    [list ::tktree::updown $win 0]
+      bind $win <Down>    [list ::tktree::updown $win 1]
+      bind $win <Left>    [list ::tktree::leftright $win 0]
+      bind $win <Right>    [list ::tktree::leftright $win 1]
+
+      #Build the tree when idle
+      buildwhenidle $win
+    }
+ }
+