Tcl Library Source Code

set here [file dirname [file normalize [file join [pwd] [info script]]]]

set version 0.2
set module [file tail $here]

set fout [open [file join $here [file tail $module].tcl] w]
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide %module% %version%
namespace eval ::%module% {}
}]
if {$module ne "tool"} {
  puts $fout [string map $map {::tool::module push %module%}]
}

# Track what files we have included so far
set loaded {}
# These files must be loaded in a particular order
foreach file {
  baseclass.tcl procs.tcl stylesheet.tcl string.tcl
} {
  lappend loaded $file
  set fin [open [file join $here src $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $here src *.tcl]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set fin [open [file join $here src $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
  namespace export *
}
}]
close $fout

###
# Build our pkgIndex.tcl file
###
set fout [open [file join $here pkgIndex.tcl] w]
puts $fout [string map $map {# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool-ui 0.2 [list source [file join $dir tool-ui.tcl]]

::namespace eval ::tool::ui {}
::namespace eval ::tool::ui::element  {}
::namespace eval ::tool::ui::datatype {}
set ::tool::ui::datatype::regen 1

tool::define ::tool::ui::datatype {
  property classinfo type core
  variable internalvalue {}
  variable displayvalue {}
  
  meta set is {
    integer: 0
    string:  0
    real:    0
    number:  0
    date:    0
    complex: 0
    boolean: 0
  }
  
  class_method register {name body} {
    ::tool::define ::tool::ui::datatype::$name $body
    set ::tool::ui::datatype::regen 1
  }
  
  method datatype_inferences {options} {}
  
  method is::default {} {
    if {[my meta exists is ${method}]} {
      return [string is true [my meta get is ${method}:]]
    }
    return 0
  }
  
  method Generate_Select_Datatype {} {
    set ::tool::ui::datatype::regen 0
    set nspace [my meta get namespace datatype:]
    set default [my meta get namespace default:]
    set buffer [string map [list %NSPACE% $nspace] {
  set info [my config dump]
  set datatype {}
  foreach param {datatype type field widget storage} {
    if {[set v [dict getnull $info $param]] ne {}} {
      if {[info exists ::oo::dialect::cname(%NSPACE%::${v})]} {
        return $::oo::dialect::cname(%NSPACE%::${v})
      }
      set datatype $v
      break
    }
  }
  if {$%NSPACE%::regen} {
    set body [my Generate_Select_Datatype]
    oo::define [info object class [self]] method Select_Datatype {} $body
    return [my Select_Datatype]
  }
  set storage [dict getnull $info storage]
}]
    append buffer \n {# Adhoc rules}
    foreach {alias class} [lsort -dictionary -stride 2 [array get ::oo::dialect::cname ${nspace}::*]] {
      if {$alias ne $class} continue      
      set cexpr [::oo::meta::localdata $class is claim:]
      if {[string length $cexpr]} {
        append buffer \n [list if $cexpr [list return $class]]
      }
    }
    append buffer \n "  " [list return [info commands ${nspace}::${default}]]
    return $buffer
  }
  
  method Select_Datatype {} {
    set body [my Generate_Select_Datatype]
    oo::define ::tool::ui::datatype method Select_Datatype {} $body
    return [my Select_Datatype]
  }

  method value_display {} {
    my variable displayvalue
    if {![info exists displayvalue]} {
      set displayvalue [my Value_Display [my Value_Get]] 
    }
    return $displayvalue
  }
  
  # title: Format and internally coded value into human readable format
  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    return $value
  }
  
  # title: Convert an internally encoded value to its externally encoded value
  method Value_Export value {
    return $value
  }
  
  # title: Retrieve the internally encoded value stored with Value_Store
  method Value_Get {} {
    my variable internalvalue
    return $internalvalue
  }
  
  # title: Convert an externally encoded value to its internally encoded value
  method Value_Import  value {
    return $value
  }

  # title: Interpret a human editable value into an internally encoded value
  method Value_Interpret  value {
    return $value
  }
 
  # title: Store a value in the internally coded format for later recall
  method Value_Store value {
    my variable internalvalue displayvalue
    set internalvalue $value
    set displayvalue [my Value_Display $value]
  }
  
  method Value_Url {} {
    return {}
  }
}

tool::define ::tool::ui::element {
  superclass ::tool::ui::datatype
  
  property classinfo type core

  option unknown      {default 0}
  option showlabels   {default 1}
  option units        {default {}}
  option data_source  {default {}}
  option label        {default {}}
  option description  {default {}}
  option field        {default {}}
  option textvariable {default {}}
  option readonly     {default 0}
  option command      {default {}}
  option post_command {default {}}
  option colorstate   {default normal}
  option row          {default {}}
  
  variable entryvalue {}

  meta set namespace {
    datatype:     ::tool::ui::datatype
  }
  
  variable displayvalue {}
  
  ###
  # Place to store an internal representation
  # of the value:
  # variable local_value
  ###
  option form {
    class organ
    description {The form we are representing}
  }
  
  constructor {} {}
  
  ###
  # description:
  #    Called during the destructor of taotk widgets prior
  #    to the destruction of tk objects and the unlinking and
  #    destruction of the object and it's subobjects. It gives
  #    complex UIs an easy to maintain shim with which to respond
  #    to the object's destruction, without having to modify the
  #    the (admitedly) complex taotk object destructor.
  ###
  method action::destroy {} {}

  method action::revert_to_default {} {
    set field [my cget field]
    set default [my cget default]
    if {$default in {{} default}} {
      set default [my <form> private Option_Default $field]
    }
    my Value_Store $default
  }

  method ApplySelectedValue newvalue {
    if {[set command [my cget post_command]] ne {}} {
      set field [my cget field]
      eval [string map [list %field% [list $field] %self% [namespace which my] %value% [list $newvalue]] $command]
    }
    if {[set command [my cget command]] ne {}} {
      set field [my cget field]
      eval [string map [list %field% [list $field] %self% [namespace which my] %value% [list $newvalue]] $command]
    }
    set varname [my GlobalVariableName]
    if { $varname ne {} } {
      set $varname $newvalue
    }
  }


  method attach {organs args} {
    my variable field
    my graft {*}$organs

    set dictargs {}
    foreach {dfield dval} [::tool::args_to_options {*}$args] {
      dict set dictargs [string trim $dfield :] $dval
    }
    set options [my inferences [dict merge $dictargs $organs]]
    set form [dict get $options form]
    my config merge $options
    my graft form $form parent $form object $form
    my config merge [list form $form parent $form object $form]
    my <form> formelement register [self] $options
    
    set datatype   [my Select_Datatype]
    my mixinmap datatype $datatype
    if {$datatype ne {}} {
      dict set options datatype [namespace tail $datatype]
    }
    set dopts [my datatype_inferences $options]
    my config merge $dopts
  }
  
  ###
  # description:
  #    This command is run after the arguments are inputted
  #    internally, and should throw an error if a needed argument
  #    was not given a value.
  ###
  method check_required_args {} {
    return {}
  }
  
  method ClearError {} {}

  method DefaultValue {} {
    my variable config
    set getcmd [dict getnull $config default-command]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% [my cget field] %widget% [namespace which my] %self% [my cget object] %object% [my cget object]] $getcmd]]
    } else {
      return [dict getnull $config default]
    }
  }
  
  # Return descriptive text about this field
  method Description {} {
    return [my cget description]
  }
  
  method display {} {}

  method drawn {} {
    return 1
  }
  method edit {} {}
  
  method inferences {info} {
    set result [dict merge $info [my organ all]]
    set form ::noop
    if {[dict exists $info form]} {
      set form [dict get $info form]    
    } elseif {[dict exists $info object]} {
      set form [dict get $info object]
    } elseif {[dict exists $info parent]} {
      set form [dict get $info parent]
    }
    dict set result form $form
    set field [string tolower [dict get $info field]]
    if {![dict exists $info labels]} {
      dict set result labels 1
    }
    set label {}
    set description {}
  
    if {![dict exists $info units]} {
      dict set result units {}
    }
    foreach mf {desc description comment} {
      if {[dict exists $info $mf]} {
        append description [string trim [dict get $info $mf]]
      }
    }
    if {[dict exists $info label]} {
      set label [dict get $info label]
    }
    if { $label == {} } {
      set label $field
    } else {
      set description "Full Name: $field\n$description"
    }
    
    switch {[dict getnull $info mode]} {
      dynamic -
      spec -
      specs {
        dict set result mode  dynamic
      }
      default {
        dict set result mode  static
      }
    }
    dict set result label $label
    dict set result description $description
    return $result
  }

  method ErrorInvalid {newvalue {error {}} {errdat {}}} {
    puts stderr "Failed to interpret $newvalue : $error"
    puts stderr [dict getnull $errdat -errorinfo]
  }

  # title: Pull the contents from the widget and decode the human-readable input into machine values
  method get {} {
    return [my Value_Export [my Value_Get]]
  }

  method GlobalVariableName {} {
    return [my cget textvariable]
  }

  # title: Pull new contents to the widget and encode the machine value to the human-readable output
  method put value {
    set ivalue [my Value_Import $value]
    my Value_Store $ivalue
    my config merge [list value $value]
  }

  method readonly {} {
    return [string is true -strict [my cget readonly]]
  }
  
  method Validate newvalue {
    if {[catch {
      set ivalue [my Value_Interpret $newvalue]
      my Value_Store $ivalue
      set result [my Value_Export $ivalue]
      my ClearError
      my ApplySelectedValue $result
    } error errdat]} {
      my ErrorInvalid $newvalue $error $errdat
      return 0
    }
    return 1
  }
}

###
# Basic functions for maintaining a relationship between
# forms and their fields
###
tool::define ::tool::ui::form {

  variable formelement_object {}
  variable formelement_fields {}

  method formelement::register {object info} {
    my variable formelement_object formelement_fields subobjects
    dict set info dobject $object
    if {[dict exists $info field]} {
      set field [dict get $info field]
      if {[dict exists $info subform]} {
        dict set formelement_object {*}[dict get $info subform] $field $object
        dict set formelement_fields $object [list {*}[dict get $info subform] $field]
      } else {
        dict set formelement_object $field $object
        dict set formelement_fields $object $field
      }
    }
    dict set info event 0
    dict set subobjects $object $info
  }
  
  method formelement::field {object} {
    my variable formelement_fields
    return [dict getnull $formelement_fields $object]
  }
  
  method formelement::object {args} {
    my variable formelement_object subobjects formelement_fields
    set dobject {}
    if {[info exists subobjects] && [dict exists $subobjects {*}$args dobject]} {
      set dobject [dict get $subobjects {*}$args dobject]
    } elseif {[info exists formelement_object] && [dict exists $formelement_object [lindex $args 0]]} {
      set dobject [lindex $args 0]
    }
    if {$dobject eq {}} {
      return {}
    }
    if {[info command $dobject] eq {}} {
      my formelement unregister $dobject
      return {}
    }
    return $dobject
  }
  
  method formelement::info {object} {
    my variable subobjects
    return [dict getnull $subobjects $object]
  }
  
  method formelement::unregister object {
    my variable formelement_object formelement_fields subobjects
    catch {dict unset formelement_object {*}$formelement_fields $object}
    catch {dict unset formelement_fields $object}
    catch {dict unset subobjects $object}
  }
  
  method FormRead {args} {
    my variable formelement_object
    if {![info exists formelement_object]} {
      return {}
    }
    set result {}
    foreach dobject [dict getnull $formelement_object {*}$args] {
      if {[info command $dobject] eq {}} continue
      dict set result [$dobject cget field] [$dobject get]
    }
    return $result
  }
  
  method FormReset subform {
    my variable subformrow display_map
    set display_map {}
    unset -nocomplain subformrow
  }
  
  method FormObject {api args} {
    set fconfig [dict merge {*}$args]
    set field   [dict get $fconfig field]
    set subform [dict get $fconfig subform]
    set objname [my SubObject $subform $field]
    if {[info command $objname] eq {}} {
      $api create $objname
    } else {
      if {[info object class $objname] ne $api} {
        $objname destroy
        $api create $objname
      }      
    }
    $objname attach [list form [self]] $fconfig
    return $objname
  }
}

::tool::ui::datatype register boolean {
  aliases bool u1

  meta branchset is {
    number:  1
    integer: 1
    boolean: 1
    real: 1
  }

  method datatype_inferences info {
    set result {}
    if {[dict isnull $info storage]} {
      dict set result storage boolean
    }
    if {[dict isnull $info widget]} {
      dict set result widget boolean
    }
    return $result 
  }

  method Value_Export value {
    return [string is true -strict $value]
  }

  method Value_Import  value {
    return [string is true -strict $value]
  }

}

::tool::ui::datatype register number {
  meta branchset is {
    number:  1
    integer: 1
    real:    1
    ranged:  0
  }
  option range {default {}}
  option divisions {default 0}

  method Range {} {
    return [my cget range]
  }
  
  method Value_Import value {
    if { $value in {NULL {}} } {
      return [my cget default]
    }
    return $value
  }

  
  method Value_Interpret value {
    if { $value in {NULL {}} } {
      return [my cget default]
    }
    set range [my Range]
    if {[llength $range]==0} {
      return $value
    }
    set from [lindex $range 0]
    set to   [lindex $range 1]
    if { $to eq {} } {
      set to 1.0
    }
    if { $from eq {} } {
      set from 0.0
    }
    set divisions [my cget divisions]
    if {$value > $to} {
      return $to
    } elseif {$value < $from} {
      return $from
    } elseif {[set divisions [my cget divisions]]>0} {
      return [expr {round((($value-$from)/($to-$from)*$divisions))/$divisions*($to-$from)+$from}]
    }
    return $value
  }
}

# title: Integer UI
::tool::ui::datatype register integer {
  aliases u2 u3 u4 u5 u6 u7 u8 u16 u32 u64 long time timer {long long}
  superclass number
  meta branchset is {
    number:  1
    integer: 1
    real:    0
    claim:   {$datatype in {int integer unsigned uint long {long long} time timer} || ([string index $datatype 0] eq "u" && [string is integer -strict [string range $datatype 1 end]])}
  }
  option format {default %d}

  method datatype_inferences info {
    set result {}
    if {[dict isnull $info storage]} {
      foreach field {datatype type} {
        set v [dict getnull $info $field]
        if {$v ne {}} {
          dict set result storage $v
          break
        }
      }
      dict set result storage int
    }
    return $result
  }
  
  method Value_Import value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget format]
    set c [scan $value $format newvalue]
    if {![info exists newvalue]} {
      error "Bad value $value"
    }
    return $newvalue
  }
  
  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget format]
    set c [scan $value $format newvalue]
    if {![info exists newvalue]} {
      error "Bad value $value"
    }
    return $newvalue
  }
}

# title: real
::tool::ui::datatype register real {
  aliases float double widedouble
  superclass number
  meta branchset is {
    number:  1
    integer: 0
    real:    1
  }
  option format {default %g}
  
  method datatype_inferences info {
    set result {}
    if {[dict isnull $info storage]} {
      foreach field {datatype type} {
        set v [dict getnull $info $field]
        if {$v ne {}} {
          dict set result storage $v
          break
        }
      }
      dict set result storage double
    }
    return $result
  }

  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget format]
    set c [scan $value $format newvalue]
    if {![info exists newvalue]} {
      error "Bad value $value"
    }
    return $newvalue
  }
}

::tool::ui::datatype register percentage {
  superclass real
  option divisions {default 1000.0}
  meta branchset is {
    ranged:  1
    match: {$datatype in {percent percentage %}}
  }
  
  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return [my cget default]
    }
    if {$value > 100.0} {
      return 100.0
    } elseif {$value < 0.0} {
      return 0.0
    } elseif {[set divisions [my cget divisions]]>0} {
      return [expr {round($value*$divisions)/$divisions}]
    }
    return $value
  }
  
  method Range {} {
    return {0.0 100.0}
  }
}


