#! /usr/bin/tclsh
package require sqlite3
package require Tk
proc .init {. _ args} [string map [
list @bindsubs@ {%k %K %s %b %T %c %x %y}
] {
$_ .vars doublewindow events gryp info keyspressed lastevent \
lasteventtime lastfocus nodenumbers origtext tree text top
dict size $args
foreach {opt val} $args {
switch $opt {
gryp - top {
set $opt $val
}
default {
error [list {unknown option} $opt]
}
}
}
trace add variable [$_ .namespace]::top unset [list ::apply [
list {top args} {
destroy $top {*}[winfo children $top]
}] $top]
set history_pause 0
set lastfocus {}
set nohistory 0
set nodenumbers 0
set origtext {}
sqlite3 [$_ .namespace]::db
$_ .eval [list $_ .routine db]
$_ dbsetup
$_ .routine gryp $gryp
set message $top.message
message $top.message
pack $message -fill both -expand yes
pack forget $message
set left [frame $top.left]
set right [frame $top.right]
pack $left -side left -fill both -expand yes
pack $right -side right -fill both -expand yes
set text [text $top.text]
bind $text <FocusIn> [list $_ valueFocusIn]
bind $text <FocusOut> [list $_ valueFocusOut]
bind $text <Key> [list ::apply [list _ {
$_ keypress_text @bindsubs@
} [namespace current]] $_]
pack configure $text -in $right
set tree $top.tree
ttk::treeview $tree -selectmode none \
-xscrollcommand [list $_ xscroll] \
-yscrollcommand [list $_ yscroll]
$_ .routine tree $tree
#set script {
# upvar tree tree
# if {$up eq $node} {
# set current {}
# } else {
# set current $up
# }
# set item [$tree insert $current end -id $node -text $value]
# $tree tag add node $item
# #$tree tag bind $item <Double-Button-1> [list $_ edit $rowid]
# #$tree tag bind $item <Return> [list $_ edit $rowid]
#}
#$_ db transaction {
# $_ gryp session tree node walk {} $script
#}
$_ gryp session subscribe close [list $_ event $_ close]
$_ gryp session subscribe delete [list $_ event $_ session_delete]
$_ gryp session subscribe dialogue [list $_ event $_ dialogue]
$_ gryp session subscribe dialogueoff [list $_ event $_ dialogueoff]
$_ gryp session subscribe edit [list $_ event $_ session_edit]
$_ gryp session subscribe focus [list $_ event $_ session_focus]
$_ gryp session subscribe insert [list $_ event $_ session_insert]
$_ gryp session subscribe empty [list $_ event $_ session_empty]
$_ gryp session subscribe update [list $_ event $_ session_update]
$_ gryp session subscribe open [list $_ event $_ open]
$_ gryp session subscribe select [list $_ event $_ select]
$_ gryp session subscribe setting [list $_ event $_ session_setting]
$_ gryp session subscribe nodenumbershide [
list $_ event $_ nodenumbershide]
$_ gryp session subscribe nodenumbersshow [
list $_ event $_ nodenumbersshow]
set keyspressed {}
set lastevent {}
set lasteventtime 0
bind Treeview <Key-space> {}
$tree tag configure dialogue -background yellow -foreground white
$tree tag configure select -background blue -foreground white
$tree tag configure focus -background black -foreground white
bind $tree <Configure> [list $_ setup]
bind $tree <e> [list $_ node_edit]
bind $tree <BackSpace> [list $_ gryp session history previous]
bind $tree <<TreeviewClose>> [list $_ node_closed]
bind $tree <Shift-BackSpace> [list $_ gryp session history next]
bind $tree <<TreeviewSelect>> [list $_ selected]
set keypress [list ::apply [list _ {
$_ keypress @bindsubs@
# supress the class event handler
return -level 1 -code break
} [namespace current]] $_]
set keypresstop [list ::apply [list _ {
$_ keypress @bindsubs@
} [namespace current]] $_]
## override the class bindings
#bind $tree <Key-Right> $keypress
#bind $tree <Key-Left> $keypress
#bind $tree <Key-Down> $keypress
#bind $tree <Key-Up> $keypress
#bind $tree <Button-1> $keypress
bind $tree <Key> $keypress
bind $tree <Button> $keypress
bind . <Button> $keypresstop
#bind . <KeyPress> $keypresstop
bind . <KeyRelease> [list ::apply [list _ {
$_ keyrelease %k %K %s
} [namespace current]] $_]
pack configure $tree -in $left
pack $tree -fill both -expand yes
$_ gryp session run
return
}]
.my .method .init
proc close {. _ item} {
$_ .vars tree
$tree item $item -open 0
}
.my .method close
proc dbsetup {. _} {
}
.my .method dbsetup
proc dialogue {. _ item} {
$_ .vars tree
$tree tag add dialogue $item
}
.my .method dialogue
proc dialogueoff {. _ item} {
$_ .vars tree
$tree tag remove dialogue $item
}
.my .method dialogueoff
proc event {. _ args} {
after 0 [list after idle [list {*}$args]]
}
.my .method event
proc focusselected {. _} {
$_ .vars tree
set focus [$tree focus]
if {$focus in [$tree selection]} {
return 1
}
return 0
}
.my .method focusselected
proc getdirectory {. _} {
set file [tk_chooseDirectory -title \
{choose existing work directory}]
return $file
}
.my .method getdirectory
proc keypress {. _ args} {
$_ .vars keyspressed lastevent lasteventtime text tree
$_ keyspressed {*}$args
if {[focus] ne $tree} {
return
}
set ms [clock milliseconds]
lassign $args keycode keysym state button type count x y
dict set keyspressed $keysym {}
switch $keysym {
ampersand {
$_ gryp session event [$tree focus] nodenumbers
}
Delete {
$_ gryp session event [$tree focus] delete
}
Down {
set focus [$tree focus]
if {[dict exists $keyspressed Control_L]} {
$_ refocus
} else {
set open [$tree item $focus -open]
if {$open} {
set next [lindex [$tree children $focus] 0]
} else {
set next [$tree next $focus]
}
while {$next eq {}} {
set next [$tree parent $focus]
if {$next eq {}} {
break
}
set focus $next
set next [$tree next $next]
}
if {$next ne {}} {
$_ gryp session event $next focus
}
}
}
Escape {
$_ gryp session event [$tree focus] escape
}
Left {
set item [$tree focus]
set open [$tree item $item -open]
if {$open} {
$_ gryp session event $item close
} else {
set item [$tree parent $item]
if {$item ne {}} {
$_ gryp session event $item focus
}
}
}
Next {
$_ pagedown
}
Prior {
$_ pageup
}
Return {
if {$state & 4} {
$_ gryp session event [$tree focus] actions
} else {
$_ gryp session event [$tree focus] open
}
}
Right {
if {$state & 4} {
$_ gryp session event [$tree focus] actions
} else {
$_ gryp session event [$tree focus] open
}
}
Up {
set focus [$tree focus]
if {[dict exists $keyspressed Control_L]} {
$_ refocus
} else {
set prev [$tree prev $focus]
if {$prev eq {}} {
set prev [$tree parent $focus]
} else {
while 1 {
set open [$tree item $prev -open]
if {$open} {
set newprev [lindex [$tree children $prev] end]
if {$newprev eq {}} break else {
set prev $newprev
}
} else {
break
}
}
}
if {$prev ne {}} {
$_ gryp session event $prev focus
}
}
}
space {
if {[dict exists $keyspressed Control_L]} {
set mode toggle
} else {
if {[$_ focusselected]} {
set mode remove
} else {
set mode set
}
}
$_ gryp session event [$tree focus] select $mode
}
default {
switch $button {
1 {
$_ .vars doublewindow
set item [$tree identify item $x $y]
$_ gryp session event $item focus
if {[lindex $lastevent 3] == 1} {
set elapsed [expr {$ms - $lasteventtime}]
if {$elapsed < 300} {
$_ toggleopen $item
}
}
}
2 {
set item [$tree identify item $x $y]
$_ gryp session focus $item
if {$item ne {}} {
$_ gryp session event $item actions
}
}
}
}
}
set lastevent $args
set lasteventtime $ms
}
.my .method keypress
proc keypress_text {. _ args} {
$_ .vars keyspressed lastevent lasteventtime text tree
$_ keyspressed {*}$args
lassign $args keycode keysym state button type count x y
switch $keysym {
Return {
if {[dict exists $keyspressed Control_L]} {
$_ savenode [$tree focus]
tailcall return -level 1 -code break
}
}
}
}
.my .method keypress_text
proc keyrelease {. _ args} {
$_ .vars keyspressed tree
lassign $args keycode keysym
dict unset keyspressed $keysym
}
.my .method keyrelease
proc keyspressed {. _ args} {
$_ .vars keyspressed tree
lassign $args keycode keysym state button type count x y
if {$button ne {??}} {
lassign [winfo pointerxy .] x y
set win [winfo containing $x $y]
focus $win
}
dict set keyspressed $keysym {}
return
}
.my .method keyspressed
proc item_activate {. _} {
$_ .vars tree
set focus [$tree focus]
#$_ gryp session activate
return
}
.my .method item_activate
proc node_closed {. _} {
$_ .vars tree
set item [$tree focus]
puts stark!
$_ gryp session event $item close
}
.my .method node_closed
proc node_edit {. _} {
$_ .vars tree
set item [$tree focus]
$_ gryp session event $item edit
}
.my .method node_edit
proc open_ {. _ item} {
$_ .vars text tree
set parent [$tree parent $item]
#while {$parent ne {}} {
# set opened [$tree item $parent -open]
# if {!$opened} {
# $_ gryp session event $parent open
# }
# set parent [$tree parent $parent]
#}
$tree item $item -open 1
return
}
.my .method open open_
proc pagedown {. _} {
$_ .vars tree
$tree yview scroll 1 pages
}
.my .method pagedown
proc pageup {. _} {
$_ .vars tree
$tree yview scroll -1 pages
}
.my .method pageup
proc refocus {. _} {
$_ .vars tree
set children [$tree children {}]
while {[llength $children]} {
set children [lassign $children[set children {}] child]
set bbox [$tree bbox $child]
if {[llength $bbox]} {
$_ gryp session focus $child
return
}
set open [$tree item $child -open]
if {$open} {
lappend children {*}[$tree children $child] {*}$children[
set children {}]
}
}
return
}
.my .method refocus
proc savenode {. _ node} {
$_ .vars origtext text
set newtext [string range [$text get 1.0 end] 0 end-1]
if {$newtext ne $origtext} {
$_ gryp session write $node $newtext
}
return
}
.my .method savenode
proc select {. _ mode args} {
$_ .vars tree
switch $mode {
set {
$tree tag remove select
}
}
foreach arg $args {
switch $mode {
add - set {
$tree tag add select $arg
}
remove {
$tree tag remove select $arg
}
toggle {
if {[$tree tag has select $arg]} {
$tree tag remove select $arg
} else {
$tree tag add select $arg
}
}
}
}
}
.my .method select
proc selected {. _} {
$_ .vars lastfocus text tree
set focus [$tree focus]
set lastfocus $focus
$_ gryp session focus $focus
return
}
.my .method selected
proc session_delete {. _ node} {
$_ .vars tree
$tree delete [list $node]
}
.my .method session_delete
proc session_edit {. _ item type} {
$_ .vars text tree
set children [$tree children $item]
if {![llength $children]} {
switch $type {
directory {
set file [$_ getdirectory]
$_ gryp session write $item $file
}
default {
$_ text_update $item
focus $text
}
}
}
}
.my .method session_edit
proc session_focus {. _ item} {
$_ .vars origtext text tree
focus $tree
set focus [$tree focus]
# maybe not a good idea to automatically save the node
#$_ savenode $focus
if {$focus ne $item} {
$tree focus $item
$tree tag remove focus
$tree tag add focus $item
$tree see $item
set origtext [$tree item $item -text]
$_ text_update $item
}
return
}
.my .method session_focus
proc session_empty {. _ item empty} {
variable image
$_ .vars tree
if {$empty} {
$tree item $item -image {}
} else {
$tree item $item -image $image
}
}
.my .method session_empty
proc session_insert {. _ cursor direction item value} {
$_ .vars nodenumbers tree
if {$nodenumbers} {
set value [list $item $value]
}
puts [list inserting $cursor $direction $item $value]
switch $direction {
after - before {
set parent [$tree parent $cursor]
set index [$tree index $cursor]
$switch $direction {
after {
incr index
}
before {
incr index -1
}
}
set item [$tree insert $cursor $index -id $item -text $value]
$_ session_empty $cursor 0
}
in {
set item [$tree insert $cursor end -id $item -text $value]
$_ session_empty $cursor 0
}
default {
error [list {unknown direction} $direction
}
}
$tree tag add node $item
return
}
.my .method session_insert
proc session_setting {. _ args} {
$_ .vars tree
set args [lassign $args[set args {}] arg]
switch $arg {
ui {
set args [lassign $args[set args {}] arg]
switch $arg {
doublewindow {
$_ .vars doublewindow
set doublewindow [lindex $args end]
}
}
}
}
}
.my .method session_setting
proc session_update {. _ parent item value} {
$_ .vars tree
set item [$tree item $item -text $value]
return
}
.my .method session_update
proc setup {. _} {
$_ .vars tree
bind $tree <Configure> {}
}
.my .method setup
proc nodenumbershide {. _ item} {
$_ .vars nodenumbers tree
set nodenumbers 0
set item {}
$_ walk item
while {$item ne {}} {
if {[$tree tag has numbered $item]} {
$tree item $item -text [lindex [$tree item $item -text] end]
$tree tag remove numbered $item
}
$_ walk item
}
}
.my .method nodenumbershide
proc nodenumbersshow {. _ item} {
$_ .vars nodenumbers tree
set nodenumbers 1
set item {}
$_ walk item
while {$item ne {}} {
if {![$tree tag has numbered $item]} {
$tree item $item -text [list $item [$tree item $item -text]]
$tree tag add numbered $item
}
$_ walk item
}
}
.my .method nodenumbersshow
proc text_update {. _ item} {
$_ .vars text tree
$text delete 1.0 end
set origtext [$tree item $item -text]
$text insert 1.0 $origtext
return
}
.my .method text_update
proc textcmd {. _} {
$_ .vars text
return $text
}
.my .method textcmd
proc toggleopen {. _ item} {
$_ .vars tree
set open [$tree item $item -open]
if {$open} {
$_ gryp session close $item
} else {
$_ gryp session event $item open
}
}
.my .method toggleopen
proc treecmd {. _} {
$_ .vars tree
return $tree
}
.my .method treecmd
proc valueFocusIn {. _} {
$_ .vars text tree
}
.my .method valueFocusIn
proc valueFocusOut {. _} {
$_ .vars tree
# maybe not a good idea to automatically save on focusout
#$_ savenode [$tree focus]
return
}
.my .method valueFocusOut
proc walk {. _ varname} {
$_ .vars tree
upvar $varname item
set down [$tree children $item]
if {[llength $down]} {
set item [lindex $down 0]
} else {
set next [$tree next $item]
if {$next eq {}} {
set up [$tree parent $item]
while 1 {
if {$up eq {}} {
set item $up
break
}
set next [$tree next $up]
if {$next ne {}} {
set item $next
break
}
set up [$tree parent $up]
}
} else {
set item $next
}
}
return $item
}
.my .method walk
proc xscroll {. _ args} {
}
.my .method xscroll
proc yscroll {. _ x y} {
$_ .vars tree
set focus [$tree focus]
if {$focus eq {}} {
set bbox {}
} else {
set bbox [$tree bbox $focus]
}
}
.my .method yscroll
set image [image create bitmap -data {
#define data_width 4
#define data_height 4
static unsigned char data_bits[] = {
0xf6,
0xff,
0xff,
0xf6,
}
} -background white]