SR Technology WTK Repo
Check-in [b88021946e]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Removed several debugging puts statements Fixed some snitizisms I had missed in the canvas implementation. Rather than use delegation to re-use the "event_fire" method, I've simply created an object_event_fire method for the canvas to distinguish between widget bindings and canvas object bindings
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:b88021946e23f2d50c70ebcb2d93bb1c3fcde57c
User & Date: seandeelywoods 2013-02-12 15:35:58
Context
2013-02-12
20:29
Added oval, circle, and arc types to the canvas/wtk.js Modified the "graft" keyword such that calling the method of a graft with no arguments returns the object The wtk widget classes now fall back to the traditional unknown handler if the first argument does not look like a tkpath check-in: bb947dbc82 user: seandeelywoods tags: trunk
15:35
Removed several debugging puts statements Fixed some snitizisms I had missed in the canvas implementation. Rather than use delegation to re-use the "event_fire" method, I've simply created an object_event_fire method for the canvas to distinguish between widget bindings and canvas object bindings check-in: b88021946e user: seandeelywoods tags: trunk
15:13
Ported code to TclOO. Demos all work. Integrated the Odie package to extend TclOO and add extra keywords and to make TclOO more snitlike. check-in: 833107b47e user: seandeelywoods tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to demo.tcl.

1
2
3
4
5
6
7
8
9
10