# title: A real number between zero ane one
::tool::ui::datatype register kronecker {
  superclass real
  meta branchset is {
    ranged:  1
    match: {$datatype in {kronecker unit kronecker_delta}}
  }
  # When displaying on a scale, get
  # to the nearest 0.05
  option divisions {default 0}
  
  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return [my cget default]
    }
    if {$value > 1.0} {
      return 1.0
    } elseif {$value < 0.0} {
      return 0.0
    } elseif {[set divisions [my cget divisions]]>0} {
      return [expr {round($value*$divisions)/$divisions}]
    }
    return $value
  }
  
  method Range {} {
    return {0.0 1.0}
  }
}

# title: A value which stores a physical quantity that can be expressed in multiple units
::tool::ui::datatype register physics {
  superclass real
  
  option delimeter {default "*"}
  option units {}
  
  method unit_info {specinfo} {
    my variable system_units system_options
    set result {}
    set system_units [dict getnull $specinfo units]
    if {[::tool::is_null $system_units]} {
      set system_units [my meta get physics units:]
      dict set result units $system_units
    }
    set system_options [dict getnull $specinfo options]
    if {[::tool::is_null $system_options]} {
      set system_options [my meta getnull physics options:]
      dict set result options $system_options
    }
    if {$system_units ni $system_options} {
      lappend system_option $system_units
      dict set result options $system_options
    }
    return $result
  }
  
  method datatype_inferences specinfo {
    set result {}
    set widget [dict getnull $specinfo widget]
    if {[::tool::is_null $widget]} {
      dict set result widget physics
    }
    set format [dict getnull $specinfo format]
    if {[::tool::is_null $format]} {
      dict set result format %s
    }
    foreach {f v} [my unit_info $specinfo] {
      dict set result $f $v
    }
    return $result
  }
  
  method Value_Store value {
    my variable irm_value user_value user_units system_units displayvalue internalvalue
    if {![info exists system_units]} {
      set system_units [my cget units]
    }
    if {[::tool::is_null $value]} {
      set irm_value   {}
      set user_value  {}
      set displayvalue {}
      set internalvalue {}
      set user_units {}
      return {}
    }
    set value [string map {+ { } , { } * { } x { }} $value]
    set irm_value   [lindex $value 0]
    set user_value  [lindex $value 1]
    if {[llength $value]==1} {
      set user_units $system_units
      set user_value $irm_value
      set internalvalue $irm_value
      set displayvalue [my Value_Display $irm_value]
    } elseif {[llength $value]==0 || [::tool::is_null $user_value]} {
      set user_units $system_units
      set user_value $irm_value
      set internalvalue {}
      set displayvalue  {}
    } else {
      set user_units   [lindex $value 2]
      set internalvalue [list $irm_value $user_value $user_units]
      set displayvalue [my Value_Display $internalvalue]
    }
  }
  
  method Value_Get {} {
    my variable irm_value user_value user_units
    if {[::tool::is_null $irm_value]} {
      return {}
    }
    return [list $irm_value $user_value $user_units]
  }

  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    my variable system_units
    set value [string map {+ { } , { } * { } x { }} $value]
    if {![info exists system_units]} {
      return $value
    }
    if {[llength $value]<2 || [lindex $value 1] eq {}} {
      return $value
    }
    if {[lindex $value 2] eq "$system_units" || [lindex $value 0] eq [lindex $value 1]} {
      return "[lindex $value 0] $system_units"
    }
    return "[lindex $value 1] [lindex $value 2] ([lindex $value 0] ${system_units})"
  }
  
  method Value_Interpret newvalue {
    if { $newvalue in {NULL {}} } {
      return [my cget default]
    }
    my variable system_units
    if {[llength $newvalue]==2} {
      set irm_value [::siground::signif [::units::convert $newvalue $system_units] 6]
      return [list $irm_value {*}$newvalue]
    }
    set irm_value [lindex $newvalue 0]
    set human_value [lrange $newvalue 1 end]
    if {[llength $human_value]==0} {
      return $irm_value
    }
    if {[llength $human_value]==1} {
      return [lindex $human_value 0]
    }
    if {[string index $human_value 0] eq "."} {
      set human_value 0$human_value
    }
    set irm_value [::siground::signif [::units::convert $human_value $system_units] 6]
    set user_quantity [::siground::signif [lindex $human_value 0] 6]
    if {$irm_value eq $user_quantity} {
      return [lindex $human_value 0]
    }
    return [list $irm_value {*}$human_value]
  }
}

::tool::ui::datatype register volume {
  superclass physics
  
  meta set physics units: m^3
  meta set physics options:  {liters gallons m^3}
}

::tool::ui::datatype register length {
  superclass physics
  
  meta set physics units: meter
  meta set physics options:  {meter feet inch mile km mm cm}
}

::tool::ui::datatype register flow {
  superclass physics

  meta set physics units: liter/second
  meta set physics options:  {liter/second gallon/minute}

}

::tool::ui::datatype register power {
  superclass physics
  
  meta set physics units: watt
  meta set physics options:  {watt kw hp}
}

::tool::ui::datatype register temperature {
  superclass physics
  
  meta set physics units: celsius
  meta set physics options:  {kelvin celsius farhenheit}
}

::tool::ui::datatype register kelvin {
  superclass physics
  
  meta set physics units: kelvin
  meta set physics options:  {kelvin celsius farhenheit}
  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    my variable system_units
    set degsym "\xB0"
    if {[llength $value]<2 || [lindex $value 1] eq {}} {
      return "$value ( [::siground::signif [::units::convert [list $value $system_units] celsius] 4]${degsym}C)"
    }
    if {[lindex $value 2] eq "$system_units" || [lindex $value 0] eq [lindex $value 1]} {
      set value [lindex $value 1]
      return "$value ( [::siground::signif [::units::convert [list $value $system_units] celsius] 4]${degsym}C)"
    }
    return "[lindex $value 1] ${degsym}[lindex $value 2] ([lindex $value 0] ${degsym}${system_units})"
  }
}

::namespace eval ::tool::ui {}

proc ::tool::ui::widget_select {nspace info} {
  set nspace ::[string trimleft $nspace :]
  ###
  # Look for storage specific codes
  ###
  set widget {}
  if {[dict exists $info widget]} {
    set widget [dict get $info widget]
  } else {
    set widget {}
    if {[dict exists $info storage]} {
      set widget [dict get $info storage]
    } else {
      if {[dict exists $info type]} {
        set widget [dict get $info type]
      }
    }
  }
  if {[info command ${nspace}::$widget] ne {} } {
    return ${nspace}::$widget
  }
  if { $widget ne {} } {
    switch $widget {
      bool - boolean - u1 {
        return ${nspace}::boolean
      }
      generic - string - text {
        return ${nspace}::string
      }
      vector {
        return ${nspace}::vector
      }
      longtext -
      blob -
      script {
        return ${nspace}::script
      }
    }
  }
  if {[dict exists $info field]} {
    # Guess based on field name
    set field [dict get $info field]
    
    if {[info command ${nspace}::$field] ne {} } {
      return ${nspace}::$field
    }
  }
  if {[dict exists $info values-format]} {
    switch [dict get $info values-format] {
      enum -
      enumerated -
      select_keyvalue -
      list {
        return ${nspace}::select
      }
    }
  }

  if {[dict exists $info values]} {
    return ${nspace}::select
  }
  if {[dict exists $info range]} {
    return ${nspace}::scale
  }

  if {[dict exists $info history]} {
    if {[string is true [dict get $info history]]} {
      return ${nspace}::history
    }
  }
  return ${nspace}::string
}

#
# round number to significant digits
# according to 
# http://perfdynamics.blogspot.de/2010/04/significant-figures-in-r-and-rounding.html
# round number num to n significant digits
# works only in the range of double
# it is published under the same licence as Tcl
# (c) J. Heidemeier 2014
#
namespace eval ::siground {}
proc ::siground::signif {num n {decimalPoint .}} {
set orig $num
# arguments:
# num: number to be rounded (integer, real or exponential format)
# n: number of significant digits (positive integer)
# decimalPoint: decimal separator character for the output (default .)
# 
# reasonable figure for significant digits ?
    if {!([string is integer $n] && $n > 0)} \
        {error  "number of significant digits $n is not a positive integer"}
#
# ensure that num is numeric
# and split into sign, integer, decimal and exponent part
#
if {[regexp {^([+,-]?)([0-9]+)(\.?[0-9]*)?([eE][+-]?[0-9]+)?$} $num -> s i d e]} {
# i must contain alt least one digit
if {![string length i]} "error wrong format $num, no digit in Integerpart "
#
# type of number
# 
    set typ ""    
    if {[string length $e]} {set typ e}
    if {[string length $d]} {
        if {$typ ne {e}} {set typ d}
    } else {
        if {$typ ne {e}} {
                set typ i
#
#
#
        } else {
# reformat iexx to i.0exx bringen
            set d {.0}
       }
    }
# remove leading 0, if digits 1-9 in i-part
# or collapse several 0 to 0
#
    if {[string length $i] > 1} {
        regexp  {^(0*)([1-9][0-9]*)$} $i -> NULL DIG
        if {[string length $DIG]} {
            set i $DIG
        } else {
            set i 0 ;# collapse to one 0
        }
    }
#        
# build teststring for rounding process
#
set tstring $i
            
set decpos [expr {[string length $i] -1}]
# skip decimalpoint and append decimalpart
if {[string length $d]} {
       append tstring [string range $d 1 end]
} 
# enough digits for the rounding process       
    set ndigs [string length $tstring]
    if {$ndigs < $n} {
        return $orig
    #    error "more significant digits $n requested than available $ndigs"
    }

# x is the last significant digit
# y and z are the following 2 digits, if y or z are blank
# zeros are appended     
    set x [string index $tstring $n-1]
        if  {$ndigs == $n} {
            set y 0
        } else {
        set y [string index $tstring $n]
    }
    if {$ndigs > $n} {
        set z [string index $tstring $n+1]
    } else {
        set z 0
    }
# the actual test; pad0 pads zeros for the integerpart
    if {$y < 5} {        
        set rstring "[string range $tstring 0 $n-1][pad0 $decpos $n]"
    } elseif {$y > 5} {
         incr x
            set rstring "[string range $tstring 0 $n-2]$x[pad0 $decpos $n]"
    } else {
# y == 5; test for parity jitter
        if {$z >= 1} {
                set rstring "[string range $tstring 0 $n-1][pad0 $decpos $n]"
        } else {
            if {[isOdd $x]} {
                incr x
            }
                set rstring "[string range $tstring 0 $n-2]$x[pad0 $decpos $n]"
        }
    }
} else {
 error "number to round \"$num\" is not numeric"
}
# reformatting the output    
    switch -exact -- $typ {
        i {set result "$s$rstring"}
        d {
            set decfrac [string range $rstring $decpos+1 end]
            if {![string length $decfrac]} {
                set result "$s$rstring"
            } else {
                set result "$s[string range $rstring 0 $decpos]$decimalPoint$decfrac"
            }
        }
        e {
            set result "$s[string range $rstring 0 $decpos]$decimalPoint[string range $rstring $decpos+1 end]$e"
        }
    }
return  $result
}
#
# pad integer part with 0 if necessary
# arguments
# decpos:  index of the last digit before the decimal point
# n:  number of significant digits
#
proc ::siground::pad0 {decpos n} {

    set v {}
    incr decpos
    set x [expr {$decpos - $n}]
    
    if {$x} {
        set v [string repeat 0 $x] 
    }
    return $v
 }

proc ::siground::isOdd n {
    try {
        expr {$n & 1}
    } trap {ARITH DOMAIN} {message options} {
        return -options $options -errorinfo "$n is not an integer"
    }
}

::tool::ui::datatype register select {
  meta set is claim: {[dict getnull $info values-format] eq "list"}
  option values {}
  option cache-values {type: boolean default: 1}
  
  option state {
    widget select
    values {normal readonly disabled}
    default readonly
  }

  method datatype_inferences {options} {
    set result {}
    if {[dict isnull $options widget]} {
      dict set result widget select
    }
    if {[dict isnull $options state]} {
      dict set result state readonly
    }
    return $result
  }

  method CalculateValues {} {
    set values [my GetConfigValueList]
    return $values
  }

  method CalculateValueWidth values {
    set w 0
    set n 0
    foreach v $values {
      incr n
      set l [string length $v]
      incr bins($l)
      if {$l > $w} {
        set w $l
      }
    }
    if { $w > 30} {
      set w 30
    }
    return $w
  }
  
  method Description {} {
    set text [my cget description]
    set thisline {}
    set values [my CalculateValues]
    set format [my cget values-format]
    append text \n "Possible Values:"
    foreach value [my CalculateValues] {
      if {[string length $thisline]>40} {
        append text \n [string trim $thisline]
        set thisline {}
      }
      append thisline " $value"
    }
    append text \n [string trim $thisline]
    return $text
  }

  method GetConfigValueList {} {
    my variable config values
    if {[info exists values]} {
      return $values
    }
    foreach opt {values-command options_command} {
      if {[dict exists $config $opt]} {
        set script [string map [list %field% [dict getnull $config field] %config% $config] [dict get $config $opt]]
        if {[catch $script cvalues]} {
          puts "Warning: Error computing values for $field: $values"
          set cvalues {}
        } else {
          if {[llength $cvalues]} {
            return $cvalues
          }
        }
      }
    }
    if {[dict exists $config options]} {
      set values [dict get $config options]
      if {[llength $values]} {
        return $values
      }
    }
    if {[dict exists $config values]} {
      set values [dict get $config values]
    }
    if {![info exists values]} {
      set values {}
    }
    return $values
  }
}

::tool::ui::datatype register select_keyvalue {
  superclass select

  option accept_number {
    datatype boolean
    default 1
  }
  
  method CalculateValues {} {
    set values [my GetConfigValueList]
    set result {}
    foreach {key value} $values {
      lappend result $key
    }
    return $result
  }

  method Description {} {
    set text [my cget description]
    append text \n "Possible Values:"
    foreach {key value} [my GetConfigValueList] {
      append text \n " * $key - $value"
    }
    return $text
  }
  
  method Value_Export rawvalue {
    set values [my GetConfigValueList]
    foreach {var val} $values {
      if {$rawvalue eq $val} {
        return $val
      }
      if {$rawvalue eq $var} {
        return $val
      }
    }
    return $rawvalue
  }

  method Value_Interpret  rawvalue {
    set values [my GetConfigValueList]
    foreach {var val} $values {
      if {$rawvalue eq $val} {
        return $var
      }
      if {$rawvalue eq $var} {
        return $var
      }
    }
    if {[my cget accept_number]} {
      if {[string is double $rawvalue]} {
        return $rawvalue
      }
    }
    error "Invalid Value \"$rawvalue\". Valid: [join [dict keys $values] ,]"
  }
}

::tool::ui::datatype register enumerated {
  aliases enum
  superclass select
  meta branchset is {
    number:  1
    integer: 1
    real:    0
  }

  option enum {
    default {}
  }

  method CalculateValues {} {
    set values {}
    foreach {id code comment} [my GetConfigValueList] {
      lappend values "$id - $code $comment"
    }
    return $values
  }
  
  method Description {} {
    set text [my cget description]
    append text \n "Possible Values:"
    foreach {id code comment} [my GetConfigValueList] {
      append text \n " * $id - ($code) $comment"
    }
    return $text
  }

  method Value_Interpret value {
    set value [lindex $value 0]
    foreach {id code comment} [my GetConfigValueList] {
      if {$value == $id } {
        return $id
      }
    }
    return {}
  }

  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    foreach {id code comment} [my GetConfigValueList] {
      if { [lindex $value 0] == $id } {
        return "$id - $code"
      }
    }
    return $value
  }
}

###
# Handlers for basic string widgets
###

