blob: 08adce28315767632e4c69f5605a68730b4eb40b (
plain)
1
2
3
4
5
6
7
8
9
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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
package provide kb-mode 0.1
set kbmode 1
proc kb-mode_init {canvas} {
puts "init kb-mode"
set self "kbcursor"
append_callback kb-mode key kb-mode_key
Kb_cursor new_as $self $canvas
$self draw
return $self
}
def Canvas kb-mode_key {x y key iso shift} {
set c [$self widget]
set step [$@kbcursor step]
if {$@keyprefix} {
$@kbcursor get_key $key
set @keyprefix 0
}
switch $key {
BackSpace {$self delete_selection}
Up {$@kbcursor move 0 -$step; if {$shift} {$self arrow_key 0 -$step}}
Down {$@kbcursor move 0 +$step; if {$shift} {$self arrow_key 0 +$step}}
Left {$@kbcursor move -$step 0; if {$shift} {$self arrow_key -$step 0}}
Right {$@kbcursor move +$step 0; if {$shift} {$self arrow_key +$step 0}}
t {$self kbcursor_select}
Return {$self return_key $x $y $key $iso $shift}
default {}
}
}
def Canvas kbcursor_move_up {} {$@kbcursor move 0 -[$@kbcursor step]}
def Canvas kbcursor_move_down {} {$@kbcursor move 0 [$@kbcursor step]}
def Canvas kbcursor_move_left {} {$@kbcursor move -[$@kbcursor step] 0}
def Canvas kbcursor_move_right {} {$@kbcursor move [$@kbcursor step] 0}
def Canvas move_selection_up {} {$self arrow_key 0 -[$@kbcursor step]}
def Canvas move_selection_down {} {$self arrow_key 0 +[$@kbcursor step]}
def Canvas move_selection_left {} {$self arrow_key -[$@kbcursor step] 0}
def Canvas move_selection_right {} {$self arrow_key 0 +[$@kbcursor step] 0}
class_new Kb_cursor {View}
def Kb_cursor init {canvas} {
super
set @canvas $canvas
set @x 200
set @y 200
set @h [expr [font metrics [$self look font] -linespace]+3]
set @step [expr ceil($@h*1.5)]
set @prefixkeys {}
$self init_keys
$self recenter
}
def Kb_cursor xy {} {return [list $@x $@y]}
def Kb_cursor step {} {return $@step}
def Kb_cursor draw {} {
set c [$@canvas widget]
set line1 [list $@x $@y $@x [expr $@y+$@h]]
set line2 [list $@x $@y [expr $@x+3] $@y]
set line3 [list $@x [expr $@y+$@h-1] [expr $@x+3] [expr $@y+$@h-1]]
$self item LINE1 line $line1 -fill red -width 2
$self item LINE2 line $line2 -fill red -width 1
$self item LINE3 line $line3 -fill red -width 1
$c raise $self
}
def Kb_cursor move {x y} {
set @x [expr $@x + $x]
set @y [expr $@y + $y]
$self test_bounds
$self draw
set action [$@canvas action]
if {$action != "none"} {
if {[$action class] == "SelRect"} {
$action motion $@x $@y 256 "none"
}
}
}
def Kb_cursor scroll_canvas {} {
set c [$@canvas widget]
mset {x1 y1 x2 y2} [$c bbox all]
puts "xview [$c xview]"
set x2 [expr $x2]; set y2 [expr $y2]
}
def Kb_cursor test_bounds {} {
set c [$@canvas widget]
set width [winfo width $c]; set height [winfo height $c]
set x1 [$c canvasx 2]; set y1 [$c canvasy 2]
set x2 [expr $x1+$width-2]
set y2 [expr $y1+$height-2]
if {$@x >= $x2} {$self scroll r [expr int($@x-$x2)]}
if {$@x <= $x1} {$self scroll l [expr int($@x-$x1)]}
if {$@y >= $y2} {$self scroll b [expr int($@y-$y2)]}
if {$@y <= $y1} {$self scroll t [expr int($@y-$y1)]}
}
def Kb_cursor scroll {direction diff} {
set c [$@canvas widget]
set width [winfo width $c]; set height [winfo height $c]
set x1 [$c canvasx 2]; set y1 [$c canvasy 2]
mset {l r} [$c xview]
mset {t b} [$c yview]
foreach {n0 n1 n2 n3 region} [$c configure -scrollregion] {mset {rx1 ry1 rx2 ry2} $region}
switch $direction {
r {set axis "x"; if {$r == 1} {set rx2 [expr $rx2+$width]}}
l {set axis "x"; if {$l == 0} {set rx1 [expr $rx1-$width]}}
b {set axis "y"; if {$b == 1} {set ry2 [expr $ry2+$height]}}
t {set axis "y"; if {$t == 0} {set ry1 [expr $ry1-$height]}}
}
$c configure -scrollregion [list $rx1 $ry1 $rx2 $ry2]
$c [list $axis]view scroll $diff units
}
def Canvas kbcursor_recenter {} {$@kbcursor recenter}
def Kb_cursor recenter {} {
set c [$@canvas widget]
set width [winfo width $c]; set height [winfo height $c]
set x1 [$c canvasx 2]; set y1 [$c canvasy 2]
set x2 [expr $x1+$width]
set y2 [expr $y1+$height]
set @x [expr $x1+($width/2)]
set @y [expr $y1+($height/2)]
$self draw
}
def Canvas kbcursor_Object {} {mset {x y} [$@kbcursor xy]; $self new_objectxy [expr $x+4] $y obj}
def Canvas kbcursor_Message {} {mset {x y} [$@kbcursor xy]; $self new_objectxy [expr $x+4] $y msg}
def Canvas kbcursor_bng {} {mset {x y} [$@kbcursor xy]; $self new_objectxy [expr $x+4] $y obj bng}
def Canvas kbcursor_tgl {} {mset {x y} [$@kbcursor xy]; $self new_objectxy [expr $x+4] $y obj tgl}
def Canvas kbcursor_nbx {} {mset {x y} [$@kbcursor xy]; $self new_objectxy [expr $x+4] $y obj nbx}
def Canvas kbcursor_select {} {
mset {x y} [lmap + [$@kbcursor xy] 4]; set x [expr $x+4]
mset {type id detail} [$self identify_target $x $y 0]
puts "type:: $type || id:: $id || detail:: $detail"
if {$type == "object"} {
if {![$id selected?]} {$self selection+= $id} else {$self selection-= $id}
}
}
def Kb_cursor init_keys {} {
global newkey accels
#@keys used for prefix keycommands
dict set @prefixkeys "1" "kbcursor_Object"
dict set @prefixkeys "2" "kbcursor_Message"
dict set @prefixkeys "b" "kbcursor_bng"
dict set @prefixkeys "t" "kbcursor_tgl"
dict set @prefixkeys "3" "kbcursor_nbx"
#@ctrlkeys overwrites the existing keybindings
foreach {key command} $newkey {
if {[catch {set vars [dict get $accels $key]}]} {puts "$key not bound yet......";set vars {}}
set new_val {}
foreach item $vars {
mset {class cmd} [split $item ":"]
if {$class == [$@canvas class]} {
set n $class:$command
lappend new_val $n
} else {
lappend new_val $item
}
}
if {$new_val == ""} {set new_val [$@canvas class]:$command}
dict set accels $key $new_val
}
}
def Kb_cursor get_key {key} {
if {[catch {set command [dict get $@prefixkeys $key]}]} {
post "key Ctrl-x $key not bound"
} {
puts "run $command"
$@canvas $command
}
}
set newkey {
Ctrl+p {kbcursor_move_up}
Ctrl+n {kbcursor_move_down}
Ctrl+f {kbcursor_move_right}
Ctrl+b {kbcursor_move_left}
Ctrl+P {move_selection_up}
Ctrl+N {move_selection_down}
Ctrl+F {move_selection_right}
Ctrl+B {move_selection_left}
Alt+f {}
Alt+b {}
Ctrl+space {kbcursor_mark}
}
def Canvas kbcursor_mark {} {
mset {x y} [$@kbcursor xy]
if {$@action == "none"} {
set @action [SelRect new $self $x $y 256 "none"]
} else {
if {[$@action class] == "SelRect"} {
$@action unclick $x $y 236 "none"
}
}
}
|
