Posted to tcl by hypnotoad at Sun May 12 20:53:06 GMT 2019view raw

  1. ###
  2. # topic: 044407824c5396262b0c21c08bef030c
  3. ###
  4. tao::define ::irmgui::tree {
  5. superclass ::taotk::frame
  6.  
  7. option master {class organ default ::appmain}
  8. option model {class organ default ::db}
  9.  
  10. option only_leaf {
  11. default 1
  12. type boolean
  13. }
  14.  
  15. constructor {window args} {
  16. my graft db ::db
  17. my Hull_Build $window {} {*}$args
  18. }
  19.  
  20. signal content {
  21. action {my Widget_Content}
  22. }
  23.  
  24. signal repaint {
  25. action {my repaint}
  26. }
  27.  
  28. signal stretch {
  29. follows content
  30. action {my Widget_Stretch}
  31. }
  32. ###
  33. # topic: 346fdcec07b804d4bf46c9f05d0cf0fdaebb575a
  34. ###
  35. method bind {event command} {
  36. ::bind [my organ canvas] $event $command
  37. }
  38.  
  39. ###
  40. # topic: c3ecc24f91dc449b3affa4f5fc0bb31f6f129a1d
  41. ###
  42. method columns {} {
  43. #return {name xtypeid}
  44. return name
  45. }
  46.  
  47. ###
  48. # topic: 6b5848fdbe1b8f1d895321951fd4750cd9dfb64d
  49. ###
  50. method currentlyOpen {} {
  51. my variable _open
  52. set result {}
  53. foreach {typeid} [array names _open] {
  54. lappend result $typeid 1 0 0
  55. }
  56. return $result
  57. #return [my <db> eval {select typeid,open,0,0 from mem.simtype where open=1}]
  58. }
  59.  
  60. ###
  61. # topic: 60188e2559740d4090276b84bf50ea7e08ae5340
  62. ###
  63. method currentSelection {} {
  64. return $::g(typeselect)
  65. }
  66.  
  67. ###
  68. # topic: 9cd4ea021426c97c533473542fa6615f598b3f6e
  69. ###
  70. method displaycolumns {} {
  71. return {}
  72. }
  73.  
  74. ###
  75. # topic: f0e1d9fdc64c2462e0d8bcda3b0ca5f8303d369f
  76. ###
  77. method Hull_Populate {} {
  78. set w [my widget hull]
  79. my graft canvas $w.tree
  80. my graft tree $w.tree
  81. my graft treewidget $w.tree
  82.  
  83. ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview"
  84. canvas $w.tree -yscrollcommand "$w.vsb set"
  85.  
  86. pack $w.vsb -side left -fill y
  87. pack $w.tree -side left -fill both -expand 1
  88.  
  89. oo::objdefine [self] forward tree $w.tree
  90. #if {[info commands ::odie::dictionary_compare] != {}} {
  91. # my <db> collate DICTIONARY ::odie::dictionary_compare
  92. #}
  93. }
  94.  
  95. ###
  96. # topic: 23859dd0b694779ea35c8e4d4db633658f7ea287
  97. ###
  98. method isopen typeid {
  99. return [my <db> onecolumn {select open from mem.simtype where typeid=:typeid}]
  100. }
  101.  
  102. ###
  103. # topic: d00cc6c4c2bba9ddca6ce3cd973e1fa41c8c580e
  104. # title: Draw a tree node
  105. # description: Ascend from leaves to draw trunks
  106. ###
  107. method redrawNode_bottomup typeid {
  108. set path {}
  109. set thistype $typeid
  110. while {$thistype ni {0 {}}} {
  111. my <db> eval {update mem.simtype set open=1 where typeid=:thistype}
  112. set thistype [my <db> onecolumn {select parent from mem.simtype where typeid=:typeid}]
  113. if {$typetype in $path} {
  114. puts "Warning: $typeid is one of its own parents"
  115. break
  116. }
  117. lappend path $typeid
  118. }
  119. #my signal redraw
  120. }
  121.  
  122. ###
  123. # topic: 9160d030fd9ee8c2d246c081cf8ef4139bc318b6
  124. # title: Draw a tree node
  125. # description: Descend from trunks to draw leaves
  126. ###
  127. method redrawNode_topdown {pnode typeid} {
  128. set info [my node_info $typeid]
  129. if {[llength $info] eq 0} {
  130. return
  131. }
  132. dict with info {}
  133.  
  134. set t [my treewidget insert $pnode end -text $name -image {} -values $row -tags $tags]
  135.  
  136. ###
  137. # Add children
  138. ###
  139. array set dat [my childNodes $typeid]
  140. foreach {name} [lsort -dictionary [array names dat]] {
  141. set childid $dat($name)
  142. ###
  143. # Add children
  144. ###
  145. my redrawNode_topdown $t $childid
  146. }
  147.  
  148. return $t
  149. }
  150.  
  151. ###
  152. # topic: bed531ec0b3ba101bb245d316530f0fb2a6c46e1
  153. ###
  154. method setbg state {
  155. my variable tree
  156. switch $state {
  157. grey {
  158. my treewidget configure -style TaoGrey.Treeview
  159. }
  160. default {
  161. my treewidget configure -style Tao.Treeview
  162. }
  163. }
  164. update idletasks
  165. }
  166.  
  167. ###
  168. # topic: bd851711b4a303904b181f653ebe5b0573c49a2d
  169. ###
  170. method showtype {typeid {select 0}} {
  171. my variable _open
  172. set parent [my <db> onecolumn {select parent from xtype where typeid=:typeid}]
  173. set _open($parent) 1
  174. set _open($typeid) 1
  175. if {$select} {
  176. global g
  177. lappend g(typeselect) $typeid
  178. }
  179. my signal content
  180. }
  181.  
  182.  
  183. method click {x y} {
  184. set typeid {}
  185. set clickon none
  186. lassign [my item_at_location $x $y] typeid clickon
  187. set fullname [db one {SELECT fullname FROM xtype WHERE typeid=$typeid}]
  188. variable _open
  189. global g
  190. if {$clickon eq "fork"} {
  191. if {[info exists _open($typeid)]} {
  192. unset _open($typeid)
  193. # ::rtest::record "type close $fullname"
  194. } else {
  195. set _open($typeid) 1
  196. # ::rtest::record "type open $fullname"
  197. }
  198. my signal content
  199. }
  200. my <master> notify tree_visible [list typeid $typeid]
  201. if {$clickon eq "text"} {
  202. my <master> event generate tree_select [list typeid $typeid]
  203. my <db> eval {update simtype set selected=0; update simtype set selected=1 where typeid=:typeid}
  204. set g(typeselect) $typeid
  205. set bbox [my <canvas> bbox y$typeid.text]
  206.  
  207. foreach v $bbox d {-2 -1 1 1} {
  208. lappend bbox2 [expr $v + $d]
  209. }
  210. my <canvas> delete selbox
  211. set id [eval my <canvas> create rectangle $bbox2 -fill #d0d0ff -tags selbox]
  212. my <canvas> lower $id
  213. ::event generate [my organ canvas] <<TreeviewSelect>>
  214. }
  215. if {$clickon in {none {}} && $g(typeselect) ne ""} {
  216. set g(typeselect) ""
  217. my <canvas> delete selbox
  218. }
  219. if {$clickon eq "icon"} {
  220. my <master> notify tree_visible [list typeid $typeid]
  221. set active [my <model> simtype setting $typeid active]
  222. if { $active == 1 } {
  223. set active 0
  224. } else {
  225. set active 1
  226. }
  227. my signal content
  228. my <model> simtype active $typeid $active
  229. my <master> signal typetree
  230. }
  231. }
  232.  
  233. method item_at_location {x y} {
  234. set x [my <canvas> canvasx $x]
  235. set y [my <canvas> canvasy $y]
  236. set x0 [expr {$x-2}]
  237. set x1 [expr {$x+2}]
  238. set y0 [expr {$y-2}]
  239. set y1 [expr {$y+2}]
  240. my variable _map
  241. set idlist [my <canvas> find overlapping $x0 $y0 $x1 $y1]
  242. foreach id $idlist {
  243. if {[info exists _map($id)]} {return $_map($id)}
  244. }
  245. return {}
  246. }
  247.  
  248. ###
  249. # topic: 0096f51242551ac91458647d143e2146
  250. ###
  251. method childNodes typeid {
  252. return [my <model> eval {select name,typeid from xtype where parent=:typeid order by name}]
  253. }
  254.  
  255. ###
  256. # topic: 2d9488eb125be18d65e257a7a4ae18d7
  257. ###
  258. method columns {} {
  259. return {name class typeid}
  260. }
  261.  
  262. ###
  263. # topic: a2b7b8fe19a238f10c39cc5c449d37fa
  264. ###
  265. method displaycolumns {} {
  266. return {}
  267. }
  268.  
  269. method initialize {} {
  270. my event subscribe [my organ master] actionstack_pop
  271. set ::g(typeselect) {}
  272. next
  273. }
  274.  
  275. ###
  276. # topic: c8945944427da83ffd8f25d60154ff58
  277. ###
  278. method node_info id {
  279. if { $id == 0 } {
  280. return {}
  281. }
  282. if {![my <model> exists {select typeid from xtype where typeid=:id}]} {
  283. return {}
  284. }
  285.  
  286. set result [my <model> eval {select 'typeid',typeid,'parent',parent,'name',name,'class',class from xtype where typeid=:id}]
  287. set row {}
  288. foreach field [my columns] {
  289. lappend row [dict getnull $result $field]
  290. }
  291. set unit y$id
  292. dict set result row $row
  293. dict set result tags [list all [dict get $result class] $unit]
  294. return $result
  295. }
  296.  
  297. ###
  298. # topic: d44626f010bf6aea26cc210718552325
  299. ###
  300. method nodetag unit {
  301. my <model> onecolumn {select unit from mem.simtype where unit=:unit or typeid=:unit}
  302. }
  303.  
  304. method notify::actionstack_pop {sender info} {
  305. set w [my widget subwindow treeselect]
  306. destroy $w
  307. }
  308.  
  309. ###
  310. # topic: 32bcb274c50481ce47f5ca7997921efa
  311. ###
  312. method parentNode unit {
  313. set typeid [my <model> onecolumn {select typeid from mem.simtype where unit=:unit or typeid=:unit}]
  314. return [my <model> onecolumn {select parent from xtype where parent=:typeid}]
  315. }
  316.  
  317. method Redraw_Layer {depth base y} {
  318. if {$base eq ""} {
  319. set t1 {(parent IS NULL or parent=0)}
  320. } else {
  321. set t1 "parent=:base"
  322. }
  323. set sql "SELECT xtype.typeid as typeid, name, nchild, \
  324. active, oncount \
  325. FROM xtype NATURAL JOIN simtype \
  326. WHERE $t1 AND name NOT NULL ORDER BY name"
  327. #if {[info commands ::odie::dictionary_compare] ne {}} {
  328. # append sql " COLLATE DICTIONARY"
  329. #}
  330.  
  331. set xbm [expr {5+8*$depth}]
  332. set xt [expr {$xbm+11}]
  333. variable _open
  334. variable _map
  335. global g
  336. set top $y
  337. set last_y $y
  338. set children [db eval $sql]
  339. foreach {typeid name nchild active oncount} [lsort -stride 5 -index 1 -dictionary $children] {
  340. if {$nchild>0} {
  341. set open [info exists _open($typeid)]
  342. set bm [expr {$open?"::tree::openbm":"::tree::closedbm"}]
  343. set id [my <canvas> create image $xbm $y -image $bm -anchor c]
  344. set _map($id) [list $typeid fork]
  345. set isleaf 0
  346. } else {
  347. set open 0
  348. set isleaf 1
  349. }
  350. set fg black
  351.  
  352. if {$active==1} {
  353. set icon ::tree::green-check
  354. } elseif {$active==2} {
  355. set icon ::tree::red-x
  356. } elseif {$oncount>0} {
  357. set icon ::tree::blue-dot
  358. } else {
  359. set hit [db eval "select * from mem.entity where typeid = $typeid"]
  360. if {$hit == $typeid} {
  361. set icon ::tree::green-dot
  362. } else {
  363. set icon ::tree::gray-dot
  364. }
  365. }
  366. set id [my <canvas> create image $xt $y -image $icon -tags [list y$typeid.icon icon] -anchor w]
  367. set _map($id) [list $typeid icon]
  368. set bbox [my <canvas> bbox $id]
  369.  
  370. set xtext [expr {[lindex $bbox 2]+5}]
  371.  
  372. set id [my <canvas> create text $xtext $y -text $name -tags [list y$typeid.text] -anchor w -fill $fg]
  373. set _map($id) [list $typeid text]
  374. set bbox [my <canvas> bbox $id]
  375. if {$g(typeselect)==$typeid} {
  376. foreach v $bbox d {-2 -1 1 1} {
  377. lappend bbox2 [expr $v + $d]
  378. }
  379. set id [eval my <canvas> create rectangle $bbox2 -fill #d0d0ff -tags selbox]
  380. my <canvas> lower $id
  381. set _map($id) [list $typeid text]
  382. }
  383.  
  384. my <canvas> create line $xbm $y $xt $y -fill gray -tags bgline
  385. set last_y $y
  386. incr y 16
  387. if {$open} {
  388. set y [my Redraw_Layer [expr {$depth+1}] $typeid $y]
  389. }
  390. }
  391. set vline [my <canvas> create line $xbm [expr {$top-16}] $xbm $last_y \
  392. -fill gray -tags bgline]
  393. my <canvas> lower bgline
  394. return $y
  395. }
  396.  
  397. ###
  398. # topic: e03c35dbb814f2a4b7fc5bc903e918bf
  399. ###
  400. method rootNodes {} {
  401. return [my <model> eval {select name,typeid from xtype where parent is null or parent=0 order by fullname}]
  402. }
  403.  
  404. ###
  405. # topic: 05369c766afa30cb21f6d031d4fd6b33
  406. ###
  407. method select_dialog {label match_funct args} {
  408. ###
  409. # Step one, check the tree
  410. ###
  411. set typeid [my <master> <tree> selected_type]
  412. if {[{*}$match_funct $class $typeid]} {
  413. return $typeid
  414. }
  415. set tl [my widget toplevel]
  416. set w [my widget subwindow treeselect]
  417. set obj [namespace current]::selector
  418. catch {$obj destroy}
  419. destroy $w
  420. ::taotk::toplevel $w -windowstyle modal -parent $tl
  421. ttk::label $w.l -text $label
  422. pack $w.l -side top
  423. if {[llength $args]==1} {
  424. set args [lindex $args 0]
  425. }
  426. update
  427. ::irm.typeselect create $obj $w.tree match_function $match_funct master [my organ master] {*}$args
  428. $obj signal content
  429. pack $w.tree -side top -fill both -expand 1
  430. set g [wm geometry $tl]
  431. set x [split $g +]
  432. wm geometry $w 400x500+[join [lrange $x 1 2] +]
  433.  
  434.  
  435. set typeid [$obj grabSelection]
  436. my showtype $typeid 1
  437. catch {typeselect destroy}
  438. destroy $w
  439. return $typeid
  440. }
  441.  
  442. ###
  443. # topic: 69c5be2d764b56ae85da24ad502309d3
  444. ###
  445. method selected_type {} {
  446. my variable selected_type
  447. if {[info exists selected_type]} {
  448. return $selected_type
  449. }
  450. global g
  451. return $g(typeselect)
  452. }
  453.  
  454. method stretch {} {
  455. my signal stretch
  456. }
  457.  
  458. method Widget_Stretch {} {
  459. ::update idletasks
  460. set bbox [my <canvas> bbox all]
  461. if {[llength $bbox]==0} {
  462. set bbox {0 0 200 800}
  463. }
  464. lassign $bbox x0 y0 x1 y1
  465. my <canvas> config -scrollregion $bbox
  466. my <master> <pane> sash 0 [expr {int(ceil(abs($x0-$x1))+30)}]
  467. bind [my <master> organ pane] <Double-Button-1> "[self] signal stretch"
  468. }
  469.  
  470. method unselect {} {
  471. my canvas delete selbox
  472. global g
  473. set g(seltype) {}
  474. }
  475.  
  476. ###
  477. # topic: a0866cfba29d19d42e5a2ebfcbbacec5141c5f4f
  478. # description: Clear all of the items out of the tree
  479. ###
  480. method Widget_Clear {} {
  481. my variable _map
  482. unset -nocomplain _map
  483. my <canvas> delete all
  484. }
  485.  
  486. ###
  487. # topic: 4be65389c424491f7dfa515cc1ae85bd5001c14a
  488. ###
  489. method Widget_Content {} {
  490. set tw [appmain organ tree]
  491. ###
  492. # Capture who is open
  493. ###
  494. #array unset open_list *
  495. set open_list [my currentlyOpen]
  496.  
  497. my Widget_Clear
  498. my Redraw_Layer 0 {} 8
  499. ::update idletasks
  500. lassign [my <canvas> bbox all] x0 y0 x1 y1
  501. set width [expr {$x1-$x0}]
  502. if {$width < 200} {
  503. set width 200
  504. }
  505. my <canvas> configure -scrollregion [list 0 0 $x1 $y1] -width $width
  506.  
  507. my default
  508. }
  509. }
  510.  
  511. ###
  512. # topic: 905929f18260003e71cf942a9e371bb8
  513. ###
  514. tao::define ::irm.typeselect {
  515. superclass ::irmgui::tree
  516.  
  517. option only_leaf {
  518. type boolean
  519. default 0
  520. }
  521.  
  522. option allow_root {
  523. type boolean
  524. default 0
  525. }
  526.  
  527. option match_function {
  528. default ::tree::true
  529. }
  530.  
  531. ###
  532. # topic: 0981149764a30f5cf4abc8cd4523dbfe
  533. ###
  534. method action::select {
  535. dict with dictargs {}
  536. lassign [my item_at_location $x $y] typeid clickon
  537. set masterobj [my organ master]
  538. set typeobj [my <master> layer xtype]
  539. set class {}
  540. my <db> eval {select class,name from xtype where typeid=:typeid} {}
  541. if {$class ne {}} {
  542. global g
  543. if {[string is true [my cget only_leaf]] && ![::readi::class_leaf $class]} {
  544. continue
  545. }
  546. $typeobj node dialog $typeid
  547. set g(typeselect) $typeid
  548. my variable selected_type
  549. set varn [my varname selected_type]
  550. set $varn $typeid
  551. return $typeid
  552. }
  553. return {}
  554. }
  555.  
  556. ###
  557. # topic: 27a34d12e4a1e55e565ece93e85dcdc6
  558. ###
  559. method default {} {
  560. #my <treewidget> configure -selectmode browse
  561. my bind <KeyPress-Escape> "[self] actionCancel"
  562. my bind <1> "[self] click %x %y"
  563. global g simconfig
  564. set ::g(seltype) {0 1 2 3 4 5}
  565. }
  566.  
  567. ###
  568. # topic: 585d924ca764fee66b41518670d3c0cc
  569. ###
  570. method displaycolumns {} {
  571. return {typeid}
  572. }
  573.  
  574. ###
  575. # topic: d6f1c6cf569e5ea84a0b3906e60ca6be
  576. ###
  577. method grabSelection {} {
  578. my variable selected_type
  579. set varn [my varname selected_type]
  580. if {[info coroutine] eq {}} {
  581. vwait $varn
  582. } else {
  583. ::coroutine::util::vwait $varn
  584. }
  585. return $selected_type
  586. }
  587.  
  588. ###
  589. # topic: ebadbee58ae5739cf4094bb56fa39b3f
  590. ###
  591. method node_info id {
  592. if { $id == 0 && [my cget allow_root]} {
  593. set result {typeid 0 parent -1 name (ROOT) class x }
  594. } else {
  595. if {![my <model> simtype exists $id]} {
  596. return {}
  597. }
  598.  
  599. set result [my <model> eval {select 'typeid',typeid,'parent',parent,'name',name,'class',class from xtype where typeid=:id}]
  600. }
  601. set row {}
  602. foreach field [my columns] {
  603. lappend row [dict getnull $result $field]
  604. }
  605. set unit y$id
  606. dict set result row $row
  607. dict set result tags [list all [dict get $result class] $unit]
  608. return $result
  609. }
  610.  
  611. ###
  612. # topic: d7b0365f61416e6114b5e73c0dac0b64
  613. ###
  614. method Option_set::match_function newvalue {
  615. my variable config
  616. if { $newvalue eq {} } {
  617. set newvalue ::tree::true
  618. }
  619. dict set config match_function $newvalue
  620. set match_funct $newvalue
  621. }
  622.  
  623. ###
  624. # topic: 1107de5f8a7c33abd470dfb8be587fe8
  625. ###
  626. method rootNodes {} {
  627. set matchfun [my cget match_function]
  628. if {$matchfun eq {}} {
  629. set matchfun ::tree::true
  630. }
  631. set result {}
  632. if {[my cget allow_root]} {
  633. lappend result "(ROOT)" 0
  634. }
  635. my <model> eval {select typeid,name,class from xtype order by fullname} {
  636. if {[{*}$matchfun $class $typeid]} {
  637. lappend result $name $typeid
  638. }
  639. }
  640. return $result
  641. }
  642.  
  643. ###
  644. # topic: 731c2d9f06bcc3787435b312900eace3
  645. ###
  646. method Widget_Content {} {
  647. my variable matchfun
  648. ###
  649. # Capture who is open
  650. ###
  651.  
  652. my Widget_Clear
  653. foreach {name typeid} [lsort -dictionary -stride 2 [my rootNodes]] {
  654. my redrawNode_bottomup $typeid
  655. }
  656.  
  657. ###
  658. # Redraw will be done later
  659. ###
  660. my default
  661. }
  662. }
  663.  
  664. ###
  665. # topic: 22eba86507208e4eed2c4b07fc67f880
  666. # description:
  667. # This module is responsible for drawing the tree widget showing
  668. # the xtype hierarchy on the left side of the screen.
  669. #
  670. # Everything is in its own namespace
  671. ###
  672. tao::define ::irmgui::typetree {
  673. superclass ::irmgui::tree
  674.  
  675. property repaint_script {
  676. set icon {}
  677. if {$leaf} {
  678. if {$active==1} {
  679. set icon ::tree::green-check
  680. } elseif {$active==2} {
  681. set icon ::tree::red-x
  682. } elseif {$oncount>0} {
  683. set icon ::tree::blue-dot
  684. } else {
  685. if { $hidden } {
  686. set icon ::tree::red-dot
  687. } elseif { $visible } {
  688. set icon ::tree::green-dot
  689. } else {
  690. set icon ::tree::gray-dot
  691. }
  692. }
  693. } else {
  694. if {$active==1} {
  695. set icon ::tree::green-check
  696. } elseif {$active==2} {
  697. set icon ::tree::red-x
  698. } elseif {$oncount>0} {
  699. set icon ::tree::blue-triangle
  700. } else {
  701. if { $hidden } {
  702. set icon ::tree::red-triangle
  703. } elseif { $visible } {
  704. set icon ::tree::green-triangle
  705. } else {
  706. set icon ::tree::gray-triangle
  707. }
  708. }
  709. }
  710. my <canvas> itemconfigure $unit.icon -image $icon
  711. }
  712.  
  713. method initialize {} {
  714. next
  715. my event subscribe * typetree_modified
  716. }
  717.  
  718. ###
  719. # topic: 99152fc9a9ec31a0bf93ec2720c98536
  720. ###
  721. method action::highlight typeid {
  722. destroy .select
  723. toplevel .select
  724. ttk::label .select.knum -text "Select Color for y$typeid"
  725. pack .select.knum -side top -fill x
  726.  
  727. foreach color {red orange yellow green blue indigo purple} {
  728. button .select.c[incr cnum] -text { } -bg $color -command "set ::g(selector_color) $color"
  729. pack .select.c$cnum -side top -fill x
  730. }
  731. button .select.custom -text "Select Custom Color" -command {set ::g(selector_color) [tk_chooseColor]}
  732. pack .select.custom -side top -fill x
  733.  
  734. set ::g(selector_color) {}
  735. while {$::g(selector_color) eq {}} {
  736. vwait ::g(selector_color)
  737. }
  738. destroy .select
  739. if {$::g(selector_color) eq "cancel"} {
  740. return
  741. }
  742. set color $::g(selector_color)
  743. my <master> <db> eval {insert or replace into mem.highlight(unit,color) select unit,:color from mem.entity where typeid=:typeid;}
  744. my <master> signal update
  745. }
  746.  
  747. ###
  748. # topic: 22eb6754e97f17d206b727e65adba4fe
  749. ###
  750. method action::right_click {
  751. if {![my <master> meta cget mode_editor]} {
  752. return 0
  753. }
  754. # {w x y X Y} are fed into the event
  755. dict with dictargs {}
  756. destroy $w.menu
  757. set typeid {}
  758. lassign [my item_at_location $x $y] typeid element
  759. set masterobj [my organ master]
  760. set typeobj [my <master> layer xtype]
  761. ::menu $w.menu -tearoff 0
  762. if { $typeid == {} } {
  763. $w.menu add command -label "New Type Category" -command [list $typeobj action create_type]
  764. tk_popup $w.menu $X $Y
  765. return
  766. }
  767. my <db> eval {select class,name from xtype where typeid=:typeid} {}
  768. $w.menu add command -label "Edit $name $typeid" -command [list $typeobj node dialog $typeid]
  769. if {[my <model> simtype setting $typeid active] < 2} {
  770. $w.menu add command -label "Hide $name $typeid" -command "$masterobj <model> simtype active $typeid 2 ; $masterobj signal typetree"
  771. } else {
  772. $w.menu add command -label "Unhide $name $typeid" -command "$masterobj <model> simtype active $typeid 0 ; $masterobj signal typetree"
  773. }
  774. switch $class {
  775. "k" {
  776. $w.menu add command -label "Create Link" -command [list $masterobj layer link action create_link typeid $typeid]
  777. }
  778. "x" {
  779. $w.menu add command -label "New Category" -command [list $typeobj action create_type $typeid 0]
  780. $w.menu add command -label "New Type" -command [list $typeobj action create_type $typeid 1]
  781. }
  782. "g" {
  783. $w.menu add command -label "New Division" -command [list $typeobj action create_type $typeid 0 group]
  784. $w.menu add command -label "New Role" -command [list $typeobj action create_type $typeid 1 crew]
  785. }
  786. "r" {
  787. $w.menu add command -label "New Sub-Type" -command [list $typeobj action create_type $typeid 1 rollup]
  788. }
  789. }
  790. $w.menu add command -label "Highlight $name $typeid" -command [namespace code [list my action highlight $typeid]]
  791. #$w.menu add command -label "Display $name" -command [list ::newtree::display $class $typeid]
  792. tk_popup $w.menu $X $Y
  793. }
  794.  
  795. ###
  796. # topic: 0101076fbc67332972beee89f6d33b83
  797. ###
  798. method action::select {
  799. dict with dictargs {}
  800. lassign [my item_at_location $x $y] typeid clickon
  801. set masterobj [my organ master]
  802. set typeobj [my <master> layer xtype]
  803. set class {}
  804. my <db> eval {select class,name from xtype where typeid=:typeid} {}
  805. if {$class ne {}} {
  806. global g
  807. $typeobj node dialog $typeid
  808. set g(typeselect) $typeid
  809. my variable selected_type
  810. set varn [my varname selected_type]
  811. set $varn $typeid
  812. return $typeid
  813. }
  814. return {}
  815. }
  816.  
  817. ###
  818. # topic: 9590385a142cd8c2443691c4d3e0ac85
  819. # description:
  820. # Toggle the display in response to a mouse click
  821. # on the bubble icon
  822. ###
  823. method action::toggle {
  824. # w x y given by event
  825. dict with dictargs {}
  826. my click [dict get $dictargs x] [dict get $dictargs y]
  827.  
  828. }
  829.  
  830. ###
  831. # topic: 51722cb8de08248decfd1d103414f4d6
  832. # description:
  833. # Toggle the display in response to a mouse click
  834. # on the bubble icon
  835. ###
  836. method action::toggle_hide {
  837. # w x y given by event
  838. dict with dictargs {}
  839. set typeid {}
  840. lassign [my item_at_location $x $y] typeid element
  841. if { $typeid == {} } return
  842. set active [my <model> simtype setting $typeid active]
  843. if { $active == 2 } {
  844. set active 0
  845. } else {
  846. set active 2
  847. }
  848. my <treewidget> itemconfigure y$typeid.icon -image icon:eye
  849. update idletasks
  850. my <model> simtype active $typeid $active
  851. my <model> visible treefilter
  852. my <master> signal typetree
  853. }
  854.  
  855. ###
  856. # topic: 43e2587d1ecdb323d607c2de1be0df50
  857. ###
  858. method default {} {
  859. my variable tree
  860.  
  861. #my <treewidget> column #0 -stretch 1
  862. #my <treewidget> column class -width 30 -stretch 0
  863.  
  864. #my <treewidget> configure -selectmode browse
  865.  
  866. my bind <Button-1> "[self] action toggle {w %W x %x y %y}"
  867. my bind <Alt-Button-1> "[self] action toggle_hide {w %W x %x y %y}"
  868. my bind <Shift-Button-1> "[self] action toggle_hide {w %W x %x y %y}"
  869.  
  870. my bind <Double-Button-1> "[self] action select {w %W x %x y %y}"
  871. my bind <Control-Button-1> "[self] action right_click {w %W x %x y %y X %X Y %Y}"
  872. my bind <Button-2> "[self] action right_click {w %W x %x y %y X %X Y %Y}"
  873. my bind <Button-3> "[self] action right_click {w %W x %x y %y X %X Y %Y}"
  874. my bind <KeyPress-Escape> {set ::tree::selected_type {}}
  875.  
  876. my bind <<TreeviewSelect>> {}
  877. global g simconfig
  878. set ::g(seltype) {x k r e p v}
  879. }
  880.  
  881. ###
  882. # topic: 544b397eea83aa6d5b7262df5fcb578c
  883. ###
  884. method isActive nodeid {
  885. return [my <model> onecolumn {return active from mem.simtype where typeid=:nodeid or unit=:nodeid}]
  886. }
  887.  
  888. method notify::typetree_modified {sender dictargs} {
  889. switch [dict getnull $dictargs action] {
  890. created {
  891. set parent [dict getnull $dictargs parent]
  892. set tag [my nodetag $parent]
  893. foreach item [my treewidget tag has $tag] {
  894. catch {my treewidget item $item -open 1}
  895. catch {my treewidget see $item}
  896. }
  897. }
  898. }
  899. }
  900.  
  901. ###
  902. # topic: 20c7d84f002bb949acb3512beb2dedeb
  903. ###
  904. method record command {
  905. ::rtest::record $command
  906. }
  907.  
  908. ###
  909. # topic: af6ba91c8cbf1d13c5645bd097a4c577
  910. ###
  911. method repaint args {
  912. ###
  913. # Capture who is open
  914. ###
  915. set script [my meta cget repaint_script]
  916. my <model> eval {select * from mem.simtype} $script
  917. }
  918.  
  919. ###
  920. # topic: ac7ad89909e2988d08a23a0cfd27caf0
  921. ###
  922. method repaint_node node {
  923. set script [my meta cget repaint_script]
  924. my <model> simtype exists $node
  925. my <model> eval {select * from mem.simtype where unit=:node or typeid=:node} $script
  926. return [get icon]
  927. }
  928.  
  929. ###
  930. # topic: f92931f4c4818eeb2e8e7e5bd12187d9
  931. # title: Restore the state of the tree
  932. ###
  933. method restore_state {x {redraw 1}} {
  934. foreach {openstate typestate} $x break
  935. my all_off
  936.  
  937. foreach open $openstate {
  938. set typeid [db onecolumn {select typeid from xtype where typeid=$open}]
  939.  
  940. if { $typeid != {} } {
  941. my showtype $typeid
  942. continue
  943. }
  944. set typeid [::readi::search_attribute prior_typeid $open]
  945. if { $typeid != {} } {
  946. my showtype $typeid
  947. }
  948. }
  949. db transaction {
  950. foreach {t a c d} $typestate {
  951. if { $a } {
  952. my activeType $t $a 0
  953. }
  954. }
  955. }
  956. my repaint
  957. my <master> signal update
  958. }
  959.  
  960. ###
  961. # topic: 38d69300168adb8cb7518ea3e7f0e93c
  962. ###
  963. method show {{newstate {}}} {
  964. return
  965. global g simconfig
  966. variable toplevel
  967. set tf $toplevel
  968. if { $newstate != {} } {
  969. set ::g(show-xtype-tree) $newstate
  970. }
  971. if {!$::g(show-xtype-tree)} {
  972. catch {my <master> pane forget $tf}
  973. } else {
  974. my <master> pane insert 0 $tf
  975. }
  976. }
  977.  
  978. ###
  979. # topic: a22d4bc4cbc9b8748fd820ac7ecfd62d
  980. ###
  981. method Units_of_Typeid typeid {
  982. set units [my <model> eval {select distinct unit from mem.entity where typeid=:typeid}]
  983. set children [my <model> eval {select typeid from xtype where parent=:typeid}]
  984. foreach child $children {
  985. lappend units {*}[my Units_of_Typeid $child]
  986. }
  987. return $units
  988. }
  989.  
  990. ###
  991. # topic: 1f6742ae49ba4d5a1658aa85c7fdb1dc
  992. # title: Remove the selection from the tree widget
  993. ###
  994. method unselect {} {
  995. global g simconfig
  996. set ::g(seltype) {}
  997. }
  998. }
  999.  
  1000. namespace eval ::tree {}
  1001.  
  1002. #
  1003. # Bitmaps used to show which parts of the tree can be opened.
  1004. #
  1005. set maskdata "#define solid_width 9\n#define solid_height 9"
  1006. append maskdata {
  1007. static unsigned char solid_bits[] = {
  1008. 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
  1009. 0xff, 0x01, 0xff, 0x01, 0xff, 0x01
  1010. };
  1011. }
  1012. set data "#define open_width 9\n#define open_height 9"
  1013. append data {
  1014. static unsigned char open_bits[] = {
  1015. 0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
  1016. 0x01, 0x01, 0x01, 0x01, 0xff, 0x01
  1017. };
  1018. }
  1019. image create bitmap ::tree::openbm -data $data -maskdata $maskdata \
  1020. -foreground black -background white
  1021. set data "#define closed_width 9\n#define closed_height 9"
  1022. append data {
  1023. static unsigned char closed_bits[] = {
  1024. 0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
  1025. 0x11, 0x01, 0x01, 0x01, 0xff, 0x01
  1026. };
  1027. }
  1028. image create bitmap ::tree::closedbm -data $data -maskdata $maskdata \
  1029. -foreground black -background white
  1030.  
  1031. image create photo ::tree::green-check -data {
  1032. R0lGODlhCgAKAPAAAP///wChACH5BAEAAAAALAAAAAAKAAoAAAIQhI95EQrsoJITSWoYXnup
  1033. AgA7////
  1034. }
  1035. image create photo ::tree::red-x -data {
  1036. R0lGODlhCQAJAPAAAP///9sAACH5BAEAAAAALAAAAAAJAAkAAAISTIB5pofMEjBOUjmXdTE+
  1037. jRkFADv/
  1038. }
  1039. image create photo ::tree::blue-dot -data {
  1040. R0lGODlhCQAJAPAAAP///0hI/yH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
  1041. ADv/
  1042. }
  1043. image create photo ::tree::red-dot -data {
  1044. R0lGODlhCQAJAPAAAP///+YAACH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
  1045. ADv/
  1046. }
  1047. image create photo ::tree::green-dot -data {
  1048. R0lGODlhCQAJAPAAAP///wDPACH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
  1049. ADv/
  1050. }
  1051. image create photo ::tree::gray-dot -data {
  1052. R0lGODlhCQAJAPAAAP///6+vryH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
  1053. ADv/
  1054. }
  1055.