###
# title: Arbitrary Date/Time
###
::tool::ui::datatype register datetime {

  option display_format {default {}}  
  option output_format  {default {}}
  option gmt {datatype boolean default 0}

  meta branchset is {
    date: 1
  }
  
  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget display_format]
    if { $format ni { {} "unixtime" } } {
      return [clock scan $value -format $format -gmt [my cget gmt]]
    }
    return [clock scan $value]
  }

  method Value_Export value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget output_format]
    if { $format ni { {} "unixtime" } } {
      return [clock format $value -format $format -gmt [my cget gmt]]
    }
    return $value
  }

  method Value_Import  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget output_format]
    if { $format ni { {} "unixtime" } } {
      return [clock scan $value -format $format -gmt [my cget gmt]]
    }
    return [clock scan $value]
  }
  
  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget display_format]
    if { $format ne {} } {
      return [clock format $value -format $format -gmt [my cget gmt]]
    }
    return [clock format $value -gmt [my cget gmt]]
  }
}

###
# title: unixtime
###
::tool::ui::datatype register unixtime {

  option gmt {datatype boolean default 0}
  option display_format {default {%Y-%m-%d %H:%M:%S}}  

  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return {}
    }
    return [clock scan $value]
  }

  method Value_Export value {
    if {[::tool::is_null $value]} {
      return {}
    }
    return $value
  }

  method Value_Import  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    if {![string is integer -strict $value]} {
      return [clock scan $value]
    }
    return $value
  }
  
  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget display_format]
    if { $format ne {} } {
      return [clock format $value -format $format -gmt [my cget gmt]]
    } else {
      return [clock format $value -gmt [my cget gmt]]
    }
  }
}

###
# topic: e10dc9220800b9649c51f42b176d2d1afa8dc93d
# description:
#    Facilities expected of any object
#    that is marked as a master to a dynamic object
###
tool::define ::tool::ui::stylesheet {
  superclass
  
  property style_prefix {Tool}

  option initial-filepath [list tab General type pathname default [pwd] description {Path where file dialogs open by default}]
  
  option stylelist { default {} }
  
  option color-background [subst {
    signal stylesheet
    usage gui
    tab colors
    type color
    default white
    description {Default background color for windows}
  }]

  option color-row-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #BBF
    description {Color of even numbered rows in the display}
  }

  option color-row-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #FFF
    description {Color of even numbered rows in the display}
  }
  option color-red-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #F44
    description {Color of even numbered red rows in the display (with error)}
  }
  option color-red-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #F00
    description {Color of even numbered red rows in the display (with error)}
  }

  option color-blue-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #44F
    description {Color of even numbered red rows in the display (with error)}
  }
  option color-blue-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #00F
    description {Color of even numbered red rows in the display (with error)}
  }

  option color-green-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #4F4
    description {Color of even numbered red rows in the display (with error)}
  }
  option color-green-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #0F0
    description {Color of even numbered red rows in the display (with error)}
  }

  option color-grey-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #a0a0a0
    description {Color of even numbered grey rows in the display (with disabled/greyed)}
  }
  option color-grey-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #888
    description {Color of even numbered grey rows in the display (with disabled/greyed)}
  }
  
  option font-button {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default TkDefaultFont
    description {Font used on standard buttons}
  }
  option font-button-bold {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on bold buttons}
  }
  option font-button-small {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on small buttons}
  }
  option font-button-fixed {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on fixed font buttons}
  }
  option font-canvas {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on canvas elements}
  }
  option font-console {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {fixed 10}
    description {Font used on console widgets}
  }
  option font-editor {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {fixed 10}
    description {Font used on editable text widgets}
  }
  option font-entry {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default TkDefaultFont
    description {Font used on standard entry boxes}
  }
  option font-fixed {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Standard fixed space font}
  }
  option font-label {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default TkDefaultFont
    description {Font used on standard labels}
  }
  option font-normal {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {helvetica 10}
    description {Standard proportional font}
  }
  option font-popups {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on popups}
  }
  option font-text {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {fixed 10}
    description {Font used on normal text widgets}
  }
  
  option style_background {
    type color
    tab general
    signal stylesheet
    default grey
  }
  
  ###
  # topic: 576dca7d430159ab89fb1130fb72039aba74a5b5
  ###
  method Option_font_default field {
    # Font defaults for generic unix
    switch $field {
      font-fixed        {return {fixed 10}}
      font-button-fixed {return {fixed 12}}
      font-button-small {return {fixed 6}}
      font-button-bold  {return {fixed 12 bold}}
      font-canvas       {return {fixed 10}}
      font-popups       {return {fixed 8}}      
    }
  }

  method TkFontToCSS font {
    set family [lindex $font 0]
    if {$family eq "TkDefaultFont"} {
      set family Helvetica
    } else {
      dict set info -family $family
    }
    if {[lindex $font 1] ne {}} {
      dict set info -size [lindex $font 1]
    } else {
      dict set info -size medium
    }
    switch [lindex $font 2] {
      italic {
        dict set info -style italic
        dict set info -wieght normal
      }
      bold {
        dict set info -style normal
        dict set info -wieght bold
      }
      default {
        dict set info -style normal
        dict set info -wieght normal
      }
    }
    
    set size [dict get $info -size]
    if {[string is integer $size]} {
      append result "font-size:${size}pt\;"
    } else {
      append result "font-size:${size}\;"
    }
    append result "font-family:\"[dict get $info -family]\"\;"
    append result "font-weight:[dict get $info -weight]\;"
    append result "font-style:[dict get $info -slant]\;"
    return $result
  }

  ###
  # title: Return this sheet as a Cascading style sheet
  ###
  method css args {
    my variable css
    if {("reset" ni $args) && [info exists css]} {
      return $css
    }
    set result {}
    
    # Set the background
    append result "body \{"
    append result "background-color:[my cget color-background]\;"
    append result "\}"
    
    # Tweak text
    foreach {taglist option} {
      {p div html} font-normal
      .tkentry font-entry
      .tklabel font-label
      {typewriter verbatim} font-fixed
    } {
      set cssf [my TkFontToCSS [my cget $option]]
      foreach tag $taglist {
        append result "\n$tag \{${cssf}\}"
      }
    }
    foreach {style} {
      row red blue green grey
    } {
      append result "\nroweven$style \{background-color:[my cget color-${style}-even]\;\}"
    }
    set css $result
    return $result
  }
  ###
  # title: Return a row color in the given style
  ###
  method row_color {{row {}} {substyle {}}} {
    if { $row eq {} } {
      my variable Rowcount
      set row $Rowcount
    }
    switch $substyle {
      green {
        if {[expr {$row % 2}]} {
          return [my cget color-green-odd]
        } else {
          return [my cget color-green-even]
        }        
      }
      blue {
        if {[expr {$row % 2}]} {
          return [my cget color-blue-odd]
        } else {
          return [my cget color-blue-even]
        }        
      }
      grey -
      missing {
        if {[expr {$row % 2}]} {
          return [my cget color-grey-odd]
        } else {
          return [my cget color-grey-even]
        }
      }
      red -
      error {
        if {[expr {$row % 2}]} {
          return [my cget color-red-odd]
        } else {
          return [my cget color-red-even]
        }
      }
      default {
        if {[expr {$row % 2}]} {
          return [my cget color-row-odd]
        } else {
          return [my cget color-row-even]
        }
      }
    }
  }
}

###
# title: Vector
###
::tool::ui::datatype register vector {
  superclass ::tool::ui::form
  property vector_fields {
    x {type real format {%g} width 10}
    y {type real format {%g} width 10}
    z {type real format {%g} width 10}
  }
  
  method datatype_inferences options {
    set result {}
    if {[dict isnull $options widget]} {
      dict set result widget vector
    }
    return $result
  }
  
  method Value_Export newvalue {
    set result {}
    array set content $newvalue
    foreach {vfield info} [my Vector_Fields]  {
      set format [if_null [dict getnull $info format] %s]
      set newvalue [format $format $content($vfield)]
      lappend result $newvalue
    }
    return $result
  }
  
  method Vector_Fields {} {
    return [my meta cget vector_fields]
  }

  method Value_Get {} {
    my variable local_array
    return [array get local_array]
  }
  
  method Value_Store value {
    my variable local_array internalvalue displayvalue
    if {[::tool::is_null $value]} {
      set internalvalue {}
      set displayvalue {}
      return
    }
    array set local_array $value
    foreach {field val} [array get local_array] {
      dict set internalvalue $field $val
      set obj [my formelement object $field]
      if {$obj ne {}} {
        $obj put $val
      }
    }
    set displayvalue [my Value_Display $internalvalue]
  }
  
  method Value_Import  inputvalue {
    set idx -1
    foreach {vfield info} [my Vector_Fields] {
      incr idx
      set format [if_null [dict getnull $info format] %s]
      set value [lindex $inputvalue $idx]
      if {[dict exists $info default]} {
        if {$value eq {}} {
          set value [dict get $info default]
        }
      }
      if {$value eq {}} {
        set local_array($vfield) $value
      } elseif { $format in {"%d" int integer} } {
        if [catch {expr {int($value)}} nvalue] {
          puts "Err: $format $vfield. Raw: $value. Err: $nvalue"
          dict set result $vfield $value
        } else {
          dict set result $vfield $nvalue
        }
      } else {
        if [catch {format $format $value} nvalue] {
          puts "Err: $vfield. Raw: $value. Err: $nvalue"
          dict set result $vfield $value
        } else {
          dict set result $vfield $nvalue
        }
      }
    }
    return $result
  }
}

[comment {-*- tool-ui -*-}]
[manpage_begin tool-ui n 0.1]
[keywords TclOO]
[keywords tao]
[keywords odielib]
[copyright {2014 Sean Woods <[email protected]>}]
[moddesc {Tao User Interface (TaoUI)}]
[titledesc {Abstractions to allow Tao to express Native Tk, HTML5, and Tao-Layout interfaces}]
[category {Object System}]
[require Tcl 8.6]
[description]

[para]

The [package tool-ui] package to allows Tao to express Native Tk, HTML5, and Tao-Layout interfaces.
[para]
Code in this module returns only text and list values. It should not rely on the presence of Tk
or a web backend.

[section COMMANDS]
[para]

[section "REFERENCES"]


[section AUTHORS]
Sean Woods

[vset CATEGORY tool-ui]
[include scripts/feedback.inc]

[manpage_end]

###
# Amalgamated package for tool-ui
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide tool-ui 0.2
namespace eval ::tool-ui {}

::tool::module push tool-ui
###
# START: baseclass.tcl
###
::namespace eval ::tool::ui {}
::namespace eval ::tool::ui::element  {}
::namespace eval ::tool::ui::datatype {}
set ::tool::ui::datatype::regen 1

tool::define ::tool::ui::datatype {
  property classinfo type core
  variable internalvalue {}
  variable displayvalue {}
  
  meta set is {
    integer: 0
    string:  0
    real:    0
    number:  0
    date:    0
    complex: 0
    boolean: 0
  }
  
  class_method register {name body} {
    ::tool::define ::tool::ui::datatype::$name $body
    set ::tool::ui::datatype::regen 1
  }
  
  method datatype_inferences {options} {}
  
  method is::default {} {
    if {[my meta exists is ${method}]} {
      return [string is true [my meta get is ${method}:]]
    }
    return 0
  }
  
  method Generate_Select_Datatype {} {
    set ::tool::ui::datatype::regen 0
    set nspace [my meta get namespace datatype:]
    set default [my meta get namespace default:]
    set buffer [string map [list %NSPACE% $nspace] {
  set info [my config dump]
  set datatype {}
  foreach param {datatype type field widget storage} {
    if {[set v [dict getnull $info $param]] ne {}} {
      if {[info exists ::oo::dialect::cname(%NSPACE%::${v})]} {
        return $::oo::dialect::cname(%NSPACE%::${v})
      }
      set datatype $v
      break
    }
  }
  if {$%NSPACE%::regen} {
    set body [my Generate_Select_Datatype]
    oo::define [info object class [self]] method Select_Datatype {} $body
    return [my Select_Datatype]
  }
  set storage [dict getnull $info storage]
}]
    append buffer \n {# Adhoc rules}
    foreach {alias class} [lsort -dictionary -stride 2 [array get ::oo::dialect::cname ${nspace}::*]] {
      if {$alias ne $class} continue      
      set cexpr [::oo::meta::localdata $class is claim:]
      if {[string length $cexpr]} {
        append buffer \n [list if $cexpr [list return $class]]
      }
    }
    append buffer \n "  " [list return [info commands ${nspace}::${default}]]
    return $buffer
  }
  
  method Select_Datatype {} {
    set body [my Generate_Select_Datatype]
    oo::define ::tool::ui::datatype method Select_Datatype {} $body
    return [my Select_Datatype]
  }

  method value_display {} {
    my variable displayvalue
    if {![info exists displayvalue]} {
      set displayvalue [my Value_Display [my Value_Get]] 
    }
    return $displayvalue
  }
  
  # title: Format and internally coded value into human readable format
  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    return $value
  }
  
  # title: Convert an internally encoded value to its externally encoded value
  method Value_Export value {
    return $value
  }
  
  # title: Retrieve the internally encoded value stored with Value_Store
  method Value_Get {} {
    my variable internalvalue
    return $internalvalue
  }
  
  # title: Convert an externally encoded value to its internally encoded value
  method Value_Import  value {
    return $value
  }

  # title: Interpret a human editable value into an internally encoded value
  method Value_Interpret  value {
    return $value
  }
 
  # title: Store a value in the internally coded format for later recall
  method Value_Store value {
    my variable internalvalue displayvalue
    set internalvalue $value
    set displayvalue [my Value_Display $value]
  }
  
  method Value_Url {} {
    return {}
  }
}

