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

###
# topic: 044407824c5396262b0c21c08bef030c
###
tao::define ::irmgui::tree {
  superclass ::taotk::frame

  option master {class organ default ::appmain}
  option model {class organ default ::db}

  option only_leaf {
    default 1
    type boolean
  }

  constructor {window args} {
    my graft db ::db
    my Hull_Build $window {} {*}$args
  }

  signal content {
    action {my Widget_Content}
  }

  signal repaint {
    action {my repaint}
  }

  signal stretch {
    follows content
    action {my Widget_Stretch}
  }
  ###
  # topic: 346fdcec07b804d4bf46c9f05d0cf0fdaebb575a
  ###
  method bind {event command} {
    ::bind [my organ canvas] $event $command
  }

  ###
  # topic: c3ecc24f91dc449b3affa4f5fc0bb31f6f129a1d
  ###
  method columns {} {
    #return {name xtypeid}
    return name
  }

  ###
  # topic: 6b5848fdbe1b8f1d895321951fd4750cd9dfb64d
  ###
  method currentlyOpen {} {
    my variable _open
    set result {}
    foreach {typeid} [array names _open] {
      lappend result $typeid 1 0 0
    }
    return $result
    #return [my <db> eval {select typeid,open,0,0 from mem.simtype where open=1}]
  }

  ###
  # topic: 60188e2559740d4090276b84bf50ea7e08ae5340
  ###
  method currentSelection {} {
    return $::g(typeselect)
  }

  ###
  # topic: 9cd4ea021426c97c533473542fa6615f598b3f6e
  ###
  method displaycolumns {} {
    return {}
  }

  ###
  # topic: f0e1d9fdc64c2462e0d8bcda3b0ca5f8303d369f
  ###
  method Hull_Populate {} {
    set w [my widget hull]
    my graft canvas $w.tree
    my graft tree $w.tree
    my graft treewidget $w.tree

    ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview"
    canvas $w.tree -yscrollcommand "$w.vsb set"

    pack $w.vsb -side left -fill y
    pack $w.tree -side left -fill both -expand 1

    oo::objdefine [self] forward tree $w.tree
    #if {[info commands ::odie::dictionary_compare] != {}} {
    #  my <db> collate DICTIONARY ::odie::dictionary_compare
    #}
  }

  ###
  # topic: 23859dd0b694779ea35c8e4d4db633658f7ea287
  ###
  method isopen typeid {
    return [my <db> onecolumn {select open from mem.simtype where typeid=:typeid}]
  }

  ###
  # topic: d00cc6c4c2bba9ddca6ce3cd973e1fa41c8c580e
  # title: Draw a tree node
  # description: Ascend from leaves to draw trunks
  ###
  method redrawNode_bottomup typeid {
    set path {}
    set thistype $typeid
    while {$thistype ni {0 {}}} {
      my <db> eval {update mem.simtype set open=1 where typeid=:thistype}
      set thistype [my <db> onecolumn {select parent from mem.simtype where typeid=:typeid}]
      if {$typetype in $path} {
        puts "Warning: $typeid is one of its own parents"
        break
      }
      lappend path $typeid
    }
    #my signal redraw
  }

  ###
  # topic: 9160d030fd9ee8c2d246c081cf8ef4139bc318b6
  # title: Draw a tree node
  # description: Descend from trunks to draw leaves
  ###
  method redrawNode_topdown {pnode typeid} {
    set info [my node_info $typeid]
    if {[llength $info] eq 0} {
      return
    }
    dict with info {}

    set t [my treewidget insert $pnode end -text $name -image {} -values $row -tags $tags]

    ###
    # Add children
    ###
    array set dat [my childNodes $typeid]
    foreach {name} [lsort -dictionary [array names dat]] {
      set childid $dat($name)
      ###
      # Add children
      ###
      my redrawNode_topdown $t $childid
    }

    return $t
  }

  ###
  # topic: bed531ec0b3ba101bb245d316530f0fb2a6c46e1
  ###
  method setbg state {
    my variable tree
    switch $state {
      grey {
        my treewidget configure -style TaoGrey.Treeview
      }
      default {
        my treewidget configure -style Tao.Treeview
      }
    }
    update idletasks
  }

  ###
  # topic: bd851711b4a303904b181f653ebe5b0573c49a2d
  ###
  method showtype {typeid {select 0}} {
    my variable _open
    set parent [my <db> onecolumn {select parent from xtype where typeid=:typeid}]
    set _open($parent) 1
    set _open($typeid) 1
    if {$select} {
      global g
      lappend g(typeselect) $typeid
    }
    my signal content
  }


  method click {x y} {
    set typeid {}
    set clickon none
    lassign [my item_at_location $x $y] typeid clickon
    set fullname [db one {SELECT fullname FROM xtype WHERE typeid=$typeid}]
    variable _open
    global g
    if {$clickon eq "fork"} {
      if {[info exists _open($typeid)]} {
        unset _open($typeid)
        # ::rtest::record "type close $fullname"
      } else {
        set _open($typeid) 1
        # ::rtest::record "type open $fullname"
      }
      my signal content
    }
    my <master> notify tree_visible [list typeid $typeid]
    if {$clickon eq "text"} {
      my <master> event generate tree_select [list typeid $typeid]
      my <db> eval {update simtype set selected=0; update simtype set selected=1 where typeid=:typeid}
      set g(typeselect) $typeid
      set bbox [my <canvas> bbox y$typeid.text]

      foreach v $bbox d {-2 -1 1 1} {
        lappend bbox2 [expr $v + $d]
      }
      my <canvas> delete selbox
      set id [eval my <canvas> create rectangle $bbox2 -fill #d0d0ff -tags selbox]
      my <canvas> lower $id
      ::event generate [my organ canvas] <<TreeviewSelect>>
    }
    if {$clickon in {none {}} && $g(typeselect) ne ""} {
      set g(typeselect) ""
      my <canvas> delete selbox
    }
    if {$clickon eq "icon"} {
      my <master> notify tree_visible [list typeid $typeid]
      set active [my <model> simtype setting $typeid active]
      if { $active == 1 } {
        set active 0
      } else {
        set active 1
      }
      my signal content
      my <model> simtype active $typeid $active
      my <master> signal typetree
    }
  }

  method item_at_location {x y} {
    set x [my <canvas> canvasx $x]
    set y [my <canvas>  canvasy $y]
    set x0 [expr {$x-2}]
    set x1 [expr {$x+2}]
    set y0 [expr {$y-2}]
    set y1 [expr {$y+2}]
    my variable _map
    set idlist [my <canvas> find overlapping $x0 $y0 $x1 $y1]
    foreach id $idlist {
      if {[info exists _map($id)]} {return $_map($id)}
    }
    return {}
  }

  ###
  # topic: 0096f51242551ac91458647d143e2146
  ###
  method childNodes typeid {
    return [my <model> eval {select name,typeid from xtype where parent=:typeid order by name}]
  }

  ###
  # topic: 2d9488eb125be18d65e257a7a4ae18d7
  ###
  method columns {} {
    return {name class typeid}
  }

  ###
  # topic: a2b7b8fe19a238f10c39cc5c449d37fa
  ###
  method displaycolumns {} {
    return {}
  }

  method initialize {} {
    my event subscribe [my organ master] actionstack_pop
    set ::g(typeselect) {}
    next
  }

  ###
  # topic: c8945944427da83ffd8f25d60154ff58
  ###
  method node_info id {
    if { $id == 0 } {
      return {}
    }
    if {![my <model> exists {select typeid from xtype where typeid=:id}]} {
      return {}
    }

    set result [my <model> eval {select 'typeid',typeid,'parent',parent,'name',name,'class',class from xtype where typeid=:id}]
    set row {}
    foreach field [my columns] {
      lappend row [dict getnull $result $field]
    }
    set unit y$id
    dict set result row $row
    dict set result tags [list all [dict get $result class] $unit]
    return $result
  }

  ###
  # topic: d44626f010bf6aea26cc210718552325
  ###
  method nodetag unit {
    my <model> onecolumn {select unit from mem.simtype where unit=:unit or typeid=:unit}
  }

  method notify::actionstack_pop {sender info} {
    set w [my widget subwindow treeselect]
    destroy $w
  }

  ###
  # topic: 32bcb274c50481ce47f5ca7997921efa
  ###
  method parentNode unit {
    set typeid [my <model> onecolumn {select typeid from mem.simtype where unit=:unit or typeid=:unit}]
    return [my <model> onecolumn {select parent from xtype where parent=:typeid}]
  }

  method Redraw_Layer {depth base y} {
    if {$base eq ""} {
      set t1 {(parent IS NULL or parent=0)}
    } else {
      set t1 "parent=:base"
    }
    set sql "SELECT xtype.typeid as typeid, name, nchild, \
                  active, oncount \
           FROM xtype NATURAL JOIN simtype \
           WHERE $t1 AND name NOT NULL ORDER BY name"
    #if {[info commands ::odie::dictionary_compare] ne {}} {
    #  append sql " COLLATE DICTIONARY"
    #}

    set xbm [expr {5+8*$depth}]
    set xt [expr {$xbm+11}]
    variable _open
    variable _map
    global g
    set top $y
    set last_y $y
    set children [db eval $sql]
    foreach {typeid name nchild active oncount} [lsort -stride 5 -index 1 -dictionary $children] {
      if {$nchild>0} {
        set open [info exists _open($typeid)]
        set bm [expr {$open?"::tree::openbm":"::tree::closedbm"}]
        set id [my <canvas> create image $xbm $y -image $bm -anchor c]
        set _map($id) [list $typeid fork]
        set isleaf 0
      } else {
        set open 0
        set isleaf 1
      }
      set fg black

      if {$active==1} {
        set icon ::tree::green-check
      } elseif {$active==2} {
        set icon ::tree::red-x
      } elseif {$oncount>0} {
        set icon ::tree::blue-dot
      } else {
        set hit [db eval "select * from mem.entity where typeid = $typeid"]
        if {$hit == $typeid} {
          set icon ::tree::green-dot
        } else {
          set icon ::tree::gray-dot
        }
      }
      set id [my <canvas> create image $xt $y -image $icon -tags [list y$typeid.icon icon] -anchor w]
      set _map($id) [list $typeid icon]
      set bbox [my <canvas> bbox $id]

      set xtext [expr {[lindex $bbox 2]+5}]

      set id [my <canvas> create text $xtext $y -text $name  -tags [list y$typeid.text] -anchor w -fill $fg]
      set _map($id) [list $typeid text]
      set bbox [my <canvas> bbox $id]
      if {$g(typeselect)==$typeid} {
        foreach v $bbox d {-2 -1 1 1} {
          lappend bbox2 [expr $v + $d]
        }
        set id [eval my <canvas> create rectangle $bbox2 -fill #d0d0ff -tags selbox]
        my <canvas> lower $id
        set _map($id) [list $typeid text]
      }

      my <canvas> create line $xbm $y $xt $y -fill gray -tags bgline
      set last_y $y
      incr y 16
      if {$open} {
        set y [my Redraw_Layer [expr {$depth+1}] $typeid $y]
      }
    }
    set vline [my <canvas> create line $xbm [expr {$top-16}] $xbm $last_y \
                 -fill gray -tags bgline]
    my <canvas> lower bgline
    return $y
  }

  ###
  # topic: e03c35dbb814f2a4b7fc5bc903e918bf
  ###
  method rootNodes {} {
    return [my <model> eval {select name,typeid from xtype where parent is null or parent=0 order by fullname}]
  }

  ###
  # topic: 05369c766afa30cb21f6d031d4fd6b33
  ###
  method select_dialog {label match_funct args} {
    ###
    # Step one, check the tree
    ###
    set typeid [my <master> <tree> selected_type]
    if {[{*}$match_funct $class $typeid]} {
      return $typeid
    }
    set tl [my widget toplevel]
    set w [my widget subwindow treeselect]
    set obj [namespace current]::selector
    catch {$obj destroy}
    destroy $w
    ::taotk::toplevel $w -windowstyle modal -parent $tl
    ttk::label $w.l -text $label
    pack $w.l -side top
    if {[llength $args]==1} {
      set args [lindex $args 0]
    }
    update
    ::irm.typeselect create $obj $w.tree match_function $match_funct  master [my organ master] {*}$args
    $obj signal content
    pack $w.tree -side top -fill both -expand 1
    set g [wm geometry $tl]
    set x [split $g +]
    wm geometry $w 400x500+[join [lrange $x 1 2] +]


    set typeid [$obj grabSelection]
    my showtype $typeid 1
    catch {typeselect destroy}
    destroy $w
    return $typeid
  }

  ###
  # topic: 69c5be2d764b56ae85da24ad502309d3
  ###
  method selected_type {} {
    my variable selected_type
    if {[info exists selected_type]} {
      return $selected_type
    }
    global g
    return $g(typeselect)
  }

  method stretch {} {
    my signal stretch
  }

  method Widget_Stretch {} {
    ::update idletasks
    set bbox [my <canvas> bbox all]
    if {[llength $bbox]==0} {
      set bbox {0 0 200 800}
    }
    lassign $bbox x0 y0 x1 y1
    my <canvas> config -scrollregion $bbox
    my <master> <pane> sash 0 [expr {int(ceil(abs($x0-$x1))+30)}]
    bind [my <master> organ pane] <Double-Button-1> "[self] signal stretch"
  }

  method unselect {} {
    my canvas delete selbox
    global g
    set g(seltype) {}
  }

  ###
  # topic: a0866cfba29d19d42e5a2ebfcbbacec5141c5f4f
  # description: Clear all of the items out of the tree
  ###
  method Widget_Clear {} {
    my variable _map
    unset -nocomplain _map
    my <canvas> delete all
  }

  ###
  # topic: 4be65389c424491f7dfa515cc1ae85bd5001c14a
  ###
  method Widget_Content {} {
    set tw [appmain organ tree]
    ###
    # Capture who is open
    ###
    #array unset open_list *
    set open_list [my currentlyOpen]

    my Widget_Clear
    my Redraw_Layer 0 {} 8
    ::update idletasks
    lassign [my <canvas> bbox all] x0 y0 x1 y1
    set width [expr {$x1-$x0}]
    if {$width < 200} {
      set width 200
    }
    my <canvas> configure -scrollregion [list 0 0 $x1 $y1] -width $width

    my default
  }
}

###
# topic: 905929f18260003e71cf942a9e371bb8
###
tao::define ::irm.typeselect {
  superclass ::irmgui::tree

  option only_leaf {
    type boolean
    default 0
  }

  option allow_root {
    type boolean
    default 0
  }

  option match_function {
    default ::tree::true
  }

  ###
  # topic: 0981149764a30f5cf4abc8cd4523dbfe
  ###
  method action::select {
    dict with dictargs {}
    lassign [my item_at_location $x $y] typeid clickon
    set masterobj [my organ master]
    set typeobj   [my <master> layer xtype]
    set class {}
    my <db> eval {select class,name from xtype where typeid=:typeid} {}
    if {$class ne {}} {
      global g
      if {[string is true [my cget only_leaf]] && ![::readi::class_leaf $class]} {
        continue
      }
      $typeobj node dialog $typeid
      set g(typeselect) $typeid
      my variable selected_type
      set varn [my varname selected_type]
      set $varn $typeid
      return $typeid
    }
    return {}
  }

  ###
  # topic: 27a34d12e4a1e55e565ece93e85dcdc6
  ###
  method default {} {
    #my <treewidget> configure -selectmode browse
    my bind <KeyPress-Escape> "[self] actionCancel"
    my bind <1> "[self] click %x %y"
    global g simconfig
    set ::g(seltype) {0 1 2 3 4 5}
  }

  ###
  # topic: 585d924ca764fee66b41518670d3c0cc
  ###
  method displaycolumns {} {
    return {typeid}
  }

  ###
  # topic: d6f1c6cf569e5ea84a0b3906e60ca6be
  ###
  method grabSelection {} {
    my variable selected_type
    set varn [my varname selected_type]
    if {[info coroutine] eq {}} {
      vwait $varn
    } else {
      ::coroutine::util::vwait $varn
    }
    return $selected_type
  }

  ###
  # topic: ebadbee58ae5739cf4094bb56fa39b3f
  ###
  method node_info id {
    if { $id == 0 && [my cget allow_root]} {
      set result {typeid 0 parent -1 name (ROOT) class x }
    } else {
      if {![my <model> simtype exists $id]} {
        return {}
      }

      set result [my <model> eval {select 'typeid',typeid,'parent',parent,'name',name,'class',class from xtype where typeid=:id}]
    }
    set row {}
    foreach field [my columns] {
      lappend row [dict getnull $result $field]
    }
    set unit y$id
    dict set result row $row
    dict set result tags [list all [dict get $result class] $unit]
    return $result
  }

  ###
  # topic: d7b0365f61416e6114b5e73c0dac0b64
  ###
  method Option_set::match_function newvalue {
    my variable config
    if { $newvalue eq {} } {
      set newvalue ::tree::true
    }
    dict set config match_function $newvalue
    set match_funct $newvalue
  }

  ###
  # topic: 1107de5f8a7c33abd470dfb8be587fe8
  ###
  method rootNodes {} {
    set matchfun [my cget match_function]
    if {$matchfun eq {}} {
      set matchfun ::tree::true
    }
    set result {}
    if {[my cget allow_root]} {
      lappend result "(ROOT)" 0
    }
    my <model> eval {select typeid,name,class from xtype order by fullname} {
      if {[{*}$matchfun $class $typeid]} {
        lappend result $name $typeid
      }
    }
    return $result
  }

  ###
  # topic: 731c2d9f06bcc3787435b312900eace3
  ###
  method Widget_Content {} {
    my variable matchfun
    ###
    # Capture who is open
    ###

    my Widget_Clear
    foreach {name typeid} [lsort -dictionary -stride 2 [my rootNodes]] {
      my redrawNode_bottomup $typeid
    }

    ###
    # Redraw will be done later
    ###
    my default
  }
}

###
# topic: 22eba86507208e4eed2c4b07fc67f880
# description:
#    This module is responsible for drawing the tree widget showing
#    the xtype hierarchy on the left side of the screen.
#
#    Everything is in its own namespace
###
tao::define ::irmgui::typetree {
  superclass ::irmgui::tree

  property repaint_script {
    set icon {}
    if {$leaf} {
      if {$active==1} {
        set icon ::tree::green-check
      } elseif {$active==2} {
        set icon ::tree::red-x
      } elseif {$oncount>0} {
        set icon ::tree::blue-dot
      } else {
        if { $hidden } {
          set icon ::tree::red-dot
        } elseif { $visible } {
          set icon ::tree::green-dot
        } else {
          set icon ::tree::gray-dot
        }
      }
    } else {
      if {$active==1} {
        set icon ::tree::green-check
      } elseif {$active==2} {
        set icon ::tree::red-x
      } elseif {$oncount>0} {
        set icon ::tree::blue-triangle
      } else {
        if { $hidden } {
          set icon ::tree::red-triangle
        } elseif { $visible } {
          set icon ::tree::green-triangle
        } else {
          set icon ::tree::gray-triangle
        }
      }
    }
    my <canvas> itemconfigure $unit.icon -image $icon
  }

  method initialize {} {
    next
    my event subscribe * typetree_modified
  }

  ###
  # topic: 99152fc9a9ec31a0bf93ec2720c98536
  ###
  method action::highlight typeid {
    destroy .select
    toplevel .select
    ttk::label .select.knum -text "Select Color for y$typeid"
    pack .select.knum -side top -fill x

    foreach color {red orange yellow green blue indigo purple} {
      button .select.c[incr cnum] -text {     } -bg $color -command "set ::g(selector_color) $color"
      pack .select.c$cnum -side top -fill x
    }
    button .select.custom -text "Select Custom Color" -command {set ::g(selector_color) [tk_chooseColor]}
    pack .select.custom -side top -fill x

    set ::g(selector_color) {}
    while {$::g(selector_color) eq {}} {
      vwait ::g(selector_color)
    }
    destroy .select
    if {$::g(selector_color) eq "cancel"} {
      return
    }
    set color $::g(selector_color)
    my <master> <db> eval {insert or replace into mem.highlight(unit,color) select unit,:color from mem.entity where typeid=:typeid;}
    my <master> signal update
  }

  ###
  # topic: 22eb6754e97f17d206b727e65adba4fe
  ###
  method action::right_click {
    if {![my <master> meta cget mode_editor]} {
      return 0
    }
    # {w x y X Y} are fed into the event
    dict with dictargs {}
    destroy $w.menu
    set typeid {}
    lassign [my item_at_location $x $y] typeid element
    set masterobj [my organ master]
    set typeobj   [my <master> layer xtype]
    ::menu $w.menu -tearoff 0
    if { $typeid == {} } {
      $w.menu add command -label "New Type Category" -command  [list $typeobj action create_type]
      tk_popup $w.menu $X $Y
      return
    }
    my <db> eval {select class,name from xtype where typeid=:typeid} {}
    $w.menu add command -label "Edit $name $typeid" -command  [list $typeobj node dialog $typeid]
    if {[my <model> simtype setting $typeid active] < 2} {
      $w.menu add command -label "Hide $name $typeid" -command "$masterobj <model> simtype active $typeid 2 ; $masterobj signal typetree"
    } else {
      $w.menu add command -label "Unhide $name $typeid" -command "$masterobj <model> simtype active $typeid 0 ; $masterobj signal typetree"
    }
    switch $class {
      "k" {
        $w.menu add command -label "Create Link" -command [list $masterobj layer link action create_link typeid $typeid]
      }
      "x" {
        $w.menu add command -label "New Category" -command [list $typeobj action create_type $typeid 0]
        $w.menu add command -label "New Type" -command [list $typeobj action create_type $typeid 1]
      }
      "g" {
        $w.menu add command -label "New Division" -command [list $typeobj action create_type $typeid 0 group]
        $w.menu add command -label "New Role" -command [list $typeobj action create_type $typeid 1 crew]
      }
      "r" {
        $w.menu add command -label "New Sub-Type" -command [list $typeobj action create_type $typeid 1 rollup]
      }
    }
    $w.menu add command -label "Highlight $name $typeid" -command [namespace code [list my action highlight $typeid]]
    #$w.menu add command -label "Display $name" -command [list ::newtree::display $class $typeid]
    tk_popup $w.menu $X $Y
  }

  ###
  # topic: 0101076fbc67332972beee89f6d33b83
  ###
  method action::select {
    dict with dictargs {}
    lassign [my item_at_location $x $y] typeid clickon
    set masterobj [my organ master]
    set typeobj   [my <master> layer xtype]
    set class {}
    my <db> eval {select class,name from xtype where typeid=:typeid} {}
    if {$class ne {}} {
      global g
      $typeobj node dialog $typeid
      set g(typeselect) $typeid
      my variable selected_type
      set varn [my varname selected_type]
      set $varn $typeid
      return $typeid
    }
    return {}
  }

  ###
  # topic: 9590385a142cd8c2443691c4d3e0ac85
  # description:
  #    Toggle the display in response to a mouse click
  #    on the bubble icon
  ###
  method action::toggle {
    # w x y given by event
    dict with dictargs {}
    my click [dict get $dictargs x] [dict get $dictargs y]

  }

  ###
  # topic: 51722cb8de08248decfd1d103414f4d6
  # description:
  #    Toggle the display in response to a mouse click
  #    on the bubble icon
  ###
  method action::toggle_hide {
    # w x y given by event
    dict with dictargs {}
    set typeid {}
    lassign [my item_at_location $x $y] typeid element
    if { $typeid == {} } return
    set active [my <model> simtype setting $typeid active]
    if { $active == 2 } {
      set active 0
    } else {
      set active 2
    }
    my <treewidget> itemconfigure y$typeid.icon -image icon:eye
    update idletasks
    my <model> simtype active $typeid $active
    my <model> visible treefilter
    my <master> signal typetree
  }

  ###
  # topic: 43e2587d1ecdb323d607c2de1be0df50
  ###
  method default {} {
    my variable tree

    #my <treewidget> column #0 -stretch 1
    #my <treewidget> column class -width 30 -stretch 0

    #my <treewidget> configure -selectmode browse

    my bind <Button-1>       "[self] action toggle {w %W x %x y %y}"
    my bind <Alt-Button-1>   "[self] action toggle_hide {w %W x %x y %y}"
    my bind <Shift-Button-1> "[self] action toggle_hide {w %W x %x y %y}"

    my bind <Double-Button-1> "[self] action select {w %W x %x y %y}"
    my bind <Control-Button-1> "[self] action right_click {w %W x %x y %y X %X Y %Y}"
    my bind <Button-2> "[self] action right_click {w %W x %x y %y X %X Y %Y}"
    my bind <Button-3> "[self] action right_click {w %W x %x y %y X %X Y %Y}"
    my bind <KeyPress-Escape> {set ::tree::selected_type {}}

    my bind <<TreeviewSelect>> {}
    global g simconfig
    set ::g(seltype) {x k r e p v}
  }

  ###
  # topic: 544b397eea83aa6d5b7262df5fcb578c
  ###
  method isActive nodeid {
    return [my <model> onecolumn {return active from mem.simtype where typeid=:nodeid or unit=:nodeid}]
  }

  method notify::typetree_modified {sender dictargs} {
    switch [dict getnull $dictargs action] {
      created {
        set parent [dict getnull $dictargs parent]
        set tag [my nodetag $parent]
        foreach item [my treewidget tag has $tag] {
          catch {my treewidget item $item -open 1}
          catch {my treewidget see $item}
        }
      }
    }
  }

  ###
  # topic: 20c7d84f002bb949acb3512beb2dedeb
  ###
  method record command {
    ::rtest::record $command
  }

  ###
  # topic: af6ba91c8cbf1d13c5645bd097a4c577
  ###
  method repaint args {
    ###
    # Capture who is open
    ###
    set script [my meta cget repaint_script]
    my <model> eval {select * from mem.simtype} $script
  }

  ###
  # topic: ac7ad89909e2988d08a23a0cfd27caf0
  ###
  method repaint_node node {
    set script [my meta cget repaint_script]
    my <model> simtype exists $node
    my <model> eval {select * from mem.simtype where unit=:node or typeid=:node} $script
    return [get icon]
  }

  ###
  # topic: f92931f4c4818eeb2e8e7e5bd12187d9
  # title: Restore the state of the tree
  ###
  method restore_state {x {redraw 1}} {
    foreach {openstate typestate} $x break
    my all_off

    foreach open $openstate {
      set typeid [db onecolumn {select typeid from xtype where typeid=$open}]

      if { $typeid != {} } {
        my showtype $typeid
        continue
      }
      set typeid [::readi::search_attribute prior_typeid $open]
      if { $typeid != {} } {
        my showtype $typeid
      }
    }
    db transaction {
      foreach {t a c d} $typestate {
        if { $a } {
          my activeType $t $a 0
        }
      }
    }
    my repaint
    my <master> signal update
  }

  ###
  # topic: 38d69300168adb8cb7518ea3e7f0e93c
  ###
  method show {{newstate {}}} {
    return
    global g simconfig
    variable toplevel
    set tf $toplevel
    if { $newstate != {} } {
        set ::g(show-xtype-tree) $newstate
    }
    if {!$::g(show-xtype-tree)} {
      catch {my <master> pane forget $tf}
    } else {
      my <master> pane insert 0 $tf
    }
  }

  ###
  # topic: a22d4bc4cbc9b8748fd820ac7ecfd62d
  ###
  method Units_of_Typeid typeid {
    set units    [my <model> eval {select distinct unit from mem.entity where typeid=:typeid}]
    set children [my <model> eval {select typeid from xtype where parent=:typeid}]
    foreach child $children {
      lappend units {*}[my Units_of_Typeid $child]
    }
    return $units
  }

  ###
  # topic: 1f6742ae49ba4d5a1658aa85c7fdb1dc
  # title: Remove the selection from the tree widget
  ###
  method unselect {} {
    global g simconfig
    set ::g(seltype) {}
  }
}

namespace eval ::tree {}

#
# Bitmaps used to show which parts of the tree can be opened.
#
set maskdata "#define solid_width 9\n#define solid_height 9"
append maskdata {
  static unsigned char solid_bits[] = {
   0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01,
   0xff, 0x01, 0xff, 0x01, 0xff, 0x01
  };
}
set data "#define open_width 9\n#define open_height 9"
append data {
  static unsigned char open_bits[] = {
   0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01,
   0x01, 0x01, 0x01, 0x01, 0xff, 0x01
  };
}
image create bitmap ::tree::openbm -data $data -maskdata $maskdata \
  -foreground black -background white
set data "#define closed_width 9\n#define closed_height 9"
append data {
  static unsigned char closed_bits[] = {
   0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01,
   0x11, 0x01, 0x01, 0x01, 0xff, 0x01
  };
}
image create bitmap ::tree::closedbm -data $data -maskdata $maskdata \
  -foreground black -background white

image create photo ::tree::green-check -data {
    R0lGODlhCgAKAPAAAP///wChACH5BAEAAAAALAAAAAAKAAoAAAIQhI95EQrsoJITSWoYXnup
    AgA7////
}
image create photo ::tree::red-x -data {
    R0lGODlhCQAJAPAAAP///9sAACH5BAEAAAAALAAAAAAJAAkAAAISTIB5pofMEjBOUjmXdTE+
    jRkFADv/
}
image create photo ::tree::blue-dot -data {
    R0lGODlhCQAJAPAAAP///0hI/yH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
    ADv/
}
image create photo ::tree::red-dot -data {
    R0lGODlhCQAJAPAAAP///+YAACH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
    ADv/
}
image create photo ::tree::green-dot -data {
    R0lGODlhCQAJAPAAAP///wDPACH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
    ADv/
}
image create photo ::tree::gray-dot -data {
    R0lGODlhCQAJAPAAAP///6+vryH5BAEAAAAALAAAAAAJAAkAAAIPhI8Wm+vnoooM0GoleqkX
    ADv/
}

Recent Posts

• tcl by Bradipo
  1 hours ago
• tcl by aspect
  1 hours ago
• tcl by Bradipo
  2 hours ago
• tcl by Bradipo
  3 hours ago
• tcl by Bradipo
  4 hours ago
• lilypond by Bradipo
  1 days ago
• tcl by cgm
  11 days ago
• tcl by dandyn
  20 days ago
• tcl by Stu
  21 days ago
• tcl by dandyn
  23 days ago

Submit

• New paste

Documentation

• From Jabber