proc render {} {
  puts RENDER
  ::wtk::wm title . "Feet to Meters"
  
  ::wtk::grid [::wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
  ::wtk::grid columnconfigure .c 0 -weight 1; ::wtk::grid rowconfigure .c 0 -weight 1
  ::wtk::grid [::wtk::button .c.calc -text "Calculate" -radius 7 -bg #ffccff -fg darkgreen -command calculate] -column 0 -row 1 -sticky w
  ::wtk::grid [::wtk::entry .c.feet -width 7 -textvariable feet -bg GreenYellow -fg Red] -column 1 -row 1 -sticky we
  ::wtk::grid [::wtk::label .c.flbl -text "feet" -bg yellow] -column 2 -row 1 -sticky w


<







1
2

3
4
5
6
7
8
9

proc render {} {

  ::wtk::wm title . "Feet to Meters"
  
  ::wtk::grid [::wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
  ::wtk::grid columnconfigure .c 0 -weight 1; ::wtk::grid rowconfigure .c 0 -weight 1
  ::wtk::grid [::wtk::button .c.calc -text "Calculate" -radius 7 -bg #ffccff -fg darkgreen -command calculate] -column 0 -row 1 -sticky w
  ::wtk::grid [::wtk::entry .c.feet -width 7 -textvariable feet -bg GreenYellow -fg Red] -column 1 -row 1 -sticky we
  ::wtk::grid [::wtk::label .c.flbl -text "feet" -bg yellow] -column 2 -row 1 -sticky w

Changes to geomanagers/wtk-grid.tcl.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
    proc grid {w args} {
        variable widgets
        switch -exact -- $w {
            "columnconfigure" {}        
            "rowconfigure" {}
            default {
              set w [namespace tail $w]
              set wobj ::$w
              
              puts [list grid $w [info object class $wobj]]
              
              set parent [join [lrange [split $w .] 0 end-1] .]
              if {$parent eq ""} {set parent "."}
              if {![info exists widgets($parent)]} {error "no parent widget found"}
              if {![$wobj was_created]} {$wobj do_create}
              if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
              if {[dict keys $args -row]==""} {dict set args -row 0}
              ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"     







|
<
<
<







5
6
7
8
9
10
11
12



13
14
15
16
17
18
19
    proc grid {w args} {
        variable widgets
        switch -exact -- $w {
            "columnconfigure" {}        
            "rowconfigure" {}
            default {
              set w [namespace tail $w]
              set wobj ::$w              



              set parent [join [lrange [split $w .] 0 end-1] .]
              if {$parent eq ""} {set parent "."}
              if {![info exists widgets($parent)]} {error "no parent widget found"}
              if {![$wobj was_created]} {$wobj do_create}
              if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
              if {[dict keys $args -row]==""} {dict set args -row 0}
              ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"     

Changes to lib/wtk-base.tcl.

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
        variable created
        variable wobj
        variable postcreatemsgs
        variable propertiesDict
        variable options

        constructor {new_tkpath args} {
          puts [list WIDGET [info object class [self]] $new_tkpath $args]
          my variable id tkpath postcreatemsgs created options
          set created 0
          set postcreatemsgs {}
          set tkpath $new_tkpath
          if { $tkpath eq "." } {
            # used for root window only
            dict set propertiesDict class Toplevel
................................................................................
            my create ::$objname $objname {*}$args
            return $objname
          }
          error "Unknown method $objname. Valid: [info class methods [info object class [self]]]"
        }

        class_method option args {
          puts $args
        }

        method property_set {propertyKey value} {
            dict set propertiesDict {*}$propertyKey value
            return $value;
        }
        method property_has {args} {







|







 







|







64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
        variable created
        variable wobj
        variable postcreatemsgs
        variable propertiesDict
        variable options

        constructor {new_tkpath args} {
          #puts [list WIDGET [info object class [self]] $new_tkpath $args]
          my variable id tkpath postcreatemsgs created options
          set created 0
          set postcreatemsgs {}
          set tkpath $new_tkpath
          if { $tkpath eq "." } {
            # used for root window only
            dict set propertiesDict class Toplevel
................................................................................
            my create ::$objname $objname {*}$args
            return $objname
          }
          error "Unknown method $objname. Valid: [info class methods [info object class [self]]]"
        }

        class_method option args {
          puts "Option $args"
        }

        method property_set {propertyKey value} {
            dict set propertiesDict {*}$propertyKey value
            return $value;
        }
        method property_has {args} {

Changes to widgets/canvas.tcl.

10
11
12
13
14
15
16









17
18
19
20

21
22
23

24
25
26
27
28
29




30











31



32

33
34
35
36
37
38
39
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
  _wtkoption -width 100 {$JS.width=$V;$JS.style.width='${V}px';}
  _wtkoption -height 100 {$JS.height=$V;$JS.style.height='${V}px';}
  _wtkoption -background "#ffffff" {$JS.style.background='$V';}

  variable mousedown 0
  variable nextid 1
  variable items









  
  method do_createjs {} {return "wtk.createCanvas('[my id]');"}
  
  method create {itemtype args} {

      if {$itemtype ni [my property itemtypes]} {error "bad item type"}
      lassign [_parseCoordsAndOptions $args [my property opts.$itemtype]] coords opts
      set cid $nextid; incr nextid

      set items($cid) [list type $itemtype coords $coords]
      ::wtk::toclient "wtk.objs\['[my id]'\].createItem($cid,'$itemtype',\[[join $coords ,]\],$opts);"
      return $cid
  }
  
  method wtk_event {which args} {; # todo - make generic




      if {$which=="mousedown"} {set mousedown 1; set subs [list %x [lindex $args 0] %y [lindex $args 1]]; $W event_fire "<1>" $subs; if {[lindex $args 3]!=""} {$self event_fire [lindex $args 3] "<1>" $subs}}











      if {$which=="mousemove"} {if {$mousedown} {set ev "<B1-Motion>"} else {set ev "<Motion>"}; $W event_fire $ev [list %x [lindex $args 0] %y [lindex $args 1]]}



      if {$which=="mouseup"} {set mousedown 0; $W event_fire "<B1-Release>" [list %x [lindex $args 0] %y [lindex $args 1]]}

  }
  
  method _parseCoordsAndOptions {s optmap} {
      set coords ""; set inopts 0; set opts ""
      foreach {x y} [split $s] {
          if {!$inopts && [string is integer $x]} {
              if {![string is integer $y]} {error "odd number of coordinates"}
................................................................................
      return [list $coords "\{[join $opts ,]\}"]
  }

  variable bindings
  
  method bind {id ev script} {set bindings(${id},$ev) $script}
  
  method event_fire {id ev subs} {
    if {[info exists bindings(${id},$ev)]} {
      uplevel #0 [string map $subs $bindings(${id},$ev)]
    }
  }
}








>
>
>
>
>
>
>
>
>




>
|
|
|
>
|
|
|


|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>







 







|






10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
  _wtkoption -width 100 {$JS.width=$V;$JS.style.width='${V}px';}
  _wtkoption -height 100 {$JS.height=$V;$JS.style.height='${V}px';}
  _wtkoption -background "#ffffff" {$JS.style.background='$V';}

  variable mousedown 0
  variable nextid 1
  variable items
  
  constructor args {
    set path [next {*}$args]
    my variable nextid mousedown items
    set nextid 1
    set mousedown 0
    
    return $path
  }
  
  method do_createjs {} {return "wtk.createCanvas('[my id]');"}
  
  method create {itemtype args} {
    my variable nextid
    if {$itemtype ni [my property itemtypes]} {error "bad item type"}
    lassign [my _parseCoordsAndOptions $args [my property opts.$itemtype]] coords opts
    set cid $nextid
    incr nextid
    set items($cid) [list type $itemtype coords $coords]
    ::wtk::toclient "wtk.objs\['[my id]'\].createItem($cid,'$itemtype',\[[join $coords ,]\],$opts);"
    return $cid
  }
  
  method wtk_event {which args} {
      # todo - make generic
      my variable mousedown
      if {$which=="mousedown"} {
        set mousedown 1
        set subs [list %x [lindex $args 0] %y [lindex $args 1]]
        my event_fire "<1>" $subs
        if {[lindex $args 3]!=""} {
          my object_event_fire [lindex $args 3] "<1>" $subs
        }
      }
      if {$which=="mousemove"} {
        if {$mousedown} {
          set ev "<B1-Motion>"
        } else {
          set ev "<Motion>"
        }
        my event_fire $ev [list %x [lindex $args 0] %y [lindex $args 1]]
      }
      if {$which=="mouseup"} {
        set mousedown 0
        my event_fire "<B1-Release>" [list %x [lindex $args 0] %y [lindex $args 1]]
      }
  }
  
  method _parseCoordsAndOptions {s optmap} {
      set coords ""; set inopts 0; set opts ""
      foreach {x y} [split $s] {
          if {!$inopts && [string is integer $x]} {
              if {![string is integer $y]} {error "odd number of coordinates"}
................................................................................
      return [list $coords "\{[join $opts ,]\}"]
  }

  variable bindings
  
  method bind {id ev script} {set bindings(${id},$ev) $script}
  
  method object_event_fire {id ev subs} {
    if {[info exists bindings(${id},$ev)]} {
      uplevel #0 [string map $subs $bindings(${id},$ev)]
    }
  }
}