tool::define ::tool::ui::element {
  superclass ::tool::ui::datatype
  
  property classinfo type core

  option unknown      {default 0}
  option showlabels   {default 1}
  option units        {default {}}
  option data_source  {default {}}
  option label        {default {}}
  option description  {default {}}
  option field        {default {}}
  option textvariable {default {}}
  option readonly     {default 0}
  option command      {default {}}
  option post_command {default {}}
  option colorstate   {default normal}
  option row          {default {}}
  
  variable entryvalue {}

  meta set namespace {
    datatype:     ::tool::ui::datatype
  }
  
  variable displayvalue {}
  
  ###
  # Place to store an internal representation
  # of the value:
  # variable local_value
  ###
  option form {
    class organ
    description {The form we are representing}
  }
  
  constructor {} {}
  
  ###
  # description:
  #    Called during the destructor of taotk widgets prior
  #    to the destruction of tk objects and the unlinking and
  #    destruction of the object and it's subobjects. It gives
  #    complex UIs an easy to maintain shim with which to respond
  #    to the object's destruction, without having to modify the
  #    the (admitedly) complex taotk object destructor.
  ###
  method action::destroy {} {}

  method action::revert_to_default {} {
    set field [my cget field]
    set default [my cget default]
    if {$default in {{} default}} {
      set default [my <form> private Option_Default $field]
    }
    my Value_Store $default
  }

  method ApplySelectedValue newvalue {
    if {[set command [my cget post_command]] ne {}} {
      set field [my cget field]
      eval [string map [list %field% [list $field] %self% [namespace which my] %value% [list $newvalue]] $command]
    }
    if {[set command [my cget command]] ne {}} {
      set field [my cget field]
      eval [string map [list %field% [list $field] %self% [namespace which my] %value% [list $newvalue]] $command]
    }
    set varname [my GlobalVariableName]
    if { $varname ne {} } {
      set $varname $newvalue
    }
  }


  method attach {organs args} {
    my variable field
    my graft {*}$organs

    set dictargs {}
    foreach {dfield dval} [::tool::args_to_options {*}$args] {
      dict set dictargs [string trim $dfield :] $dval
    }
    set options [my inferences [dict merge $dictargs $organs]]
    set form [dict get $options form]
    my config merge $options
    my graft form $form parent $form object $form
    my config merge [list form $form parent $form object $form]
    my <form> formelement register [self] $options
    
    set datatype   [my Select_Datatype]
    my mixinmap datatype $datatype
    if {$datatype ne {}} {
      dict set options datatype [namespace tail $datatype]
    }
    set dopts [my datatype_inferences $options]
    my config merge $dopts
  }
  
  ###
  # description:
  #    This command is run after the arguments are inputted
  #    internally, and should throw an error if a needed argument
  #    was not given a value.
  ###
  method check_required_args {} {
    return {}
  }
  
  method ClearError {} {}

  method DefaultValue {} {
    my variable config
    set getcmd [dict getnull $config default-command]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% [my cget field] %widget% [namespace which my] %self% [my cget object] %object% [my cget object]] $getcmd]]
    } else {
      return [dict getnull $config default]
    }
  }
  
  # Return descriptive text about this field
  method Description {} {
    return [my cget description]
  }
  
  method display {} {}

  method drawn {} {
    return 1
  }
  method edit {} {}
  
  method inferences {info} {
    set result [dict merge $info [my organ all]]
    set form ::noop
    if {[dict exists $info form]} {
      set form [dict get $info form]    
    } elseif {[dict exists $info object]} {
      set form [dict get $info object]
    } elseif {[dict exists $info parent]} {
      set form [dict get $info parent]
    }
    dict set result form $form
    set field [string tolower [dict get $info field]]
    if {![dict exists $info labels]} {
      dict set result labels 1
    }
    set label {}
    set description {}
  
    if {![dict exists $info units]} {
      dict set result units {}
    }
    foreach mf {desc description comment} {
      if {[dict exists $info $mf]} {
        append description [string trim [dict get $info $mf]]
      }
    }
    if {[dict exists $info label]} {
      set label [dict get $info label]
    }
    if { $label == {} } {
      set label $field
    } else {
      set description "Full Name: $field\n$description"
    }
    
    switch {[dict getnull $info mode]} {
      dynamic -
      spec -
      specs {
        dict set result mode  dynamic
      }
      default {
        dict set result mode  static
      }
    }
    dict set result label $label
    dict set result description $description
    return $result
  }

  method ErrorInvalid {newvalue {error {}} {errdat {}}} {
    puts stderr "Failed to interpret $newvalue : $error"
    puts stderr [dict getnull $errdat -errorinfo]
  }

  # title: Pull the contents from the widget and decode the human-readable input into machine values
  method get {} {
    return [my Value_Export [my Value_Get]]
  }

  method GlobalVariableName {} {
    return [my cget textvariable]
  }

  # title: Pull new contents to the widget and encode the machine value to the human-readable output
  method put value {
    set ivalue [my Value_Import $value]
    my Value_Store $ivalue
    my config merge [list value $value]
  }

  method readonly {} {
    return [string is true -strict [my cget readonly]]
  }
  
  method Validate newvalue {
    if {[catch {
      set ivalue [my Value_Interpret $newvalue]
      my Value_Store $ivalue
      set result [my Value_Export $ivalue]
      my ClearError
      my ApplySelectedValue $result
    } error errdat]} {
      my ErrorInvalid $newvalue $error $errdat
      return 0
    }
    return 1
  }
}



###
# END: baseclass.tcl
###
###
# START: procs.tcl
###
::namespace eval ::tool::ui {}

proc ::tool::ui::widget_select {nspace info} {
  set nspace ::[string trimleft $nspace :]
  ###
  # Look for storage specific codes
  ###
  set widget {}
  if {[dict exists $info widget]} {
    set widget [dict get $info widget]
  } else {
    set widget {}
    if {[dict exists $info storage]} {
      set widget [dict get $info storage]
    } else {
      if {[dict exists $info type]} {
        set widget [dict get $info type]
      }
    }
  }
  if {[info command ${nspace}::$widget] ne {} } {
    return ${nspace}::$widget
  }
  if { $widget ne {} } {
    switch $widget {
      bool - boolean - u1 {
        return ${nspace}::boolean
      }
      generic - string - text {
        return ${nspace}::string
      }
      vector {
        return ${nspace}::vector
      }
      longtext -
      blob -
      script {
        return ${nspace}::script
      }
    }
  }
  if {[dict exists $info field]} {
    # Guess based on field name
    set field [dict get $info field]
    
    if {[info command ${nspace}::$field] ne {} } {
      return ${nspace}::$field
    }
  }
  if {[dict exists $info values-format]} {
    switch [dict get $info values-format] {
      enum -
      enumerated -
      select_keyvalue -
      list {
        return ${nspace}::select
      }
    }
  }

  if {[dict exists $info values]} {
    return ${nspace}::select
  }
  if {[dict exists $info range]} {
    return ${nspace}::scale
  }

  if {[dict exists $info history]} {
    if {[string is true [dict get $info history]]} {
      return ${nspace}::history
    }
  }
  return ${nspace}::string
}


###
# END: procs.tcl
###
###
# START: stylesheet.tcl
###
###
# topic: e10dc9220800b9649c51f42b176d2d1afa8dc93d
# description:
#    Facilities expected of any object
#    that is marked as a master to a dynamic object
###
tool::define ::tool::ui::stylesheet {
  superclass
  
  property style_prefix {Tool}

  option initial-filepath [list tab General type pathname default [pwd] description {Path where file dialogs open by default}]
  
  option stylelist { default {} }
  
  option color-background [subst {
    signal stylesheet
    usage gui
    tab colors
    type color
    default white
    description {Default background color for windows}
  }]

  option color-row-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #BBF
    description {Color of even numbered rows in the display}
  }

  option color-row-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #FFF
    description {Color of even numbered rows in the display}
  }
  option color-red-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #F44
    description {Color of even numbered red rows in the display (with error)}
  }
  option color-red-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #F00
    description {Color of even numbered red rows in the display (with error)}
  }

  option color-blue-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #44F
    description {Color of even numbered red rows in the display (with error)}
  }
  option color-blue-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #00F
    description {Color of even numbered red rows in the display (with error)}
  }

  option color-green-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #4F4
    description {Color of even numbered red rows in the display (with error)}
  }
  option color-green-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #0F0
    description {Color of even numbered red rows in the display (with error)}
  }

  option color-grey-even {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #a0a0a0
    description {Color of even numbered grey rows in the display (with disabled/greyed)}
  }
  option color-grey-odd {
    signal stylesheet
    usage gui
    tab colors
    type color
    default #888
    description {Color of even numbered grey rows in the display (with disabled/greyed)}
  }
  
  option font-button {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default TkDefaultFont
    description {Font used on standard buttons}
  }
  option font-button-bold {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on bold buttons}
  }
  option font-button-small {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on small buttons}
  }
  option font-button-fixed {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on fixed font buttons}
  }
  option font-canvas {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on canvas elements}
  }
  option font-console {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {fixed 10}
    description {Font used on console widgets}
  }
  option font-editor {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {fixed 10}
    description {Font used on editable text widgets}
  }
  option font-entry {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default TkDefaultFont
    description {Font used on standard entry boxes}
  }
  option font-fixed {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Standard fixed space font}
  }
  option font-label {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default TkDefaultFont
    description {Font used on standard labels}
  }
  option font-normal {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {helvetica 10}
    description {Standard proportional font}
  }
  option font-popups {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default-command {my Option_font_default %field%}
    description {Font used on popups}
  }
  option font-text {
    signal stylesheet
    type font
    tab fonts
    usage gui
    default {fixed 10}
    description {Font used on normal text widgets}
  }
  
  option style_background {
    type color
    tab general
    signal stylesheet
    default grey
  }
  
  ###
  # topic: 576dca7d430159ab89fb1130fb72039aba74a5b5
  ###
  method Option_font_default field {
    # Font defaults for generic unix
    switch $field {
      font-fixed        {return {fixed 10}}
      font-button-fixed {return {fixed 12}}
      font-button-small {return {fixed 6}}
      font-button-bold  {return {fixed 12 bold}}
      font-canvas       {return {fixed 10}}
      font-popups       {return {fixed 8}}      
    }
  }

  method TkFontToCSS font {
    set family [lindex $font 0]
    if {$family eq "TkDefaultFont"} {
      set family Helvetica
    } else {
      dict set info -family $family
    }
    if {[lindex $font 1] ne {}} {
      dict set info -size [lindex $font 1]
    } else {
      dict set info -size medium
    }
    switch [lindex $font 2] {
      italic {
        dict set info -style italic
        dict set info -wieght normal
      }
      bold {
        dict set info -style normal
        dict set info -wieght bold
      }
      default {
        dict set info -style normal
        dict set info -wieght normal
      }
    }
    
    set size [dict get $info -size]
    if {[string is integer $size]} {
      append result "font-size:${size}pt\;"
    } else {
      append result "font-size:${size}\;"
    }
    append result "font-family:\"[dict get $info -family]\"\;"
    append result "font-weight:[dict get $info -weight]\;"
    append result "font-style:[dict get $info -slant]\;"
    return $result
  }

  ###
  # title: Return this sheet as a Cascading style sheet
  ###
  method css args {
    my variable css
    if {("reset" ni $args) && [info exists css]} {
      return $css
    }
    set result {}
    
    # Set the background
    append result "body \{"
    append result "background-color:[my cget color-background]\;"
    append result "\}"
    
    # Tweak text
    foreach {taglist option} {
      {p div html} font-normal
      .tkentry font-entry
      .tklabel font-label
      {typewriter verbatim} font-fixed
    } {
      set cssf [my TkFontToCSS [my cget $option]]
      foreach tag $taglist {
        append result "\n$tag \{${cssf}\}"
      }
    }
    foreach {style} {
      row red blue green grey
    } {
      append result "\nroweven$style \{background-color:[my cget color-${style}-even]\;\}"
    }
    set css $result
    return $result
  }
  ###
  # title: Return a row color in the given style
  ###
  method row_color {{row {}} {substyle {}}} {
    if { $row eq {} } {
      my variable Rowcount
      set row $Rowcount
    }
    switch $substyle {
      green {
        if {[expr {$row % 2}]} {
          return [my cget color-green-odd]
        } else {
          return [my cget color-green-even]
        }        
      }
      blue {
        if {[expr {$row % 2}]} {
          return [my cget color-blue-odd]
        } else {
          return [my cget color-blue-even]
        }        
      }
      grey -
      missing {
        if {[expr {$row % 2}]} {
          return [my cget color-grey-odd]
        } else {
          return [my cget color-grey-even]
        }
      }
      red -
      error {
        if {[expr {$row % 2}]} {
          return [my cget color-red-odd]
        } else {
          return [my cget color-red-even]
        }
      }
      default {
        if {[expr {$row % 2}]} {
          return [my cget color-row-odd]
        } else {
          return [my cget color-row-even]
        }
      }
    }
  }
}


###
# END: stylesheet.tcl
###
###
# START: string.tcl
###
###
# Handlers for basic string widgets
###

###
# title: Arbitrary Date/Time
###
::tool::ui::datatype register datetime {

  option display_format {default {}}  
  option output_format  {default {}}
  option gmt {datatype boolean default 0}

  meta branchset is {
    date: 1
  }
  
  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget display_format]
    if { $format ni { {} "unixtime" } } {
      return [clock scan $value -format $format -gmt [my cget gmt]]
    }
    return [clock scan $value]
  }

  method Value_Export value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget output_format]
    if { $format ni { {} "unixtime" } } {
      return [clock format $value -format $format -gmt [my cget gmt]]
    }
    return $value
  }

  method Value_Import  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget output_format]
    if { $format ni { {} "unixtime" } } {
      return [clock scan $value -format $format -gmt [my cget gmt]]
    }
    return [clock scan $value]
  }
  
  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget display_format]
    if { $format ne {} } {
      return [clock format $value -format $format -gmt [my cget gmt]]
    }
    return [clock format $value -gmt [my cget gmt]]
  }
}

###
# title: unixtime
###
::tool::ui::datatype register unixtime {

  option gmt {datatype boolean default 0}
  option display_format {default {%Y-%m-%d %H:%M:%S}}  

  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return {}
    }
    return [clock scan $value]
  }

  method Value_Export value {
    if {[::tool::is_null $value]} {
      return {}
    }
    return $value
  }

  method Value_Import  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    if {![string is integer -strict $value]} {
      return [clock scan $value]
    }
    return $value
  }
  
  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget display_format]
    if { $format ne {} } {
      return [clock format $value -format $format -gmt [my cget gmt]]
    } else {
      return [clock format $value -gmt [my cget gmt]]
    }
  }
}

###
# END: string.tcl
###
###
# START: form.tcl
###

###
# Basic functions for maintaining a relationship between
# forms and their fields
###
tool::define ::tool::ui::form {

  variable formelement_object {}
  variable formelement_fields {}

  method formelement::register {object info} {
    my variable formelement_object formelement_fields subobjects
    dict set info dobject $object
    if {[dict exists $info field]} {
      set field [dict get $info field]
      if {[dict exists $info subform]} {
        dict set formelement_object {*}[dict get $info subform] $field $object
        dict set formelement_fields $object [list {*}[dict get $info subform] $field]
      } else {
        dict set formelement_object $field $object
        dict set formelement_fields $object $field
      }
    }
    dict set info event 0
    dict set subobjects $object $info
  }
  
  method formelement::field {object} {
    my variable formelement_fields
    return [dict getnull $formelement_fields $object]
  }
  
  method formelement::object {args} {
    my variable formelement_object subobjects formelement_fields
    set dobject {}
    if {[info exists subobjects] && [dict exists $subobjects {*}$args dobject]} {
      set dobject [dict get $subobjects {*}$args dobject]
    } elseif {[info exists formelement_object] && [dict exists $formelement_object [lindex $args 0]]} {
      set dobject [lindex $args 0]
    }
    if {$dobject eq {}} {
      return {}
    }
    if {[info command $dobject] eq {}} {
      my formelement unregister $dobject
      return {}
    }
    return $dobject
  }
  
  method formelement::info {object} {
    my variable subobjects
    return [dict getnull $subobjects $object]
  }
  
  method formelement::unregister object {
    my variable formelement_object formelement_fields subobjects
    catch {dict unset formelement_object {*}$formelement_fields $object}
    catch {dict unset formelement_fields $object}
    catch {dict unset subobjects $object}
  }
  
  method FormRead {args} {
    my variable formelement_object
    if {![info exists formelement_object]} {
      return {}
    }
    set result {}
    foreach dobject [dict getnull $formelement_object {*}$args] {
      if {[info command $dobject] eq {}} continue
      dict set result [$dobject cget field] [$dobject get]
    }
    return $result
  }
  
  method FormReset subform {
    my variable subformrow display_map
    set display_map {}
    unset -nocomplain subformrow
  }
  
  method FormObject {api args} {
    set fconfig [dict merge {*}$args]
    set field   [dict get $fconfig field]
    set subform [dict get $fconfig subform]
    set objname [my SubObject $subform $field]
    if {[info command $objname] eq {}} {
      $api create $objname
    } else {
      if {[info object class $objname] ne $api} {
        $objname destroy
        $api create $objname
      }      
    }
    $objname attach [list form [self]] $fconfig
    return $objname
  }
}
###
# END: form.tcl
###
###
# START: number.tcl
###

::tool::ui::datatype register boolean {
  aliases bool u1

  meta branchset is {
    number:  1
    integer: 1
    boolean: 1
    real: 1
  }

  method datatype_inferences info {
    set result {}
    if {[dict isnull $info storage]} {
      dict set result storage boolean
    }
    if {[dict isnull $info widget]} {
      dict set result widget boolean
    }
    return $result 
  }

  method Value_Export value {
    return [string is true -strict $value]
  }

  method Value_Import  value {
    return [string is true -strict $value]
  }

}

::tool::ui::datatype register number {
  meta branchset is {
    number:  1
    integer: 1
    real:    1
    ranged:  0
  }
  option range {default {}}
  option divisions {default 0}

  method Range {} {
    return [my cget range]
  }
  
  method Value_Import value {
    if { $value in {NULL {}} } {
      return [my cget default]
    }
    return $value
  }

  
  method Value_Interpret value {
    if { $value in {NULL {}} } {
      return [my cget default]
    }
    set range [my Range]
    if {[llength $range]==0} {
      return $value
    }
    set from [lindex $range 0]
    set to   [lindex $range 1]
    if { $to eq {} } {
      set to 1.0
    }
    if { $from eq {} } {
      set from 0.0
    }
    set divisions [my cget divisions]
    if {$value > $to} {
      return $to
    } elseif {$value < $from} {
      return $from
    } elseif {[set divisions [my cget divisions]]>0} {
      return [expr {round((($value-$from)/($to-$from)*$divisions))/$divisions*($to-$from)+$from}]
    }
    return $value
  }
}

# title: Integer UI
::tool::ui::datatype register integer {
  aliases u2 u3 u4 u5 u6 u7 u8 u16 u32 u64 long time timer {long long}
  superclass number
  meta branchset is {
    number:  1
    integer: 1
    real:    0
    claim:   {$datatype in {int integer unsigned uint long {long long} time timer} || ([string index $datatype 0] eq "u" && [string is integer -strict [string range $datatype 1 end]])}
  }
  option format {default %d}

  method datatype_inferences info {
    set result {}
    if {[dict isnull $info storage]} {
      foreach field {datatype type} {
        set v [dict getnull $info $field]
        if {$v ne {}} {
          dict set result storage $v
          break
        }
      }
      dict set result storage int
    }
    return $result
  }
  
  method Value_Import value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget format]
    set c [scan $value $format newvalue]
    if {![info exists newvalue]} {
      error "Bad value $value"
    }
    return $newvalue
  }
  
  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget format]
    set c [scan $value $format newvalue]
    if {![info exists newvalue]} {
      error "Bad value $value"
    }
    return $newvalue
  }
}

# title: real
::tool::ui::datatype register real {
  aliases float double widedouble
  superclass number
  meta branchset is {
    number:  1
    integer: 0
    real:    1
  }
  option format {default %g}
  
  method datatype_inferences info {
    set result {}
    if {[dict isnull $info storage]} {
      foreach field {datatype type} {
        set v [dict getnull $info $field]
        if {$v ne {}} {
          dict set result storage $v
          break
        }
      }
      dict set result storage double
    }
    return $result
  }

  method Value_Display  value {
    if {[::tool::is_null $value]} {
      return {}
    }
    set format [my cget format]
    set c [scan $value $format newvalue]
    if {![info exists newvalue]} {
      error "Bad value $value"
    }
    return $newvalue
  }
}

::tool::ui::datatype register percentage {
  superclass real
  option divisions {default 1000.0}
  meta branchset is {
    ranged:  1
    match: {$datatype in {percent percentage %}}
  }
  
  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return [my cget default]
    }
    if {$value > 100.0} {
      return 100.0
    } elseif {$value < 0.0} {
      return 0.0
    } elseif {[set divisions [my cget divisions]]>0} {
      return [expr {round($value*$divisions)/$divisions}]
    }
    return $value
  }
  
  method Range {} {
    return {0.0 100.0}
  }
}


# title: A real number between zero ane one
::tool::ui::datatype register kronecker {
  superclass real
  meta branchset is {
    ranged:  1
    match: {$datatype in {kronecker unit kronecker_delta}}
  }
  # When displaying on a scale, get
  # to the nearest 0.05
  option divisions {default 0}
  
  method Value_Interpret value {
    if {[::tool::is_null $value]} {
      return [my cget default]
    }
    if {$value > 1.0} {
      return 1.0
    } elseif {$value < 0.0} {
      return 0.0
    } elseif {[set divisions [my cget divisions]]>0} {
      return [expr {round($value*$divisions)/$divisions}]
    }
    return $value
  }
  
  method Range {} {
    return {0.0 1.0}
  }
}

# title: A value which stores a physical quantity that can be expressed in multiple units
::tool::ui::datatype register physics {
  superclass real
  
  option delimeter {default "*"}
  option units {}
  
  method unit_info {specinfo} {
    my variable system_units system_options
    set result {}
    set system_units [dict getnull $specinfo units]
    if {[::tool::is_null $system_units]} {
      set system_units [my meta get physics units:]
      dict set result units $system_units
    }
    set system_options [dict getnull $specinfo options]
    if {[::tool::is_null $system_options]} {
      set system_options [my meta getnull physics options:]
      dict set result options $system_options
    }
    if {$system_units ni $system_options} {
      lappend system_option $system_units
      dict set result options $system_options
    }
    return $result
  }
  
  method datatype_inferences specinfo {
    set result {}
    set widget [dict getnull $specinfo widget]
    if {[::tool::is_null $widget]} {
      dict set result widget physics
    }
    set format [dict getnull $specinfo format]
    if {[::tool::is_null $format]} {
      dict set result format %s
    }
    foreach {f v} [my unit_info $specinfo] {
      dict set result $f $v
    }
    return $result
  }
  
  method Value_Store value {
    my variable irm_value user_value user_units system_units displayvalue internalvalue
    if {![info exists system_units]} {
      set system_units [my cget units]
    }
    if {[::tool::is_null $value]} {
      set irm_value   {}
      set user_value  {}
      set displayvalue {}
      set internalvalue {}
      set user_units {}
      return {}
    }
    set value [string map {+ { } , { } * { } x { }} $value]
    set irm_value   [lindex $value 0]
    set user_value  [lindex $value 1]
    if {[llength $value]==1} {
      set user_units $system_units
      set user_value $irm_value
      set internalvalue $irm_value
      set displayvalue [my Value_Display $irm_value]
    } elseif {[llength $value]==0 || [::tool::is_null $user_value]} {
      set user_units $system_units
      set user_value $irm_value
      set internalvalue {}
      set displayvalue  {}
    } else {
      set user_units   [lindex $value 2]
      set internalvalue [list $irm_value $user_value $user_units]
      set displayvalue [my Value_Display $internalvalue]
    }
  }
  
  method Value_Get {} {
    my variable irm_value user_value user_units
    if {[::tool::is_null $irm_value]} {
      return {}
    }
    return [list $irm_value $user_value $user_units]
  }

  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    my variable system_units
    set value [string map {+ { } , { } * { } x { }} $value]
    if {![info exists system_units]} {
      return $value
    }
    if {[llength $value]<2 || [lindex $value 1] eq {}} {
      return $value
    }
    if {[lindex $value 2] eq "$system_units" || [lindex $value 0] eq [lindex $value 1]} {
      return "[lindex $value 0] $system_units"
    }
    return "[lindex $value 1] [lindex $value 2] ([lindex $value 0] ${system_units})"
  }
  
  method Value_Interpret newvalue {
    if { $newvalue in {NULL {}} } {
      return [my cget default]
    }
    my variable system_units
    if {[llength $newvalue]==2} {
      set irm_value [::siground::signif [::units::convert $newvalue $system_units] 6]
      return [list $irm_value {*}$newvalue]
    }
    set irm_value [lindex $newvalue 0]
    set human_value [lrange $newvalue 1 end]
    if {[llength $human_value]==0} {
      return $irm_value
    }
    if {[llength $human_value]==1} {
      return [lindex $human_value 0]
    }
    if {[string index $human_value 0] eq "."} {
      set human_value 0$human_value
    }
    set irm_value [::siground::signif [::units::convert $human_value $system_units] 6]
    set user_quantity [::siground::signif [lindex $human_value 0] 6]
    if {$irm_value eq $user_quantity} {
      return [lindex $human_value 0]
    }
    return [list $irm_value {*}$human_value]
  }
}

::tool::ui::datatype register volume {
  superclass physics
  
  meta set physics units: m^3
  meta set physics options:  {liters gallons m^3}
}

::tool::ui::datatype register length {
  superclass physics
  
  meta set physics units: meter
  meta set physics options:  {meter feet inch mile km mm cm}
}

::tool::ui::datatype register flow {
  superclass physics

  meta set physics units: liter/second
  meta set physics options:  {liter/second gallon/minute}

}

::tool::ui::datatype register power {
  superclass physics
  
  meta set physics units: watt
  meta set physics options:  {watt kw hp}
}

::tool::ui::datatype register temperature {
  superclass physics
  
  meta set physics units: celsius
  meta set physics options:  {kelvin celsius farhenheit}
}

::tool::ui::datatype register kelvin {
  superclass physics
  
  meta set physics units: kelvin
  meta set physics options:  {kelvin celsius farhenheit}
  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    my variable system_units
    set degsym "\xB0"
    if {[llength $value]<2 || [lindex $value 1] eq {}} {
      return "$value ( [::siground::signif [::units::convert [list $value $system_units] celsius] 4]${degsym}C)"
    }
    if {[lindex $value 2] eq "$system_units" || [lindex $value 0] eq [lindex $value 1]} {
      set value [lindex $value 1]
      return "$value ( [::siground::signif [::units::convert [list $value $system_units] celsius] 4]${degsym}C)"
    }
    return "[lindex $value 1] ${degsym}[lindex $value 2] ([lindex $value 0] ${degsym}${system_units})"
  }
}

###
# END: number.tcl
###
###
# START: round.tcl
###
#
# round number to significant digits
# according to 
# http://perfdynamics.blogspot.de/2010/04/significant-figures-in-r-and-rounding.html
# round number num to n significant digits
# works only in the range of double
# it is published under the same licence as Tcl
# (c) J. Heidemeier 2014
#
namespace eval ::siground {}
proc ::siground::signif {num n {decimalPoint .}} {
set orig $num
# arguments:
# num: number to be rounded (integer, real or exponential format)
# n: number of significant digits (positive integer)
# decimalPoint: decimal separator character for the output (default .)
# 
# reasonable figure for significant digits ?
    if {!([string is integer $n] && $n > 0)} \
        {error  "number of significant digits $n is not a positive integer"}
#
# ensure that num is numeric
# and split into sign, integer, decimal and exponent part
#
if {[regexp {^([+,-]?)([0-9]+)(\.?[0-9]*)?([eE][+-]?[0-9]+)?$} $num -> s i d e]} {
# i must contain alt least one digit
if {![string length i]} "error wrong format $num, no digit in Integerpart "
#
# type of number
# 
    set typ ""    
    if {[string length $e]} {set typ e}
    if {[string length $d]} {
        if {$typ ne {e}} {set typ d}
    } else {
        if {$typ ne {e}} {
                set typ i
#
#
#
        } else {
# reformat iexx to i.0exx bringen
            set d {.0}
       }
    }
# remove leading 0, if digits 1-9 in i-part
# or collapse several 0 to 0
#
    if {[string length $i] > 1} {
        regexp  {^(0*)([1-9][0-9]*)$} $i -> NULL DIG
        if {[string length $DIG]} {
            set i $DIG
        } else {
            set i 0 ;# collapse to one 0
        }
    }
#        
# build teststring for rounding process
#
set tstring $i
            
set decpos [expr {[string length $i] -1}]
# skip decimalpoint and append decimalpart
if {[string length $d]} {
       append tstring [string range $d 1 end]
} 
# enough digits for the rounding process       
    set ndigs [string length $tstring]
    if {$ndigs < $n} {
        return $orig
    #    error "more significant digits $n requested than available $ndigs"
    }

# x is the last significant digit
# y and z are the following 2 digits, if y or z are blank
# zeros are appended     
    set x [string index $tstring $n-1]
        if  {$ndigs == $n} {
            set y 0
        } else {
        set y [string index $tstring $n]
    }
    if {$ndigs > $n} {
        set z [string index $tstring $n+1]
    } else {
        set z 0
    }
# the actual test; pad0 pads zeros for the integerpart
    if {$y < 5} {        
        set rstring "[string range $tstring 0 $n-1][pad0 $decpos $n]"
    } elseif {$y > 5} {
         incr x
            set rstring "[string range $tstring 0 $n-2]$x[pad0 $decpos $n]"
    } else {
# y == 5; test for parity jitter
        if {$z >= 1} {
                set rstring "[string range $tstring 0 $n-1][pad0 $decpos $n]"
        } else {
            if {[isOdd $x]} {
                incr x
            }
                set rstring "[string range $tstring 0 $n-2]$x[pad0 $decpos $n]"
        }
    }
} else {
 error "number to round \"$num\" is not numeric"
}
# reformatting the output    
    switch -exact -- $typ {
        i {set result "$s$rstring"}
        d {
            set decfrac [string range $rstring $decpos+1 end]
            if {![string length $decfrac]} {
                set result "$s$rstring"
            } else {
                set result "$s[string range $rstring 0 $decpos]$decimalPoint$decfrac"
            }
        }
        e {
            set result "$s[string range $rstring 0 $decpos]$decimalPoint[string range $rstring $decpos+1 end]$e"
        }
    }
return  $result
}
#
# pad integer part with 0 if necessary
# arguments
# decpos:  index of the last digit before the decimal point
# n:  number of significant digits
#
proc ::siground::pad0 {decpos n} {

    set v {}
    incr decpos
    set x [expr {$decpos - $n}]
    
    if {$x} {
        set v [string repeat 0 $x] 
    }
    return $v
 }

proc ::siground::isOdd n {
    try {
        expr {$n & 1}
    } trap {ARITH DOMAIN} {message options} {
        return -options $options -errorinfo "$n is not an integer"
    }
}

###
# END: round.tcl
###
###
# START: select.tcl
###

::tool::ui::datatype register select {
  meta set is claim: {[dict getnull $info values-format] eq "list"}
  option values {}
  option cache-values {type: boolean default: 1}
  
  option state {
    widget select
    values {normal readonly disabled}
    default readonly
  }

  method datatype_inferences {options} {
    set result {}
    if {[dict isnull $options widget]} {
      dict set result widget select
    }
    if {[dict isnull $options state]} {
      dict set result state readonly
    }
    return $result
  }

  method CalculateValues {} {
    set values [my GetConfigValueList]
    return $values
  }

  method CalculateValueWidth values {
    set w 0
    set n 0
    foreach v $values {
      incr n
      set l [string length $v]
      incr bins($l)
      if {$l > $w} {
        set w $l
      }
    }
    if { $w > 30} {
      set w 30
    }
    return $w
  }
  
  method Description {} {
    set text [my cget description]
    set thisline {}
    set values [my CalculateValues]
    set format [my cget values-format]
    append text \n "Possible Values:"
    foreach value [my CalculateValues] {
      if {[string length $thisline]>40} {
        append text \n [string trim $thisline]
        set thisline {}
      }
      append thisline " $value"
    }
    append text \n [string trim $thisline]
    return $text
  }

  method GetConfigValueList {} {
    my variable config values
    if {[info exists values]} {
      return $values
    }
    foreach opt {values-command options_command} {
      if {[dict exists $config $opt]} {
        set script [string map [list %field% [dict getnull $config field] %config% $config] [dict get $config $opt]]
        if {[catch $script cvalues]} {
          puts "Warning: Error computing values for $field: $values"
          set cvalues {}
        } else {
          if {[llength $cvalues]} {
            return $cvalues
          }
        }
      }
    }
    if {[dict exists $config options]} {
      set values [dict get $config options]
      if {[llength $values]} {
        return $values
      }
    }
    if {[dict exists $config values]} {
      set values [dict get $config values]
    }
    if {![info exists values]} {
      set values {}
    }
    return $values
  }
}

::tool::ui::datatype register select_keyvalue {
  superclass select

  option accept_number {
    datatype boolean
    default 1
  }
  
  method CalculateValues {} {
    set values [my GetConfigValueList]
    set result {}
    foreach {key value} $values {
      lappend result $key
    }
    return $result
  }

  method Description {} {
    set text [my cget description]
    append text \n "Possible Values:"
    foreach {key value} [my GetConfigValueList] {
      append text \n " * $key - $value"
    }
    return $text
  }
  
  method Value_Export rawvalue {
    set values [my GetConfigValueList]
    foreach {var val} $values {
      if {$rawvalue eq $val} {
        return $val
      }
      if {$rawvalue eq $var} {
        return $val
      }
    }
    return $rawvalue
  }

  method Value_Interpret  rawvalue {
    set values [my GetConfigValueList]
    foreach {var val} $values {
      if {$rawvalue eq $val} {
        return $var
      }
      if {$rawvalue eq $var} {
        return $var
      }
    }
    if {[my cget accept_number]} {
      if {[string is double $rawvalue]} {
        return $rawvalue
      }
    }
    error "Invalid Value \"$rawvalue\". Valid: [join [dict keys $values] ,]"
  }
}

::tool::ui::datatype register enumerated {
  aliases enum
  superclass select
  meta branchset is {
    number:  1
    integer: 1
    real:    0
  }

  option enum {
    default {}
  }

  method CalculateValues {} {
    set values {}
    foreach {id code comment} [my GetConfigValueList] {
      lappend values "$id - $code $comment"
    }
    return $values
  }
  
  method Description {} {
    set text [my cget description]
    append text \n "Possible Values:"
    foreach {id code comment} [my GetConfigValueList] {
      append text \n " * $id - ($code) $comment"
    }
    return $text
  }

  method Value_Interpret value {
    set value [lindex $value 0]
    foreach {id code comment} [my GetConfigValueList] {
      if {$value == $id } {
        return $id
      }
    }
    return {}
  }

  method Value_Display value {
    if {[::tool::is_null $value]} {
      return {}
    }
    foreach {id code comment} [my GetConfigValueList] {
      if { [lindex $value 0] == $id } {
        return "$id - $code"
      }
    }
    return $value
  }
}

###
# END: select.tcl
###
###
# START: vector.tcl
###
###
# title: Vector
###
::tool::ui::datatype register vector {
  superclass ::tool::ui::form
  property vector_fields {
    x {type real format {%g} width 10}
    y {type real format {%g} width 10}
    z {type real format {%g} width 10}
  }
  
  method datatype_inferences options {
    set result {}
    if {[dict isnull $options widget]} {
      dict set result widget vector
    }
    return $result
  }
  
  method Value_Export newvalue {
    set result {}
    array set content $newvalue
    foreach {vfield info} [my Vector_Fields]  {
      set format [if_null [dict getnull $info format] %s]
      set newvalue [format $format $content($vfield)]
      lappend result $newvalue
    }
    return $result
  }
  
  method Vector_Fields {} {
    return [my meta cget vector_fields]
  }

  method Value_Get {} {
    my variable local_array
    return [array get local_array]
  }
  
  method Value_Store value {
    my variable local_array internalvalue displayvalue
    if {[::tool::is_null $value]} {
      set internalvalue {}
      set displayvalue {}
      return
    }
    array set local_array $value
    foreach {field val} [array get local_array] {
      dict set internalvalue $field $val
      set obj [my formelement object $field]
      if {$obj ne {}} {
        $obj put $val
      }
    }
    set displayvalue [my Value_Display $internalvalue]
  }
  
  method Value_Import  inputvalue {
    set idx -1
    foreach {vfield info} [my Vector_Fields] {
      incr idx
      set format [if_null [dict getnull $info format] %s]
      set value [lindex $inputvalue $idx]
      if {[dict exists $info default]} {
        if {$value eq {}} {
          set value [dict get $info default]
        }
      }
      if {$value eq {}} {
        set local_array($vfield) $value
      } elseif { $format in {"%d" int integer} } {
        if [catch {expr {int($value)}} nvalue] {
          puts "Err: $format $vfield. Raw: $value. Err: $nvalue"
          dict set result $vfield $value
        } else {
          dict set result $vfield $nvalue
        }
      } else {
        if [catch {format $format $value} nvalue] {
          puts "Err: $vfield. Raw: $value. Err: $nvalue"
          dict set result $vfield $value
        } else {
          dict set result $vfield $nvalue
        }
      }
    }
    return $result
  }
}
###
# END: vector.tcl
###

namespace eval ::tool-ui {
  namespace export *
}

set here [file dirname [file normalize [file join [pwd] [info script]]]]

set version 0.7
set module [file tail $here]

set fout [open [file join $here [file tail $module].tcl] w]
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide %module% %version%
namespace eval ::%module% {}
}]
if {$module ne "tool"} {
  puts $fout [string map $map {::tool::module push %module%}]
}

# Track what files we have included so far
set loaded {}
# These files must be loaded in a particular order
foreach file {
  core.tcl
  uuid.tcl
  ensemble.tcl
  metaclass.tcl
  option.tcl
  event.tcl
  pipeline.tcl
} {
  lappend loaded $file
  set fin [open [file join $here src $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $here src *.tcl]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set fin [open [file join $here src $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
  namespace export *
}
}]
close $fout

###
# Build our pkgIndex.tcl file
###
set fout [open [file join $here pkgIndex.tcl] w]
puts $fout [string map $map {# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool 0.7 [list source [file join $dir tool.tcl]]

package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
#package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0

proc ::tool::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::tool::module {cmd args} {
  ::variable moduleStack
  ::variable module

  switch $cmd {
    push {
      set module [lindex $args 0]
      lappend moduleStack $module
      return $module
    }
    pop {
      set priormodule      [lindex $moduleStack end]
      set moduleStack [lrange $moduleStack 0 end-1]
      set module [lindex $moduleStack end]
      return $priormodule
    }
    peek {
      set module      [lindex $moduleStack end]
      return $module
    }
    default {
      error "Invalid command \"$cmd\". Valid: peek, pop, push"
    }
  }
}
::tool::module push core

proc ::tool::pathload {path {order {}} {skip {}}} {
  ###
  # On windows while running under a VFS, the system sometimes
  # gets confused about the volume we are running under
  ###
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string range $path 1 6] eq ":/zvfs"} {

  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $order {
    set file [file tail $file]
    if {$file in $loaded} continue
    if {![file exists [file join $path $file]]} {
      puts "WARNING [file join $path $file] does not exist in [info script]"
    } else {
      uplevel #0 [list source [file join $path $file]]
    }
    lappend loaded $file
  }
  foreach file [lsort -dictionary [glob -nocomplain [file join $path *.tcl]]] {
    if {[file tail $file] in $loaded} continue
    uplevel #0 [list source $file]
    lappend loaded [file tail $file]
  }
}

proc ::tool::define::coroutine {name corobody} {
  set class [current_class]
  ::oo::meta::info $class set method_ensemble ${name} _preamble: [list {} [string map [list %coroname% $name] {
    my variable coro_queue coro_lock
    set coro %coroname%
    set coroname [info object namespace [self]]::%coroname%
  }]]
  ::oo::meta::info $class set method_ensemble ${name} coroutine: {{} {
    return $coroutine
  }}
  ::oo::meta::info $class set method_ensemble ${name} restart: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
    set coro_lock($coroname) 0
    ::coroutine $coroname {*}[namespace code [list my $coro main]]
    ::cron::object_coroutine [self] $coroname
  }}
  ::oo::meta::info $class set method_ensemble ${name} kill: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
  }}

  ::oo::meta::info $class set method_ensemble ${name} main: [list {} $corobody]

  ::oo::meta::info $class set method_ensemble ${name} clear: {{} {
    set coro_queue($coroname) {}
  }}
  ::oo::meta::info $class set method_ensemble ${name} next: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    set coro_queue($coroname) [lrange $coro_queue($coroname) 1 end]
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} peek: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    return 0
  }}

  ::oo::meta::info $class set method_ensemble ${name} running: {{} {
    if {[info commands $coroname] eq {}} {
      return 0
    }
    if {[::cron::task exists $coroname]} {
      set info [::cron::task info $coroname]
      if {[dict exists $info running]} {
        return [dict get $info running]
      }
    }
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} send: {args {
    lappend coro_queue($coroname) $args
    if {[info coroutine] eq $coroname} {
      return
    }
    if {[info commands $coroname] eq {}} {
      ::coroutine $coroname {*}[namespace code [list my $coro main]]
      ::cron::object_coroutine [self] $coroname
    }
    if {[info coroutine] eq {}} {
      ::cron::do_one_event $coroname
    } else {
      yield
    }
  }}
  ::oo::meta::info $class set method_ensemble ${name} default: {args {my [self method] send $method {*}$args}}

}

    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]
      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      set default $body
      dict unset einfo default:
    }
    set methodlist {}
    foreach item [dict keys $einfo] {
      lappend methodlist [string trimright $item :]
    }
    set methodlist  [lsort -dictionary -unique $methodlist]
    foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
      if {$submethod in {"_preamble:" "default:"}} continue
      set submethod [string trimright $submethod :]
      lassign $esubmethodinfo arglist realbody
      if {[string length [string trim $realbody]] eq {}} {
        dict set eswitch $submethod {}
      } else {
        if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
          set body {}
        } else {
          set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
        }
        append body "\n      " [string trim $realbody] "      \n"
        dict set eswitch $submethod $body
      }
    }
    if {![dict exists $eswitch <list>]} {
      dict set eswitch <list> {return $methodlist}
    }
    if {$default=="standard"} {
      set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
    }
    dict set eswitch default $default
    set mbody {}    
    if {[dict exists $einfo _preamble:]} {
      append mbody [lindex [dict get $einfo _preamble:] 1] \n


    }
    append mbody \n [list set methodlist $methodlist]
    append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append mbody \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $mbody]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tool::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
#    Generate an event

}

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tool::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tool::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::tool::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
}

proc ::tool::event::sleep msec {










  ::cron::sleep $msec





}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tool::event::subscribe {self who event} {
  upvar #0 ::tool::object_subscribe($self) subscriptions

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tool::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::tool::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

###
# topic: 8bcae430f1eda4ccdb96daedeeea3bd409c6bb7a
# description: Add properties and option handling

    $command $class $metadata
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tool::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"

    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###

      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"

      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx

    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tool::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {

#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  variable mixinmap {}
  variable DestroyEvent 0

  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    
  method ancestors {{reverse 0}} {
    set result [::oo::meta::ancestors [info object class [self]]]
    if {$reverse} {
      return [lreverse $result]
    }
    return $result
  }
  
  method DestroyEvent {} {
    my variable DestroyEvent
    return $DestroyEvent
  }
  
  ###
  # title: Forward a method
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }

  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set prior $mixins

    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      if {$class ni $prior} {
        my meta mixin $class
      }
      my ClassPublicApply $class
    }
    foreach class $prior {
      if {$class ni $mixins } { 
        my meta mixout $class
      }
    }
  }

  method mixinmap args { 
    my variable mixinmap
    set priorlist {}
    foreach {slot classes} $args {
      if {[dict exists $mixinmap $slot]} {
        lappend priorlist {*}[dict get $mixinmap $slot]  
        foreach class [dict get $mixinmap $slot] {
          if {$class ni $classes && [$class meta exists mixin unmap-script:]} {
            if {[catch [$class meta get mixin unmap-script:] err errdat]} {
              puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
            }
          }
        }
      }
      dict set mixinmap $slot $classes
    }
    my Recompute_Mixins
    foreach {slot classes} $args {
      foreach class $classes {
        if {$class ni $priorlist && [$class meta exists mixin map-script:]} {
          if {[catch [$class meta get mixin map-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
    foreach {slot classes} $mixinmap {
      foreach class $classes {
        if {[$class meta exists mixin react-script:]} {
          if {[catch [$class meta get mixin react-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR REACTING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
  }

  method debug_mixinmap {} {
    my variable mixinmap
    return $mixinmap
  }

  method Recompute_Mixins {} {
    my variable mixinmap
    set classlist {}
    foreach {item class} $mixinmap {
      if {$class ne {}} {
        lappend classlist $class
      }
    }
    my mixin {*}$classlist
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {

::namespace eval ::tool {}

proc ::tool::is_null value {
  return [expr {$value in {{} NULL}}]
}


proc ::tool::uuid_seed args {
  if {[llength $args]==0 || ([llength $args]==1 && [is_null [lindex $args 0]])} {
    if {[info exists ::env(USERNAME)]} {
      set user $::env(USERNAME)
    } elseif {[info exists ::env(USER)]} {
      set user $::env(USER)
    } else {
      set user $::env(user)
    }

###
# Amalgamated package for tool
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide tool 0.7
namespace eval ::tool {}

###
# START: core.tcl
###
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
#package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0

proc ::tool::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::tool::module {cmd args} {
  ::variable moduleStack
  ::variable module

  switch $cmd {
    push {
      set module [lindex $args 0]
      lappend moduleStack $module
      return $module
    }
    pop {
      set priormodule      [lindex $moduleStack end]
      set moduleStack [lrange $moduleStack 0 end-1]
      set module [lindex $moduleStack end]
      return $priormodule
    }
    peek {
      set module      [lindex $moduleStack end]
      return $module
    }
    default {
      error "Invalid command \"$cmd\". Valid: peek, pop, push"
    }
  }
}
::tool::module push core

proc ::tool::pathload {path {order {}} {skip {}}} {
  ###
  # On windows while running under a VFS, the system sometimes
  # gets confused about the volume we are running under
  ###
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string range $path 1 6] eq ":/zvfs"} {
      set path [string range $path 2 end]
    }
  }
  set loaded {pkgIndex.tcl index.tcl}
  foreach item $skip {
    lappend loaded [file tail $skip]
  }
  if {[file exists [file join $path metaclass.tcl]]} {
    lappend loaded metaclass.tcl
    uplevel #0 [list source [file join $path metaclass.tcl]]
  }
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $order {
    set file [file tail $file]
    if {$file in $loaded} continue
    if {![file exists [file join $path $file]]} {
      puts "WARNING [file join $path $file] does not exist in [info script]"
    } else {
      uplevel #0 [list source [file join $path $file]]
    }
    lappend loaded $file
  }
  foreach file [lsort -dictionary [glob -nocomplain [file join $path *.tcl]]] {
    if {[file tail $file] in $loaded} continue
    uplevel #0 [list source $file]
    lappend loaded [file tail $file]
  }
}

###
# END: core.tcl
###
###
# START: uuid.tcl
###
::namespace eval ::tool {}

proc ::tool::is_null value {
  return [expr {$value in {{} NULL}}]
}


proc ::tool::uuid_seed args {
  if {[llength $args]==0 || ([llength $args]==1 && [is_null [lindex $args 0]])} {
    if {[info exists ::env(USERNAME)]} {
      set user $::env(USERNAME)
    } elseif {[info exists ::env(USER)]} {
      set user $::env(USER)
    } else {
      set user $::env(user)
    }
    incr ::tool::nextuuid $::tool::globaluuid
    set ::tool::UUID_Seed [list user@[info hostname] [clock format [clock seconds]]]
  } else {
    incr ::tool::globaluuid $::tool::nextuuid
    set ::tool::nextuuid 0
    set ::tool::UUID_Seed $args
  }
}

###
# topic: 0a19b0bfb98162a8a37c1d3bbfb8bc3d
# description:
#    Because the tcllib version of uuid generate requires
#    network port access (which can be slow), here's a fast
#    and dirty rendition
###
proc ::tool::uuid_generate args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [::sha1::sha1 -hex [join $block ""]]
}

###
# topic: ee3ec43cc2cc2c7d6cf9a4ef1c345c19
###
proc ::tool::uuid_short args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [string range [::sha1::sha1 -hex [join $block ""]] 0 16]
}

###
# topic: b14c505537274904578340ec1bc12af1
# description:
#    Implementation the uses a compiled in ::md5 implementation
#    commonly used by embedded application developers
###
namespace eval ::tool {
  namespace export *
}
###
# Cache the bits of the UUID seed that aren't likely to change
# once the software is loaded, but which can be expensive to
# generate
###
set ::tool::nextuuid 0
set ::tool::globaluuid 0
::tool::uuid_seed

###
# END: uuid.tcl
###
###
# START: ensemble.tcl
###
::namespace eval ::tool::define {}

if {![info exists ::tool::dirty_classes]} {
  set ::tool::dirty_classes {}
}

###
# Monkey patch oometa's rebuild function to
# include a notifier to tool
###
proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}

proc ::tool::ensemble_build_map args {
  set emap {}
  foreach thisclass $args {
    foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
      foreach {submethod subinfo} $einfo {
        dict set emap $ensemble $submethod $subinfo
      }
    }
  }
  return $emap
}

proc ::tool::ensemble_methods emap {
  set result {}
  foreach {ensemble einfo} $emap {
    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]
      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      set default $body
      dict unset einfo default:
    }
    set methodlist {}
    foreach item [dict keys $einfo] {
      lappend methodlist [string trimright $item :]
    }
    set methodlist  [lsort -dictionary -unique $methodlist]
    foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
      if {$submethod in {"_preamble:" "default:"}} continue
      set submethod [string trimright $submethod :]
      lassign $esubmethodinfo arglist realbody
      if {[string length [string trim $realbody]] eq {}} {
        dict set eswitch $submethod {}
      } else {
        if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
          set body {}
        } else {
          set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
        }
        append body "\n      " [string trim $realbody] "      \n"
        dict set eswitch $submethod $body
      }
    }
    if {![dict exists $eswitch <list>]} {
      dict set eswitch <list> {return $methodlist}
    }
    if {$default=="standard"} {
      set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
    }
    dict set eswitch default $default
    set mbody {}    
    if {[dict exists $einfo _preamble:]} {
      append mbody [lindex [dict get $einfo _preamble:] 1] \n
    }
    append mbody \n [list set methodlist $methodlist]
    append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append mbody \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $mbody]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tool::dynamic_object_ensembles {thisobject thisclass} {
  variable trace
  set ensembledict {}
  foreach dclass $::tool::dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::tool::obj_ensemble_cache($cclass)
      }
    }
  }
  set ::tool::dirty_classes {}
  ###
  # Only go through the motions for classes that have a locally defined
  # ensemble method implementation
  ###
  foreach aclass [::oo::meta::ancestors $thisclass] {
    if {[info exists ::tool::obj_ensemble_cache($aclass)]} continue
    set emap [::tool::ensemble_build_map $aclass]
    set body [::tool::ensemble_methods $emap]
    oo::define $aclass $body
    # Define a property for this ensemble for introspection
    foreach {ensemble einfo} $emap {
      ::oo::meta::info $aclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
    }
    set ::tool::obj_ensemble_cache($aclass) 1
  }
}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tool::define::method {rawmethod args} {
  set class [current_class]
  set mlist [split $rawmethod "::"]
  if {[llength $mlist]==1} {
    ###
    # Simple method, needs no parsing
    ###
    set method $rawmethod
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  set ensemble [lindex $mlist 0]
  set method [join [lrange $mlist 2 end] "::"]
  switch [llength $args] {
    1 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: [list dictargs [lindex $args 0]]
    }
    2 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: $args
    }
    default {
      error "Usage: method NAME ARGLIST BODY"
    }
  }
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal dict
###
proc ::tool::define::dictobj args {
  dict_ensemble {*}$args
}
proc ::tool::define::dict_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  set initial [dict getnull $cases initialize]
  variable $varname $initial
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  }
  set template [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      dict set %VARNAME% $field $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      dict set %VARNAME% $field $result
    }
    initial {} {
      return [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
    }
    reset {} {
      set %VARNAME% [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
      return $%VARNAME%
    }
    dump {} {
      return $%VARNAME%
    }
    append args {
      return [dict $method %VARNAME% {*}$args]
    }
    incr args {
      return [dict $method %VARNAME% {*}$args]
    }
    lappend args {
      return [dict $method %VARNAME% {*}$args]
    }
    set args {
      return [dict $method %VARNAME% {*}$args]
    }
    unset args {
      return [dict $method %VARNAME% {*}$args]
    }
    update args {
      return [dict $method %VARNAME% {*}$args]
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        dict set %VARNAME% {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    rmerge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%  
    }
    merge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%
    }
    replace args {
      set %VARNAME% [dict rmerge $%VARNAME% {%INITIAL%} {*}$args]
    }
    default args {
      return [dict $method $%VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

proc ::tool::define::arrayobj args {
  array_ensemble {*}$args
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal array
###
proc ::tool::define::array_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  set initial [dict getnull $cases initialize]
  array $varname $initial

  set map [list %CLASS% $class %METHOD% $methodname %VARNAME% $varname %CASES% $CASES %INITIAL% $initial]

  ::oo::define $class method _${methodname}Get {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return $%VARNAME%($field)
    }
    return [my meta getnull %VARNAME% $field:]
  }]
  ::oo::define $class method _${methodname}Exists {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return 1
    }
    return [my meta exists %VARNAME% $field:]
  }]
  set methoddata [::oo::meta::info $class set array_ensemble $methodname: $varname]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  } 
  set template  [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    reset {} {
      ::array unset %VARNAME% *
      foreach {field value} [my meta getnull %VARNAME%] {
        set %VARNAME%([string trimright $field :]) $value
      }
      ::array set %VARNAME% {%INITIAL%}
      return [array get %VARNAME%]
    }
    ni value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value ni $data}]
    }
    in value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value in $data}]
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      set %VARNAME%($field) $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      set %VARNAME%($field) $result
    }
    dump {} {
      set result {}
      foreach {var val} [my meta getnull %VARNAME%] {
        dict set result [string trimright $var :] $val
      }
      foreach {var val} [lsort -dictionary -stride 2 [array get %VARNAME%]] {
        dict set result [string trimright $var :] $val
      }
      return $result
    }
    exists args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Exists $field]
    }
    getnull args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]      
    }
    get field {
      set field [string trimright $field :]
      set data [my _%METHOD%Get $field]
    }
    set args {
      set field [string trimright [lindex $args 0] :]
      ::set %VARNAME%($field) {*}[lrange $args 1 end]        
    }
    append args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      ::append data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    incr args {
      set field [string trimright [lindex $args 0] :]
      ::incr %VARNAME%($field) {*}[lrange $args 1 end]
    }
    lappend args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      $method data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        set %VARNAME%([string trimright $field :]) $value
      }
    }
    rmerge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    merge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    default args {
      return [array $method %VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}


###
# END: ensemble.tcl
###
###
# START: metaclass.tcl
###
#-------------------------------------------------------------------------
# TITLE: 
#    tool.tcl
#
# PROJECT:
#    tool: TclOO Helper Library
#
# DESCRIPTION:
#    tool(n): Implementation File
#
#-------------------------------------------------------------------------

namespace eval ::tool {}

###
# New OO Keywords for TOOL
###
namespace eval ::tool::define {}
proc ::tool::define::array {name {values {}}} {
  set class [current_class]
  set name [string trimright $name :]:
  if {![::oo::meta::info $class exists array $name]} {
    ::oo::meta::info $class set array $name {}
  }
  foreach {var val} $values {
    ::oo::meta::info $class set array $name: $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::tool::define::component {name info} {
  set class [current_class]
  ::oo::meta::info $class branchset component $name $info
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tool::define::constructor {arglist rawbody} {
  set body {
::tool::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  append body {
# Run "initialize"
my initialize
  }
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
# topic: 7a5c7e04989704eef117ff3c9dd88823
# title: Specify the a method for the class object itself, instead of for objects of the class
###
proc ::tool::define::class_method {name arglist body} {
  set class [current_class]
  ::oo::meta::info $class set class_typemethod $name: [list $arglist $body]
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tool::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::tool::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

###
# topic: 8bcae430f1eda4ccdb96daedeeea3bd409c6bb7a
# description: Add properties and option handling
###
proc ::tool::define::property args {
  set class [current_class]
  switch [llength $args] {
    2 {
      set type const
      set property [string trimleft [lindex $args 0] :]
      set value [lindex $args 1]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    3 {
      set type     [lindex $args 0]
      set property [string trimleft [lindex $args 1] :]
      set value    [lindex $args 2]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    default {
      error "Usage:
property name type valuedict
OR property name value"
    }
  }
  ::oo::meta::info $class set {*}$args
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::tool::define::variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :]
  ::oo::meta::info $class set variable $name: $default
  ::oo::define $class variable $name
}

###
# Utility Procedures
###

# topic: 643efabec4303b20b66b760a1ad279bf
###
proc ::tool::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

###
# topic: b40970b0d9a2525990b9105ec8c96d3d
###
proc ::tool::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimright [string trimleft $var -] :] $val
  }
  return $result
}

###
# topic: a92cd258900010f656f4c6e7dbffae57
###
proc ::tool::dynamic_methods class {
  ::oo::meta::rebuild $class
  set metadata [::oo::meta::metadata $class]
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class $metadata
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tool::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of tool
      ###
      set dictargs [::tool::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}

###
# topic: b88add196bb63abccc44639db5e5eae1
###
proc ::tool::dynamic_methods_class {thisclass metadata} {
  foreach {method info} [dict getnull $metadata class_typemethod] {
    lassign $info arglist body
    set method [string trimright $method :]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tool::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::tool::object_create {objname {class {}}} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    set ${varname}($objname) {}
  }
  if {$class eq {}} {
    set class [info object class $objname]
  }
   set object_info($objname) [list class $class]
  if {$class ne {}} {
    $objname graft class $class
    foreach command [info commands [namespace current]::dynamic_object_*] {
      $command $objname $class
    }
  }
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    if {[info exists ${varname}($object)]} {
      set ${varname}($newname) [set ${varname}($object)]
      unset ${varname}($object)
    }
  }
  variable coroutine_object
  foreach {coro coro_objname} [array get coroutine_object] {
    if { $object eq $coro_objname } {
      set coroutine_object($coro) $newname
    }
  }
  rename $object ::[string trimleft $newname]
  ::tool::event::generate $object object_rename [list newname $newname]
}

proc ::tool::object_destroy objname {
  ::tool::event::generate $objname object_destroy [list objname $objname]
  ::tool::event::cancel $objname *
  ::cron::object_destroy $objname
  variable coroutine_object
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    unset -nocomplain ${varname}($objname)
  }
}

#-------------------------------------------------------------------------
# Option Handling Mother of all Classes

# tool::object
#
# This class is inherited by all classes that have options.
#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  variable mixinmap {}
  variable DestroyEvent 0

  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    
  method ancestors {{reverse 0}} {
    set result [::oo::meta::ancestors [info object class [self]]]
    if {$reverse} {
      return [lreverse $result]
    }
    return $result
  }
  
  method DestroyEvent {} {
    my variable DestroyEvent
    return $DestroyEvent
  }
  
  ###
  # title: Forward a method
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }
  
  ###
  # title: Direct a series of sub-functions to a seperate object
  ###
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      if {$stub eq "class"} {
        # Force class to always track the object's current class
        set obj [info object class [self]]
      }
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }
  
  # Called after all options and public variables are initialized
  method initialize {} {}
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method InitializePublic {} {
    my variable config meta
    if {![info exists meta]} {
      set meta {}
    }
    if {![info exists config]} {
      set config {}
    }
    my ClassPublicApply {}
  }
  
  class_method info {which} {
    my variable cache
    if {![info exists cache($which)]} {
      set cache($which) {}
      switch $which {
        public {
          dict set cache(public) variable [my meta branchget variable]
          dict set cache(public) array [my meta branchget array]
          set optinfo [my meta getnull option]
          dict set cache(public) option_info $optinfo
          foreach {var info} [dict getnull $cache(public) option_info] {
            if {[dict exists $info aliases:]} {
              foreach alias [dict exists $info aliases:] {
                dict set cache(public) option_canonical $alias $var
              }
            }
            set getcmd [dict getnull $info default-command:]
            if {$getcmd ne {}} {
              dict set cache(public) option_default_command $var $getcmd
            } else {
              dict set cache(public) option_default_value $var [dict getnull $info default:]
            }
            dict set cache(public) option_canonical $var $var
          }
        }
      }
    }
    return $cache($which)
  }
  
  ###
  # Incorporate the class's variables, arrays, and options
  ###
  method ClassPublicApply class {
    my variable config
    set integrate 0
    if {$class eq {}} {
      set class [info object class [self]]      
    } else {
      set integrate 1
    }
    set public [$class info public]
    foreach {var value} [dict getnull $public variable] {
      if { $var in {meta config} } continue
      my variable $var
      if {![info exists $var]} {
        set $var $value
      }
    }
    foreach {var value} [dict getnull $public array] {
      if { $var eq {meta config} } continue
      my variable $var
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          set ${var}($f) $v
        }
      }
    }
    set dat [dict getnull $public option_info]
    if {$integrate} {
      my meta rmerge [list option $dat]
    }
    my variable option_canonical
    array set option_canonical [dict getnull $public option_canonical]
    set dictargs {}
    foreach {var getcmd} [dict getnull $public option_default_command] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var [{*}[string map [list %field% $var %self% [namespace which my]] $getcmd]]
    }
    foreach {var value} [dict getnull $public option_default_value] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var $value
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      if {[dict exists $config $field]} continue
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set prior $mixins

    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      if {$class ni $prior} {
        my meta mixin $class
      }
      my ClassPublicApply $class
    }
    foreach class $prior {
      if {$class ni $mixins } { 
        my meta mixout $class
      }
    }
  }

  method mixinmap args { 
    my variable mixinmap
    set priorlist {}
    foreach {slot classes} $args {
      if {[dict exists $mixinmap $slot]} {
        lappend priorlist {*}[dict get $mixinmap $slot]  
        foreach class [dict get $mixinmap $slot] {
          if {$class ni $classes && [$class meta exists mixin unmap-script:]} {
            if {[catch [$class meta get mixin unmap-script:] err errdat]} {
              puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
            }
          }
        }
      }
      dict set mixinmap $slot $classes
    }
    my Recompute_Mixins
    foreach {slot classes} $args {
      foreach class $classes {
        if {$class ni $priorlist && [$class meta exists mixin map-script:]} {
          if {[catch [$class meta get mixin map-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
    foreach {slot classes} $mixinmap {
      foreach class $classes {
        if {[$class meta exists mixin react-script:]} {
          if {[catch [$class meta get mixin react-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR REACTING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
  }

  method debug_mixinmap {} {
    my variable mixinmap
    return $mixinmap
  }

  method Recompute_Mixins {} {
    my variable mixinmap
    set classlist {}
    foreach {item class} $mixinmap {
      if {$class ne {}} {
        lappend classlist $class
      }
    }
    my mixin {*}$classlist
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      my Morph_leave
      my variable mixins
      oo::objdefine [self] class ::${newclass}
      my graft class ::${newclass}
      # Reapply mixins
      my mixin {*}$mixins
      my InitializePublic
      my Morph_enter
    }
  }

  ###
  # Commands to perform as this object transitions out of the present class
  ###
  method Morph_leave {} {}
  ###
  # Commands to perform as this object transitions into this class as a new class
  ###
  method Morph_enter {} {}
  
  ###
  # title: List which objects are forwarded as organs
  ###
  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }
}



###
# END: metaclass.tcl
###
###
# START: option.tcl
###
###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tool::define::option {name args} {
  set class [current_class]
  set dictargs {default: {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimright [string trimleft $var -] :]: $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class:]
  if {$optclass ne {}} {
    foreach {f v} [::oo::meta::info $class getnull option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default:]
    }
  }
  ::oo::meta::info $class branchset option $name $dictargs
}

###
# topic: 827a3a331a2e212a6e301f59c1eead59
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::tool::define::option_class {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  ::oo::meta::info $class branchset option_class $name $dictargs
}

::tool::define ::tool::object {
  property options_strict 0
  variable organs {}

  option_class organ {
    widget label
    set-command {my graft %field% %value%}
    get-command {my organ %field%}
  }

  option_class variable {
    widget entry
    set-command {my variable %field% ; set %field% %value%}
    get-command {my variable %field% ; set %field%}
  }
  
  dict_ensemble config config {
    get {
      return [my Config_get {*}$args]
    }
    merge {
      return [my Config_merge {*}$args]
    }
    set {
      my Config_set {*}$args
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget args {
    return [my Config_get {*}$args]
  }

  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }

  method Config_get {field args} {
    my variable config option_canonical option_getcmd
    set field [string trimleft $field -]
    if {[info exists option_canonical($field)]} {
      set field $option_canonical($field)
    }
    if {[info exists option_getcmd($field)]} {
      return [eval $option_getcmd($field)]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    if {[llength $args]} {
      return [lindex $args 0]
    }
    return [my meta cget $field] 
  }
  
  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method Config_merge dictargs {
    my variable config option_canonical
    set rawlist $dictargs
    set dictargs {}
    set dat [my meta getnull option]
    foreach {field val} $rawlist {
      set field [string trimleft $field -]
      set field [string trimright $field :]
      if {[info exists option_canonical($field)]} {
        set field $option_canonical($field)
      }
      dict set dictargs $field $val
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    return $dictargs
  }
  
  method Config_set args {
    set dictargs [::tool::args_to_options {*}$args]
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }
  
  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method Config_triggers dictargs {
    set dat [my meta getnull option]
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field post-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }

  method Option_Default field {
    set info [my meta getnull option $field]
    set getcmd [dict getnull $info default-command:]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
    } else {
      return [dict getnull $info default:]
    }
  }
}

package provide tool::option 0.1

###
# END: option.tcl
###
###
# START: event.tcl
###
###
# This file implements the Tool event manager
###

::namespace eval ::tool {}

::namespace eval ::tool::event {}

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tool::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
#    Generate an event
#    Adds a subscription mechanism for objects
#    to see who has recieved this event and prevent
#    spamming or infinite recursion
###
proc ::tool::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::tool::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::tool::event::notify $who $self $event $info}
  }
}

###
# topic: 891289a24b8cc52b6c228f6edb169959
# title: Return a unique event handle
###
proc ::tool::event::nextid {} {
  return "event#[format %0.8x [incr ::tool::event_count]]"
}

###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::tool::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::tool::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}

###
# topic: b4b12f6aed69f74529be10966afd81da
###
proc ::tool::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return 
  if {$::tool::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tool::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tool::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::tool::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
}

proc ::tool::event::sleep msec {
  ::cron::sleep $msec
}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tool::event::subscribe {self who event} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue      
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}

###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::tool::event::unsubscribe {self args} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }  
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the 
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

::tool::define ::tool::object {
  ###
  # topic: 20b4a97617b2b969b96997e7b241a98a
  ###
  method event {submethod args} {
    ::tool::event::$submethod [self] {*}$args
  }
}

###
# topic: 37e7bd0be3ca7297996da2abdf5a85c7
# description: The event manager for Tool
###
namespace eval ::tool::event {
  variable nextevent {}
  variable nexteventtime 0
}


###
# END: event.tcl
###
###
# START: pipeline.tcl
###
::namespace eval ::tool::signal {}
::namespace eval ::tao {}

# Provide a backward compatible hook
proc ::tool::main {} {
  ::cron::main
}

proc ::tool::do_events {} {
  ::cron::do_events
}

proc ::tao::do_events {} {
  ::cron::do_events
}

proc ::tao::main {} {
  ::cron::main
}


package provide tool::pipeline 0.1


###
# END: pipeline.tcl
###
###
# START: coroutine.tcl
###
proc ::tool::define::coroutine {name corobody} {
  set class [current_class]
  ::oo::meta::info $class set method_ensemble ${name} _preamble: [list {} [string map [list %coroname% $name] {
    my variable coro_queue coro_lock
    set coro %coroname%
    set coroname [info object namespace [self]]::%coroname%
  }]]
  ::oo::meta::info $class set method_ensemble ${name} coroutine: {{} {
    return $coroutine
  }}
  ::oo::meta::info $class set method_ensemble ${name} restart: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
    set coro_lock($coroname) 0
    ::coroutine $coroname {*}[namespace code [list my $coro main]]
    ::cron::object_coroutine [self] $coroname
  }}
  ::oo::meta::info $class set method_ensemble ${name} kill: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
  }}

  ::oo::meta::info $class set method_ensemble ${name} main: [list {} $corobody]

  ::oo::meta::info $class set method_ensemble ${name} clear: {{} {
    set coro_queue($coroname) {}
  }}
  ::oo::meta::info $class set method_ensemble ${name} next: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    set coro_queue($coroname) [lrange $coro_queue($coroname) 1 end]
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} peek: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    return 0
  }}

  ::oo::meta::info $class set method_ensemble ${name} running: {{} {
    if {[info commands $coroname] eq {}} {
      return 0
    }
    if {[::cron::task exists $coroname]} {
      set info [::cron::task info $coroname]
      if {[dict exists $info running]} {
        return [dict get $info running]
      }
    }
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} send: {args {
    lappend coro_queue($coroname) $args
    if {[info coroutine] eq $coroname} {
      return
    }
    if {[info commands $coroname] eq {}} {
      ::coroutine $coroname {*}[namespace code [list my $coro main]]
      ::cron::object_coroutine [self] $coroname
    }
    if {[info coroutine] eq {}} {
      ::cron::do_one_event $coroname
    } else {
      yield
    }
  }}
  ::oo::meta::info $class set method_ensemble ${name} default: {args {my [self method] send $method {*}$args}}

}

###
# END: coroutine.tcl
###
###
# START: organ.tcl
###
###
# A special class of objects that
# stores no meta data of its own
# Instead it vampires off of the master object
###
tool::class create ::tool::organelle {
  
  constructor {master} {
    my entangle $master
    set final_class [my select]
    if {[info commands $final_class] ne {}} {
      # Safe to switch class here, we haven't initialized anything
      oo::objdefine [self] class $final_class
    }
    my initialize
  }

  method entangle {master} {
    my graft master $master
    my forward meta $master meta
    foreach {stub organ} [$master organ] {
      my graft $stub $organ
    }
    foreach {methodname variable} [my meta branchget array_ensemble] {
      my forward $methodname $master $methodname
    }
  }
  
  method select {} {
    return {}
  }
}

###
# END: organ.tcl
###
###
# START: script.tcl
###
###
# Add configure by script facilities to TOOL
###
::tool::define ::tool::object {

  ###
  # Allows for a constructor to accept a psuedo-code
  # initialization script which exercise the object's methods
  # sans "my" in front of every command
  ###
  method Eval_Script script {
    set buffer {}
    set thisline {}
    foreach line [split $script \n] {
      append thisline $line
      if {![info complete $thisline]} {
        append thisline \n
        continue
      }
      set thisline [string trim $thisline]
      if {[string index $thisline 0] eq "#"} continue
      if {[string length $thisline]==0} continue
      if {[lindex $thisline 0] eq "my"} {
        # Line already calls out "my", accept verbatim
        append buffer $thisline \n
      } elseif {[string range $thisline 0 2] eq "::"} {
        # Fully qualified commands accepted verbatim
        append buffer $thisline \n
      } elseif {
        append buffer "my $thisline" \n
      }
      set thisline {}
    }
    eval $buffer
  }
}
###
# END: script.tcl
###

namespace eval ::tool {
  namespace export *
}

  NestedObjectE do somethingelse
} {D}

test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectF do somethingelse
} {C}

###
# Set of tests to exercise the mixinmap system
###
tool::define MixinMainClass {
  variable mainvar unchanged
  
  method test::which {} {
    my variable mainvar
    return $mainvar
  }
  
  method test::main args {
    puts [list this is main $method $args]
  }

}

tool::define MixinTool {
  variable toolvar unchanged.mixin
  meta set mixin unmap-script: {
my test untool $class
  }
  meta set mixin map-script: {
my test tool $class
  }
  meta set mixin name: {Generic Tool}
  
  method test::untool class { 
    my variable toolvar mainvar
    set mainvar {}
    set toolvar {} 
  }
  
  method test::tool class {
    my variable toolvar mainvar
    set mainvar [$class meta get mixin name:] 
    set toolvar [$class meta get mixin name:] 
  }
}

tool::define MixinToolA {
  superclass MixinTool
  meta set mixin name: {Tool A}
}

tool::define MixinToolB {
  superclass MixinTool
  meta set mixin name: {Tool B}

  method test_newfunc {} {
    return "B"
  }
}

MixinMainClass create mixintest

test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {unchanged}

mixintest mixinmap tool MixinToolA
test tool-mixinmap-002 {Test mixin map script ran} {
  mixintest test which
} {Tool A}

mixintest mixinmap tool MixinToolB
test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test which
} {Tool B}

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test_newfunc
} {B}

mixintest mixinmap tool {}
test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {}

###
# Coroutine tests
###
tool::define coro_example {
  
  dict_ensemble coro_a_info coro_a_info {
    initialize {
      restart 0
      phase 0
      loop  0
      event 0
      idle  0
    }
  }
  
  coroutine coro_a {
    my coro_a_info merge {
      phase 0
      loop  0
      event 0
      idle  0
    }
    yield [info coroutine]
    while 1 {
      my coro_a_info incr phase
      my coro_a_info set  loop 0
      while 1 {
        if {[my $coro next event]} {
          my coro_a_info incr idle
          yield
          continue
        }
        my coro_a_info set last_event $event
        my coro_a_info incr loop
        my coro_a_info incr event
        switch [lindex $event 0] {
          phase {
            break
          }
          quit {
            return
          }
          b {
            my coro_b send [lrange $event 1 end]
          }
        }
      }
    }
  }
  
  dict_ensemble coro_b_info coro_b_info {
    initialize {
      restart 0
      phase 0
      loop  0
      event 0
      idle  0
    }
  }
  
  coroutine coro_b {
    my coro_b_info merge {
      phase 0
      loop  0
      event 0
      idle  0
    }
    yield [info coroutine]

    while 1 {
      my coro_b_info incr phase
      my coro_b_info set  loop 0
      while 1 {
        if {[my $coro next event]} {
          my coro_b_info incr idle
          yield
          continue
        }
        my coro_b_info incr loop
        my coro_b_info incr event
        switch [lindex $event 0] {
          phase break
          quit return
          a {
            my coro_a [lrange $event 1 end]
          }
        }
      }
    }
  }
  

  dict_ensemble coro_yodawg_info coro_yodawg_info {
    initialize {
      restart 0
      phase 0
      loop  0
      event 0
      idle  0
      yodawg  0
    }
  }
  
  coroutine coro_yodawg {
    my coro_yodawg_info merge {
      phase 0
      loop  0
      event 0
      idle  0
      yodawg  0
      iloop 0
    }
    yield [info coroutine]

    while 1 {
      my coro_yodawg_info incr phase
      my coro_yodawg_info set  loop 0
      while 1 {
        if {[my $coro next event]} {
          my coro_yodawg_info incr idle
          yield
          continue
        }
        my coro_yodawg_info set last_event $event
        my coro_yodawg_info incr loop
        my coro_yodawg_info incr event
        switch [lindex $event 0] {
          phase break
          quit {
            return
          }
          yodawg {
            my coro_yodawg_info incr yodawg
            if {[my coro_yodawg_info get yodawg] <32} {
              my coro_yodawg yodawg
              yield
            }
          }
          iloop {
            my coro_yodawg_info incr iloop
          }
        }
      }
    }
  }
}

set obj [coro_example new]
$obj coro_a none
test tool-coroutine-001-00 {Test coroutine } {
  $obj coro_a_info get restart
} 0
test tool-coroutine-001-01 {Test coroutine } {
  $obj coro_a_info get loop
} 1
$obj coro_a none
test tool-coroutine-001-02 {Test coroutine } {
  $obj coro_a_info get loop
} 2
$obj coro_a none
test tool-coroutine-001-03 {Test coroutine } {
  $obj coro_a_info get loop
} 3
$obj coro_a phase
test tool-coroutine-002-01 {Test coroutine } {
  $obj coro_a_info get loop
} 0
test tool-coroutine-002-02 {Test coroutine } {
  $obj coro_a_info get phase
} 2

###
# Start both coroutines over
$obj coro_a restart
$obj coro_b restart

test tool-coroutine-003-01-A {Test coroutine } {
  $obj coro_a_info get phase
} 0
test tool-coroutine-003-01-B {Test coroutine } {
  $obj coro_a_info get loop
} 0
test tool-coroutine-003-01-C {Test coroutine } {
  $obj coro_a_info get phase
} 0
test tool-coroutine-003-01-D {Test coroutine } {
  $obj coro_b_info get loop
} 0


$obj coro_a b
###
# Test coroutines calling coroutines
test tool-coroutine-003-02-A {Test coroutine } {
  $obj coro_a_info get loop
} 1
test tool-coroutine-003-02-B {Test coroutine } {
  $obj coro_b_info get loop
} 1

$obj coro_b a
###
# Test coroutines calling coroutines
# Note: Each call to each other coroutine can only happen
# once per "send"
###
test tool-coroutine-003-03-A {Test coroutine } {
  $obj coro_a_info get loop
} 1
test tool-coroutine-003-03-B {Test coroutine } {
  $obj coro_b_info get loop
} 2

###
# Rig the coroutine to call itself back from the other coroutine
###
$obj coro_b a b
###
# Test coroutines calling coroutines
test tool-coroutine-003-04-A {Test coroutine } {
  $obj coro_a_info get loop
} 2
test tool-coroutine-003-04-B {Test coroutine } {
  $obj coro_b_info get loop
} 3

# We should see A update in the background
$obj coro_b loop
test tool-coroutine-003-05-A {Test coroutine } {
  $obj coro_a_info get loop
} 3
test tool-coroutine-003-05-B {Test coroutine } {
  $obj coro_b_info get loop
} 5

# Now only B advances
$obj coro_b loop
test tool-coroutine-003-05-A {Test coroutine } {
  $obj coro_a_info get loop
} 3
test tool-coroutine-003-05-B {Test coroutine } {
  $obj coro_b_info get loop
} 6

# Now only A advances
$obj coro_a loop
test tool-coroutine-003-06-A {Test coroutine } {
  $obj coro_a_info get loop
} 4
test tool-coroutine-003-06-B {Test coroutine } {
  $obj coro_b_info get loop
} 6

###
# Test a malformed coroutine that calls itself
# The safety mechanism should allow the event to re-schedule itself
# but only once per call, and only execute once per call
###
test tool-coroutine-yodawg-00 {Test coroutine - yodawg } {
  $obj coro_yodawg running
} 0

$obj coro_yodawg yodawg
test tool-coroutine-yodawg-01 {Test coroutine - yodawg } {
  $obj coro_yodawg_info get yodawg
} 1
$obj coro_yodawg
test tool-coroutine-yodawg-02 {Test coroutine - yodawg } {
  $obj coro_yodawg_info get yodawg
} 2
$obj coro_yodawg yodawg
$obj coro_yodawg yodawg
test tool-coroutine-yodawg-03 {Test coroutine - yodawg } {
  $obj coro_yodawg_info get yodawg
} 4
for {set x 1} {$x < 32} {incr x} {
  $obj coro_yodawg iloop
  set a [$obj coro_yodawg_info get yodawg]
  set levent [$obj coro_yodawg_info get last_event]
  set iloop [$obj coro_yodawg_info get iloop]
  if {$a > 32} break
  test tool-coroutine-yodawg-03-yd-$x {Test coroutine - yodawg } {
    set a
  } [expr {4+$x}]
  test tool-coroutine-yodawg-03-le-$x {Test coroutine - yodawg } {
    set levent
  } yodawg
  # The iloop should *ALSO* be running side-by-side with the yodawg
  # However, not until the first three yodawg events are processed
  # in the queue
  if {$x > 3} {
    test tool-coroutine-yodawg-03-il-$x {Test coroutine - yodawg } {
      set iloop
    } [expr {$x-3}]
  }
}
###
# With the yodawgs resolved we should now
# be processing events in order once more
# Add one more event
#
# NOTE the lagging iloop events do catch up
###
$obj coro_yodawg end
test tool-coroutine-yodawg-03-iloop-count {Test coroutine - yodawg } {
  $obj coro_yodawg_info get iloop
} $x
test tool-coroutine-yodawg-03-endevent {Test coroutine - yodawg } {
  $obj coro_yodawg_info get last_event
} end

# -------------------------------------------------------------------------


testsuiteCleanup

# Local variables:
# mode: tcl