#!/usr/bin/tclsh
# © Wolf-Dieter Busch Thu May 20 12:40:15 CEST 2021
package require Tk 8.6.1
#
# XMl -- minimalistic but working XML parser
# usage: package require XML
# 
# xml parse $src ?-space yes|no? 
# xml findElementsByName $tree $name
# xml findElementById $tree $id
# xml getElement $tree ?n1 ?n2 ...??
# xml getText $tree ?n1 ?n2 ...??
# xml unparse $tree ?-pp?
#
# default: xml parse $src -space no
#

package require Tcl 8.6.1
package provide xml 0.3

namespace eval xml {
  namespace export\
    parse\
    unparse\
    getElement\
    getText\
    findElementById\
    findElementsByName
}

namespace eval xml namespace import ::tcl::mathop::+

proc ::xml::tokenize txt {
  set start 0
  set result {}
  while true {
    set openIdx [string first < $txt $start]
    if {$openIdx < 0} break
    if {[regexp {[[:alpha:]/]} [string index $txt $openIdx+1]]} then {
      set closeIdx [string first > $txt $openIdx]
      lappend result [list $openIdx $closeIdx]
    } elseif {[string range $txt $openIdx $openIdx+3] eq "<!--"} then {
      set closeIdx [string first --> $txt $openIdx]
      lappend result [list $openIdx [+ $closeIdx 2]]
    } else {
      incr start
      continue
    }
    set start $closeIdx
  }
  set result
}

proc ::xml::parse {src args} {
  set option [dict merge {
    -space no
  } {*}[lmap {a b} $args {
    if {$a ni { -space }} then {
      return -code error [list unknown option: $a -- {*}[info level 0]]
    }
    list $a $b
  }]]
  #
  # encode <![CDATA[http://www.taz.de//!p4608/]]>
  set cdataMap [concat {*}[lsort -unique [lmap {a b}\
    [regexp -inline -all {<!\[CDATA\[(.*?)\]\]>} $src] {
    list $a [string map {
      ]\] ]]
      ]\> ]&gt;
      < &lt; 
      & &amp; 
      > &gt; 
    } $b]
  }]]]
  set src [string map $cdataMap $src]
  set pairs [tokenize $src]
  #
  # set pairs [tokenize $src]
  #
  # list of tag strings
  set tagList [lmap pair $pairs {string range $src {*}$pair}]
  # indices of pcdata
  set strIdx [lrange [concat {*}$pairs] 1 end-1]
  # list of pcdata strings
  set strList {}
  foreach {i j} $strIdx {
    lappend strList [string range $src $i+1 $j-1]
  }
  # tokens alternating: tag, pcdata, tag, ...
  set tokens {}
  foreach tag $tagList str $strList {
    lappend tokens $tag
    if {[dict get $option -space]} then {
      if {$str ne ""} then {
        lappend tokens $str
      }
    } else {
      if {![string is space $str]} then {
        lappend tokens [string trim $str]
      }
    }
  }
  while {
    [string match <!--*--> [lindex $tokens 0]] ||
    [string match <\\?*\\?> [lindex $tokens 0]]
  } {
    set tokens [lrange $tokens 1 end]
  }
  # process list
  tokensVarToTree tokens
}


proc ::xml::tokensVarToTree _tokens {
  upvar $_tokens tokens
  set tokens [lassign $tokens token]
  if {[regexp {^<[[:alpha:]][^>]*>$} $token]} then {
    #
    # token is opening TAG 
    #
    regexp {[[:alnum:]]+} $token name
    set result [dict create type element name $name attribute "" content ""]
    set attList\
      [regexp -inline -all {([[:alnum:]]+)="([^"]*)"} $token]
    lappend attList\
      {*}[regexp -inline -all {([[:alnum:]]+)='([^']*)'} $token]
    foreach {match att val} $attList {
      dict set result attribute $att $val
    }
    dict set result content {}
    if {![regexp {/\s*>} $token]} then {
      #
      # non-empty TAG
      #
      while {
        [llength $tokens] > 0 &&
        ![string match </* [lindex $tokens 0]]
      } {
        dict lappend result content [tokensVarToTree tokens]
      }
      set tokens [lrange $tokens 1 end]
    }
    set result
  } elseif {[string match <!--*--> $token]} then {
    #
    # token is COMMENT
    #
    dict create type comment content [string range $token 4 end-3] 
  } else {
    #
    # token is PCDATA
    #
    dict create type pcdata content $token
  }
}

proc ::xml::getElement {tree args} {
  lassign [info level 0] recurse
  if {$args eq ""} then {
    set tree
  } else {
    switch -exact -- [dict get $tree type] {
      pcdata - comment {
        set tree
      }
      element {
        set args [lassign $args index]
        if {$index < [llength [dict get $tree content]]} then {
          $recurse [lindex [dict get $tree content] $index] {*}$args
        }      
      }
      default {
        return -code error [list unknown type [dict get $tree type]]
      }
    }
  }
}

proc ::xml::findElementById {tree id args} {
  lassign [info level 0] recurse
  if {[dict get $tree type] eq "element"} then {
    set i 0  
    foreach child [dict get $tree content] {
      if {[dict get $child type] eq "element" &&
          [dict exists $child attribute id] &&
          [dict get $child attribute id] eq $id} then {
        return [concat $args $i]
      }
      set path [$recurse $child $id {*}$args $i]
      if {$path ne ""} then {
        return $path
      }
      incr i
    }
  }
}

proc ::xml::findElementsByNameRoutine {tree names args} {
  if {[dict get $tree type] eq "element"} then {
    set i 0  
    foreach child [dict get $tree content] {
      if {[dict get $child type] eq "element"} then {
        set name [dict get $child name]
        if {[llength $names] == 1} then {
          lassign $names pattern
          if {[string match $pattern $name]} then {
            yield [concat $args $i]
          }
        } else {
          if {$name in $names} then {
            yield [concat $args $i]
          }
        }
      }
      findElementsByNameRoutine $child $names {*}$args $i
      incr i
    }
  }
}

proc ::xml::findElementsByName {tree args} {
  # xml findElementsByName $tree td ⇒ {1 0 1} {1 1 1}
  # xml findElementsByName $tree {t[dh]} ⇒ {1 0 0} {1 0 1} {1 1 0} {1 1 1}
  # xml findElementsByName $tree td th ⇒ {1 0 0} {1 0 1} {1 1 0} {1 1 1}
  lassign [info level 0] recurse
  set i 1
  while {[info commands c$i] ne ""} {
    incr i
  }
  set coroutine c$i
  coroutine $coroutine apply [list  {tree names} {
      yield [info coroutine]
      findElementsByNameRoutine $tree $names
    } [namespace current]] $tree $args
  set result {}
  while true {
    set path [$coroutine]
    if {$path ne ""} then {
      lappend result $path
    } else {
      return $result
    }
  }
}

proc ::xml::unparse {tree {indent 0} args} {
  lassign [info level 0] recurse
  if {![string is digit $indent]} then {
    lappend args $indent
    set indent 0
  }
  set result ""
  if {"-pp" in $args} then {
    if {$indent > 0} then {
      append result \n
    }
    append result [string repeat "  " $indent]
  }
  if {[dict get $tree type] eq "comment"} then {
    append result <!--[dict get $tree content]-->
  } elseif {[dict get $tree type] eq "pcdata"} then {
    if {"-pp" in $args} then {
      set trimmedTxt [string trim [dict get $tree content]]
      if {$trimmedTxt ne ""} then {
        append result $trimmedTxt
      }
    } else {
      append result [dict get $tree content]
    }
  } else {
    append result <[dict get $tree name]
    foreach {key val} [dict get $tree attribute] {
      append result " $key="
      if {[string first \u0022 $val] < 0} then {
        append result \" $val \"
      } else {
        append result ' $val '
      }
    }
    if {[llength [dict get $tree content]] == 0} then {
      append result " />"
    } else {
      append result >
      foreach child [dict get $tree content] {
        append result [$recurse $child [+ $indent 1] {*}$args]
      }
      if {"-pp" in $args} then {
        append result \n[string repeat "  " $indent]
      }
      append result </[dict get $tree name]>
    }
  }
  set result
}

proc ::xml::decode txt {
  lappend map "&lt;" < "&gt;" > "&amp;" & "&quot;" \"
  set matches [lsort -unique [regexp -inline -all {&#[0-9]+;} $txt]]
  foreach match $matches {
    regexp {([0-9]+)} $match - i
    lappend map $match [format %c [scan $i %d]]
  }
  string map $map $txt
}

proc ::xml::getText {tree args} {
  set child [getElement $tree {*}$args]
  if {[dict get $child type] eq "pcdata"} then {
    decode [dict get $child content]
  } elseif {[llength [dict get $child content]] > 0} then {
    getText $child 0
  }
}

namespace eval xml namespace ensemble create


#
# obj -- minimalistic object orientation for Tcl
# usage: package require obj
#

package require Tcl 8.5
package provide obj 0.2

#
# namespace obj
# variable counter to calculate unique object name
# sub-namespace inst for object instances
# sub-namespace class for class namespaces
#

namespace eval obj {
  variable counter 0
  namespace eval inst {}
  namespace eval class {}
  namespace export *
}

namespace eval obj::find {
  namespace ensemble create
  namespace export *
}

proc obj::find::object class {
  append data\
    [namespace qualifiers [namespace current]]\
    ::class:: $class ::data
  array names $data ::obj::inst::*
}

proc obj::find::class {{pat *}} {
  set result {}
  foreach ns [namespace children\
                [namespace qualifiers\
                   [namespace current]]::class $pat] {
    lappend result [namespace tail $ns]
  }
  set result
}

#
# obj::info $object $what
# intended to use as method:
# $object info $what
# $object info ? tells what is provided.
#

proc obj::info {self {how ""} args} {
  if {[exists $self]} then {
    if {$how eq ""} then {
      set how ?
    }
    switch -exact -- $how {
      class {
        namespace tail [namespace qualifiers [namespace origin $self]]
      }
      exists {
        exists {*}$args
      }
      self - object {
        set self
      } 
      namespace {
        namespace qualifiers [namespace origin $self]
      } 
      instances {
        array names\
          [namespace qualifiers\
             [namespace origin $self]]::data ::obj::inst::*
      } 
      methods {
        set pat [lindex $args 0]
        if {$pat eq ""} then {
          set pat {[a-zA-Z0-9]*}
        }
        set result {}
        foreach m [set [info $self namespace]::data(methods)] {
          if {[string match $pat $m]} then {
            lappend result $m
          }
        }
        set result
      }
      args {
        set method {*}$args
        set proc [namespace qualifiers [namespace origin $self]]::$method
        set argl {}
        foreach arg [lrange [::info args $proc] 1 end] {
          if {[::info default $proc $arg defVar]} then {
            lappend argl [list $arg $defVar]
          } else {
            lappend argl $arg
          }
        }
        set argl
      }
      body {
        set method {*}$args
        set proc [namespace qualifiers [namespace origin $self]]::$method
        ::info body $proc
      }
      comment - # {
        set result {}
        foreach line [::split [$self info body {*}$args] \n] {
          set line [string trim $line]
          if {$line eq {}} then continue
          if {[string index $line 0] ne "#"} then break
          lappend result [string trim $line "# "]
        }
        set result [string trim [join $result \n]]
        set line [lindex [split $result \n] 0]
        if {[string is list -strict $line]} then {
          lassign $line a b c d e
          if {$a eq "delegate" &&
              $b eq "to" &&
              $c in [$self component] &&
              $d in {as ""} &&
              (($e eq "" && $d eq "") ||
               $e in [$self component $c info methods])} then {
            if {$e eq ""} then {
              set e [lindex [::info level 0] end]
            }
            append result " -->\n" [$self component $c info comment $e]
          }
        }
        set result
      }
      source - method {
        list [namespace origin method] [info $self class] {*}$args\
          [info $self args {*}$args] [info $self body {*}$args]
      }
      constructor {
        list [namespace current]::constructor [info $self class]\
          [info $self args __constructor] [info $self body __constructor]
      }
      destructor {
        list [namespace current]::destructor [info $self class]\
          [info $self body __destructor]
      }
      classes {
        set p [namespace origin $self]
        set ns [namespace qualifiers [namespace qualifiers $p]]
        set result {}
        foreach c [namespace children $ns] {
          lappend result [namespace tail $c]
        }
        set result
      }
      configuremethod - validatemethod {
        set option {*}$args
        list [namespace current]::$how [info $self class] $option\
          [info $self args [string range __$how 0 end-6]$option]\
          [info $self body [string range __$how 0 end-6]$option]
      }
      cgetmethod {
        set option {*}$args
        list [namespace current]::cgetmethod [info $self class] $option\
          [info $self body __cget$option]
      }
      options {
        set p [namespace qualifiers [namespace origin $self]]
        set arrayName ${p}::data(options)
        dict keys [set $arrayName]
      }
      common {
        set ns [namespace qualifiers [namespace origin $self]]
        set ${ns}::data(common)
      }
      data {
        set ns [namespace qualifiers [namespace origin $self]]
        set ${ns}::data($self)
      }
      private {
        dict keys [dict get [info $self data] private]
      }
      help - \? {
        list added/modified subcommands:\
          self class namespace instances methods body args\
          source method comment constructor destructor\
          options classes cgetmethod validatemethod\
          data private common help ?
      } 
      default {
        uplevel #0 [list ::info $how {*}$args]
      }
    } 
  } else {
    # obiously basic proc meant
    uplevel ::info $self {*}[concat $how $args]
  }
}

proc obj::_generate-object_ args {
  set class [namespace tail [lindex [::info level 0] 0]]
  new $class {*}$args
}

#
# obj::class $classname
# initializes $classname with basic methods
# as well as keywords my and our for methods inside only.
#

proc obj::class {class args} {
  namespace eval class::$class {
    # core procedure
    namespace export _root-object_
    proc _root-object_ {{method ::return} args} {
      $method [::lindex [::info level 0] 0] {*}$args
    }
    # data
    array set data {}
    set data(options) {}
    set data(common) {}
    set data(methods) {cget configure info destroy private common isa}
  }
  # import pre-defined procedures and methods
  namespace eval class::$class [::subst {
      namespace import\
        [::namespace current]::new\
        [::namespace current]::info\
        [::namespace current]::local\
        [::namespace current]::exists
    }]
  # define core methods
  method $class __constructor args # false
  method $class __destructor args # false
  #
  method $class isa class\
    [subst {expr {\$class eq "$class" ? true : false}}] false
  #
  method $class cget key {
    ::variable data
    if {$key ni $data(options)} then {
      ::return -code error "no valid option: $key"
    }
    $self __cget$key
    ::dict get $data($self) option $key
  } false 
  method $class configure {args} {
    ::variable data
    ::if {![::llength $args]} then {
      ::set result {}
      ::foreach {key val} [::dict get $data($self) option] {
        ::lappend result\
          [::list $key [::dict get $data(options) $key] [$self cget $key]]
      }
      ::set result
    } else {
      if {[::llength $args] == 1} then {
        if {$args ni $data(options)} then {
          ::return -code error "no valid option: $args"
        }
        ::list {*}$args\
          [::dict get $data(options) {*}$args]\
          [$self cget {*}$args]
      } else {
        ::foreach {key val} $args {
          if {$key ni $data(options)} then {
            ::return -code error "no valid option: $key"
          }
          $self __validate$key $val
          ::dict set data($self) option $key $val
          $self __configure$key $val
        }
      }
    }
  } false
  method $class component {{component {}} args} {
    ::variable data
    if {$component eq ""} then {
      set result {}
      foreach {key val} [::dict get $data($self) private] {
        if {[::info command $val] ne "" &&
            [::namespace qualifiers $val] eq "::obj::inst"} then {
          lappend result $key
        }
      }
      set result
    } else {
      [::dict get $data($self) private $component] {*}$args
    }
  } false
  method $class private args {
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys [::dict get $data($self) private]
    } elseif {[::llength $args] == 1} then {
      ::dict get $data($self) private {*}$args
    } else {
      ::dict set data($self) private {*}$args
      ::lindex $args end
    }
  } false
  method $class common args {
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys [::dict get $data(common)]
    } elseif {[::llength $args] == 1} then {
      ::dict get $data(common) {*}$args
    } else {
      ::dict set data(common) {*}$args
      ::lindex $args end
    }
  } false
  method $class destroy args {
    ::if {[exists $self]} then {
      set result [$self __destructor]
      ::variable data
      ::unset data($self)
      ::rename $self ""
      set result
    } else {
      # presumably a Tk widget was to destroy
      ::destroy $self {*}$args
    }
  } false
  # debugging purposes
  method $class inside args {{*}$args}
  # define special procedures our & my
  proc class::${class}::our args {
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys $data(common)
    } elseif {[::llength $args] == 1} then {
      ::dict get $data(common) {*}$args
    } else {
      ::dict set data(common) {*}$args
    }
  }
  proc class::${class}::my args {
    ::upvar self self
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys [::dict get $data($self) private]
    } elseif {[::llength $args] == 1} then {
      ::dict get $data($self) private {*}$args
    } else {
      ::dict set data($self) private {*}$args
      ::dict get $data($self) private [::lindex $args 0]
    }
  }
  proc class::${class}::!my {name args} {
    # removes key from dict,
    # returns value of previously destroyed key
    ::upvar self self
    ::variable data
    ::catch {::dict get $data($self) private $name {*}$args} result
    ::dict unset data($self) private $name {*}$args
    ::set result
  }
  proc class::${class}::?my {name args} {
    # shortcut for ::dict get [my $name {*}$args]
    ::upvar self self
    ::variable data
    ::dict get $data($self) private $name {*}$args
  }
  array set opt [concat {
      -configure {}
      -common {}
    } $args]
  foreach {key val} $opt(-configure) {
    configure $class $key $val
  }
  dict keys $opt(-common)
  set class::${class}::data(common) $opt(-common)
  list class $class
}

proc obj::common {class {key ?} args} {
  if {$key eq "?"} then {
    inscope $class "dict keys \$data(common)"
  } elseif {$args eq ""} then {
    inscope $class "dict get \$data(common) $key"
  } else {
    lassign $args val
    dict set class::${class}::data(common) $key $val
    list in class $class, common $key is $val
  }
}

proc obj::exists obj {
  if {[::info proc $obj] eq ""} then {
    return false
  }
  set ins [namespace current]::inst::*
  if {![string match $ins $obj]} then {
    return false
  }
  set cns [namespace current]::class::*
  if {![string match $cns [namespace origin $obj]]} then {
    return false
  }
  return true
}

#
# obj::method $class $method {...} {...}
# cares pf forbidden method names
#

proc obj::method {class {method {}} args} {
  if {$method eq ""} then {
    set result {}
    foreach p [::info procs [::namespace current]::class::${class}::*] {
      if {[string first __ $p] < 0 &&
          $p ni {configure destroy cget} &&
          [lindex [::info args $p] 0] eq "self"} then {
        lappend result [namespace tail $p]
      }
    }
    set result
  } elseif {$args eq {}} then {
    set m [namespace current]::class::${class}::$method
    if {[::info procs $m] ne $m} then {
      set result {}
      foreach p [::info procs $m] {
        lappend result [::namespace tail $p]
      }
      set result
    } else {
      ::list [::namespace origin method] $class $method\
        [lrange [info args $m] 1 end]\
        [info body $m]
    }
  } else {
    lassign $args argl body check
    if {![string is false -strict $check]} then {
      switch -glob -- $method\
        _root-object_ - __constructor - __destructor - destroy -\
        new - my - our - private - common - isa -\
        configure - cget - __configure-* - __cget-* - __validate-* {
        return -code error [list forbidden method name: $method, sorry!]
      }
      upvar [namespace current]::class::${class}::data data
      if {$method ni $data(methods)} then {
        lappend data(methods) $method
      }
      if {[::info command ::$method] ne ""} then {
        puts stderr\
          "Warning: method $method in class $class hides command ::$method"
      }
      set procName [namespace current]::class::${class}::$method
      if {[::info command $procName] ne "" &&
          [lindex [::info args $procName] 0] ne "self"} then {
        puts stderr\
          "Warning: method $method in class $class overwrites a procedure!"
      }
    }
    proc $class $method [concat self $argl] $body
    list method $class $method
  }
}

proc obj::proc args {
  if {[llength $args] == 3} then {
    ::proc {*}$args
  } elseif {[llength $args] == 4} then {
    inscope [lindex $args 0] ::proc {*}[lrange $args 1 end]
  } else {
    append err [::info level 0]\
      \n---\neither:\n\
      "proc name argl body"\
      \nor:\n\
      "proc class name argl body"
    return -code error $err
  }
}

#
# obj::constructor $classname {...} {...}
# obj::destructor $classname {...}
#

proc obj::constructor {class args body} {
  method $class __constructor $args $body false
  list constructor $class
}
proc obj::destructor {class body} {
  method $class __destructor {} $body false
  list destructor $class
}

#
# obj::new $class ?options ?more??
# options are recognized by leading -
# parsing options is stopped by --
# additional args for constructor can follow the options
#

proc obj::new {class args} {
  variable counter
  set objName [namespace current]::inst::[incr counter]
  namespace import -force class::${class}::_root-object_
  rename _root-object_ $objName
  dict set class::${class}::data($objName) option\
    [set class::${class}::data(options)]
  dict set class::${class}::data($objName) private {}
  set index 0
  foreach {key val} $args {
    if {[string index $key 0] ne "-" ||
	[string is double -strict $key]} then break
    if {$key eq "--"} then {
      incr index
      break
    }
    incr index 2
    dict set class::${class}::data($objName) option $key $val
  }
  $objName __constructor {*}[lrange $args $index end]
  set objName
}

#
# obj::local $class ...
# creates new object inside procedure body
# and manages that it destroys on leaving this procedure.
#

proc obj::local {class args} {
  set obj [new $class {*}$args]
  set name [string map {:: :} [list local object $obj]]
  uplevel [list set $name $obj]
  uplevel\
    [list trace add variable $name unset\
       "$obj destroy;#"]
  set obj
}

#
# obj::option $class $key ?$val?
# installs appropriate option for class
#

proc obj::configure {class key {val ""}} {
  if {[string index $key 0] ne "-"} then {
    set key -$key
  }
  dict set class::${class}::data(options) $key $val
  method $class __cget$key {} # false
  method $class __validate$key val # false
  method $class __configure$key val # false
  lappend [namespace current]::class::${class}::data(methods)\
    __configure$key __cget$key __validate$key
  list class $class has option $key with default $val 
}

#
# obj::cgetmethod $lass $key {...}
# obj::validatemethod $lass $key {...}
# obj::configuremethod $lass $key $val {...}
# intended for additional control.
# These procs are invoked by delegate option (below).
#

proc obj::cgetmethod {class {key ""} args} {
  if {$key eq ""} then {
    set result {}
    foreach m [::info procs [namespace current]::class::${class}::__cget-*] {	
      set opt [regexp -inline {[-][^.]+$} $m]
      set body [::info body $m]
      if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
        lappend result $opt
      }
    }
    set result
  } elseif {$args eq ""} then {
    list [namespace origin cgetmethod] $class $key\
      [::info body [namespace current]::class::${class}::__cget$key]
  } else {
    lassign $args body
    method $class __cget$key {} $body false
    list cgetmethod $class $key
  }
}

proc obj::configuremethod {class {key ""} {val ""} {body #}} {
  if {$key eq ""} then {
    set result {}
    foreach m [::info procs [namespace current]::class::${class}::__configure-*] {	
      set opt [regexp -inline {[-][^.]+$} $m]
      set body [::info body $m]
      if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
        lappend result $opt
      }
    }
    set result
  } elseif {$val eq ""} then {
    list [namespace origin configuremethod] $class $key\
      [lrange [::info args [namespace current]::class::${class}::__configure$key] 1 end]\
      [::info body [namespace current]::class::${class}::__configure$key]
  } else {
    method $class __configure$key $val $body false
    list configuremethod $class $key
  }
}

proc obj::validatemethod {class {key ""} {val ""} {body #}} {
  if {$key eq ""} then {
    set result {}
    foreach m [::info procs [namespace current]::class::${class}::__validate-*] {	
      set opt [regexp -inline {[-][^.]+$} $m]
      set body [::info body $m]
      if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
        lappend result $opt
      }
    }
    set result
  } elseif {$val eq ""} then {
    list [namespace origin validatemethod] $class $key\
      [lrange [::info args [namespace current]::class::${class}::__validate$key] 1 end]\
      [::info body [namespace current]::class::${class}::__validate$key]
  } else {
    method $class __validate$key $val $body false
    list validatemethod $class $key
  }
}

proc obj::read-only {class key} {
  validatemethod $class $key val [subst -nocommand {
    return -code error\
      [list You tried to set \$val on\
	 read-only option $key of class $class.]
  }]
  list option $key of class $class is read-only.
}

#
# delegate methods & options to components
#

namespace eval obj {
  namespace eval delegate {
    namespace export *
    namespace ensemble create
  }
}

#
# obj::delegate method $method $class $component ?as-method?
#

proc obj::delegate::method {method class component {as ""}} {
  if {$as eq ""} then {
    set as $method
  }
  set ns [namespace qualifiers [namespace current]]
  ${ns}::method $class $method args [subst -nocommand {
    # delegate to $component as $as
    \$self component $component $as {*}\$args
  }]
  lappend result\
    class $class delegates method $method to component $component
  if {$as ne $method} then {
    lappend result as $as
  }
  set result
}

#
# obj::delegate option $option $class $component ?as-option?
#

proc obj::delegate::option {option class component {as ""}} {
  if {$as eq ""} then {
    set as $option
  }
  set ns [namespace qualifiers [namespace current]]
  ${ns}::configuremethod $class $option args [subst -nocommand {
    \$self component $component configure $as {*}\$args
  }]
  ${ns}::cgetmethod $class $option [subst -nocommand {
    variable data
    dict set data(\$self) option $option\
      [\$self component $component cget $as]
  }]
  list class $class delegates option $option to component $component\
    {*}[if {$as ne $option} then {list as $as}]
}

#
# obj::inscope $class cmd ...
#

proc obj::inscope {class args} {
  namespace inscope [namespace current]::class::$class {*}$args
}

proc obj::help {{cmd --}} {
  set procs ""
  foreach p [info procs [namespace current]::*] {
    if {[string first _ $p] < 0} then {
      lappend procs [namespace tail $p]
    }
  }
  if {$cmd ni $procs} then {
    set procs
  } else {
    set argl {}
    foreach arg [::info args $cmd] {
      if {[::info default $cmd $arg def]} then {
        lappend argl [list $arg $def]
      } else {
        lappend argl $arg
      }
    }
    list obj::$cmd $argl
  }
}




#!/usr/bin/tclsh

::tcl::tm::path add ~/bin/TM

# package require XML
# package require obj
# package require Bezier

# cd /home/wolf/bin/Projekte/vectorleaf
cd [file join [file dirname [info script]]]

# start here

namespace eval obj namespace ensemble create

namespace eval canvasexport {
  
  namespace import ::tcl::mathop::* ::tcl::mathfunc::*
  
  proc mvg canvas {
    set col2hex {color {
        if {[winfo exists $color] && [winfo class $color] eq "Canvas"} then {
          set color [$color cget -bg]
        }
        if {$color eq ""} then {
          set result none
        } else {
          set result #
          foreach x [winfo rgb . $color] {
            append result [format %02x [expr {int($x / 256)}]]
          }
        }
        set result
      }}
    set splinecoords2mvg {{coords {canBeClosed yes}} {
        set closed [expr {$canBeClosed &&
            [lindex $coords 0] == [lindex $coords end-1] &&
            [lindex $coords 1] == [lindex $coords end]}]
        if {$closed} then {
          lassign [lrange $coords end-3 end] x0 y0 x1 y1
          set x [expr {($x0+$x1)/2.0}]
          set y [expr {($y0+$y1)/2.0}]
          lset coords end-1 $x
          lset coords end $y
          set coords [concat $x $y $coords]
        }
        if {[llength $coords] == 6} then {
          lreplace $coords 2 1 Q
        } else {
          lappend result {*}[lrange $coords 0 1]
          set co1 [lrange $coords 2 end-4]
          set co2 [lrange $coords 4 end-2]
          foreach {x1 y1} $co1 {x2 y2} $co2 {
            lappend result $x1 $y1 [expr {($x1+$x2)/2.0}] [expr {($y1+$y2)/2.0}]
          }
          lappend result {*}[lrange $coords end-3 end]
          lreplace $result 2 1 Q
        }
      }}
    array set mode {fill "" 
      stroke "" 
      strokewidth "" 
      joinstyle "" 
      capstyle ""
      fontfamily "" 
      fontsize ""}
    lappend result [list viewbox 0 0 [winfo width $canvas] [winfo height $canvas]]
    # lappend result [list stroke none]\
      [list fill [apply $col2hex $canvas]]\
      [list rectangle 0 0 [winfo width $canvas] [winfo height $canvas]]
    foreach item [$canvas find all] {
      if {[$canvas itemcget $item -state] eq "hidden"} continue
      set type [$canvas type $item]
      lappend result "# $type ... [$canvas gettags $item]"
      # outline width
      if {$type in {polygon oval arc rectangle line}} then {
        set width [$canvas itemcget $item -width]
        if {$width != $mode(strokewidth)} then {
          set mode(strokewidth) $width
          lappend result [list stroke-width $width]
        }
      }
      # fill, stroke
      if {$type in {polygon oval arc rectangle}} then {
        set fill [apply $col2hex [$canvas itemcget $item -fill]]
        if {$mode(fill) ne $fill} then {
          set mode(fill) $fill
          lappend result [list fill $fill]
        }
        set stroke [apply $col2hex [$canvas itemcget $item -outline]]
        if {$mode(stroke) ne $stroke} then {
          set mode(stroke) $stroke
          lappend result [list stroke $stroke]
        }
      }
      # joinstyle
      if {$type in {polygon line}} then {
        set joinstyle [$canvas itemcget $item -joinstyle]
        if {$mode(joinstyle) ne $joinstyle} then {
          set mode(joinstyle) $joinstyle
          lappend result [list stroke-linejoin $joinstyle]
        }
      }
      # line color, capstyle
      if {$type in {line}} then {
        if {$mode(fill) ne "none"} then {
          set mode(fill) none
          lappend result [list fill none]
        }
        set stroke [apply $col2hex [$canvas itemcget $item -fill]]
        if {$mode(stroke) ne $stroke} then {
          set mode(stroke) $stroke
          lappend result [list stroke $stroke]
        }
        set capstyle [dict get {butt butt projecting square round round}\
            [$canvas itemcget $item -capstyle]]
        if {$mode(capstyle) ne $capstyle} then {
          set mode(capstyle) $capstyle
          lappend result [list stroke-linecap $capstyle]
        }
      }
      # text color, font, size
      if {$type in {text}} then {
        if {$mode(stroke) ne "none"} then {
          set mode(stroke) none
          lappend result [list stroke none]
        }
        set fill [apply $col2hex [$canvas itemcget $item -fill]]
        if {$mode(fill) ne $fill} then {
          set mode(fill) $fill
          lappend result [list fill $fill]
        }
        set font [$canvas itemcget $item -font]
        # font-family, font-size
        if {$font in font names} then {
          set fontsize [font configure $font -size]
          set fontfamily [font configure $font -family]
        } else {
          if {[llength $font] == 1} then {
            set fontsize 12
          } else {
            set fontsize [lindex $font 1]
          }
          set fontfamily [lindex $font 0]
        }
        if {$fontsize < 0} then {
          set fontsize [expr {int(-$fontsize / [tk scaling])}]
        }
        if {$mode(fontsize) ne $fontsize} then {
          set mode(fontsize) $fontsize
          lappend result [list font-size $fontsize]
        }
        #
        # Attention! In some cases, IM assumes 72dpi,
        # where 90dpi is necessary.
        # Then, on cmd line, use switch -density as follows:
        # convert -density 90 test.mvg test.png
        #
        if {$mode(fontfamily) ne $fontfamily} then {
          set mode(fontfamily) $fontfamily
          lappend result [list font $fontfamily]
        }
        #
        # Attention! Care that IM has access to fonts.
        # If not, an error msg is shown,
        # then the default font is used silently.
        #
      }
      set line {}
      set coords [$canvas coords $item]
      switch -exact -- $type {
        line {
          # start of path
          lappend line path 'M
          set smooth [$canvas itemcget $item -smooth]
          if {[string is true -strict $smooth]} then {
            if {[$canvas itemcget $item -arrow] eq "none"} then {
              lappend line {*}[apply $splinecoords2mvg $coords]
            } else {
              lappend line {*}[apply $splinecoords2mvg $coords false]
            }
          } elseif {[string is false -strict $smooth]} then {
            lappend line {*}[lrange $coords 0 1] L {*}[lrange $coords 2 end]
          } else {
            lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end]
          }
          append line '
          lappend result $line
        }
        polygon {
          lappend line path 'M
          set smooth [$canvas itemcget $item -smooth]
          if {[string is false -strict $smooth]} then {
            # line
            lassign $coords x0 y0
            lassign [lrange $coords end-1 end] x1 y1
            set x [expr {($x0+$x1)/2.0}]
            set y [expr {($y0+$y1)/2.0}]
            lappend line $x $y L {*}$coords $x $y Z
          } elseif {[string is true -strict $smooth]} then {
            # spline
            if {[lindex $coords 0] != [lindex $coords end-1] ||
              [lindex $coords 1] != [lindex $coords end]} then {
              lappend coords {*}[lrange $coords 0 1]
            }
            lappend line {*}[apply $splinecoords2mvg $coords]
          } else {
            # raw = bezier
            lappend line {*}[lrange $coords 0 1]\
              C {*}[lrange $coords 2 end] {*}[lrange $coords 0 1]
          }
          append line '
          lappend result $line
        }
        oval {
          lassign $coords x0 y0 x1 y1
          lappend line ellipse [expr {($x0+$x1)/2.0}] [expr {($y0+$y1)/2.0}]\
            [expr {$x1-($x0+$x1)/2.0}] [expr {$y1-($y0+$y1)/2.0}] 0 360
          lappend result $line
        }
        arc {
          lappend result [list push graphic-context]
          lappend result [list stroke-linejoin miter]
          # lappend result [list stroke-linejoin bevel]
          # lappend result [list stroke-linejoin round]
          lappend line path 'M
          lassign $coords x0 y0 x1 y1
          set rx [expr {($x1-$x0)/2.0}]
          set ry [expr {($y1-$y0)/2.0}]
          set x [expr {($x0+$x1)/2.0}]
          set y [expr {($y0+$y1)/2.0}]
          set f [expr {acos(0)/90}]
          set start [$canvas itemcget $item -start]
          set startx [expr {cos($start*$f)*$rx+$x}]
          set starty [expr {sin(-$start*$f)*$ry+$y}]
          set angle [expr {$start+[$canvas itemcget $item -extent]}]
          set endx [expr {cos($angle*$f)*$rx+$x}]
          set endy [expr {sin(-$angle*$f)*$ry+$y}]
          # start point
          lappend line\
            [expr {($startx+$x)/2.0}] [expr {($starty+$y)/2.0}]\
            $startx $starty
          lappend line A
          # radiusx, radiusy
          lappend line $rx $ry
          # angle -- always 0
          lappend line 0
          # "big" or "small"?
          lappend line [expr {$angle-$start > 180}]
          # right side (always)
          lappend line 0
          # end point
          lappend line $endx $endy
          # close path
          lappend line L $x $y Z
          append line '
          lappend result $line
          lappend result [list pop graphic-context]
        }
        rectangle {
          lappend result\
            [list push graphic-context]\
            [list stroke-linejoin miter]\
            [concat rectangle $coords]\
            [list pop graphic-context]
        }
        text {
          lassign [$canvas bbox $item] x0 y0 x1 y1
          lappend line text $x0 $y1
          append line " '[$canvas itemcget $item -text]'"
          lappend result $line
        }
        image - bitmap {
          set img [$canvas itemcget $item -image]
          set file [$img cget -file]
          lassign [$canvas bbox $item] x0 y0
          lappend result [list image over $x0 $y0 0 0 '$file']       
        }
        default {
          lappend result "# not yet done:\
              [$canvas type $item] [$canvas coords $item]\
              ([$canvas gettags $item])"
        }
      }
    }
    join $result \n
  }

  proc svg {{canvas .c} {title tk}} {
    lappend result [subst {<svg xmlns="http://www.w3.org/2000/svg"\
          width="[$canvas cget -width]px"\
          height="[$canvas cget -height]px"\
          viewbox="0 0 [$canvas cget -width] [$canvas cget -height]">}]
    foreach item [$canvas find all] {
      if {[$canvas itemcget $item -state] eq "hidden"} continue
      if {[$canvas itemcget $item -fill] eq ""} continue
      switch -exact -- [$canvas type $item] {
        line {
          lappend result [lineToSVG $item]
        }
        polygon {
          lappend result [polyToSVG $item]
        }
        default {
          lappend result "<!-- [$canvas type $item] not yet done -->"
        }
      }
    }
    string cat \n [join $result "\n  "] \n </svg>
  }

  proc hex color {
    lassign [winfo rgb . $color] r g b
    string cat #\
      [string range [format %04x $r] 0 1]\
      [string range [format %04x $g] 0 1]\
      [string range [format %04x $b] 0 1]
  }
  
  proc lineToSVG {item {canvas .c}} {
    set coords [$canvas coords $item]
    set style "fill:none;\
        fill-rule:evenodd;\
        stroke:[hex [$canvas itemcget $item -fill]];\
        stroke-width:[$canvas itemcget $item -width]px;\
        stroke-linecap:[$canvas itemcget $item -capstyle];\
        stroke-linejoin:[$canvas itemcget $item -joinstyle];\
        stroke-opacity:1"
    set path [lmap {x y} $coords {string cat $x , $y}]
    if {[$canvas itemcget $item -smooth] eq "raw"} then {
      # bezier 
      while {[llength $path] % 3 != 1} {
        # gemäß Canvas-Regeln für Bezier
        lappend path [lindex $path end]
      }
      string cat <path\
        " d=" \" "M [lindex $path 0] C [lrange $path 1 end]" \"\
        " class=" \" [concat [$canvas type $item] [$canvas gettags $item]] \"\
        " style=" \" $style \"\
        " id=" \" [$canvas type $item]-[$canvas find withtag $item] \"\
        " />"
    } elseif {[$canvas itemcget $item -smooth]} then {
      # spline
      # not yet done
    } else {
      # straight
      string cat <path\
        " d=" \" "M $path" \"\
        " class=" \" [concat [$canvas type $item] [$canvas gettags $item]] \"\
        " style=" \" $style \"\
        " id=" \" [$canvas type $item]-[$canvas find withtag $item] \"\
        " />"
    }
  }
  
  proc polyToSVG {item {canvas .c}} {
    set coords [$canvas coords $item]
    set style "fill:[hex [$canvas itemcget $item -fill]];\
        fill-rule:evenodd;\
        stroke:[$canvas itemcget $item -outline];\
        stroke-width:[$canvas itemcget $item -width]px;\
        stroke-linejoin:[$canvas itemcget $item -joinstyle];\
        stroke-opacity:1"
    set path [lmap {x y} $coords {string cat $x , $y}]
    if {[$canvas itemcget $item -smooth] eq "raw"} then {
      # bezier
      while {[llength $path] % 3 != 0} {
        # gemäß Canvas-Regeln für Bezier
        lappend path [lindex $path end]
      }
      # gemäß SVG-Regeln für Bezier
      lappend path [lindex $path 0]
      #
      string cat <path\
        " d=" \" "M [lindex $path 0] C [lrange $path 1 end] Z" \"\
        " class=" \" [concat [$canvas type $item] [$canvas gettags $item]] \"\
        " style=" \" $style \"\
        " id=" \" [$canvas type $item]-[$canvas find withtag $item] \"\
        " />"
    } elseif {[$canvas itemcget $item -smooth]} then {
      # spline
      # not yet done
    } else {
      # straight
      # not yet done
    }
  }
  
  namespace export svg mvg
  namespace ensemble create
}

array set externalApp {
  svg eog
  mvg convert
}

proc canvasToBitmap {{canvas .c} {file X:} {background white} args} {
  variable externalApp
  set ch [open tmp.mvg w]
  puts $ch [canvasexport mvg $canvas]
  close $ch
  exec $externalApp(mvg)\
    -size [$canvas cget -width]x[$canvas cget -height]\
    xc:$background\
    -draw @tmp.mvg\
    $file {*}$args
}

proc adjustChildGeometry win {
  set par [winfo parent $win]
  set top [winfo toplevel $par]
  set screenw [winfo screenwidth $win]
  lassign [split [winfo geometry $top] x+] topw toph topx topy
  lassign [split [winfo geometry $par] x+] parw parh parx pary
  set spaceLeft $topx
  set spaceRight [- $screenw $topx $parw]
  if {$spaceRight > $spaceLeft} then {
    wm geometry $win +[+ $topx $parx $parw]+[+ $pary $topy]
  } else {
    set cmd [subst -nocommand {
        wm geometry $win +[expr {
        max(0, $topx + $parx - [winfo reqwidth $win])
      }]+[+ $pary $topy]
      }]
    eval $cmd
    update
    after idle $cmd
  }
}

# package require Tk

bind Entry <<Paste>> {
  catch {
    catch {
      %W delete sel.first sel.last
    }
    %W insert insert [::tk::GetSelection %W CLIPBOARD]
    tk::EntrySeeInsert %W
  }
}

destroy .entryCopyPaste
bind Entry <3> "tk_popup [menu .entryCopyPaste -tearoff no] %X %Y"
.entryCopyPaste add command -label Cut -command {event generate [focus] <<Cut>>}
.entryCopyPaste add command -label Copy -command {event generate [focus] <<Copy>>}
.entryCopyPaste add command -label Paste -command {event generate [focus] <<Paste>>}

event add <<Click>> <Button-1><ButtonRelease>
event add <<ControlClick>> <Control-Button-1><ButtonRelease>
event add <<DoubleClick>> <Double-Button-1><ButtonRelease>
event add <<ShiftControlClick>> <Control-Shift-Button-1><ButtonRelease>
event add <<ZoomIn>> <Control-Key-plus>
event add <<ZoomOut>> <Control-Key-minus>
event add <<ZoomOriginal>> <Control-0>

namespace import ::tcl::mathop::* ::tcl::mathfunc::*

#{string cat

if {[info command ::tcl::string::cat] eq ""} then {
  proc ::tcl::string::cat args {::join $args ""}
  apply {
    map {
      dict set map cat ::tcl::string::cat
      namespace ensemble configure string -map $map
    }
  } [namespace ensemble configure string -map] 
}

#string cat}

proc bindOnce {win event action} {
  bind $win $event [list bind $win $event [bind $win $event]]
  bind $win $event +$action
}

# debug
proc -- args #
proc ++ args {eval {*}$args}
proc dot {x y args} {
  set r 5
  .c create oval [- $x $r] [- $y $r] [+ $r $x] [+ $r $y]\
    -tags dot -fill yellow -stipple gray25
}

# Liste ohne Dubletten
proc lunique l {
  set result {}
  foreach e $l {
    if {$e ni $result} then {
      lappend result $e
    }
  }
  set result
}

# list difference
proc ldifference {l args} {
  if {[llength $args] > 0} then {
    set args [lassign $args m]
    set result {}
    foreach el $l {
      if {$el ni $m} then {
        lappend result $el
      }
    }
    ldifference $result {*}$args
  } else {
    set l
  }
}

# temporary bindings of current vars
proc fluid-let {varlist script} {
  foreach {key val} $varlist {
    dict set backup $key [uplevel set $key]
    uplevel set $key $val
  }
  set result [uplevel $script]
  dict for {key val} $backup {
    uplevel set $key $val
  }
  set result
}

# --- Elementare Geometrie ---

proc rotate {x y phi cX cY} {
  # coords x, y rotated by phi around cX, cY
  set c [cos $phi]
  set s [sin $phi]
  list\
    [expr {($x - $cX) * $c - ($y - $cY) * $s + $cX}]\
    [expr {($y - $cY) * $c + ($x - $cX) * $s + $cY}]
}

proc fexpr str {
  set sciPat {[0-9](?:\.[0-9]*)?[eE][+-]?[0-9]+}
  set ranges [regexp -inline -indices -all $sciPat $str]
  set sciWords [lmap range $ranges {
      double [string range $str {*}$range]
    }]
  set betweenRanges [concat {*}[lmap range $ranges {
        lassign $range from to
        list [- $from 1] [+ $to 1]
      }]]
  set numPat {\.[0-9]+|[0-9]+(?:\.[0-9]*)?}
  set restWords [lmap {from to} "0 $betweenRanges end" {
      regsub -all $numPat [string range $str $from $to] double(&)
    }]
  foreach restWord $restWords sciWord $sciWords {
    append result $restWord $sciWord
  }
  expr $result
}

-- blink {
  Make widgets or canvas items or text non-painfully blink.
  Examples:

  blink .label
  blink .canvas -tag ball
  blink .text -color0 blue   -color1 yellow
  blind .text -color0 yellow -color1 blue   -att backgroundbli
  blink info
  blink .canvas stop
  blink stop

  With Text widget, default attribute is -foreground
  with Canvas widget, default attribute is -fill
  With Text and Canvas widgets, default tag is "blink".

  default interval is 20.
}

# Blinken
proc blink {widget args} {
  lassign [info level 0] blink
  if {$widget eq "info"} then {
    #
    # info
    #
    set result {}
    foreach event [after info] {
      set info [after info $event]
      if {[lindex $info end] eq "timer" &&
          [lindex $info 0 0] eq $blink} then {
        lassign $info cmd
        lassign $cmd blink widget
        if {[winfo exists $widget]} then {
          set line [list $blink $widget]
          set opts [lrange $cmd 2 end]
          if {[winfo class $widget] in {Text Canvas}} then {
            lappend line -tag [dict get $opts -tag]
          } 
          lappend line -att [dict get $opts -att]
          lappend result $line
        }
      }
    }
    lsort $result
  } elseif {$widget in "stop off"} then {
    #
    # stop all after-events
    #
    foreach event [after info] {
      set info [after info $event]
      if {[lindex $info end] eq "timer" &&
          [lindex $info 0 0] eq $blink} then {
        after cancel $event
      }
    }
  } elseif {[winfo exists $widget]} then {
    if {$args eq "stop"} then {
      $blink $widget -action stop
    } else {
      set class [winfo class $widget]
      #
      # prepare
      #
      set item {
        -step 0
        -red0 0
        -green0 0
        -blue0 0
        -tag blink
        -red1 65535
        -green1 65535
        -blue1 65535
        -interval 25
        -action continue
      }
      #
      # set default target attributes
      #
      switch -exact -- $class {
        Text {
          dict set item -att -foreground
        }
        Canvas {
          dict set item -att -fill
        }
        default {
          dict set item -att -fg
        }
      }
      #
      # customize by command line
      #
      dict for {key val} $args {
        dict set item $key $val
      }
      #
      # translate named colors if given
      #
      if {[dict exists $item -color0]} then {
        lassign [winfo rgb . [dict get $item -color0]] r g b
        dict set item -red0 $r
        dict set item -green0 $g
        dict set item -blue0 $b
        dict unset item -color0
      }
      if {[dict exists $item -color1]} then {
        lassign [winfo rgb . [dict get $item -color1]] r g b
        dict set item -red1 $r
        dict set item -green1 $g
        dict set item -blue1 $b
        dict unset item -color1
      }
      #
      if {[dict get $item -action] eq "continue"} then {
        #
        # calculate increasement of color
        #
        dict incr item -step
        if {[dict get $item -step] >= 100} then {
          dict set item -step 0
        }
        set pi [expr {
          atan2(0,-1)
        }]
        set factor [expr {
          (cos($pi * 2 * [dict get $item -step] / 100) + 1) / 2
        }]
        #
        # generate hexadecimal color string
        #
        set rrrrggggbbbb #
        #
        set red0 [dict get $item -red0]
        set red1 [dict get $item -red1]
        set red [expr {$red0+int(($red1-$red0)*$factor)}]
        append rrrrggggbbbb [format %04x $red]
        #
        set green0 [dict get $item -green0]
        set green1 [dict get $item -green1]
        set green [expr {$green0+int(($green1-$green0)*$factor)}]
        append rrrrggggbbbb [format %04x $green]
        #
        set blue0 [dict get $item -blue0]
        set blue1 [dict get $item -blue1]
        set blue [expr {$blue0+int(($blue1-$blue0)*$factor)}]
        append rrrrggggbbbb [format %04x $blue]
        #
        set tag [dict get $item -tag]
        set att [dict get $item -att]
        switch -exact -- $class {
          Canvas {
            $widget itemconfigure $tag $att $rrrrggggbbbb
          }
          Text {
            $widget tag configure $tag $att $rrrrggggbbbb
          }
          default {
            $widget configure $att $rrrrggggbbbb
          }
        }
        #
        # repeat
        #
        set interval [dict get $item -interval]
        after $interval [list blink $widget {*}$item]
        #
      } else {
        #
        # stop blinking of $widget
        #
        foreach event [after info] {
          set info [after info $event]
          set line [lindex $info 0]
          lassign $line proc arg 
          if {$proc eq $blink && $arg eq $widget} then {
            after cancel $event
          }
        }
      }
    }
  }
}

# Farbhelligkeit 
proc rgb color {
  if {![string match #* $color]} then {
    winfo rgb . $color
  } else {
    set color [string range $color 1 end]
    switch -exact -- [string length $color] {
      3 {
        set r [string repeat [string index $color 0] 4]
        set g [string repeat [string index $color 1] 4]
        set b [string repeat [string index $color 2] 4]
      }
      6 {
        set r [string repeat [string range $color 0 1] 2]
        set g [string repeat [string range $color 2 3] 2]
        set b [string repeat [string range $color 4 5] 2]
      }
      12 {
        set r [string range $color 0 3]
        set g [string range $color 4 7]
        set b [string range $color 8 11]
      }
    }
    list [scan $r %x] [scan $g %x] [scan $b %x]
  }
}

proc brighten {color factor} {
  lassign [rgb $color] r g b
  #
  if {$factor < 1} then {
    # darker
    set r3 [round [* $r $factor]]
    set g3 [round [* $g $factor]]
    set b3 [round [* $b $factor]]
  } else {
    # brighter
    set f1 [- 2 $factor]
    #
    set r1 [- 65535 $r]
    set g1 [- 65535 $g]
    set b1 [- 65535 $b]
    #
    set r2 [round [* $r1 $f1]]
    set g2 [round [* $g1 $f1]]
    set b2 [round [* $b1 $f1]]
    #
    set r3 [- 65535 $r2]
    set g3 [- 65535 $g2]
    set b3 [- 65535 $b2]
  }
  string cat # [format %04x $r3] [format %04x $g3] [format %04x $b3]
}

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

# Klasse dot  
obj class dot -common {
  canvas .c
  instances {}
} -configure {
  -x 0.0
  -y 0.0
}

obj constructor dot args {
  $self storeXY
  # Liste der verwendenden Objekte line
  my lines {}
  foreach {x y} [concat {*}$args] {
    $self configure -x $x -y $y
  }
  $self storeXY
  our instances [concat [our instances] $self]
}

obj destructor dot {
  $self show no
  set index [lsearch [our instances] $self]
  our instances [lreplace [our instances] $index $index]
}

obj inscope dot variable zoom 1.0

obj configuremethod dot -x num {
  if {$num ne double($num)} then {
    $self configure -x [double $num]
  }
}

obj configuremethod dot -y num {
  if {$num ne double($num)} then {
    $self configure -y [double $num]
  }
}

obj method dot canvas args {
  [our canvas] {*}$args
}

obj method dot storeXY {{x ""} {y ""}} {
  if {[regexp {^[[:alpha:]]+$} $x]} then {
    list [my baseX] [my baseY]
  } else {
    if {[string is double -strict $x]} then {
      my baseX $x
    } else {
      my baseX [$self cget -x]
    }
    if {[string is double -strict $y]} then {
      my baseY $y
    } else {
      my baseY [$self cget -y]
    }
  }
}

obj method dot xy {{raw display}} {
  if {[string is true -strict $raw]} then {
    # $dot xy yes
    list [$self cget -x] [$self cget -y]
  } else {
    variable zoom
    set x [* $zoom [$self cget -x]]
    set y [* $zoom [$self cget -y]]
    if {$raw ni {display pointer}} then {
      # $dot xy no
      list $x $y
    } else {
      # $dot xy display
      set dx [- [int $x] [$self canvas canvasx [int $x]]]
      set dy [- [int $y] [$self canvas canvasy [int $y]]]
      list [+ $x $dx] [+ $y $dy]
    }
  }
}

#
# Affine Transformationen
# Zur Verkettung
# Argumente #0, #1 immer die aktuellen Koordinaten
#
obj inscope dot proc rotate {x y phi cX cY} {
  # coords x, y rotated by phi around cX, cY
  set c [cos $phi]
  set s [sin $phi]
  list\
    [expr {($x - $cX) * $c - ($y - $cY) * $s + $cX}]\
    [expr {($y - $cY) * $c + ($x - $cX) * $s + $cY}]
}
obj inscope dot proc shearHorizontal {x y BotY TopY dx} {
  list [expr {$x + $dx * ($y - $BotY) / ($TopY - $BotY)}] $y
}
obj inscope dot proc scaleVertical {x y c f} {
  list $x [expr {$c + ($y - $c) * $f}]
}
obj inscope dot proc shearVertical {x y LeftX RightX dy} {
  list $x [expr {$y + $dy * ($x - $LeftX) / ($RightX - $LeftX)}]
}
obj inscope dot proc scaleHorizontal {x y c f} {
  list [expr {$c + ($x - $c) * $f}] $y
}
obj inscope dot proc moveVertical {x y dy} {
  list $x [+ $y $dy]
}
obj inscope dot proc moveHorizontal {x y dx} {
  list [+ $x $dx] $y
}

# Beliebige Abfolge Affiner Transformationen
obj method dot transform args {
  set x [my baseX]
  set y [my baseY]
  foreach {func argl} $args {
    lassign [$func $x $y {*}$argl] x y
  }
  $self configure -x $x -y $y
}

# hinzufügen eines Verwender
obj method dot add args {
  set lines [my lines]
  foreach line $args {
    if {$line ni $lines} then {
      lappend lines $line
    }
  }
  my lines $lines
}

# entfernen eines Verwenders
obj method dot remove args {
  if {$args eq "all"} then {
    set args [my lines]
  }
  foreach line $args {
    set lines [my lines]
    set index [lsearch $lines $line]
    my lines [lreplace $lines $index $index]
  }
}

obj method dot lines args {
  lmap line [my lines] {
    $line  {*}$args
  }
}

obj method dot restoreCode {} {
  list $self configure -x [$self cget -x] -y [$self cget -y]
}

# Punkt anzeigen oder verbergen
obj method dot show {{yesNo yes} args} {
  lassign [$self xy false] x y
  if {[string is true -strict $yesNo]} then {
    $self canvas delete dot$self
    $self canvas create oval [- $x 5] [- $y 5] [+ $x 5] [+ $y 5]\
      -width 2 -fill yellow -stipple gray25 -outline navy -tags "dot dot$self"
  } elseif {[string is false -strict $yesNo]} then {
    $self canvas delete dot$self
  } else {
    $self canvas create oval\
      [- $x 5] [- $y 5] [+ $x 5] [+ $y 5]\
      -width 2 -fill white -outline blue -tags dot {*}$args
  }
}

# Daten des Punktes für XML unparse
obj method dot data {} {
  dict create type element\
    name dot\
    attribute [dict create\
    id dot-[lsearch [our instances] $self]\
    x [$self cget -x]\
    y [$self cget -y]]\
    content {}
}

# -----

# Klasse für Linien
obj class line -common {
  canvas .c
  instances {}
} -configure {
  -width 2.0
  -outline black
  -fill ""
  -smooth no
  -constraint ""
}

obj constructor line args {
  set dots {}
  if {[string is double -strict [lindex $args 0]]} then {
    foreach {x y} $args {
      if {[string is double -strict $x]} then {
        set dot [new dot -x $x -y $y]
        lappend dots $dot
        $dot add $self
      } else {
        # Objekte zu Ende, ab hier Optionen
        $self configure $x $y
      }
    } 
  } else {
    while {[llength $args] > 0} {
      if {[string match -* $args]} break
      set args [lassign $args dot]
      lappend dots $dot
      $dot add $self
    }
    $self configure {*}$args
  }
  our instances [list {*}[our instances] $self]
  my centerDot [new dot]
  my group {}
  my dots $dots
  # $self calcCenter
}

obj destructor line {
  $self draw no
  foreach dot [$self dots] {
    $dot remove $self
  }
  set index [lsearch [our instances] $self]
  our instances [lreplace [our instances] $index $index]
}

obj method line lines args {
  $self {*}$args
}

obj method line wider factor {
  if {![$self constraint linewidth]} then {
    $self configure -width [* $factor [$self cget -width]]
  }
}

obj method line brighten {what factor} {
  if {
    ![$self constraint linecolor] &&
    $what eq "outline" &&
    [$self cget -outline] ni {{} transparent}
  } then {
    set color [::brighten [$self cget -outline] $factor]
    $self configure -outline $color
  }
}

obj method line split args {
  $self
}

obj method line xy {{raw no} {bezier ""}} {
  if {$bezier eq "" || [$self cget -smooth]} then {
    concat {*}[$self dots xy $raw]
  } else {
    lassign [$self firstDot xy $raw] x0 y0
    lassign [$self lastDot xy $raw] x3 y3
    list $x0 $y0\
      [expr {$x0 + ($x3 - $x0) / 3.0}]\
      [expr {$y0 + ($y3 - $y0) / 3.0}]\
      [expr {$x0 + ($x3 - $x0) / 3.0 * 2.0}]\
      [expr {$y0 + ($y3 - $y0) / 3.0 * 2.0}]\
      $x3 $y3
  }
}

obj method line bbox {{raw no}} {
  set coords [$self xy $raw]
  if {[$self cget -smooth]} then {
    bezier bbox $coords
  } else {
    lassign $coords x0 y0 x1 y1
    list [min $x0 $x1] [min $y0 $y1] [max $x0 $x1] [max $y0 $y1]
  }
}

obj method line canvas args {
  [our canvas] {*}$args
}

obj method line raiseOnCanvas args {
  $self canvas raise line$self {*}$args
}

obj method line lowerOnCanvas args {
  $self canvas lower line$self {*}$args
}

# split line into two, return second half
obj method line intersect {{factor 0.5}} {
  if {[$self cget -smooth]} then {
    lassign [my dots] a b c d
    set firstHalf [bezier segment [$self xy true] 0 $factor]
    set secondHalf [bezier segment [$self xy true] $factor 1]
    lassign $firstHalf - - x y
    $b configure -x $x -y $y
    lassign $firstHalf - - - - x y
    $c configure -x $x -y $y
    lassign $firstHalf - - - - - - x y
    set middle [new dot -x $x -y $y]
    $self remove $d
    $self add $middle
    #
    set newLine [new line $middle]
    lassign $secondHalf - - x y
    $newLine add [new dot -x $x -y $y]
    lassign $secondHalf - - - - x y
    $newLine add [new dot -x $x -y $y] $d
  } else {
    set firstDot [$self firstDot]
    set lastDot [$self lastDot]
    lassign [$self xy true] x0 y0 x1 y1
    set xMid [expr {$x0 + ($x1 - $x0) * $factor}]
    set yMid [expr {$y0 + ($y1 - $y0) * $factor}]
    set midDot [new dot -x $xMid -y $yMid]
    $self remove all
    $self add $firstDot $midDot
    set newLine [new line $midDot $lastDot]
  }
  $newLine configure\
    -width [$self cget -width]\
    -outline [$self cget -outline]\
    -fill [$self cget -fill]\
    -smooth [$self cget -smooth]\
    -constraint [$self cget -constraint]
  set newLine
}

# create tangens to other line

obj method line tangensTo other {
  if {
    [$self cget -smooth] &&
    [$other isa line] &&
    [$other cget -smooth]
  } then {
    lassign [bezier tangens2 [$self xy] [$other xy]] myFrac otherFrac
    set line1 [$self intersect $myFrac]
    set line2 [$other intersect $otherFrac]
    set line3 [new line\
        [$self lastDot cget -x] [$self lastDot cget -y]\
        [$other lastDot cget -x] [$other lastDot cget -y]]
    list $line1 $line2 $line3
  }
}

obj method line cut other {
  if {![$self cget -smooth] && ![$other cget -smooth]} then {
    bezier lineCutLine [$self xy] [$other xy]
  } else {
    bezier cut [$self xy bezier] [$other xy bezier]
  }
}

obj method line add args {
  foreach dot $args {
    $dot add $self
    my dots [list {*}[my dots] $dot]
  }
}

obj method line remove args {
  if {$args eq "all"} then {
    set args [my dots]
  }
  lappend result
  foreach dot $args {
    lappend result $dot
    $dot remove $self
    set index [lsearch [my dots] $dot]
    my dots [lreplace [my dots] $index $index]
  }
  set result
}

obj method line restoreCode {} {
  lappend cmdLines "$self remove all"
  foreach dot [my dots] {
    lappend cmdLines "$self add $dot" [$dot restoreCode]
  }
  lappend cmdLines\
    [list $self configure\
      -width [$self cget -width]\
      -outline [$self cget -outline]\
      -smooth [$self cget -smooth]\
      -constraint [$self cget -constraint]]
  join $cmdLines \n
}

obj method line state args {
  if {[llength $args] == 0} then {
    $self canvas itemcget line$self -state
  } else {
    lassign $args state
    if {$state eq "disabled"} then {
      $self canvas itemconfigure line$self -stipple gray25 -state $state
    } else {
      $self canvas itemconfigure line$self -stipple {} -state $state
    }
  }
}

obj method line calcCenter {} {
  if {[llength [my dots]] > 0} then {
    lassign [$self bbox true] left bottom right top
    set center [expr {($left+$right)/2.0}]
    set middle [expr {($top+$bottom)/2.0}]
    [my centerDot] configure -x $center -y $middle
    [my centerDot] storeXY
    list $center $middle
  }
}

# Gruppenzugehörigkeit
obj method line group args {
  if {[llength $args] > 0} then {
    lassign $args g
    my group $g
  } else {
    my group
  }
}
obj method line topgroup {} {
  if {[my group] eq ""} then $self else {
    [my group] topgroup
  }
}

# Blinkmodus
obj method line blink {{onoff on}} {
  set tag line$self
  if {$onoff} then {
    $self canvas addtag blink withtag $tag
    $self canvas itemconfigure $tag -width [max 3 [$self cget -width]]
  } else {
    $self canvas dtag $tag blink
    $self updateAtts
  }
} 

# Aufbereitung für XML
obj method line data {} {
  dict create type element\
    name line\
    attribute [dict create\
    id line-[lsearch [our instances] $self]\
    width [$self cget -width]\
    outline [$self cget -outline]\
    smooth [$self cget -smooth]\
    constraint [$self cget -constraint]]\
    content [lmap dot [my dots] {$dot data}]
}

# Liste der Punkte
obj method line dots args {
  set options {}
  while {[string index $args 0] eq "-"} {
    set args [lassign $args option]
    lappend options $option
  }
  set dots [my dots]
  if {"-end" in $options} then {
    set dots [lreplace $dots 1 end-1]
  }
  if {"-gravity" in $options} then {
    if {[$self constraint gravity]} then {
      lmap dot $dots {$dot {*}$args}
    }
  } else {
    lmap dot $dots {$dot {*}$args}
  }
}

obj method line bezierFillDots {} {
  # for later use in fill objects
  if {[$self cget -smooth]} then {
    my dots
  } else {
    list [$self firstDot] {*}[my dots] [$self lastDot]
  }
}

# Abfrage ob auf Canvas abgebildet
obj method line drawn? {} {
  set tag line$self
  llength [$self canvas find withtag $tag]
}

# Auf Canvas abbilden

obj method line draw {{option yes} {withAtts yes}} {
  set tag line$self
  set coords [$self xy]
  if {[string is false -strict $option]} then {
    $self canvas delete $tag
  } elseif {$option eq "coords"} then {
    $self canvas coords $tag $coords
    set group [my group]
    if {$group ne "" && [$group isa fill]} then {
      $group draw fillcoords
    }
  } elseif {[$self drawn?]} then {
    $self canvas coords $tag $coords
  } else {
    $self canvas create line $coords\
      -tags "$tag line"
  }
  $self updateAtts
  $self canvas find withtag $tag
}

# Aktualisiere auf Canvas
obj method line updateAtts {} {
  set tag line$self
  $self canvas itemconfigure $tag\
    -capstyle round\
    -joinstyle miter\
    -disabledstipple gray25
  $self configure\
    -width [$self cget -width]\
    -outline [$self cget -outline]\
    -smooth [$self cget -smooth]
}

# constraints
obj method line constraint {{what {}} {how info}} {
  set constr [$self cget -constraint]
  if {$what eq ""} then {
    set constr
  } elseif {$how eq "info"} then {
    expr {$what in [$self cget -constraint] ? yes : no}
  } elseif {$how eq "toggle"} then {
    if {[$self constraint $what]} then {
      $self constraint $what no
    } else {
      $self constraint $what yes
    }
  } elseif {$how} then {
    if {$what ni $constr} then {
      lappend constr $what
      $self configure -constraint $constr
    }
  } else {
    set index [lsearch $constr $what]
    $self configure -constraint [lreplace $constr $index $index]
  }
}

# hide if state == "hidden", or anyhow
obj method line hide {{bool yes} {noPrint no}} {
  set tag line$self
  if {$bool} then {
    if {$noPrint} then {
      $self canvas itemconfigure $tag -state hidden
    } else {
      if {[$self constraint noprint]} then {
        $self canvas itemconfigure $tag -state hidden
      } else {
        $self canvas itemconfigure $tag -state normal
      }
    } 
  } else {
    $self canvas itemconfigure $tag -state normal
  }
}

# Anfangspunkt
obj method line firstDot args {
  [lindex [my dots] 0] {*}$args
}

# Endpunkt
obj method line lastDot args {
  [lindex [my dots] end] {*}$args
}

# verkettete Vorgängerlinie
obj method line prevLine args {
  foreach line [$self firstDot lines] {
    if {$line eq $self} continue
    if {[$line group] ne [my group]} continue
    return [$line {*}$args]
  }
}

# verkettete Folgelinie
obj method line nextLine args {
  foreach line [$self lastDot lines] {
    if {$line eq $self} continue
    if {[$line group] ne [my group]} continue
    return [$line {*}$args]
  }
}

obj method line chainedList {} {
  set line $self
  while true {
    set prev [$line prevLine]
    if {$prev eq ""} break
    if {$prev eq $self} break
    if {[incr i] > 999} then {
      return -code error "$i steps. Something went wrong!"
    }
    set line $prev
  }
  set end $line
  while true {
    lappend lineSet $line
    set next [$line nextLine]
    if {$next eq ""} break
    if {$next eq $end} break
    set line $next
  }
  set lineSet
}

# Verknüpfe mit anderer Linie
obj method line joinEnd {other {end last}} {
  set dots [my dots]
  if {$end eq "last"} then {
    [$self lastDot] remove $self
    lset dots end [$other firstDot]
    my dots $dots
    [$self lastDot] add $self
  } else {
    [$self firstDot] remove $self
    lset dots 0 [$other lastDot]
    my dots $dots
    [$self firstDot] add $self
  }
}

obj method line unjoin other {
  set dot [$self firstDot]
  set others [$dot lines]
  if {$other in $others} then {
    $dot remove $self
    my dots [lreplace [my dots] 0 0\
        [new dot -x [$dot cget -x] -y [$dot cget -y]]]
    $self firstDot add $self
  }
  set dot [$self lastDot]
  set others [$dot lines]
  if {$other in $others} then {
    $dot remove $self
    my dots [lreplace [my dots] end end\
        [new dot -x [$dot cget -x] -y [$dot cget -y]]]
    $self lastDot add $self
  }
}

obj configuremethod line -width w {
  if {[string is integer $w]} then {
    $self configure -width [double $w]
  } else {
    set tag line$self
    $self canvas itemconfigure $tag -width $w
  }
}
obj configuremethod line -outline c {
  set tag line$self
  if {$c eq "transparent"} then {
    set c ""
  }
  $self canvas itemconfigure $tag -fill $c
}

obj configuremethod line -fill dummy {
  if {$dummy ne ""} then {
    $self configure -fill ""
  }
}

obj method line changeLineColor color {
  if {$color ne "" && ![$self constraint linecolor]} then {
    $self configure -outline $color
  }
}

obj method line changeFillColor color #

obj method line changeLineWidth width {
  if {![$self constraint linewidth]} then {
    $self configure -width $width
  }
}

obj configuremethod line -smooth yesNo {
  set tag line$self
  if {$yesNo} then {
    # curvy
    if {[llength [my dots]] == 2} then {
      set x0 [$self firstDot cget -x]
      set y0 [$self firstDot cget -y]
      set x1 [$self lastDot cget -x]
      set y1 [$self lastDot cget -y]
      set xA [expr {$x0 + ($x1 - $x0) / 3}]
      set yA [expr {$y0 + ($y1 - $y0) / 3}]
      set xB [expr {$x0 + ($x1 - $x0) / 3 * 2}]
      set yB [expr {$y0 + ($y1 - $y0) / 3 * 2}]
      set first [$self firstDot]
      set last [$self lastDot]
      $self remove all
      $self add\
        $first [new dot -x $xA -y $yA] [new dot -x $xB -y $yB] $last
    }
    $self canvas itemconfigure $tag -smooth raw
  } else {
    # straight
    $self canvas itemconfigure $tag -smooth no
    my dots [lreplace [my dots] 1 end-1]
  }
  $self canvas coords $tag {*}[$self xy]
}

# -----

# Klasse für Flächen
obj class fill -common {
  canvas .c
  instances {}
} -configure {
  -fill white
  -outline ""
  -width ""
  -constraint ""
}

obj constructor fill args {
  my centerDot [new dot]
  my group {}
  set lines $args
  my lines $lines
  $self lines group $self
  our instances [list {*}[our instances] $self]
  $self calcCenter
}

obj destructor fill {
  $self draw no
  set index [lsearch [our instances] $self]
  our instances [lreplace [our instances] $index $index]
  foreach line [my lines] {
    $line group [my group]
  }
}

obj method fill canvas args {
  [our canvas] {*}$args
}

obj method fill wider factor {
  if {![$self constraint linewidth]} then {
    $self lines wider $factor
  }
}

obj method fill brighten {what factor} {
  switch -exact -- $what {
    outline {
      if {![$self constraint linecolor]} then {
        $self lines brighten $what $factor
      }
    }
    fill {
      if {
        ![$self constraint fillcolor] &&
        [$self cget -fill] ni {{} transparent}
      } then {
        set color [::brighten [$self cget -fill] $factor]
        $self configure -fill $color
      }
    }
  }
}

# --- Line-Objekte zu Gruppen einsammeln ---

obj inscope fill proc linesToSets lines {
  if {$lines ne {}} then {
    set lineSet [[lindex $lines 0] chainedList]
    lappend rest
    foreach line $lines {
      if {$line ni $lineSet} then {
        lappend rest $line
      }
    }
    list $lineSet {*}[linesToSets $rest]
  }
}

obj inscope fill proc lineSetToDotSet lineSet {
  set firstDot [[lindex $lineSet 0] firstDot]
  set lastDot [[lindex $lineSet end] lastDot]
  foreach line $lineSet {
    lappend dots {*}[lrange [$line bezierFillDots] 0 end-1]
  }
  if {$firstDot ne $lastDot} then {
    lappend dots $lastDot $lastDot $firstDot
  }
  set dots
}

obj inscope fill proc linesToBezierCoords lines {
  set lineSets [linesToSets $lines]
  set dotSets [lmap lineSet $lineSets {lineSetToDotSet $lineSet}]
  lassign $dotSets dots
  foreach dotSet [lrange $dotSets 1 end] {
    lappend dots\
      [lindex $dots 0] [lindex $dots 0] [lindex $dotSet 0]\
      {*}$dotSet\
      [lindex $dotSet 0] [lindex $dotSet 0] [lindex $dots 0]
  }
  concat {*}[lmap dot $dots {$dot xy false}]
}

# --- --- ---

# Zeichnen
obj method fill draw {{option yes}} {
  set tag fill$self
  set coords [linesToBezierCoords [my lines]]
  if {$option eq "coords"} then {
    $self canvas coords $tag $coords
    $self lines draw coords
  } elseif {$option eq "fillcoords"} then {
    $self canvas coords $tag $coords
  } elseif {$option} then {
    # option == yes
    if {[$self canvas find withtag $tag] eq ""} then {
      $self canvas create poly $coords -smooth raw -tags "$tag fill"
      $self updateAtts
    } else {
      $self canvas coords $tag $coords
    }
    $self lines draw
  } else {
    # option == no
    $self canvas delete $tag
    $self lines draw no
  }
}

# Attribute auf Canvas
obj method fill updateAtts {} {
  set tag fill$self
  $self configure -fill [$self cget -fill]
  $self canvas itemconfigure $tag\
    -disabledstipple gray25\
    -outline ""\
    -joinstyle miter\
    -width 0.0
}

obj method fill canvasZ {{Z {}}} {
  set tag fill$self
  set item [$self canvas find withtag $tag]
  set myZindex [lsearch [$self canvas find all] $item]
  if {[string is integer -strict $Z]} then {
    $self canvas dtag edit$self
    foreach line [$self lines] {
      $self canvas addtag edit$self withtag line$line
    }
    if {$myZindex != $Z} then {
      if {$Z == 0} then {
        $self canvas lower $tag
      } else {
        if {$myZindex < $Z} then {
          set targetZ [+ $Z 2 [llength [my lines]]]
        } else {
          set targetZ $Z
        }
        set itemBelow [lindex [$self canvas find all] $targetZ-1]
        $self canvas raise $tag {*}$itemBelow
      }
    }
    $self canvas raise edit$self $tag
    $self canvas dtag edit$self
  } else {
    if {$Z ne ""} then {
      lindex [$self canvas find all] $myZindex-1
    } else {
      set myZindex
    }
  }
}

obj method fill empty {} {
  set lines [my lines]
  $self lines group [my group]
  my lines {}
  $self draw no
  set lines
}

obj method fill add args {
  set lines [my lines]
  foreach obj $args {
    if {[$obj isa line]} then {
      if {$obj ni $lines} then {
        lappend lines $obj
        $obj group $self
      }
    } elseif {[$obj isa fill]} then {
      $self add {*}[$obj empty]
    } elseif {[$obj isa group]} then {
      $self add {*}[$group release all]
    }
  }
  my lines $lines
}

obj method fill restoreCode {} {
  lappend cmdLines\
    "$self empty"\
    "$self private lines {[my lines]}"\
    {*}[lmap line [my lines] {
      $line restoreCode
    }]\
    "$self lines group $self"\
    [list $self configure\
      -fill [$self cget -fill]\
      -constraint [$self cget -constraint]]
  join $cmdLines \n
}

obj method fill state args {
  if {[llength $args] == 0} then {
    $self canvas itemcget fill$self -state
  } else {
    lassign $args state
    $self lines state $state
    # $self canvas itemconfigure fill$self -state $state
    if {$state eq "disabled"} then {
      $self canvas itemconfigure fill$self -stipple gray25 -state $state
    } else {
      $self canvas itemconfigure fill$self -stipple {} -state $state
    }
  }
}

obj method fill calcCenter {} {
  if {[llength [my lines]] > 0} then {
    lassign [$self bbox yes] left bottom right top
    set center [expr {($left+$right)/2.0}]
    set middle [expr {($top+$bottom)/2.0}]
    [my centerDot] configure -x $center -y $middle
    [my centerDot] storeXY
    list $center $middle
  }
}

obj method fill bbox {{raw no}} {
  if {[llength [my lines]] > 0} then {
    foreach line [my lines] {
      foreach {x0 y0 x1 y1} [$line bbox $raw] {
        lappend xCoords $x0 $x1
        lappend yCoords $y0 $y1
      }
    }
    list\
      [min {*}$xCoords] [min {*}$yCoords]\
      [max {*}$xCoords] [max {*}$yCoords]
  }
}

# XML-Vorstufe
obj method fill data {} {
  dict create type element\
    name fill\
    attribute [dict create\
    id fill-[lsearch [our instances] $self]\
    fill [$self cget -fill]\
    constraint [$self cget -constraint]]\
    content [lmap line [my lines] {
    $line data
  }]
}

# Gruppenzugehörigkeit
obj method fill group args {
  if {[llength $args] > 0} then {
    lassign $args g
    my group $g
  } else {
    my group
  }
}

obj method fill topgroup {} {
  if {[my group] eq ""} then $self else {
    [my group] topgroup
  }
}

# Blink-Modus
obj method fill blink {{onoff on}} {
  $self lines blink $onoff
}

# Alle verwendeten Punkte
obj method fill dots args {
  lappend result
  lappend options
  while {[string index $args 0] eq "-"} {
    set args [lassign $args option]
    if {$option eq "-gravity"} then {
      if {![$self constraint gravity]} then {
        lappend options $option
      }
    } else {
      lappend options $option
    }
  }
  set result [concat {*}[$self lines dots {*}$options]]
  lmap obj [lunique $result] {$obj {*}$args}
}

obj method fill constraint {{what {}} {how info}} {
  set constr [$self cget -constraint]
  if {$what eq ""} then {
    set constr
  } elseif {$how eq "info"} then {
    expr {$what in [$self cget -constraint] ? yes : no}
  } elseif {$how eq "toggle"} then {
    if {[$self constraint $what]} then {
      $self constraint $what no
    } else {
      $self constraint $what yes
    }
  } elseif {$how} then {
    if {$what ni $constr} then {
      lappend constr $what
      $self configure -constraint $constr
    }
  } else {
    set index [lsearch $constr $what]
    $self configure -constraint [lreplace $constr $index $index]
  }
}

obj method fill lines args {
  lmap obj [my lines] {$obj {*}$args}
}

obj method fill split {{dummy {}}} {
  $self canvas delete fill$self
  set lines [my lines]
  $self empty
  set lines
}

obj method fill hide {{yesNo yes} {noPrint no}} {
  set tag fill$self
  if {$yesNo} then {
    if {$noPrint} then {
      $self canvas itemconfigure $tag -state hidden
      $self lines hide yes yes
    } else {
      if {[$self constraint noprint]} then {
        $self canvas itemconfigure $tag -state hidden
        $self lines hide yes yes
      } else {
        $self canvas itemconfigure $tag -state normal
        $self lines hide no
      }
    } 
  } else {
    $self canvas itemconfigure $tag -state normal
    $self lines hide no
  }
}

obj configuremethod fill -outline color {
  if {$color ne ""} then {
    $self lines configure -outline $color
    if {$color eq "transparent"} then {
      set color ""
    }
    $self configure -outline ""
  }
}

obj configuremethod fill -fill color {
  set tag fill$self
  if {$color eq "transparent"} then {
    set color ""
  }
  $self canvas itemconfigure $tag -fill $color
}

obj configuremethod fill -width w {
  if {$w ne ""} then {
    $self lines configure -width $w
    $self configure -width ""
  }
}

obj method fill changeLineColor color {
  if {$color ne "" && ![$self constraint linecolor]} then {
    $self lines changeLineColor $color
  }
}

obj method fill changeFillColor color {
  if {$color ne "" && ![$self constraint fillcolor]} then {
    $self configure -fill $color
  }
}

obj method fill changeLineWidth width {
  if {![$self constraint linewidth]} then {
    $self lines changeLineWidth $width
  }
}

# -----

# Gruppe von Objekten
obj class group -common {
  instances {}
  canvas .c
} -configure {
  -width ""
  -fill ""
  -outline ""
  -constraint ""
}

obj constructor group args {
  my centerDot [new dot]
  my group ""
  my elements {}
  foreach element $args {
    $self add $element
  }
  our instances [list {*}[our instances] $self]
  $self calcCenter
}

obj destructor group {
  foreach element [my elements] {
    $self release $element
  }
  set index [lsearch [our instances] $self]
  our instances [lreplace [our instances] $index $index]
}

obj method group canvas args {
  [our canvas] {*}$args
}

obj method group state args {
  $self elements state {*}$args
}

obj method group lines args {
  lappend result
  foreach obj [my elements] {
    lappend result {*}[$obj lines]
  }
  lmap obj [lunique $result] {$obj {*}$args}
}

obj method group wider factor {
  if {![$self constraint linewidth]} then {
    $self elements wider $factor
  }
}

obj method group brighten {what factor} {
  switch -exact -- $what {
    outline {
      if {![$self constraint linecolor]} then {
        $self elements brighten $what $factor
      }
    }
    fill {
      if {![$self constraint fillcolor]} then {
        $self elements brighten $what $factor
      }
    }
  }
}

obj method group calcCenter {} {
  if {[llength [my elements]] > 0} then {
    lassign [$self bbox yes] left bottom right top
    set center [expr {($left+$right)/2}]
    set middle [expr {($top+$bottom)/2}]
    [my centerDot] configure -x $center -y $middle
    [my centerDot] storeXY
    $self elements calcCenter
    list $center $middle
  }
}

obj method group bbox {{raw no}} {
  set minX Inf
  set minY Inf
  set maxX -Inf
  set maxY -Inf
  foreach bb [$self elements bbox $raw] {
    foreach {x0 y0 x1 y1} $bb {
      set minX [min $minX $x0]
      set minY [min $minY $y0]
      set maxX [max $maxX $x1]
      set maxY [max $maxY $y1]
    }
  }
  list $minX $minY $maxX $maxY
}

# Reihenfolge auf der Zeichenfläche
obj method group canvasItemOrder {} {
  lappend result
  foreach item [$self canvas find all] {
    foreach tag [$self canvas gettags $item] {
      if {[regexp {(line|fill)(::.*)} $tag - class obj]} then {
        if {[$obj topgroup] eq $self} then {
          lappend result $tag
        }
      }
    }
  }
  set result
}

# XML
obj method group data {} {
  dict create\
    type element\
    name group\
    attribute [dict create\
    id group-[lsearch [our instances] $self]\
    constraint [$self cget -constraint]]\
    content [lmap x [my elements] {$x data}]
}

# Element rein, raus
obj method group add args {
  foreach element $args {
    if {$element eq $self} then {
      return -code error "cannot add $self to group $self"
    }
    if {$element ni [my elements]} then {
      my elements [list {*}[my elements] $element]
      $element group $self
    }
  }
}

obj method group release args {
  if {$args eq "all"} then {
    set args [my elements]
  }
  foreach element $args {
    set index [lsearch [my elements] $element]
    if {$index >= 0} then {
      my elements [lreplace [my elements] $index $index]
      $element group [$self group]
    }
  }
  set args
}

obj method group split {{recursive no}} {
  if {$recursive} then {
    set result {}
    foreach obj [$self release all] {
      lappend result {*}[$obj split yes]
    }
  } else {
    set result [my elements]
    $self release all
  }
  set result
}

obj method group restoreCode {} {
  lappend lines "$self release all"\
    [list $self configure -constraint [$self cget -constraint]]\
    {*}[$self elements restoreCode]\
    {*}[lmap element [$self elements] {
      list $self add $element
    }]
  join $lines \n
}

obj method group elements args {
  lmap obj [my elements] {$obj {*}$args}
}

obj method group topgroup {} {
  if {[my group] eq ""} then $self else {
    [my group] topgroup
  }
}

# Gruppe
obj method group group args {
  my group {*}$args
}

# Zeichne
obj method group draw args {
  $self elements draw {*}$args
}

# Punkte

obj method group dots args {
  lappend result
  lappend options
  while {[string index $args 0] eq "-"} {
    set args [lassign $args option]
    if {$option eq "-gravity"} then {
      if {![$self constraint gravity]} then {
        lappend options $option
      }
    } else {
      lappend options $option
    }
  }
  set result [concat {*}[$self elements dots {*}$options]]
  lmap obj [lunique $result] {$obj {*}$args}
}

# constraints
obj method group constraint {{what {}} {how info}} {
  set constr [$self cget -constraint]
  if {$what eq ""} then {
    set constr
  } elseif {$how eq "info"} then {
    expr {$what in [$self cget -constraint] ? yes : no}
  } elseif {$how eq "toggle"} then {
    if {[$self constraint $what]} then {
      $self constraint $what no
    } else {
      $self constraint $what yes
    }
  } elseif {$how} then {
    if {$what ni $constr} then {
      lappend constr $what
      $self configure -constraint $constr
    }
  } else {
    set index [lsearch $constr $what]
    $self configure -constraint [lreplace $constr $index $index]
  }
}

obj method group hide {{yesNo yes} {noPrint no}} {
  if {$yesNo && [$self constraint noprint]} then {
    $self elements hide yes yes
  } else {
    $self elements hide $yesNo $noPrint
  }
}


# blink
obj method group blink {{onoff on}} {
  $self elements blink $onoff
}

obj configuremethod group -width w {
  if {$w ne ""} then {
    $self elements configure -width $w
    $self configure -width ""
  }
}
obj configuremethod group -outline c {
  if {$c ne ""} then {
    $self elements configure -outline $c
    $self configure -outline ""
  }
}
obj configuremethod group -fill c {
  if {$c ne ""} then {
    $self elements configure -fill $c
    $self configure -fill ""
  }
}

obj method group changeFillColor color {
  if {$color ne "" && ![$self constraint fillcolor]} then {
    $self elements changeFillColor $color
  }
}
obj method group changeLineColor color {
  if {$color ne "" && ![$self constraint linecolor]} then {
    $self elements changeLineColor $color
  }
}
obj method group changeLineWidth width {
  if {![$self constraint linewidth]} then {
    $self elements changeLineWidth $width
  }
}

# GlassCube

namespace eval GlassCube {
  namespace import ::tcl::mathfunc::* ::tcl::mathop::*
  
  proc p3D {x y z} {
    dict create\
      x [+ 125.0 $x]\
      y [+ 125.0 $y]\
      z [+ 125.0 $z]
  }
  
  variable center [p3D 0 0 0]
  
  variable baseCube [list\
      [p3D -50 -50 -50]\
      [p3D  50 -50 -50]\
      [p3D  50  50 -50]\
      [p3D -50  50 -50]\
      [p3D -50 -50  50]\
      [p3D  50 -50  50]\
      [p3D  50  50  50]\
      [p3D -50  50  50]]
  
  proc dotOptions 3Dpoint {
    list -x [dict get $3Dpoint x]  -y [dict get $3Dpoint y]
  }
  
  variable dots [lmap pt $baseCube {obj new dot {*}[dotOptions $pt]}]
  
  proc line {a b} {
    variable dots
    obj new line [lindex $dots $a] [lindex $dots $b]
  }
  
  variable group [obj new group -constraint {
      gravity
      noprint
      linecolor
      linewidth
    } [line 4 5] [line 5 6] [line 6 7] [line 7 4]\
      [line 0 4] [line 1 5] [line 2 6] [line 3 7]\
      [line 0 1] [line 1 2] [line 2 3] [line 3 0]]

  variable phi 0
  variable chi 0 
}

proc GlassCube::rotate {x y phi cX cY} {
  # coords x, y rotated by phi around cX, cY
  set c [cos $phi]
  set s [sin $phi]
  list\
    [expr {($x - $cX) * $c - ($y - $cY) * $s + $cX}]\
    [expr {($y - $cY) * $c + ($x - $cX) * $s + $cY}]
}

proc GlassCube::rotateYaxis {3Dpoint phi} {
  variable center
  set cX [dict get $center x]
  set cY [dict get $center z]
  set x [dict get $3Dpoint x]
  set y [dict get $3Dpoint z]
  lassign [rotate $x $y $phi $cX $cY] x y
  dict set 3Dpoint x $x
  dict set 3Dpoint z $y
}

proc GlassCube::rotateXaxis {3Dpoint phi} {
  variable center
  set cX [dict get $center z]
  set cY [dict get $center y]
  set x [dict get $3Dpoint z]
  set y [dict get $3Dpoint y]
  lassign [rotate $x $y $phi $cX $cY] x y
  dict set 3Dpoint z $x
  dict set 3Dpoint y $y
}

proc GlassCube::rotateCube {cube phi chi} {
  set cube [lmap pt $cube {rotateYaxis $pt $phi}]
  set cube [lmap pt $cube {rotateXaxis $pt $chi}]
}

proc GlassCube::glassCube {} {
  variable phi
  variable chi
  variable group
  variable baseCube
  variable dots
  foreach dot $dots p3d [rotateCube $baseCube [degree $phi] [degree $chi]] {
    $dot configure {*}[dotOptions $p3d]
  }
  $group draw
}

proc GlassCube::pi args [subst -novariable {expr "[acos -1] $args"}]

proc GlassCube::degree num {
  # degree to arcus
  pi * $num / 180.0
}

proc GlassCube::slider {canvas {onoff on}} {
  destroy $canvas.horizontal $canvas.vertical
  if {$onoff} then {
    variable group
    foreach element [$group elements] {
      if {[incr i] < 5} then {
        $element configure -outline grey72
      } elseif {$i < 9} then {
        $element configure -outline grey60 
      } else {
        $element configure -outline grey30
      }
    }
    set horizontal [scale $canvas.horizontal -orient horizontal\
        -from -90 -to 90 -resolution -1 -showvalue no\
        -variable [namespace current]::phi\
        -command [list apply [list num {
            glassCube
          } [namespace current]]]]
    set vertical [scale $canvas.vertical -orient vertical\
        -from 90 -to -90 -resolution -1 -showvalue no\
        -variable [namespace current]::chi\
        -command [list apply [list num {
            glassCube
          } [namespace current]]]]
    place $horizontal -anchor sw -relwidth 1.0 -relx 0.0 -rely 1.0\
      -width -[winfo reqwidth $vertical]
    place $vertical -anchor ne -relheight 1.0 -relx 1.0 -rely 0.0\
      -height -[winfo reqheight $horizontal]
    bind $horizontal <<ControlClick>> "$horizontal set 0; break"
    bind $vertical <<ControlClick>> "$vertical set 0; break"
    set group
  }
}

# end of GlassCube

# Canvas als Vektorgrafik-Editor
obj class canvaseditor -common "
  instances {}
  garbage [obj new group]
  "

obj constructor canvaseditor {canvas {destroyAction {}}} {
  ::destroy $canvas.x $canvas.y
  $canvas configure\
    -xscrollcommand "[scrollbar $canvas.x\
      -orient horizontal\
      -command "$canvas xview"] set"\
    -yscrollcommand "[scrollbar $canvas.y\
      -orient vertical\
      -command "$canvas yview"] set"
  variable level
  incr level($canvas)
  if {$self ni [our instances]} then {
    our instances [list {*}[our instances] $self]
  }
  my destroyAction $destroyAction
  my zoom [obj inscope dot set zoom]
  my canvas $canvas
  my defaultmessage Ready
  my memory {
    before {}
    after {}
    transformation {}
  }
  my settings [dict create filename ""\
    width [winfo reqwidth $canvas]\
    height [winfo reqheight $canvas]\
    background gray95\
    svgtool eog\
    pstool evince]
  my undoStack {}
  my redoStack {}
  my undonePtr 0
  my lastFillColor white
  my lastLineColor black
  my selection {}
  if {![winfo exists $canvas]} then {
    ::canvas $canvas
  }
  $canvas configure -highlightthickness 0\
    -background [$self setting background]\
    -width [$self setting width]\
    -height [$self setting height]\
    -scrollregion "0 0\
      [* [my zoom] [$self setting width]]\
      [* [my zoom] [$self setting height]]"
  $self buildMenu
  $self basicBindings
}

obj destructor canvaseditor {
  variable level
  incr level([my canvas]) -1
  set index [lsearch [our instances] $self]
  our instances [lreplace [our instances] $index $index]
  $self basicBindings off
  apply [list self [my destroyAction]] $self
}

obj inscope canvaseditor proc calcZoomClipping {x y width height zoom} {
  set clipFrac [/ 1.0 $zoom 2]
  set xFrac [/ [double $x] [double $width]]
  set xLeft [- $xFrac $clipFrac]
  set yFrac [/ [double $y] [double $height]]
  set yTop [- $yFrac $clipFrac]
  list [max 0.0 $xLeft] [max 0.0 $yTop]
}

obj method canvaseditor zoom {{how !?} {warp false}} {
  if {$warp} then {
    $self pointerToXY {*}[pointerXY]
  }
  set max 64
  set changed no
  switch -exact -- $how {
    !? #
    in {
      if {[my zoom] < $max} then {
        my zoom [expr {[my zoom] * sqrt(2)}]
        set changed yes
      }
    }
    out {
      if {[my zoom] > 1} then {
        my zoom [expr {[my zoom] / sqrt(2)}]
        set changed yes
      }
    }
    original - none {
      if {[my zoom] != 1.0} then {
        my zoom 1.0
        set changed yes
      }
    }
    default {
      my zoom [fexpr $how]
      set changed yes
    }
  }
  if {$changed} then {
    set diff [abs [- [my zoom] [round [my zoom]]]]
    if {$diff > 0 && $diff < 1e-13} then {
      my zoom [double [round [my zoom]]]
    }
    obj inscope dot set zoom [my zoom]
    $self canvas configure -scrollregion "0 0\
        [* [$self setting width] [my zoom]]\
        [* [$self setting height] [my zoom]]"
    after idle "event generate [my canvas] <Configure>"
    $self statusLine "Zoom [my zoom]"
    $self elements -all draw coords
    lassign [pointerXY] x y
    lassign [calcZoomClipping [$self canvasx $x] [$self canvasy $y]\
        [winfo width [my canvas]] [winfo height [my canvas]] [my zoom]]\
      clipX clipY
    $self canvas xview moveto $clipX
    $self canvas yview moveto $clipY
  }
  my zoom
}

obj method canvaseditor scrollbars {{onoff on}} {
  if {[$self canvas xview] eq "0.0 1.0" &&
    [$self canvas yview] eq "0.0 1.0"} then {
    $self buildInfoWindow
    $self statusLine\
      "No scrolling. Completely visible."
  } elseif {$onoff} then {
    $self pointerToXY {*}[pointerXY]
    $self basicBindings off
    bind [my canvas] <<Click>> "$self scrollbars off"
    bind [my canvas] <3> "$self scrollbars off"
    #
    place [my canvas].x -rely 1.0 -relx 0 -anchor sw\
      -relwidth 1.0 -width -[winfo reqwidth [my canvas].y]
    place [my canvas].y -relx 1.0 -rely 0 -anchor ne\
      -relheight 1.0 -height -[winfo reqheight [my canvas].x]
    #
  } else {
    place forget [my canvas].x
    place forget [my canvas].y
    $self basicBindings on
  }
}

obj method canvaseditor setting args {
  if {[llength $args] == 0} then {
    my settings
  } elseif {[llength $args] == 1} then {
    dict get [my settings] {*}$args
  } else {
    my settings [dict merge [my settings] $args]
  }
}

obj method canvaseditor garbage args {
  [our garbage] {*}$args
}

obj method canvaseditor memory args {
  if {[llength $args] == 0} then {
    my memory
  } elseif {[llength $args] > 1} then {
    my memory {*}$args
  } else {
    dict get [my memory] {*}$args
  }
}

obj method canvaseditor help {} {
  set win [my canvas].help
  destroy $win
  set bg "-bg ivory"
  set fg "-fg navy"
  toplevel $win {*}$bg
  wm resizable $win no no
  wm transient $win .
  pack\
    [label $win.name -text {Vectorleaf 0.1} {*}$bg]\
    [label $win.copyright -text {© 2020-2021} {*}$bg]\
    [label $win.author -text {Wolf-Dieter Busch} {*}$bg]\
    [label $win.str -text {Bremer Str. 25} {*}$bg]\
    [label $win.stadt -text {49610 Quakenbrück} {*}$bg]\
    [label $win.email -text wolf.dieter.busch@gmail.com {*}$fg {*}$bg]\
    [label $win.url -text {http://wolf-dieter-busch.de/vectorleaf/} {*}$bg]
  bind $win.url <3> "tk_popup [menu $win.copy -tearoff no] %X %Y"
  $win.copy add command -label "Copy URL" -command [subst -nocommand {
    clipboard clear
    clipboard append [$win.url cget -text]
  }]
}

# Bau das Kontextmenü auf
obj method canvaseditor buildMenu {} {
  variable level
  set canvas [my canvas]
  destroy $canvas.context
  menu $canvas.context
  #
  # Selection
  #
  $canvas.context add cascade -label select\
    -menu [menu $canvas.context.sel -tearoff no]
  #
  $canvas.context.sel add command -label Info\
    -command "$self buildInfoWindow"
  $canvas.context.sel add separator
  $canvas.context.sel add cascade -label Select\
    -menu [menu $canvas.context.sel.select -tearoff no]
  #
  $canvas.context.sel.select add command -label Enclosed\
    -command "$self createSelRect enclosed"
  $canvas.context.sel.select add command -label Overlapping\
    -command "$self createSelRect overlapping"
  $canvas.context.sel.select add command -label Toggle -command [list apply {
      self {
        $self select {*}[$self elements]
      }
    } $self]
  $canvas.context.sel.select add command -label Connected -command [list apply {
      self {
        set chain {}
        foreach obj [$self selected] {
          if {[$obj isa line]} then {
            $self select $obj
            if {$obj ni $chain} then {
              lappend chain {*}[$obj chainedList]
            }
          }
        }
        if {$chain ne {}} then {
          $self select {*}$chain
        }
      }
    } $self]
  $canvas.context.sel.select add command -label None\
    -command "$self select"
  $canvas.context.sel add separator
  #
  # Move
  #
  $canvas.context.sel add cascade -label Move\
    -menu [menu $canvas.context.sel.move -tearoff no]
  #
  $canvas.context.sel.move add command -label Free\
    -command "$self moveMode both"
  $canvas.context.sel.move add command -label Horizontal\
    -command "$self moveMode horizontal"
  $canvas.context.sel.move add command -label Vertical\
    -command "$self moveMode vertical"
  #
  # Scale
  #
  $canvas.context.sel add cascade -label Scale\
    -menu [menu $canvas.context.sel.scale -tearoff no]
  #
  $canvas.context.sel.scale add command -label Free\
    -command "$self scaleMode both"
  $canvas.context.sel.scale add command -label Proportional\
    -command "$self scaleMode proportional"
  $canvas.context.sel.scale add command -label Horizontal\
    -command "$self scaleMode horizontal"
  $canvas.context.sel.scale add command -label Vertical\
    -command "$self scaleMode vertical"
  #
  # Rotate
  #
  $canvas.context.sel add cascade -label Rotate\
    -menu [menu $canvas.context.sel.rotate -tearoff no]
  $canvas.context.sel.rotate add command -label Periphery\
    -command "$self rotateMode"
  $canvas.context.sel.rotate add command -label Scaling\
    -command "$self rotateMode yes"
  #
  # Shear
  #
  $canvas.context.sel add cascade -label Shear\
    -menu [menu $canvas.context.sel.shear -tearoff no]
  #
  $canvas.context.sel.shear add cascade -label Horizontal\
    -menu [menu $canvas.context.sel.shear.h -tearoff no]
  #
  $canvas.context.sel.shear.h add command -label Free\
    -command "$self shearHmode scaling"
  $canvas.context.sel.shear.h add command -label Parallel\
    -command "$self shearHmode parallel"
  #
  $canvas.context.sel.shear add cascade -label Vertical\
    -menu [menu $canvas.context.sel.shear.v -tearoff no]
  #
  $canvas.context.sel.shear.v add command -label Free\
    -command "$self shearVmode scaling"
  $canvas.context.sel.shear.v add command -label Parallel\
    -command "$self shearVmode parallel"
  #
  $canvas.context.sel.shear add cascade -label Diagonal\
    -menu [menu $canvas.context.sel.shear.d -tearoff no]
  #
  $canvas.context.sel.shear.d add command -label Free\
    -command "$self shearMode free"
  $canvas.context.sel.shear.d add command -label Parallel\
    -command "$self shearMode"
  $canvas.context.sel.shear.d add command -label Horizontal\
    -command "$self shearMode horizontal"
  $canvas.context.sel.shear.d add command -label Vertical\
    -command "$self shearMode vertical"
  #
  # Warp
  #
  $canvas.context.sel add cascade -label Warp\
    -menu [menu $canvas.context.sel.warp -tearoff no]
  #
  $canvas.context.sel.warp add command -label Free\
    -command "$self warpMode both"
  $canvas.context.sel.warp add command -label Horizontal\
    -command "$self warpMode horizontal"
  $canvas.context.sel.warp add command -label Vertical\
    -command "$self warpMode vertical"
  #
  $canvas.context.sel add separator
  #
  $canvas.context.sel add cascade -label Property\
    -menu [menu $canvas.context.sel.prop]
  #
  $canvas.context.sel.prop add cascade -label fill\
    -menu [menu $canvas.context.sel.prop.fill]
  $canvas.context.sel.prop.fill add command -label "Color …"\
    -command "$self changeFillColor"
  $canvas.context.sel.prop.fill add command -label Brighten\
    -command "$self withUndo selected brighten fill 1.1"
  $canvas.context.sel.prop.fill add command -label Darken\
    -command "$self withUndo selected brighten fill 0.97"
  $canvas.context.sel.prop.fill add command -label Transparent\
    -command "$self withUndo selected configure -fill transparent"
  #
  $canvas.context.sel.prop add cascade -label Line\
    -menu [menu $canvas.context.sel.prop.line]
  $canvas.context.sel.prop.line add command -label "Color …"\
    -command "$self changeLineColor"
  $canvas.context.sel.prop.line add command -label Brighten\
    -command "$self withUndo selected brighten outline 1.1"
  $canvas.context.sel.prop.line add command -label Darken\
    -command "$self withUndo selected brighten outline 0.97"
  $canvas.context.sel.prop.line add command -label Transparent\
    -command "$self withUndo selected configure -outline transparent"
  #
  $canvas.context.sel.prop add cascade -label Width\
    -menu [menu $canvas.context.sel.prop.width]
  for {set i 1} {$i <= 10} {incr i} {
    $canvas.context.sel.prop.width add command -label $i\
      -command "$self changeLineWidth $i"
  }
  $canvas.context.sel.prop.width add command -label Widen\
    -command "$self selected wider [expr {2**(1.0/3)}]"
  $canvas.context.sel.prop.width add command -label Narrow\
    -command "$self selected wider [expr {2**(-1.0/3)}]"
  #
  $canvas.context.sel add cascade -label Constraint\
    -menu [menu $canvas.context.sel.constraint -tearoff no]
  $canvas.context.sel.constraint add cascade -label Add\
    -menu [menu $canvas.context.sel.constraint.add -tearoff no]
  $canvas.context.sel.constraint add cascade -label Remove\
    -menu [menu $canvas.context.sel.constraint.remove -tearoff no]
  #
  foreach constr {
    noprint size orient shear gravity fillcolor linecolor linewidth
  } {
    $canvas.context.sel.constraint.add add command\
      -label [string totitle $constr]\
      -command "$self withUndo selected constraint $constr yes"
    $canvas.context.sel.constraint.remove add command\
      -label [string totitle $constr]\
      -command "$self withUndo selected constraint $constr no"
  }
  #
  $canvas.context.sel.constraint add command -label Inspect\
    -command "$self makeConstraintDialog"
  #
  $canvas.context.sel add command -label Numeric\
    -command "$self numericDialog"
  #
  $canvas.context.sel add separator
  #
  $canvas.context.sel add cascade -label Arrange\
    -menu [menu $canvas.context.sel.arrange]
  #
  $canvas.context.sel.arrange add command -label Left\
    -command "$self withUndo align left"
  $canvas.context.sel.arrange add command -label Center\
    -command "$self withUndo align center"
  $canvas.context.sel.arrange add command -label Right\
    -command "$self withUndo align right"
  $canvas.context.sel.arrange add separator
  $canvas.context.sel.arrange add command -label Top\
    -command "$self withUndo align top"
  $canvas.context.sel.arrange add command -label Middle\
    -command "$self withUndo align middle"
  $canvas.context.sel.arrange add command -label Bottom\
    -command "$self withUndo align bottom"
  #
  $canvas.context.sel.arrange add separator
  $canvas.context.sel.arrange add command -label Evenly\
    -command "$self alignEvenly"
  #
  # Stackorder
  #
  $canvas.context.sel add command -label Raise\
    -command "$self raiseSelection"
  $canvas.context.sel add command -label Lower\
    -command "$self lowerSelection"
  #
  $canvas.context.sel add separator
  #
  $canvas.context.sel add command -label Colorize -command [list apply {
      self {
        # create fill object out of selection
        set color\
          [tk_chooseColor -initialcolor [$self private lastFillColor]]
        if {$color ne ""} then {
          set before [$self dump]
          $self private lastFillColor $color
          set lines [concat {*}[$self selected split yes]]
          #
          foreach line $lines {
            foreach dot [$line dots -end] {
              foreach other [$dot lines] {
                if {[$other ni $lines]} then {
                  $line unjoin $other
                  break
                }
              }
            }
          }
          #
          set fill [obj new fill -fill $color {*}$lines]
          $self select
          $fill draw no
          $fill draw
          append before \n "$fill empty"
          set after [$self dump]
          $self initUndoRedo $before $after
        }
      }
    } $self]
  #
  $canvas.context.sel add separator
  #
  # Group
  #
  $canvas.context.sel add command -label Group -accelerator ^g\
    -command "$self createGroup"
  #
  $canvas.context.sel add command -label Edit\
    -command "$self editSelected" -accelerator ^e
  #
  $canvas.context.sel add separator
  #
  $canvas.context.sel add cascade -label Special\
    -menu [menu $canvas.context.sel.special -tearoff yes]
  $canvas.context.sel.special add command -label Intersect -command [list apply {
      self {
        lassign [$self selected] a b
        if {$a ne "" && $b ne "" && [$a isa line] && [$b isa line]} then {
          set before [$self dump]
          if {[$a cget -smooth] || [$b cget -smooth]} then {
            $a configure -smooth yes
            $b configure -smooth yes
          }
          lassign [$a cut $b] fracA fracB
          if {$fracA ne ""} then {
            set a1 [$a intersect $fracA]
            set b1 [$b intersect $fracB]
            $a draw
            $a1 draw
            $b draw
            $b1 draw
            $self select
            $self select $a1 $b1
          } else {
            eval $before
            return -code error {No crossing!}
          }
          set after [$self dump]
          $self initUndoRedo $before $after
        }
      }
    } $self]
  $canvas.context.sel.special add command -label Tangens -command [list apply {
      self {
        lassign [$self selected] a b
        if {
          $a ne "" &&
          $b ne "" &&
          [$a isa line] &&
          [$a cget -smooth] &&
          [$b isa line] &&
          [$b cget -smooth]
        } then {
          set before [$self dump]
          lassign [$a tangensTo $b] l1 l2 l3
          $a draw coords
          $b draw coords
          $l1 draw
          $l2 draw
          $l3 draw
          $self select
          $self select $l1 $l2 $l3
          set after [$self dump]
          $self initUndoRedo $before $after
        }
      }
    } $self]
  #
  $canvas.context.sel add separator
  $canvas.context.sel add command -label Save -command [list apply [list self {
        set directory\
          [file join [file normalize [file dirname [info script]]] lib]
        file mkdir $directory
        set file [tk_getSaveFile\
            -initialdir $directory\
            -title "Save Selection"\
            -defaultextension .vectorleaf\
            -filetypes {{Vectorleaf .vectorleaf}}]
        if {$file ne ""} then {
          set ch [open $file w]
          puts $ch [$self selectionToXML]
          close $ch
        }
      } [namespace current]] $self]
  #
  $canvas.context.sel add separator
  #
  $canvas.context.sel add command -label Duplicate -command [list apply {
      self {
        $self copyToClipboard
        $self select
        $self pasteFromClipboard
      }
    } $self]
  #
  $canvas.context.sel add separator
  #
  $canvas.context.sel add command -label Cut -accelerator ^x -command "
    $self copyToClipboard
    $self deleteSelection
    "
  $canvas.context.sel add command -label Copy -accelerator ^c -command "
    $self copyToClipboard
    $self select
    "
  $canvas.context.sel add command -label Delete -accelerator Del\
    -command "$self deleteSelection"
  #
  $canvas.context.sel add separator
  $canvas.context.sel add command -label Undo\
    -command "$self undo" -accelerator ^z
  $canvas.context.sel add command -label Redo\
    -command "$self redo" -accelerator ^Z
  #
  # No Selection
  #
  $canvas.context add cascade -label noselect\
    -menu [menu $canvas.context.nosel -tearoff no]
  #
  if {$level([my canvas]) <= 1} then {
    $self buildFileMenu $canvas.context.nosel
    $canvas.context.nosel add separator
  } else {
    $canvas.context.nosel add command -label Info\
      -command "$self buildInfoWindow"
  }
  #
  $canvas.context.nosel add cascade -label Select\
    -menu [menu $canvas.context.nosel.select -tearoff no]
  #
  $canvas.context.nosel.select add command -label Enclosed\
    -command "$self createSelRect enclosed"
  $canvas.context.nosel.select add command -label Overlapping\
    -command "$self createSelRect overlapping"
  $canvas.context.nosel.select add command -label All\
    -command [list apply {
      self {
        $self select {*}[$self elements]
      }
    } $self]
  $canvas.context.nosel add separator
  #
  $canvas.context.nosel add cascade -label Draw\
    -menu [menu $canvas.context.nosel.create -tearoff no]
  #
  $canvas.context.nosel.create add cascade -label Line\
    -menu [menu $canvas.context.nosel.create.line -tearoff no]
  $canvas.context.nosel.create.line add command -label Free\
    -command "$self createLine"
  $canvas.context.nosel.create.line add command -label Horizontal\
    -command "$self createLine horizontal"
  $canvas.context.nosel.create.line add command -label Vertical\
    -command "$self createLine vertical"
  #
  $canvas.context.nosel.create add command -label Rectangle\
    -command "$self createRectangle"
  #
  $canvas.context.nosel add command -label Load\
    -command [list apply [list self {
        set directory\
          [file join [file normalize [file dirname [info script]]] lib]
        file mkdir $directory
        set file [tk_getOpenFile\
            -initialdir $directory\
            -title "Load from library"\
            -defaultextension .vectorleaf\
            -filetypes {{Vectorleaf .vectorleaf}}]
        if {$file ne ""} then {
          set ch [open $file r]
          set xml [read $ch]
          close $ch
          set before [$self dump]
          set elements [$self elements]
          $self processXML $xml
          set after [$self dump]
          $self initUndoRedo $before $after
          $self select
          foreach object [$self elements] {
            if {$object ni $elements} then {
              $self select $object
            }
          }
        }
      } [namespace current]] $self]
  #
  $canvas.context.nosel add command -label Cube\
    -command [list apply [list self {
        variable level
        if {$level([my canvas]) <= 1} then {
          $self select
          $self basicBindings off
          $self memory before [$self dump]
          set cube [::GlassCube::slider [my canvas] on]
          bind [my canvas] <Escape> "
            ::GlassCube::slider [my canvas] off
            $self basicBindings
            destroy [my canvas].cubeDone
            $self memory after \[$self dump\]
            $self initUndoRedo \[$self memory before\] \[$self memory after\]
            "
          bind [my canvas] <3>\
            "tk_popup [menu [my canvas].cubeDone -tearoff no] %X %Y"
          #
          [my canvas].cubeDone add command -label Copy\
            -command [subst -novariable {
              clipboard clear
              clipboard append\
                "Horizontal: $::GlassCube::phi Vertical: $::GlassCube::chi"
            }]
          #
          [my canvas].cubeDone add command -label Numeric\
            -command [list apply {
              {menu canvas} {
                set numeric $menu.numeric
                destroy $numeric
                toplevel $numeric
                wm transient $numeric [winfo toplevel $canvas]
                wm title $numeric "Base Cube"
                wm resizable $numeric no no
                grid\
                  [label $numeric.hL -text Horizontal]\
                  [entry $numeric.h -textvariable ::GlassCube::phi]\
                  -sticky e
                grid\
                  [label $numeric.vL -text Vertical]\
                  [entry $numeric.v -textvariable ::GlassCube::chi]\
                  -sticky e
                bind $numeric.h <Return> ::GlassCube::glassCube
                bind $numeric.v <Return> [bind $numeric.h <Return>]
                lassign\
                  [split [winfo geometry [winfo toplevel $canvas]] +x]\
                  w h x y
                if {$x >= 0 && $y >= 0} then {
                  wm geometry $numeric +$x+$y
                }
              }
            } [my canvas].cubeDone [my canvas]]
          #
          [my canvas].cubeDone add command -label Done\
            -command "event generate [my canvas] <Escape>"
          # $self buildInfoWindow
          $self statusLine "Editing base cube"
        } 
      } [namespace current]] $self]
  #
  $canvas.context.nosel add separator
  #
  $canvas.context.nosel add cascade -label Preview\
    -menu [menu $canvas.context.nosel.preview -tearoff no]
  $canvas.context.nosel.preview add command -label Window\
    -command "
    $self basicBindings off
    $self statusLine Non-printing objects are now invisible. Click to finish.
    $self elements hide
    $self canvas configure -cursor X_cursor
    bind [my canvas] <<Click>> {
      $self elements hide no
      $self basicBindings on
      [my canvas] configure -cursor {}
    }
    $self buildInfoWindow
    "
  $canvas.context.nosel.preview add command -label SVG\
    -command [list apply {
      self {
        $self elements hide
        $self selected blink off
        global externalApp
        set ch [open tmp.svg w]
        puts $ch [canvasexport svg [$self private canvas]]
        close $ch
        $self selected blink on
        $self elements hide no
        exec [$self setting svgtool] tmp.svg &
      }
    } $self]
  $canvas.context.nosel.preview add command -label Postscript\
    -command [list apply {
      self {
        set file [dict get [$self private settings] filename]
        set ps tmp.ps
        $self selected blink off
        $self elements hide
        $self canvas postscript -file $ps\
          -pagewidth [$self canvas cget -width]
        $self elements hide no
        $self selected blink on
        exec evince $ps &
      }
    } $self]
  #
  $canvas.context.nosel add cascade -label Zoom\
    -menu [menu $canvas.context.nosel.zoom -tearoff no]
  $canvas.context.nosel.zoom add command -label In -command "$self zoom in yes"
  $canvas.context.nosel.zoom add command -label Out -command "$self zoom out yes"
  $canvas.context.nosel.zoom add command -label Original -command "$self zoom none yes"
  $canvas.context.nosel.zoom add command -label Scroll -command "$self scrollbars"
  #
  $canvas.context.nosel add separator
  #
  $canvas.context.nosel add command -label Paste\
    -command "$self pasteFromClipboard" -accelerator ^v
  $canvas.context.nosel add command -label Undo\
    -command "$self undo" -accelerator ^z
  $canvas.context.nosel add command -label Redo\
    -command "$self redo" -accelerator ^Z
  #
  $canvas.context.nosel add separator
  $canvas.context.nosel add command -label Help -command "$self help"
  #
  if {$level([my canvas]) > 1} then {
    $canvas.context.nosel add separator
    $canvas.context.nosel add command -label Done\
      -command "$self destroy" -accelerator Esc
    bind $canvas <Escape> "$canvas.context.nosel invoke Done"
  } else {
    bind $canvas <Escape> "$self select"
  }
  string cat $canvas.context
}

obj method canvaseditor buildFileMenu menu {
  $menu add cascade -label File -menu [menu $menu.file]
  $menu.file add command -label New -command [list apply {
      self {
        if {
          [llength [$self private undoStack]] == 0 ||
          [tk_messageBox\
              -title "Empty Workspace"\
              -message "Sure?"\
              -type okcancel] eq "ok"
        } then {
          destroy [$self private canvas].info
          $self canvas delete all
          $self initUndoRedo reset
          $self setting filename "" width 400 height 300 background gray95
          $self canvas configure\
            -width [$self setting width]\
            -height [$self setting height]\
            -bg [$self setting background]
          $self zoom original
        }
      }
    } $self]
  $menu.file add separator
  $menu.file add command -label Open -command [list apply [list self {
        if {
          [llength [$self private undoStack]] == 0 ||
          [tk_messageBox\
              -title "Empty Workspace"\
              -message "Sure?"\
              -type okcancel] eq "ok"
        } then {
          set directory [file normalize [file dirname [info script]]]
          set file [tk_getOpenFile\
              -initialdir $directory\
              -title "Load from library"\
              -defaultextension .vectorleaf\
              -filetypes {{Vectorleaf .vectorleaf}}]
          if {$file ne ""} then {
            $self select
            set ch [open $file r]
            set xml [read $ch]
            close $ch
            $self canvas delete all
            $self processXML $xml
            set initUndoRedo reset
            $self private settings filename $file
            #
            variable filename
            set filename([$self private canvas])\
              [file rootname [file tail $file]]
          }
        }
      } [namespace current]] $self]
  $menu.file add command -label Save\
    -command [list apply {
      {self menu} {
        set file [dict get [$self private settings] filename]
        if {$file eq ""} then {
          $menu.file invoke "Save as"
        } else {
          set ch [open $file w]
          puts $ch [$self canvasToXML]
          close $ch
        }
      }
    } $self $menu]
  $menu.file add command -label "Save as"\
    -command [list apply [list self {
        set directory\
          [file normalize [file dirname [info script]]]
        set file [tk_getSaveFile\
            -initialdir $directory\
            -title "Save Selection"\
            -defaultextension .vectorleaf\
            -filetypes {{Vectorleaf .vectorleaf}}]
        if {$file ne ""} then {
          $self private settings filename $file
          set ch [open $file w]
          puts $ch [$self canvasToXML]
          close $ch
          #
          variable filename
          set filename([$self private canvas])\
            [file rootname [file tail $file]]
        }
      } [namespace current]] $self]
  $menu.file add cascade -label Export\
    -menu [menu $menu.file.export -tearoff no] 
  $menu.file.export add command -label Postscript\
    -command [list apply {
      self {
        set file [dict get [$self private settings] filename]
        if {$file eq ""} then {
          set ps [file join [file dirname [info script]] vectorleaf.ps]
        } else {
          set ps [file rootname $file].ps
        }
        $self selected blink off
        $self elements hide
        $self canvas postscript -file $ps\
          -pagewidth [[$self private canvas] cget -width]
        $self elements hide no
        $self selected blink on
      }
    } $self]
  $menu.file.export add command -label PNG\
    -command [list apply {
      self {
        set file [dict get [$self private settings] filename]
        if {$file eq ""} then {
          set file1 [file join [file dirname [info script]] vectorleaf.png]
        } else {
          set file1 [file rootname $file].png
        }
        $self selected blink off
        $self elements hide
        canvasToBitmap [$self private canvas] $file1 [$self canvas cget -bg]
        $self elements hide no
        $self selected blink on
      }
    } $self]
  $menu.file.export add command -label ImageMagick\
    -command [list apply {
      self {
        set file [dict get [$self private settings] filename]
        if {$file eq ""} then {
          set file1 [file join [file dirname [info script]] vectorleaf.mvg]
        } else {
          set file1 [file rootname $file].mvg
        }
        $self selected blink off
        $self elements hide
        set ch [open $file1 w]
        puts $ch [canvasexport mvg [$self private canvas]]
        close $ch
        $self elements hide no
        $self selected blink on
      }
    } $self]
  $menu.file.export add command -label "Scalable Vector Graphics"\
    -command [list apply {
      self {
        set file [dict get [$self private settings] filename]
        if {$file eq ""} then {
          set file1 [file join [file dirname [info script]] vectorleaf.svg]
        } else {
          set file1 [file rootname $file].svg
        }
        $self selected blink off
        $self elements hide
        set ch [open $file1 w]
        puts $ch [canvasexport svg [$self private canvas]]
        close $ch
        $self elements hide no
        $self selected blink on
      }
    } $self]
  $menu.file add separator
  $menu.file add command -label Info\
    -command "$self buildInfoWindow"
}

obj method canvaseditor buildInfoWindow {} {
  variable filename
  variable width
  variable height
  variable background
  variable message
  #
  set canvas [$self private canvas]
  set info $canvas.info
  if {[winfo exists $canvas.info]} return
  toplevel $info
  wm title $info Info
  wm resizable $info yes no
  wm transient $info [winfo toplevel $canvas]
  #
  set filename($canvas)\
    [file tail\
      [file rootname\
        [dict get [$self private settings] filename]]]
  grid\
    [label $info.filenameLab -text Filename]\
    [entry $info.filename -state readonly\
      -textvariable [namespace current]::filename($canvas)]\
    -sticky w
  grid columnconfigure $info 0 -weight 0
  grid columnconfigure $info 1 -weight 1
  grid configure $info.filename -sticky ew
  set width($canvas) [$canvas cget -width]
  grid\
    [label $info.widthLab -text Width]\
    [entry $info.width\
      -textvariable [namespace current]::width($canvas)]\
    -sticky w
  grid configure $info.width -sticky ew
  set height($canvas) [$canvas cget -height]
  grid\
    [label $info.heightLab -text Height]\
    [entry $info.height\
      -textvariable [namespace current]::height($canvas)]\
    -sticky w
  grid configure $info.height -sticky ew
  set background($canvas) [$canvas cget -background]
  grid\
    [label $info.backgroundLab -text Background]\
    [entry $info.background\
      -textvariable [namespace current]::background($canvas)]\
    -sticky w
  grid configure $info.background -sticky ew
  #
  grid\
    [label $info.svgLab -text "SVG Viewer"]\
    [entry $info.svgTool]\
    -sticky w
  grid configure $info.svgTool -sticky ew
  $info.svgTool insert end [$self setting svgtool]
  bind $info.svgTool <Key>\
    [subst -nocommand {after idle {$self setting svgtool [%W get]}}]
  #
  grid\
    [label $info.psLab -text "Postscript Viewer"]\
    [entry $info.psTool]\
    -sticky w
  grid configure $info.psTool -sticky ew
  $info.psTool insert end [$self setting pstool]
  bind $info.psTool <Key>\
    [subst -nocommand {after idle {$self setting pstool [%W get]}}]
  #
  grid [message $info.message -foreground navy\
      -textvariable [namespace current]::message($canvas)\
      -padx 1 -pady 0 -anchor nw -justify left -anchor nw\
      -width [winfo reqwidth $info]] -\
    -sticky news
  after idle [subst -nocommand {
      $info.message configure -width [- [winfo reqwidt $info] 2]
    }]
  bind $info <Configure> [subst -nocommand {
      $info.message configure -width [- [winfo width $info] 2]
    }]
  #
  bind $info.width <Return> [subst -nocommand {
      expr [$info.width get]
      $self setting width [$info.width get]
      $canvas configure -width [* [$self setting width] [$self zoom]]
      $canvas configure -scrollregion "0 0\
          [int [* [$self setting width] [$self zoom]]]\
          [int [* [$self setting height] [$self zoom]]]"
      wm geometry . ""
    }]
  bind $info.height <Return> [subst -nocommand {
      expr [$info.height get]
      $self setting height [$info.height get]
      $canvas configure -height [* [$self setting height] [$self zoom]]
      $canvas configure -scrollregion "0 0\
          [int [* [$self setting width] [$self zoom]]]\
          [int [* [$self setting height] [$self zoom]]]"
      wm geometry . ""
    }]
  bind $info.background <Return> [subst -nocommand {
      winfo rgb . [$info.height get]
      $self setting background [$info.height get]
      $canvas configure -background [$self setting background]
    }]
  adjustChildGeometry $info
  #
  # Kontextmenü copy für Meldungszeile  
  #
  bind $info.message <3> "tk_popup [menu $info.copy -tearoff no] %X %Y"
  $info.copy add command -label Copy -command [subst -nocommand {
      clipboard clear
      clipboard append [$info.message cget -text]
    }]
  $info.copy add cascade -label Specific\
    -menu [menu $info.copy.special -tearoff no]
  foreach key {
    Class coords color linecolor linewidth width height diagonale phi Id
  } {
    $info.copy.special add command -label [string totitle $key]\
      -command [list apply {
        {key win} {
          set dict [string map {; {}} [$win cget -text]]
          clipboard clear
          if {
            [string is list $dict] &&
            [llength $dict] % 2 == 0 &&
            [dict exists $dict $key]
          } then {
            clipboard append [dict get $dict $key]
          } 
        }
      } $key $info.message]
  }
}

obj method canvaseditor canvas args {
  [my canvas] {*}$args
}

obj method canvaseditor statusLine args {
  variable message
  set message([my canvas]) [::join $args]
} 

# Events reset
obj method canvaseditor basicBindings {{onoff on}} {
  set canvas [my canvas]
  variable level
  if {$onoff} then {
    #
    # action of despair
    $canvas delete dot
    #
      bind $canvas <Control-Down> "$canvas yview scroll 1 unit"
      bind $canvas <Control-Up> "$canvas yview scroll -1 unit"
      bind $canvas <Control-Right> "$canvas xview scroll 1 unit"
      bind $canvas <Control-Left> "$canvas xview scroll -1 unit"
    #
    if {[::tk windowingsystem] eq "x11"} then {
      bind $canvas <5> "$canvas yview scroll 1 unit"
      bind $canvas <4> "$canvas yview scroll -1 unit"
      bind $canvas <Shift-5> "$canvas xview scroll 1 unit"
      bind $canvas <Shift-4> "$canvas xview scroll -1 unit"
    } else {
      # Achtung Instrumentenflug!
      # Unter Windows kontrollieren, ob die Richtung stimmt!
      bind $canvas <MouseWheel> [subst -nocommand {
          $canvas yview scroll [expr {-%D/abs(%D)}] unit
        }]
      bind $canvas <Shift-MouseWheel> [subst -nocommand {
          $canvas xview scroll [expr {-%D/abs(%D)}] unit
        }]
    }
    bind $canvas <Motion> ""
    bind $canvas <<Click>> [subst -nocommand {
        $self select {*}[$self tagCurrentToObject]
      }]
    bind $canvas <<ControlClick>> ""
    # bind $canvas <<ShiftControlClick>> ""
    bind $canvas <<DoubleClick>> [list apply {
        self {
          set canvas [$self private canvas]
          set obj [$self tagCurrentToObject]
          if {$obj eq ""} then {
            event generate $canvas <Escape>
          } else {
            $self select
            $self select $obj
            $canvas.context.sel invoke Edit
          }
        }
      } $self]
    bind $canvas <Enter> "
      focus %W
      $self zoom
      obj common dot canvas %W
      obj common line canvas %W
      obj common fill canvas %W
      obj common group canvas %W
      "
    bind $canvas <3> [list apply [list {self menu} {
          proc pointerXY {} {
            list %x %y
          }
          for {set i 0} {$i < [$menu.sel index end]} {incr i} {
            # look for changed entry label
            if {[$menu.sel type $i] eq "command"} then {
              set group [$menu.sel entrycget $i -label]
              if {$group in {Group Ungroup Intersect Split}} break
            }
          }
          set selection [$self private selection]
          lassign $selection obj
          if {[llength $selection] > 1} then {
            $menu.sel entryconfigure $group -label Group -accelerator ^g\
              -command "$self createGroup" -state normal
            $menu.sel.constraint entryconfigure Inspect -state disabled
          } elseif {[llength $selection] == 1} {
            # nur ein Objekt selektiert
            $menu.sel.constraint entryconfigure Inspect -state normal
            if {[$obj isa group]} then {
              $menu.sel entryconfigure $group -label Ungroup -accelerator ^u\
                -command "$self splitGroup" -state normal
            } elseif {[$obj isa line]} then {
              $menu.sel entryconfigure $group -label Intersect -accelerator ""\
                -command "$self intersectLine" -state normal
            } else {
              $menu.sel entryconfigure $group -label Split -accelerator ""\
                -command "$self withUndo selected empty" -state normal
            }
          }
          if {[llength [$self private selection]] == 0} then {
            tk_popup $menu.nosel %X %Y
          } else {
            tk_popup $menu.sel %X %Y
          }
        } [namespace current]] $self $canvas.context]
    $self canvas configure -cursor ""
    bind $canvas <<Undo>> "$self undo"
    bind $canvas <<Redo>> "$self redo"
    bind $canvas <Delete> "$self deleteSelection"
    bind $canvas <<Cut>> "
      $self copyToClipboard
      $self deleteSelection
      "
    bind $canvas <<Copy>> "$self copyToClipboard"
    bind $canvas <<Paste>> "$self pasteFromClipboard"
    bind $canvas <1> ""
    #
    bind $canvas <Control-a> [list apply {
        self {
          $self select {*}[$self elements]
        }
      } $self]
    bind $canvas <Control-e> "$canvas.context.sel invoke Edit"
    bind $canvas <Control-g> "$self withUndo createGroup"
    bind $canvas <Control-u> "$self withUndo splitGroup"
    #
    if {$level($canvas) > 1} then {
      bind $canvas <Escape> [subst -nocommand {
          if {[$self selected] eq {}} then {
            $canvas.context.nosel invoke Done
          } else {
            $self select
          }
        }]
    } else {
      bind $canvas <Escape> "$self select"
    }
    bind $canvas <<ZoomIn>> "$canvas.context.nosel.zoom invoke In"
    bind $canvas <<ZoomOut>> "$canvas.context.nosel.zoom invoke Out"
    bind $canvas <<ZoomOriginal>> "$canvas.context.nosel.zoom invoke Original"
    $self statusLine [my defaultmessage]
  } else {
    foreach ev {
      <Control-Down> <Control-Up>  <Control-Right> <Control-Left>
      <MouseWheel> <Shift-MouseWheel>
      <4> <5> <Control-4> <Control-5>
      <<Click>> <<DoubleClick>>
      <Enter>
      <1> <3> 
      <Control-a> <Control-e> <Control-g> <Congrol-u>
      <Delete>
      <<Undo>> <<Redo>>
      <<Cut>> <<Copy>> <<Paste>>
      <Escape>
      <<ZoomIn>> <<ZoomOut>> <<ZoomOriginal>>
    } {
      bind $canvas $ev ""
    }
    $self statusLine
  }
}

# Nächstes, fernstes Objekt dot

obj method canvaseditor nearestDot args {
  lappend options
  lappend dotOptions
  while {[string index $args 0] eq "-"} {
    set args [lassign $args option]
    if {$option in { -x -y -far }} then {
      lappend options $option
    } else {
      lappend dotOptions $option
    }
  }
  set dots [$self dots {*}$dotOptions]
  lassign [pointerXY] px py
  set li [lmap dot $dots {
      lassign [$dot xy pointer] dotx doty
      set dx [abs [- $dotx $px]]
      set dy [abs [- $doty $py]]
      set hyp [hypot $dx $dy]
      list $dot $dx $dy $hyp
    }]
  if {"-x" in $options} then {
    set li1 [lsort -real -index 1 $li]
  } elseif {"-y" in $options} then {
    set li1 [lsort -real -index 2 $li]
  } else {
    set li1 [lsort -real -index 3 $li]
  }
  if {"-far" in $options} then {
    [lindex $li1 end 0] {*}$args
  } else {
    [lindex $li1 0 0] {*}$args
  }
}

obj method canvaseditor farmostDot args {
  $self nearestDot -far {*}$args
}

obj method canvaseditor lowermostDot args {
  foreach dot [$self dots -selected {*}$args] {
    dict set all [$dot cget -y] $dot
  }
  dict get $all [max {*}[dict keys $all]]
}
obj method canvaseditor uppermostDot args {
  foreach dot [$self dots -selected {*}$args] {
    dict set all [$dot cget -y] $dot
  }
  dict get $all [min {*}[dict keys $all]]
}
obj method canvaseditor leftmostDot args {
  foreach dot [$self dots -selected {*}$args] {
    dict set all [$dot cget -x] $dot
  }
  dict get $all [min {*}[dict keys $all]]
}
obj method canvaseditor rightmostDot args {
  foreach dot [$self dots -selected {*}$args] {
    dict set all [$dot cget -x] $dot
  }
  dict get $all [max {*}[dict keys $all]]
}

# Mauszeiger auf nächsten dot
obj method canvaseditor pointerToNearestDot args {
  $self pointerToDot [$self nearestDot {*}$args]
}
obj method canvaseditor pointerToFarmostDot args {
  $self pointerToDot [$self farmostDot {*}$args]
}

# Bearbeite selektierte Objekte
obj method canvaseditor selected args {
  lmap obj [my selection] {$obj {*}$args}
}

obj method canvaseditor unSelected args {
  set objects {}
  foreach obj [$self elements] {
    if {$obj ni [my selection]} then {
      lappend objects $obj
    }
  }
  lmap obj $objects {$obj {*}$args}
}

obj method canvaseditor dots args {
  set noGravityArgs [ldifference $args -gravity]
  lappend canvasOptions
  lappend objectOptions
  lappend elements 
  while {[string index $args 0] eq "-"} {
    set args [lassign $args option]
    if {$option in {-selected -unselected}} then {
      lappend canvasOptions $option
    } else {
      lappend objectOptions $option
    }
  }
  if {"-selected" in $canvasOptions} then {
    set dots [concat {*}[$self selected dots {*}$objectOptions]]
  } else {
    set dots [concat {*}[$self elements dots {*}$objectOptions]]
    if {"-unselected" in $canvasOptions} then {
      set dots [ldifference $dots [$self dots -selected]]
    }
  }
  if {$dots eq {} && "-gravity" in $objectOptions} then {
    $self dots {*}$noGravityArgs
  } else {
    lmap dot [lunique $dots] {
      $dot {*}$args
    }
  }
}

obj method canvaseditor canvasx x {
   set nachkomma [expr {$x - round($x)}]
   expr {([$self canvas canvasx $x] + $nachkomma) / [my zoom]}
}

obj method canvaseditor canvasy y {
   set nachkomma [expr {$y - round($y)}]
   expr {([$self canvas canvasy $y] + $nachkomma) / [my zoom]}
}

# debugging purposes:
# namespace path [obj inscope canvaseditor namespace current]

obj method canvaseditor snapMode {{onOff on}} {
  set canvas [my canvas]
  if {$onOff} then {
    bind $canvas <<ControlClick>>  [list apply [list {x y} {
      proc pointerXY {} "list $x $y"
    } [namespace current]] %x %y]
    bind $canvas <<ControlClick>> +[list apply [list self {
      set found [$self nearestDot -unselected]
      $self memory found $found
      set foundx [$found cget -x]
      set foundy [$found cget -y]
      #
      set currentBind [bind [my canvas] <Motion>]
      #
      lappend map
      if {[regexp {\[[^\]]+\mcanvasx\M[^\]]+\]} $currentBind cmdx]} then {
        lappend map $cmdx $foundx
      }
      if {[regexp {\[[^\]]+\mcanvasy\M[^\]]+\]} $currentBind cmdy]} then {
        lappend map $cmdy $foundy
      }
      #
      set cmd [string map $map $currentBind]
      eval $cmd
      $self finishTransform
    } [namespace current]] $self]
    bind $canvas <<ShiftControlClick>> [bind $canvas <<ControlClick>>]
    bind $canvas <<ShiftControlClick>> +[list apply {
      self {
        $self withUndo connectWarpedLineToDot [$self memory found]
      }
    } $self]
    bind $canvas <<ControlClick>> +break 
    bind $canvas <<ShiftControlClick>> +break
  } else {
    bind $canvas <<ControlClick>> ""
    bind $canvas <<ShiftControlClick>> ""
  }
}

obj method canvaseditor pointerToXY {x y} {
  event generate [my canvas] <Motion> -warp yes -x $x -y $y
}

# Mauszeiger auf dot

obj method canvaseditor pointerToDot dot {
  $self pointerToXY {*}[$dot xy pointer]
  set dot
}

obj method canvaseditor connectWarpedLineToDot dot1 {
  $self buildInfoWindow
  $self statusLine Failure: not connected
  # exactly one object selected?
  set selection [my selection]
  if {[llength $selection] != 1} then {
    $self statusLine Failure: more than 1 object selected
    return
  }
  # not a chaining dot?
  set lines [$dot1 private lines]
  if {[llength $lines] != 1} then {
    $self statusLine Failure: target ist connection of [llength $lines] lines
    return
  }
  lassign $lines line1
  lassign $selection line0
  # is object a line?
  if {![$line0 isa line]} then {
    $self statusLine Failure: [$line0 info class] selected
    return
  }
  # same group?
  if {[$line0 group] ne [$line1 group]} then {
    $self statusLine Failure: not same group
    return
  }
  set dot0 [$self memory currentDot]
  # exactly one line?
  if {[llength [$dot0 lines]] != 1} then {
    $self statusLine Failure: warped line already connected
    return
  }
  #
  if {
    ($dot0 eq [$line0 lastDot] && $dot1 eq [$line1 lastDot] ) ||
    ($dot0 eq [$line0 firstDot] && $dot1 eq [$line1 firstDot] )
  } then {
    foreach line [$line0 chainedList] {
      $line private dots [lreverse [$line private dots]]
    }
  }
  if {[$line0 lastDot] eq $dot0} then {
    $line0 joinEnd $line1 
  } else {
    $line0 joinEnd $line1 first
  }
  $self statusLine Success: lines connected
}

# Einstellen von constraints
obj method canvaseditor makeConstraintDialog {} {
  set elements [my selection]
  if {[llength $elements] != 1} then {
    return -code error {Select exactly one element, please.}
  }
  lassign $elements obj
  set var [namespace current]::constraint
  catch {unset $var}
  catch {array unset $var}
  #
  destroy [my canvas].constraint
  set dialog [toplevel [my canvas].constraint]
  wm transient $dialog [my canvas]
  wm resizable $dialog no no
  #
  $self basicBindings no
  #
  foreach constraint {
    noprint size orient shear gravity fillcolor linecolor linewidth
  } {
    set [set var]($constraint) [$obj constraint $constraint]
    ::pack [checkbutton $dialog.$constraint\
      -text [string totitle $constraint]\
      -variable [set var]($constraint)\
      -command "$obj constraint $constraint toggle"\
      -width 18 -anchor nw -onvalue yes -offvalue no]
  }
  set before [list $obj configure -constraint [$obj cget -constraint]]
  frame $dialog.finish
  bind $dialog.finish <Destroy> [subst -nocommand {
      $self basicBindings
      $self initUndoRedo [list $before]\
        "$obj configure -constraint [list [$obj cget -constraint]]"
  }]
}

# Laufende Objektmanipulation (move, scale) beenden
obj method canvaseditor selMode {} {
  $self selected blink on
  $self selected dots storeXY
  $self basicBindings
}

# Transformation beenden, (später Redo-Stack befüllen) 
obj method canvaseditor finishTransform {{method undoRedoCode}} {
  $self memory after [$self $method]
  $self initUndoRedo [$self memory before] [$self memory after]
  $self selMode
  $self snapMode off
  $self memory transformation ""
  $self 
}

# undo, redo
obj method canvaseditor initUndoRedo args {
  #
  # Stack initialisieren
  #
  if {[lindex $args 0] eq "reset"} then {
    my undoStack {}
    my redoStack {}
    my undonePtr 0
  } else {
    if {[my undonePtr] > 0} then {
      my undoStack [lrange [my undoStack] 0 end-[my undonePtr]]
      my redoStack [lrange [my redoStack] 0 end-[my undonePtr]]
      my undonePtr 0
    }
    if {[llength $args] == 2} then {
      lassign $args undoStr redoStr
      #
      set undoStr [regsub -all {(^|\n) *} $undoStr {\1}]
      set redoStr [regsub -all {(^|\n) *} $redoStr {\1}]
      set undoStr [regsub -all {\n{2,}} $undoStr \n]
      set redoStr [regsub -all {\n{2,}} $redoStr \n]
      set undoStr \n[string trim $undoStr]\n
      set redoStr \n[string trim $redoStr]\n
      #
      set undoStack [my undoStack]
      set redoStack [my redoStack]
      if {
        $undoStr ne $redoStr &&
        ( $undoStr ne [lindex $undoStack end] ||
          $redoStr ne [lindex $redoStack end] )
      } then {
        lappend undoStack $undoStr
        lappend redoStack $redoStr
        my undoStack $undoStack
        my redoStack $redoStack
      }
    }
    # Stacklänge begrenzen
    set maxLen 99
    my undoStack [lreverse [lrange [lreverse [my undoStack]] 0 $maxLen]]
    my redoStack [lreverse [lrange [lreverse [my redoStack]] 0 $maxLen]]
  }
}

obj inscope canvaseditor proc objUndoRedoTxt obj {
  # textliche Befehlsfolge für undo erzeugen
  switch -exact -- [$obj info class] {
    group {
      lappend result\
        [list $obj configure -constraint [$obj cget -constraint]]\
        {*}[lmap x [$obj private elements] {objUndoRedoTxt $x}]
    }
    fill {
      set cmdLine [list $obj configure]
      lappend cmdLine -fill [$obj cget -fill] -constraint [$obj cget -constraint]
      lappend result $cmdLine
      foreach line [$obj private lines] {
        lappend result [objUndoRedoTxt $line]
      }
    }
    line {
      set cmdLine [list $obj configure]
      foreach p [$obj configure] {
        lappend cmdLine [lindex $p 0] [lindex $p end]
      }
      lappend result $cmdLine
      foreach dot [$obj dots] {
        lappend result\
          [list $dot configure\
            -x [$dot cget -x]\
            -y [$dot cget -y]]
      }
    }
  }
  join $result \n
}

obj method canvaseditor undoRedoCode {} {
  # Attribute 
  foreach obj [my selection] {
    append result \n [objUndoRedoTxt $obj]
  }
  foreach obj [my selection] {
    append result \n "$obj draw coords"
  }
  foreach dot [$self dots -selected] {
    append result \n "$dot lines draw coords"
  }
  # Reihenfolge übereinandergezeichneter Objekte
  set stackorder ""
  foreach item [$self canvas find all] {
    foreach tag [$self canvas gettags $item] {
      if {[regexp (?:line|fill|group)(?::.*) $tag]} then {
        lappend stackorder $tag
      }
    }
  }
  set line "$self raiseTags $stackorder"
  append result \n $line
  set result
}

obj method canvaseditor undo {} {
  # Letzter Befehl retour
  if {[my undonePtr] < [llength [my undoStack]]} then {
    set code [lindex [my undoStack] end-[my undonePtr]]
    my undonePtr [+ [my undonePtr] 1]
    set before [$self elements]
    # den Code als Lambda-Körper ausführen
    apply [list "" $code]
    $self statusLine Undo
  } else {
    $self statusLine No more undo!
  }
}

obj method canvaseditor redo {} {
  # Letztes Rückgängig zurück nehmen
  if {[my undonePtr] > 0} then {
    my undonePtr [- [my undonePtr] 1]
    set code [lindex [my redoStack] end-[my undonePtr]]
    set before [$self elements]
    # den Code als Lambda-Körper ausführen
    apply [list "" $code]
    $self statusLine Redo
  } else {
    $self statusLine No more redo.
  }
}

# Automatisches Undo-Recording
obj method canvaseditor withUndo args {
  set before [$self dump]
  uplevel $self $args
  set after [$self dump]
  $self initUndoRedo $before $after
}

# --- Gruppenbildung ---

obj method canvaseditor createGroup {} {
  set elements [my selection]
  if {[llength $elements] < 2} return
  #
  # check on connected lines
  #
  foreach obj [my selection] {
    if {[$obj isa line]} then {
      foreach dot [$obj dots -end] {
        foreach line [$dot lines] {
          if {$line ni [my selection]} then {
            $obj unjoin $line
            break
          }
        }
      }
    }
  }
  #
  set g [new group {*}$elements]
  foreach obj $elements {
    $self select $obj
  }
  $self select $g
  lappend undoLines "$self select"
  foreach obj $elements {
    lappend undoLines "$g release $obj"\
    }
  set undoString \n[join $undoLines \n]\n
  #
  lappend redoLines "$self select"
  foreach obj $elements {
    lappend redoLines "$g add $obj"
  }
  set redoString \n[join $redoLines \n]\n
  #
  $self initUndoRedo $undoString $redoString
}
obj method canvaseditor splitGroup {} {
  set groups [my selection]
  $self select
  lappend undoLines "$self select"
  lappend redoLines "$self select"
  foreach group $groups {
    if {[$group isa group]} then {
      set objects [$group private elements]
      foreach obj $objects {
        $group release $obj
        $self select $obj
        lappend undoLines "$group add $obj"
        lappend redoLines "$group release $obj"
      }
    }
  }
  set undoStr \n[join $undoLines \n]\n
  set redoStr \n[join $redoLines \n]\n
  $self initUndoRedo $undoStr $redoStr
}

# --- Objekte verändern ---

# Numerisch

obj method canvaseditor numericDialog {} {
  $self memory before [$self undoRedoCode]
  $self basicBindings off
  $self statusLine Numerical input
  set dialogWin [my canvas].numeric
  destroy $dialogWin
  toplevel $dialogWin
  wm resizable $dialogWin no no
  wm transient $dialogWin [winfo toplevel [my canvas]]
  wm title $dialogWin Numerical
  bind $dialogWin <Enter> "$self selected blink off"
  bind $dialogWin <Leave> "$self selected blink on"
  bind $dialogWin <Escape> "destroy $dialogWin"
  #
  bind $dialogWin <Destroy> [list apply [list self {
        $self memory after [$self undoRedoCode]
        $self initUndoRedo [$self memory before] [$self memory after]
        $self basicBindings on
        $self selected blink on
      }] $self]
  #
  grid\
    [label $dialogWin.widthLabel -text Width -anchor w -justify left]\
    [entry $dialogWin.width]\
    [label $dialogWin.widthComment -anchor w -justify left -text\
      "Floating point calc allowed,"]\
    -\
    -sticky news
  bind $dialogWin.width <Return> [list apply {
      {self dialogWin} {
        lassign\
          [$self adjustSelWidthHeightNumeric width [$dialogWin.width get]]\
          x y
        $dialogWin.width delete 0 end
        $dialogWin.width insert end $x
      }
    } $self $dialogWin]
  #
  grid\
    [label $dialogWin.heightLabel -text Height -anchor w -justify left]\
    [entry $dialogWin.height]\
    [label $dialogWin.heightComment -anchor w -justify left -text\
      "e. g. 4.0/3.0"]\
    -\
    -sticky news
  bind $dialogWin.height <Return> [list apply {
      {self dialogWin} {
        lassign\
          [$self adjustSelWidthHeightNumeric height [$dialogWin.height get]]\
          x y
        $dialogWin.height delete 0 end
        $dialogWin.height insert end $y
      }
    } $self $dialogWin]
  # Move horizontal
  grid\
    [label $dialogWin.movHorL -text "Move horizontal" -anchor w -justify left]\
    [entry $dialogWin.movHor]\
    [label $dialogWin.movHorComment\
      -text "Number, or left, right, Left, Right"  -anchor w -justify left]\
    -\
    -sticky news
  bind $dialogWin.movHor <Return> [list apply {
      {self entry} {
        set val [$entry get]
        if {[string is double -strict $val]} then {
          lmap dot [$self dots -selected] {
            $dot configure -x [+ [$dot cget -x] $val]
          }
        } else {
          switch -exact -- $val {
            left {
              lassign [$self bbox] left
              lmap dot [$self dots -selected] {
                $dot configure -x [- [$dot cget -x] $left]
              }
            }
            Left {
              set left [min {*}[$self dots -selected cget -x]]
              lmap dot [$self dots -selected] {
                $dot configure -x [- [$dot cget -x] $left]
              }
            }
            right {
              lassign [$self bbox] - - right
              set delta [- [$self setting width] $right]
              lmap dot [$self dots -selected] {
                $dot configure -x [+ [$dot cget -x] $delta]
              }
            }
            Right {
              set right [max {*}[$self dots -selected cget -x]]
              set delta [- [$self setting width] $right]
              lmap dot [$self dots -selected] {
                $dot configure -x [+ [$dot cget -x] $delta]
              }
            }
            default {
              return -code error\
                "Only number, or left, right, Left, Right!"
            }
          }
        }
        $self selected draw coords
      }
    } $self $dialogWin.movHor]
  # Move vertical
  grid\
    [label $dialogWin.movVerL -text "Move vertical" -anchor w -justify left]\
    [entry $dialogWin.movVer]\
    [label $dialogWin.movVerComment\
      -text "Number, or top, bottom, Top, Bottom" -anchor w -justify left]\
    -\
    -sticky news
  bind $dialogWin.movVer <Return> [list apply {
      {self entry} {
        set val [$entry get]
        if {[string is double -strict $val]} then {
          lmap dot [$self dots -selected] {
            $dot configure -y [+ [$dot cget -y] $val]
          }
        } else {
          switch -exact -- $val {
            top {
              lassign [$self bbox] - top
              lmap dot [$self dots -selected] {
                $dot configure -y [- [$dot cget -y] $top]
              }
            }
            Top {
              set top [min {*}[$self dots -selected cget -y]]
              lmap dot [$self dots -selected] {
                $dot configure -y [- [$dot cget -y] $top]
              }
            }
            bottom {
              lassign [$self bbox] - - - bottom
              set delta [- [$self setting height] $bottom]
              lmap dot [$self dots -selected] {
                $dot configure -y [+ [$dot cget -y] $delta]
              }
            }
            Bottom {
              set bottom [max {*}[$self dots -selected cget -y]]
              set delta [- [$self setting height] $bottom]
              lmap dot [$self dots -selected] {
                $dot configure -y [+ [$dot cget -y] $delta]
              }
            }
            default {
              return -code error\
                "Only number, or top, bottom, Top, Bottom!"
            }
          }
        }
        $self selected draw coords
      }
    } $self $dialogWin.movVer]
  set widthHeightLambda {
    {self dialogWin} {
      lassign [$self adjustSelWidthHeightNumeric] x y
      $dialogWin.width delete 0 end
      $dialogWin.width insert end $x
      $dialogWin.height delete 0 end
      $dialogWin.height insert end $y
    }
  }
  apply $widthHeightLambda $self $dialogWin
  #
  grid\
    [label $dialogWin.scaleLabel -text Scale -anchor w -justify left]\
    [entry $dialogWin.scale]\
    [label $dialogWin.scaleComment -anchor w -justify left\
      -text "One or two values, comma separated"]\
    -\
    -sticky news
  bind $dialogWin.scale <Return> [list apply [list {self win} {
        lassign [split [$win get] ,] width height
        set width [fexpr $width]
        if {$height eq ""} then {
          set height $width
        } else {
          set height [fexpr $height]
        }
        $self scaleSelectionNumeric $width $height
        $self memory scale [$win get]
      }] $self $dialogWin.scale]
  bind $dialogWin.scale <Return>\
    +[list apply $widthHeightLambda $self $dialogWin]
  #
  grid\
    [label $dialogWin.rotLabel -text Rotate -anchor w -justify left]\
    [entry $dialogWin.rot]\
    [label $dialogWin.rotComment -anchor w -justify left\
      -text "Floating point calc allowed"]\
    -\
    -sticky news
  if {"angle" in [dict keys [$self memory]]} then {
    $dialogWin.rot insert end [$self memory angle]
  }
  bind $dialogWin.rot <Return> [list apply {
      {self win} {
        set val [expr [$win get]]
        $self rotateSelectionNumeric $val
        $self memory angle [$win get]
      }
    } $self $dialogWin.rot]
  bind $dialogWin.rot <Return>\
    +[list apply $widthHeightLambda $self $dialogWin]
  #
  if {"scale" in [dict keys [$self memory]]} then {
    $dialogWin.scale insert end [$self memory scale]
  }
  #
  grid\
    [label $dialogWin.fColLabel -text "Fill Color" -anchor w -justify left]\
    [entry $dialogWin.fColor]\
    [button $dialogWin.fBrighten -text Brighten\
      -command "$self selected brighten fill 1.1"]\
    [button $dialogWin.fDarken -text Darken\
      -command "$self selected brighten fill 0.97"]\
    -sticky news
  $dialogWin.fColor insert end [my lastFillColor]
  bind $dialogWin.fColor <Return> [list apply {
      {self win} {
        if {[$win get] in {{} transparent}} then {
          $self selected changeFillColor transparent
        } else {
          winfo rgb . [$win get]
          $self selected changeFillColor [$win get]
          $self private lastFillColor [$win get]
        }
      }
    } $self $dialogWin.fColor]
  #
  grid\
    [label $dialogWin.lColLabel -text "Line Color" -anchor w -justify left]\
    [entry $dialogWin.lColor]\
    [button $dialogWin.lBrighten -text Brighten\
      -command "$self selected brighten outline 1.1"]\
    [button $dialogWin.lDarken -text Darken\
      -command "$self selected brighten outline 0.97"]\
    -sticky news
  $dialogWin.lColor insert end [my lastLineColor]
  bind $dialogWin.lColor <Return> [list apply {
      {self win} {
        if {[$win get] in {{} transparent}} then {
          $self selected changeLineColor transparent
        } else {
          winfo rgb . [$win get]
          $self selected changeLineColor [$win get]
          $self private lastLineColor [$win get]
        }
      }
    } $self $dialogWin.lColor]
  #
  grid\
    [label $dialogWin.lWidthLabel -text "Line width" -anchor w -justify left]\
    [entry $dialogWin.lWidth]\
    [button $dialogWin.lWiden -text Widen\
      -command "$self selected wider [expr {2**(1.0/3)}]"]\
    [button $dialogWin.lNarrow -text Narrow\
      -command "$self selected wider [expr {2**(-1.0/3)}]"]\
    -sticky news
  $dialogWin.lWidth insert end 3.0
  bind $dialogWin.lWidth <Return> [list apply {
      {self win} {
        $self selected changeLineWidth [expr [$win get]]
      }
    } $self $dialogWin.lWidth]
  adjustChildGeometry $dialogWin
}

# Scheren horizontal

obj method group shearHobject {x y x0 y0 BotY {mode parallel}} {
  if {[$self constraint shear]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot shearHobject $x $y $x0 $y0 $BotY $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self elements shearHobject $x $y $x0 $y0 $BotY $mode
  }
  $self draw
}
obj method fill shearHobject {x y x0 y0 BotY {mode parallel}} {
  if {[$self constraint shear]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot shearHobject $x $y $x0 $y0 $BotY $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self lines shearHobject $x $y $x0 $y0 $BotY $mode no
  }
  $self draw
}
obj method line shearHobject {x y x0 y0 BotY {mode parallel} {draw yes}} {
  if {[$self constraint shear]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot shearHobject $x $y $x0 $y0 $BotY $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self dots shearHobject $x $y $x0 $y0 $BotY $mode
  }
  if {$draw} then {
    $self dots lines draw coords
  }
}
obj method dot shearHobject {x y x0 y0 BotY {mode parallel}} {
  lappend transformL\
    shearHorizontal [list $BotY $y0 [- $x $x0]]
  if {$mode ne "parallel"} then {
    set fac [expr {($y - $BotY) / ($y0 - $BotY)}]
    lappend transformL scaleVertical [list $BotY $fac]
  }
  $self transform {*}$transformL
}
obj method canvaseditor shearHselection {x y x0 y0 BotY {mode parallel}} {
  $self selected shearHobject $x $y $x0 $y0 $BotY $mode
}
obj method canvaseditor shearHmode {{mode parallel}} {
  set canvas [my canvas]
  $self selected dots storeXY
  $self selected calcCenter
  $self selected blink off
  $self snapMode on
  #
  set nDot [$self nearestDot -selected]
  $self pointerToDot $nDot
  $self memory currentDot $nDot
  $self memory transformation "shear horizontal $mode"
  #
  set UppY [[$self uppermostDot -gravity] cget -y]
  set BotY [[$self lowermostDot -gravity] cget -y]
  set MidY [expr {($UppY + $BotY) / 2}]
  if {[$nDot cget -y] < $MidY} then {
    set BaseY $BotY
  } else {
    set BaseY $UppY
  }
  #
  set x0 [$nDot cget -x]
  set y0 [$nDot cget -y]
  #
  $self memory before [$self undoRedoCode]
  #
  $self basicBindings off
  $self statusLine Shear objects horizontal $mode
  after idle [list bind $canvas <Motion> [subst -nocommand {
        $self shearHselection\
          [$self canvasx %x] [$self canvasy %y]\
          $x0 $y0 $BaseY $mode
      }]]
  bind $canvas <<Click>> "
    $self finishTransform
    "
}

# Scheren vertikal

obj method group shearVobject {x y x0 y0 LeftX {mode parallel}} {
  if {[$self constraint shear]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot shearVobject $x $y $x0 $y0 $LeftX $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self elements shearVobject $x $y $x0 $y0 $LeftX $mode
  }
}
obj method fill shearVobject {x y x0 y0 LeftX {mode parallel}} {
  if {[$self constraint shear]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot shearVobject $x $y $x0 $y0 $LeftX $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self lines shearVobject $x $y $x0 $y0 $LeftX $mode no
  }
  $self draw
}
obj method line shearVobject {x y x0 y0 LeftX {mode parallel} {draw yes}} {
  if {[$self constraint shear]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot shearVobject $x $y $x0 $y0 $LeftX $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self dots shearVobject $x $y $x0 $y0 $LeftX $mode
  }
  if {$draw} then {
    $self dots lines draw coords
  }
}
obj method dot shearVobject {x y x0 y0 LeftX {mode parallel}} {
  lappend transformL\
    shearVertical [list $LeftX $x0 [- $y $y0]]
  if {$mode ne "parallel"} then {
    set fac [expr {($x - $LeftX) / ($x0 - $LeftX)}]
    lappend transformL scaleHorizontal [list $LeftX $fac]
  }
  $self transform {*}$transformL
}
obj method canvaseditor shearVselection {x y x0 y0 LeftX {mode parallel}} {
  $self selected shearVobject $x $y $x0 $y0 $LeftX $mode
}
obj method canvaseditor shearVmode {{mode parallel}} {
  set canvas [my canvas]
  $self selected dots storeXY
  $self selected calcCenter
  $self selected blink off
  $self snapMode on
  #
  set nDot [$self nearestDot -selected]
  $self pointerToDot $nDot
  $self memory currentDot $nDot
  $self memory transformation "shear vertical $mode"
  #
  set left [[$self leftmostDot -gravity] cget -x]
  set right [[$self rightmostDot -gravity] cget -x]
  set center [expr {($left + $right) / 2}]
  if {[$nDot cget -x] < $center} then {
    set BaseX $right
  } else {
    set BaseX $left
  }
  #
  $self basicBindings off
  $self statusLine Shear objects vertical $mode
  #
  $self memory before [$self undoRedoCode]
  #
  set nDotX [$nDot cget -x]
  set nDotY [$nDot cget -y]
  after idle [list bind $canvas <Motion> [subst -nocommand {
    $self shearVselection\
        [$self canvasx %x] [$self canvasy %y]\
        $nDotX $nDotY $BaseX $mode
    }]]
  bind $canvas <<Click>> "
    $self finishTransform
    "
}

# Scheren an beliebiger Achse

obj method canvaseditor shearSelection {dot dot0 cx cy phi {mode parallel}} {
  set transformL [list rotate [list $phi $cx $cy]]
  #
  lassign [$dot storeXY info] baseX baseY
  $dot storeXY
  $dot transform {*}$transformL
  $dot storeXY $baseX $baseY
  #
  $dot0 transform {*}$transformL
  set x [$dot cget -x]
  set y [$dot cget -y]
  set x0 [$dot0 cget -x]
  set y0 [$dot0 cget -y]
  lappend transformL shearHorizontal [list $cy $y0 [- $x $x0]]
  if {$mode ne "parallel"} then {
    set fac [expr {($y - $cy) / ($y0 - $cy)}]
    lappend transformL scaleVertical [list $cy $fac]
  }
  lappend transformL rotate [list [- $phi] $cx $cy]
  foreach obj [my selection] {
    foreach dot [$obj dots] {
      $dot transform {*}$transformL
    }
    if {[$obj isa line]} then {
      $obj dots lines draw coords
    } else {
      $obj draw
    }
  }
}

obj method canvaseditor shearMode {{mode parallel}} {
  set canvas [my canvas]
  $self selected dots storeXY
  $self selected calcCenter
  #
  set axis [$self calcAxis]
  set p0 [$axis firstDot]
  set p1 [$axis lastDot]
  #
  set cx [$p0 cget -x]
  set cy [$p0 cget -y]
  set ex [$p1 cget -x]
  set ey [$p1 cget -y]
  set dx [- $ex $cx]  
  set dy [- $ey $cy]
  set phi [- [atan2 $dx $dy] [atan2 1 0]]
  #
  set nDot [$self nearestDot -selected -end]
  set x0 [$nDot cget -x]
  set y0 [$nDot cget -y]
  #
  $self memory currentDot $nDot
  $self memory transformation "shear diagonal $mode"
  #
  if {[distToLine $cx $cy $ex $ey $x0 $y0] < 1} then {
    return -code error "Too close to axis!"
  }
  #
  set dot [new dot $x0 $y0]
  #
  $self memory before [$self undoRedoCode]
  #
  $self pointerToDot $nDot
  $self memory currentDot $nDot
  $self selected blink off
  $self basicBindings off
  $self statusLine Shear objects diagonal $mode
  $self snapMode on
  $axis dots show
  switch -exact -- $mode {
    horizontal {
      set motionBinding [subst -nocommand {
          $dot configure -x [$self canvasx %x] -y $y0
          $self shearSelection $dot $nDot $cx $cy $phi $mode
        }]
    }
    vertical {
      set motionBinding [subst -nocommand {
          $dot configure -x $x0 -y [$self canvasy %y]
          $self shearSelection $dot $nDot $cx $cy $phi $mode
        }]
    }
    default {
      set motionBinding [subst -nocommand {
          $dot configure -x [$self canvasx %x] -y [$self canvasy %y]
          $self shearSelection $dot $nDot $cx $cy $phi $mode
        }]
    }
  }
  after idle [list bind $canvas <Motion> $motionBinding]
  bind $canvas <<Click>> "
    $self finishTransform
    $dot destroy
    $axis dots show no
    "
}

obj inscope canvaseditor proc distToLine {x0 y0 x1 y1 x2 y2} {
  # calc distance of dot (x2 y2) to line (x0 y0 x1 y1)
  if {
    ($x0 == $x1 && $y0 == $y1) ||
    ($x2 == $x1 && $y2 == $y1) ||
    ($x0 == $x2 && $y0 == $y2)
  } then {
    return 0.0
  }
  set phi [expr {-(atan2($y1-$y0, $x1-$x0))}]
  lappend triangle\
    {*}[rotate $x0 $y0 $phi $x0 $y0]\
    {*}[rotate $x1 $y1 $phi $x0 $y0]\
    {*}[rotate $x2 $y2 $phi $x0 $y0]
  lassign $triangle left - right - - -
  set width [expr {abs($left - $right)}]
  lassign $triangle - bottom - - - top
  set height [expr {abs ($top - $bottom)}]
}

obj method canvaseditor calcAxis {} {
  set objects {}
  set nDot [$self nearestDot]
  foreach item [$self canvas find withtag line] {
    foreach tag [$self canvas gettags $item] {
      if {[regexp {line(::.+)} $tag - obj]} then {
        if {[$obj topgroup] in [my selection]} then {
          if {$nDot ni [$obj dots]} then {
            lappend objects $obj
          }
        }
      }
    }
  }
  lindex $objects end
}

# rotieren

obj method group rotateObjNumeric {arc xC yC} {
  if {[$self constraint orient]} then {
    set centerDot [my centerDot]
    set x0 [$centerDot cget -x]
    set y0 [$centerDot cget -y]
    $centerDot rotateObjNumeric $arc $xC $yC
    set x1 [$centerDot cget -x]
    set y1 [$centerDot cget -y]
    set dx [- $x1 $x0]
    set dy [- $y1 $y0]
    $self dots transform moveHorizontal $dx moveVertical $dy
  } else {
    $self elements rotateObjNumeric $arc $xC $yC
  }
  $self draw
}
obj method fill rotateObjNumeric {arc xC yC} {
  if {[$self constraint orient]} then {
    set centerDot [my centerDot]
    set x0 [$centerDot cget -x]
    set y0 [$centerDot cget -y]
    $centerDot rotateObjNumeric $arc $xC $yC
    set x1 [$centerDot cget -x]
    set y1 [$centerDot cget -y]
    set dx [- $x1 $x0]
    set dy [- $y1 $y0]
    $self dots transform moveHorizontal $dx moveVertical $dy
  } else {
    $self lines rotateObjNumeric $arc $xC $yC
  }
  $self draw
}
obj method line rotateObjNumeric {arc xC yC} {
  if {[$self constraint orient]} then {
    set centerDot [my centerDot]
    set x0 [$centerDot cget -x]
    set y0 [$centerDot cget -y]
    $centerDot rotateObjNumeric $arc $xC $yC
    set x1 [$centerDot cget -x]
    set y1 [$centerDot cget -y]
    set dx [- $x1 $x0]
    set dy [- $y1 $y0]
    $self dots transform moveHorizontal $dx moveVertical $dy
  } else {
    $self dots rotateObjNumeric $arc $xC $yC
  }
  $self draw
}
obj method dot rotateObjNumeric {arc xC yC} {
  $self transform rotate "$arc $xC $yC"
}
obj method canvaseditor rotateSelectionNumeric phi {
  set min [min {*}[$self dots -selected -gravity cget -x]]
  set max [max {*}[$self dots -selected -gravity cget -x]]
  set xC [expr {($min + $max) / 2.0}]
  set min [min {*}[$self dots -selected -gravity cget -y]]
  set max [max {*}[$self dots -selected -gravity cget -y]]
  set yC [expr {($min + $max) / 2.0}]
  set arc [expr {2 * 3.141592653589793 / 360 * $phi}]
  $self dots -selected storeXY
  $self selected rotateObjNumeric $arc $xC $yC
}

obj method group rotateObj {x y xC yC dist {dPhi 0} {scale no}} {
  if {[$self constraint orient]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot rotateObj $x $y $xC $yC $dist $dPhi $scale
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
    $self draw
  } else {
    $self elements rotateObj $x $y $xC $yC $dist $dPhi $scale
  }
}
obj method fill rotateObj {x y xC yC dist {dPhi 0} {scale no}} {
  if {[$self constraint orient]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot rotateObj $x $y $xC $yC $dist $dPhi $scale
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self lines rotateObj $x $y $xC $yC $dist $dPhi $scale no
  }
  $self draw
}
obj method line rotateObj {x y xC yC dist {dPhi 0} {scale no} {draw yes}} {
  if {[$self constraint orient]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot rotateObj $x $y $xC $yC $dist $dPhi $scale
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self dots rotateObj $x $y $xC $yC $dist $dPhi $scale
  }
  if {$draw} then {
    $self dots lines draw coords
  }
}
obj method dot rotateObj {x y xC yC dist dPhi {scale no}} {
  set dx [- $xC $x]
  set dy [- $yC $y]
  set phi [atan2 $dx $dy]
  #
  lappend transformL rotate [list [- $dPhi $phi] $xC $yC]
  if {$scale} then {
    set factor [/ [hypot $dx $dy] $dist]
    lappend transformL\
      scaleHorizontal [list $xC $factor]\
      scaleVertical [list $yC $factor]
  }
  $self transform {*}$transformL
}
obj method canvaseditor rotateSelection {x y xC yC dist {dPhi 0} {scale no}} {
  $self selected rotateObj $x $y $xC $yC $dist $dPhi $scale
}
obj method canvaseditor rotateMode {{scaling no}} {
  set canvas [my canvas]
  $self selected dots storeXY
  $self selected calcCenter
  $self selected blink off
  $self snapMode on
  #
  set min [min {*}[$self dots -selected -gravity cget -x]]
  set max [max {*}[$self dots -selected -gravity cget -x]]
  set xC [* 0.5 [+ $min $max]]
  #
  set min [min {*}[$self dots -selected -gravity cget -y]]
  set max [max {*}[$self dots -selected -gravity cget -y]]
  set yC [* 0.5 [+ $min $max]]
  set nDot [$self nearestDot -selected -end]
  #
  $self pointerToDot $nDot
  $self memory currentDot $nDot
  $self memory transformation "rotate $scaling"
  #
  set dx [- $xC [$nDot cget -x]]
  set dy [- $yC [$nDot cget -y]]
  set distance [hypot $dx $dy]
  set dPhi [atan2 $dx $dy]
  #
  $self memory before [$self undoRedoCode]
  #
  $self basicBindings no
  after idle [list bind $canvas <Motion> [subst -nocommand {
      $self rotateSelection\
        [$self canvasx %x] [$self canvasy %y]\
        $xC $yC $distance $dPhi $scaling
    }]]
  bind $canvas <<Click>> "
    $self canvas delete center
    $self finishTransform
    "
}

obj method canvaseditor bbox {} {
  set minX Inf
  set minY Inf
  set maxX -Inf
  set maxY -Inf
  foreach bb [$self selected bbox] {
    foreach {x0 y0 x1 y1} $bb {
      set minX [min $minX $x0]
      set minY [min $minY $y0]
      set maxX [max $maxX $x1]
      set maxY [max $maxY $y1]
    }
  }
  list $minX $minY $maxX $maxY
}

# Skalieren

obj method canvaseditor adjustSelWidthHeightNumeric args {
  #
  lassign [$self bbox] left top right bottom
  #
  set width [- $right $left]
  set height [- $bottom $top]
  #
  if {$args eq ""} then {
    list $width $height
  } else {
    lassign $args dim num
    if {[string match w* $dim]} then {
      # width
      set num [fexpr $num]
      set factor [/ $num $width]
      $self scaleSelectionNumeric $factor 1.0
    } elseif {[string match h* $dim]} then {
      # height
      set num [fexpr $num]
      set factor [/ [double $num] $height]
      $self scaleSelectionNumeric 1.0 $factor
    }
    $self adjustSelWidthHeightNumeric
  }
}

obj method group scaleObjNumeric {cx cy fx fy} {
  if {[$self constraint size]} then {
    set centerDot [my centerDot]
    set x0 [$centerDot cget -x]
    set y0 [$centerDot cget -y]
    $centerDot scaleObjNumeric $cx $cy $fx $fy
    set x1 [$centerDot cget -x]
    set y1 [$centerDot cget -y]
    set dx [- $x1 $x0]
    set dy [- $y1 $y0]
    $self dots transform moveHorizontal $dx moveVertical $dy 
  } else {
    $self elements scaleObjNumeric $cx $cy $fx $fy
  }
  $self draw
}
obj method fill scaleObjNumeric {cx cy fx fy} {
  if {[$self constraint size]} then {
    set centerDot [my centerDot]
    set x0 [$centerDot cget -x]
    set y0 [$centerDot cget -y]
    $centerDot scaleObjNumeric $cx $cy $fx $fy
    set x1 [$centerDot cget -x]
    set y1 [$centerDot cget -y]
    set dx [- $x1 $x0]
    set dy [- $y1 $y0]
    $self dots transform moveHorizontal $dx moveVertical $dy 
  } else {
    $self lines scaleObjNumeric $cx $cy $fx $fy
  }
  $self draw
}
obj method line scaleObjNumeric {cx cy fx fy} {
  if {[$self constraint size]} then {
    set centerDot [my centerDot]
    set x0 [$centerDot cget -x]
    set y0 [$centerDot cget -y]
    $centerDot scaleObjNumeric $cx $cy $fx $fy
    set x1 [$centerDot cget -x]
    set y1 [$centerDot cget -y]
    set dx [- $x1 $x0]
    set dy [- $y1 $y0]
    $self dots transform moveHorizontal $dx moveVertical $dy 
  } else {
    $self dots scaleObjNumeric $cx $cy $fx $fy
  }
  $self draw
}
obj method dot scaleObjNumeric {cx cy fx fy} {
  $self transform scaleHorizontal "$cx $fx" scaleVertical "$cy $fy"
}
obj method canvaseditor scaleSelectionNumeric {factorX factorY} {
  set factorX [double $factorX]
  set factorY [double $factorY]
  set min [min {*}[$self dots -selected cget -x]]
  set max [max {*}[$self dots -selected cget -x]]
  set centerX [/ [+ $min $max] 2.0]
  set min [min {*}[$self dots -selected cget -y]]
  set max [max {*}[$self dots -selected cget -y]]
  set centerY [/ [+ $min $max] 2.0]
  $self dots -selected storeXY
  $self selected scaleObjNumeric\
    $centerX $centerY [expr $factorX] [expr $factorY]
  $self dots -selected lines draw coords
}

obj method group scaleObj {x y x0 y0 refX refY {mode both}} {
  if {[$self constraint size]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot scaleObj $x $y $x0 $y0 $refX $refY $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
    $self draw
  } else {
    $self elements scaleObj $x $y $x0 $y0 $refX $refY $mode
  }
}
obj method fill scaleObj {x y x0 y0 refX refY {mode both}} {
  if {[$self constraint size]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot scaleObj $x $y $x0 $y0 $refX $refY $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self lines scaleObj $x $y $x0 $y0 $refX $refY $mode no
  }
  $self draw
}
obj method line scaleObj {x y x0 y0 refX refY {mode both} {draw yes}} {
  if {[$self constraint size]} then {
    set centerDot [my centerDot]
    lassign [$centerDot storeXY info] centerX centerY
    $centerDot scaleObj $x $y $x0 $y0 $refX $refY $mode
    set dx [- [$centerDot cget -x] $centerX]
    set dy [- [$centerDot cget -y] $centerY]
    lappend transformL moveHorizontal $dx moveVertical $dy
    $self dots transform {*}$transformL
  } else {
    $self dots scaleObj $x $y $x0 $y0 $refX $refY $mode
  }
  if {$draw} then {
    $self dots lines draw coords
  }
}
obj method dot scaleObj {x y x0 y0 refX refY {mode both}} {
  set baseHlen [- $refX $x0]
  set hLen [- $x $x0]
  if {$mode eq "vertical"} then {
    set hScale 1.0
  } else {
    set hScale [/ [double $hLen] $baseHlen]
  }
  #
  set baseVlen [- $refY $y0]
  set vLen [- $y $y0]
  if {$mode eq "horizontal"} then {
    set vScale 1.0
  } else {
    set vScale [/ [double $vLen] $baseVlen]
  }
  #
  if {$mode eq "proportional"} then {
    set hScale [max $hScale $vScale]
    set vScale $hScale
  }
  #
  set x1 [my baseX]
  set y1 [my baseY]
  set hDist0 [- $x1 $x0]
  set vDist0 [- $y1 $y0]
  set hDist1 [* $hDist0 $hScale]
  set vDist1 [* $vDist0 $vScale]
  set x2 [+ $x0 $hDist1]
  set y2 [+ $y0 $vDist1]
  $self configure -x $x2 -y $y2
}
obj method canvaseditor scaleSelection {x y x0 y0 refX refY {mode both}} {
  $self selected scaleObj $x $y $x0 $y0 $refX $refY $mode
}
obj method canvaseditor scaleMode {{mode both}} {
  set canvas [my canvas]
  $self selected dots storeXY
  $self selected calcCenter
  $self selected blink off
  $self snapMode on
  set nearDot [$self nearestDot -selected -end]
  #
  $self memory currentDot $nearDot
  $self memory transformation "scale $mode"
  #
  switch -exact -- $mode {
    horizontal {
      if {
        [min {*}[$self dots -selected -gravity cget -x]] ==
        [max {*}[$self dots -selected -gravity cget -x]]
      } then {
        return -code error "Sorry, zero width!"
      }
      set leftDot [$self leftmostDot -gravity]
      set rightDot [$self rightmostDot -gravity]
      set centerX [expr {([$leftDot cget -x] + [$rightDot cget -x]) / 2}]
      #
      if {[$nearDot cget -x] < $centerX} then {
        set farDot $rightDot
      } else {
        set farDot $leftDot
      }
    }
    vertical {
      if {
        [min {*}[$self dots -selected -gravity cget -y]] ==
        [max {*}[$self dots -selected -gravity cget -y]]
      } then {
        return -code error "Sorry, zero height!"
      }
      set topDot [$self uppermostDot -gravity]
      set botDot [$self lowermostDot -gravity]
      set midY [expr {([$topDot cget -y] + [$botDot cget -y]) / 2}]
      #
      if {[$nearDot cget -y] > $midY} then {
        set farDot $topDot
      } else {
        set farDot $botDot
      }
    }
    default {
      set farDot [$self farmostDot -selected -gravity]
    }
  }
  if {[$farDot cget -x] == [$nearDot cget -x]} then {
    set mode vertical
  } elseif {[$farDot cget -y] == [$nearDot cget -y]} then {
    set mode horizontal
  }
  $self pointerToDot $nearDot
  $self memory currentDot $nearDot
  $farDot show
  #
  $self memory before [$self undoRedoCode]
  #
  set farXY [$farDot storeXY info]
  set nearXY [$nearDot storeXY info]
  #
  after idle [list bind $canvas <Motion>\
      [subst -nocommand {$self scaleSelection\
          [$self canvasx %x] [$self canvasy %y]\
          $farXY $nearXY $mode}]]
  $self basicBindings off
  $self statusLine Scale objects $mode
  bind $canvas <<Click>> "
    $self finishTransform
    $farDot show no
    "
  $canvas configure -cursor crosshair
}

# Schieben

obj method group moveObj {x y baseX baseY {mode both}} {
  $self elements moveObj $x $y $baseX $baseY $mode
}
obj method fill moveObj {x y baseX baseY {mode both}} {
  $self lines moveObj $x $y $baseX $baseY $mode no
  $self draw
}
obj method line moveObj {x y baseX baseY {mode both} {draw yes}} {
  set dx [- $x $baseX]
  set dy [- $y $baseY]
  if {$mode eq "horizontal"} then {
    lappend transformL moveHorizontal $dx
  } elseif {$mode eq "vertical"} then {
    lappend transformL moveVertical $dy
  } else {
    lappend transformL moveHorizontal $dx moveVertical $dy
  }
  $self dots transform {*}$transformL
  if {$draw} then {
    $self dots lines draw coords
  }
}
obj method canvaseditor moveSelection {x y baseX baseY {mode both}} {
  $self selected moveObj $x $y $baseX $baseY $mode
}
obj method canvaseditor moveMode {{mode both}} {
  set canvas [my canvas]
  $self selected dots storeXY
  $self selected calcCenter
  $self snapMode on
  set refDot [$self nearestDot -selected -end]
  set baseX [$refDot private baseX]
  set baseY [$refDot private baseY]
  #
  $self memory currentDot $refDot
  $self memory transformation "move $mode"
  #
  $self selected blink off
  $self memory before [$self undoRedoCode]
  #
  $self pointerToDot $refDot
  $self memory currentDot $refDot
  update
  $self basicBindings off
  $self statusLine Move objects $mode
  after idle [list bind $canvas <Motion> [subst -nocommand {
        $self moveSelection\
          [$self canvasx %x] [$self canvasy %y]\
          $baseX $baseY $mode
      }]]
  bind $canvas <<Click>> [list $self finishTransform]
  $canvas configure -cursor crosshair
}

# Warp

obj method canvaseditor moveDot {dot x y {mode both}} {
  switch -exact -- $mode {
    horizontal {
      $dot configure -x $x
    }
    vertical {
      $dot configure -y $y
    }
    botch {
      $dot configure -x $x -y $y
    }
  }
  $dot lines draw coords
}

obj method canvaseditor warpMode {{mode both}} {
  set canvas [my canvas]
  $self statusLine ""
  set dot [$self nearestDot -selected -end]
  $self pointerToDot $dot
  $self memory currentDot $dot
  $self memory transformation "warp $mode"
  #
  $self memory dot $dot
  $self memory found ""
  #
  set x [$dot cget -x]
  set y [$dot cget -y]
  $self canvas configure -cursor crosshair
  $self selected blink off
  foreach obj [my selection] {
    if {$dot in [$obj dots]} then {
      lappend objects $obj
    }
  }
  switch -exact -- $mode {
    horizontal {
      set line [subst -nocommand {
          $dot configure -x [$self canvasx %x]
        }]
    }
    vertical {
      set line [subst -nocommand {
          $dot configure -y [$self canvasy %y]
        }]
    }
    default {
      set line [subst -nocommand {
          $dot configure -x [$self canvasx %x] -y [$self canvasy %y]
        }]
    }
  }
  lappend lines [string trim $line]
  lappend lines "$dot lines draw coords"
  #
  set code [join $lines \n]
  #
  $self memory before [$self dump]
  #
  $self basicBindings off
  $self statusLine Warp $mode
  $self snapMode on
  after idle [list bind $canvas <Motion> $code]
  bind $canvas <<Click>> "$self finishTransform dump"
}

obj method canvaseditor dump {} {
  set canvas [my canvas]
  lappend objects
  foreach obj [$self stackSequence] {
    set top [$obj topgroup]
    if {$top ni $objects} then {
      lappend objects $top
    }
  }
  foreach obj $objects {
    lappend cmdLines [$obj restoreCode]
  }
  lappend cmdLines "$self select"
  lappend cmdLines "$self canvas delete all"
  foreach obj $objects {
    lappend cmdLines [list $obj draw]
  }
  foreach tag [$self stackSequence yes] {
    lappend cmdLines "$self canvas raise $tag"
    if {[$self canvas itemcget $tag -state] eq "disabled"} then {
      lappend cmdLines "$self canvas itemconfigure $tag -state disabled"
    }
  }
  lappend cmdLines "$self select [my selection]"
  join $cmdLines \n
}

# split line object into two
obj method canvaseditor intersectLine {} {
  lassign [my selection] line
  set before [$line restoreCode]
  $self select
  #
  set newLine [$line intersect]
  append before \n "$newLine draw no"\
    \n "$newLine remove [$newLine firstDot] [$newLine lastDot]"
  #
  $line draw
  $newLine draw
  $self canvas raise line$newLine line$line
  set after [$newLine restoreCode]
  append after \n "$newLine draw"
  append after \n [$line restoreCode] \n "$line draw"
  append after \n "$self canvas raise line$newLine line$line"
  #
  $self initUndoRedo $before $after
  $self select $newLine
}

obj method canvaseditor subeditor {{before {}} {after {}}} {
  # edit selection only, avoid distraction to others
  set nonSelected [ldifference [$self elements] [$self selected]]
  $self memory before [$self dump]
  eval $before
  lappend destroyLines $after\
    "$self select"\
    "$self select {*}\[\$self elements\]"\
    "$self private zoom \[\$self private zoom\]"
  foreach element $nonSelected {
    lappend destroyLines "$element state normal"
  }
  lappend destroyLines\
    "$self buildMenu"\
    "$self basicBindings"
  foreach element $nonSelected {
    $element state disabled
  }
  lappend destroyLines\
    "$self memory after \[$self dump\]"\
    "$self initUndoRedo \[$self memory before\] \[$self memory after\]"
  $self select
  set editor [new [$self info class] [my canvas] [join $destroyLines \n]]
  $editor private zoom [my zoom]
  $editor private defaultmessage "Editing selection. Ready."
  $editor 
  $editor private settings [my settings]
  $editor buildInfoWindow
  set editor
}

obj method canvaseditor editSelected {} {
  if {[llength [my selection]] != 1} then {
    # Edit two or more elements
    set subEd [$self subeditor]
    $self statusLine {*}[$subEd private defaultmessage]
  } elseif {[$self selected isa group]} then {
    # Edit group elements
    set msg "Edit group [namespace tail [$self selected]]. Ready"
    set subEd [$self subeditor [subst {
          $self selected release all
        }] [subst {
          [$self selected] add {*}\[\$self elements\]
        }]]
    $self statusLine {*}[$subEd private defaultmessage $msg]
  } elseif {[$self selected isa fill]} then {
    # Edit fill object
    lassign [$self selected] fill
    set zIndex [$fill canvasZ]
    set msg "Edit fill [namespace tail $fill]. Ready"
    set subEd [$self subeditor [subst {
          $fill empty
        }] [subst {
          $fill add {*}\[\$self elements\]
          $fill draw no
          $fill draw
          $fill canvasZ $zIndex
        }]]
    $self statusLine [$subEd private defaultmessage $msg]
  } elseif {[$self selected isa line]} then {
    $self editLine {*}[$self selected]
  }
}

obj method canvaseditor editLine line {
  $self memory before "
    [$line restoreCode]
    $line draw
    $self select
    $self select $line
    "
  $self select
  $self select $line
  $line blink off
  $self basicBindings off
  $self statusLine Editing line $line
  $self buildInfoWindow
  $line dots show
  set canvas [my canvas]
  #
  set menu $canvas.context.dot
  destroy $menu
  menu $menu -tearoff no
  #
  $self canvas bind dot <3> [list apply {
      {self menu x y} {
        tk_popup $menu $x $y
        foreach tag [$self canvas gettags current] {
          if {[string match dot::* $tag]} then {
            set dot [string range $tag 3 end]
            proc lastDot args "$dot {*}\$args"
            break
          }
        }
      }
    } $self $menu %X %Y]
  #
  $menu add cascade -label Move -menu [menu $menu.move -tearoff no]
  $menu.move add command -label Free\
    -command [list apply [list {self canvas line} {
        $self pointerToDot [lastDot]
        $line dots show no
        bind $canvas <Motion> [subst -nocommand {
            lastDot configure\
              -x [$self canvasx %x]\
              -y [$self canvasy %y]
            lastDot lines draw
          }]
        bind $canvas <<Click>> "
          bind $canvas <Motion> {}
          $line dots show
          "
        bind $canvas <<ControlClick>>\
          [list apply [list {self canvas x y} {
              proc pointerXY {} "list $x $y"
              $self pointerToDot [$self nearestDot -unselected]
              event generate $canvas <<Motion>>
              event generate $canvas <<Click>>
              lastDot configure\
                -x [$self nearestDot -unselected cget -x]\
                -y [$self nearestDot -unselected cget -y]
            } [namespace current]] $self $canvas %x %y]
      } [namespace current]] $self $canvas $line]
  $menu.move add command -label Horizontal\
    -command [list apply [list {self canvas line} {
        $self pointerToDot [lastDot]
        $line dots show no
        bind $canvas <Motion> [subst -nocommand {
            lastDot configure -x [$self canvasx %x]
            lastDot lines draw
          }]
        bind $canvas <<Click>> "
          bind $canvas <Motion> {}
          $line dots show
          "
        bind $canvas <<ControlClick>>\
          [list apply [list {self canvas x y} {
              proc pointerXY {} "list $x $y"
              $self pointerToDot [$self nearestDot -unselected]
              event generate $canvas <<Motion>>
              event generate $canvas <<Click>>
              lastDot configure\
                -x [$self nearestDot -unselected cget -x]
            } [namespace current]] $self $canvas %x %y]
      } [namespace current]] $self $canvas $line]
  $menu.move add command -label Vertical\
    -command [list apply [list {self canvas line} {
        $self pointerToDot [lastDot]
        $line dots show no
        bind $canvas <Motion> [subst -nocommand {
            lastDot configure -y [$self canvasy %y]
            lastDot lines draw
          }]
        bind $canvas <<Click>> "
          bind $canvas <Motion> {}
          $line dots show
          "
        bind $canvas <<ControlClick>>\
          [list apply [list {self canvas x y} {
              proc pointerXY {} "list $x $y"
              $self pointerToDot [$self nearestDot -unselected]
              event generate $canvas <<Motion>>
              event generate $canvas <<Click>>
              lastDot configure\
                -y [$self nearestDot -unselected cget -y]
            } [namespace current]] $self $canvas %x %y]
      } [namespace current]] $self $canvas $line]
  $menu add command -label Smooth -command [list apply {
      line {
        $line dots show no
        if {[$line cget -smooth]} then {
          $line configure -smooth no
        } else {
          $line configure -smooth yes
        }
        $line draw
        $line dots show
      }
    } $line]
  $menu add separator
  $menu add command -label Done -accelerator Esc -command [list apply {
      {self line} {
        $line dots show no
        $self basicBindings on
        $self canvas bind dot <3> {}
        set after "
          [$line restoreCode]
          $line draw
          $self select
          $self select $line
          "
        $self memory after $after
        $self initUndoRedo [$self memory before] [$self memory after]
        $self select
        $self select $line
      }
    } $self $line]
  bind $canvas <<DoubleClick>> "$menu invoke Done"
  #
  set done $canvas.context.done
  destroy $done
  $canvas.context add cascade -menu [menu $done -tearoff no]
  $done add command -label Smooth -command "$menu invoke Smooth"
  $done add separator
  $done add command -label Done -accelerator Esc -command "$menu invoke Done"
  bind $canvas <3> [subst -nocommand {
      if {[$self canvas find withtag current] eq ""} then {
        tk_popup $done %X %Y
      }
    }]
  bind $canvas <Escape> "$done invoke Done"
}

obj method canvaseditor raiseTags args {
  foreach tags $args {
    foreach tag $tags {
      $self canvas raise $tag
    }
  }
}
obj method canvaseditor lowerTags args {
  foreach tags [lreverse $args] {
    foreach tag [lreverse $tags] {
      $self canvas lower $tag
    }
  }
}

# Ebenen
obj method canvaseditor raiseSelection {} {
  set before [$self undoRedoCode]
  $self raiseTags [$self selectedStackSequence yes]
  set after [$self undoRedoCode]
  $self initUndoRedo $before $after
}
obj method canvaseditor lowerSelection {} {
  set before [$self undoRedoCode]
  $self lowerTags [$self selectedStackSequence yes]
  set after [$self undoRedoCode]
  $self initUndoRedo $before $after
}

obj method canvaseditor stackSequence {{tagMode no}} {
  set result {}
  foreach item [$self canvas find all] {
    foreach tag [$self canvas gettags $item] {
      if {[regexp {(?:line|fill)(::.*)} $tag - obj]} then {
        if {$tagMode} then {
          lappend result $tag
        } else {
          lappend result $obj
        }
        break
      }
    }
  }
  set result
}

obj method canvaseditor selectedStackSequence {{tagMode no}} {
  lappend result
  foreach tag [$self stackSequence yes] {
    regexp {(fill|line)(::.*)} $tag - class obj
    if {[$obj topgroup] in [my selection]} then {
      if {$tagMode} then {
        lappend result $tag
      } else {
        lappend result $obj
      }
    }
  }
  set result
}

# Farbe
obj method canvaseditor changeLineColor {} {
  if {[my lastLineColor] eq ""} then {
    set lastLinecolor white
  } else {
    set lastLineColor [my lastLineColor]
  }
  set color [tk_chooseColor\
      -title Line -initialcolor $lastLineColor]
  my lastLineColor $color
  set before [$self undoRedoCode]
  $self selected changeLineColor $color
  set after [$self undoRedoCode]
  $self initUndoRedo $before $after
}

obj method canvaseditor changeFillColor {} {
  if {[my lastFillColor] eq ""} then {
    set lastFillcolor white
  } else {
    set lastFillColor [my lastFillColor]
  }
  set color [tk_chooseColor\
      -title Fill -initialcolor $lastFillColor]
  set before [$self undoRedoCode]
  $self selected changeFillColor $color
  set after [$self undoRedoCode]
  $self initUndoRedo $before $after
}

obj method canvaseditor changeLineWidth width {
  set before [$self undoRedoCode]
  $self selected changeLineWidth $width
  $self initUndoRedo $before [$self undoRedoCode]
}

# Löschen
obj method canvaseditor deleteSelection {} {
  if {[llength [my selection]] > 0} then {
    set before [$self dump]
    set stack [$self stackSequence yes]
    set selection [my selection]
    foreach obj [my selection] {
      lappend beforeLines\
        "[our garbage] release $obj"\
        [$obj restoreCode]\
        "$obj draw"
      lappend afterLines\
        "$obj draw no"\
        "[our garbage] add $obj"
      if {[$obj isa line]} then {
        foreach dot [$obj dots -end] {
          foreach line [$dot lines] {
            if {$line in $selection} continue
            $obj unjoin $line
            break
          }
        }
      }
      $self select $obj
      $obj draw no
      [our garbage] add $obj
    }
    lappend beforeLines "$self raiseTags $stack"
    set before [join $beforeLines \n]
    set after [join $afterLines \n]
    $self initUndoRedo $before $after
  }
}

# --- Zeichnen ---

obj method canvaseditor createLine {{direction both}} {
  set canvas [my canvas]
  lassign [pointerXY] x y
  #
  set x [$self canvasx $x]
  set y [$self canvasy $y]
  #
  set line [new line $x $y $x $y]
  $self select $line
  #
  $self initUndoRedo "
      $self select
      $line draw no
      " "
      $self select
      $line draw yes
      "
  #
  lassign [$line dots] a b
  $self basicBindings off
  $self statusLine Draw line $direction
  $self pointerToDot $b
  switch -exact -- $direction {
    horizontal {
      bind $canvas <Motion> [subst -nocommand {
          $b configure -x [$self canvasx %x] -y $y
        }]
    }
    vertical {
      bind $canvas <Motion> [subst -nocommand {
          $b configure -x $x -y [$self canvasy %y]
        }]
    }
    default {
      bind $canvas <Motion> [subst -nocommand {
          $b configure\
            -x [$self canvasx %x]\
            -y [$self canvasy %y]
        }]
    }
  }
  bind $canvas <Motion> "+$line draw"
  bind $canvas <<Click>> "
    $self basicBindings
    $self select $line
    $self snapMode off
    $self select $line
    "
  $self canvas configure -cursor pencil
  $line draw
  $self snapMode on
}

obj method canvaseditor createRectangle {} {
  set canvas [my canvas]
  lassign [pointerXY] x y
  #
  set x [$self canvasx $x]
  set y [$self canvasy $y]
  #
  set a [new dot -x $x -y $y]
  set b [new dot -x $x -y $y]
  set c [new dot -x $x -y $y]
  set d [new dot -x $x -y $y]
  $self pointerToDot $a
  set topLine [new line $a $b]
  set rightLine [new line $b $c]
  set bottomLine [new line $c $d]
  set leftLine [new line $d $a]
  set rect [new fill $topLine $rightLine $bottomLine $leftLine]
  $self select $rect
  $self initUndoRedo "
    $self select
    $rect draw no
    " "
    $self select
    $rect draw
    "
  $self basicBindings off
  $self statusLine Draw rectangle
  bind $canvas <Motion> [subst -nocommand {
      $b configure -x [$self canvasx %x]
      $c configure -x [$self canvasx %x] -y [$self canvasy %y]
      $d configure -y [$self canvasy %y]
      $rect draw
    }]
  $rect draw
  $canvas configure -cursor sizing
  bind $canvas <<Click>> "
    $self basicBindings
    $self select
    $self select $rect
    $self snapMode off
    "
  $self snapMode on
}

# --- Arrange --- 

obj method canvaseditor align how {
  set minX Inf
  set minY Inf
  set maxX -Inf
  set maxY -Inf
  foreach bb [$self selected bbox] {
    foreach {x0 y0 x1 y1} $bb {
      set minX [min $minX $x0]
      set minY [min $minY $y0]
      set maxX [max $maxX $x1]
      set maxY [max $maxY $y1]
    }
  }
  #
  set centerX [/ [+ $minX $maxX] 2.0]
  set centerY [/ [+ $minY $maxY] 2.0]
  #
  foreach obj [$self selected] {
    lassign [$obj bbox] x0 y0 x1 y1
    set cx [/ [+ $x1 $x0] 2.0]
    set cy [/ [+ $y1 $y0] 2.0]
    #
    set dx 0
    set dy 0
    switch -exact -- $how {
      left {
        set dx [- $minX $x0]
      }
      center {
        set dx [- $centerX $cx]
      }
      right {
        set dx [- $maxX $x1]
      }
      top {
        set dy [- $minY $y0]
      }
      middle {
        set dy [- $centerY $cy]
      }
      bottom {
        set dy [- $maxY $y1]
      }
    }
    $obj dots storeXY
    $obj dots transform\
      moveHorizontal [/ $dx [my zoom]]\
      moveVertical [/ $dy [my zoom]]
    $obj draw coords
  }
}

obj method canvaseditor alignEvenly {} {
  set before [$self undoRedoCode]
  $self dots -selected storeXY
  $self selected calcCenter
  set objL1 [my selection]
  foreach obj $objL1 {
    set centerDot [$obj private centerDot]
    lappend objL2\
      [list $obj [$centerDot cget -x] [$centerDot cget -y]]
  }
  set width [-\
      [max {*}[lmap el $objL2 {lindex $el 1}]]\
      [min {*}[lmap el $objL2 {lindex $el 1}]]]
  set height [-\
      [max {*}[lmap el $objL2 {lindex $el 2}]]\
      [min {*}[lmap el $objL2 {lindex $el 2}]]]
  if {$width > $height} then {
    set objL3 [lsort -real -index 1 $objL2]
  } else {
    set objL3 [lsort -real -index 2 $objL2]
  }
  set segs [- [llength $objL3] 1]
  set dot0 [[lindex $objL3 0 0] private centerDot]
  set dot1 [[lindex $objL3 end 0] private centerDot]
  set x0 [$dot0 cget -x]
  set y0 [$dot0 cget -y]
  set x1 [$dot1 cget -x]
  set y1 [$dot1 cget -y]
  set dx [- $x1 $x0]
  set dy [- $y1 $y0]
  for {set i 1} {$i < $segs} {incr i} {
    set li [lindex $objL3 $i]
    lassign $li obj cx cy
    set zx [expr {$x0 + $dx / $segs * $i}]
    set zy [expr {$y0 + $dy / $segs * $i}]
    set xDist [- $zx $cx]
    set yDist [- $zy $cy]
    $obj dots transform moveHorizontal $xDist moveVertical $yDist
    $self select $obj
    $obj draw
    $self select $obj
  }
  set after [$self undoRedoCode]
  $self initUndoRedo $before $after
}

# --- 

# Berechne Objekt unterm Mauszeiger
obj method canvaseditor tagCurrentToObject {} {
  foreach item [$self canvas find withtag current] {
    foreach tag [$self canvas gettags $item] {
      if {[regexp (?:line|fill)(::.*) $tag - obj]} then {
        return [$obj topgroup]
      }
    }
  }
}

# Interaktives Selektionsrecheck

obj method canvaseditor createSelRect {{how enclosed}} {
  set canvas [my canvas]
  $self basicBindings off
  $self statusLine Select area $how
  lassign [pointerXY] x y
  $self pointerToXY $x $y
  set x [$self canvas canvasx $x]
  set y [$self canvas canvasy $y]
  $self canvas delete selection
  $self canvas create rectangle $x $y $x $y -dash "7 7" -tags selection
  bind $canvas <<Click>> "$self selectByRect $how"
  bind $canvas <Motion> [subst -nocommand {
      $self canvas coords selection $x $y\
      [$self canvas canvasx %x] [$self canvas canvasy %y]
    }]
}

obj method canvaseditor selectByRect {{how enclosed}} {
  lassign [$self canvas coords selection] selx0 sely0 selx1 sely1
  $self canvas delete selection
  set items [$self canvas find $how $selx0 $sely0 $selx1 $sely1]
  set objects ""
  foreach item $items {
    if {[$self canvas itemcget $item -state] eq "disabled"} continue
    foreach tag [$self canvas gettags $item] {
      if {[regexp {(line|fill)(::.*)} $tag - class object]} then {
        lappend objects [$object topgroup]
      }
    }
  }
  set objects [lunique $objects]
  if {$how eq "enclosed"} then {
    set result {}
    foreach object $objects {
      lassign [$object bbox] objx0 objy0 objx1 objy1
      if {$selx0 > $objx0} continue
      if {$sely0 > $objy0} continue
      if {$selx1 < $objx1} continue
      if {$sely1 < $objy1} continue
      lappend result $object
    }
  } else {
    set result $objects
  }
  $self basicBindings on
  if {$result ne {}} then {
    $self select {*}$result 
  }
}

# Selektiere oder deselektiere Objekt

obj method canvaseditor select args {
  if {$args eq ""} then {
    # Außerhalb Element geklickt -- Selektion aufheben
    foreach element [my selection] {
      $element blink off
    }
    my selection {}
    $self blinking off
  } else {
    # Selektion mit Mausklick
    foreach object $args {
      if {$object ni [my selection]} then {
        # Element war noch nicht selektiert
        foreach dot [$object dots] {
          $dot storeXY
        }
        my selection [list {*}[my selection] $object]
        $object blink on
        $self blinking on
      } else {
        # Element war schon selektiert
        set index [lsearch [my selection] $object]
        my selection [lreplace [my selection] $index $index]
        $object blink off
        if {[my selection] eq {}} then {
          $self blinking off
        }
      }
    }
  }
  switch -exact -- [llength [my selection]] {
    0 {
      $self statusLine [my defaultmessage]
    }
    1 {
      lappend message\
        "Class [$self selected info class]"\
        "Id [namespace tail {*}[my selection]]"
      switch -exact -- [$self selected info class] {
        line {
          lappend message\
            "coords [$self selected xy yes]"\
            "linewidth [$object cget -width]"\
            [list linecolor [$object cget -outline]]
        }
        fill {
          lappend message [list color {*}[$self selected cget -fill]]
          set colList [lunique [$object lines cget -outline]]
          if {[llength $colList] == 1} then {
            lappend message [list linecolor {*}$colList]
          }
          set widthList [lunique [$object lines cget -width]]
          if {[llength $widthList] == 1} then {
            lappend message "linewidth $widthList"
          }
        }
        group {
          set group [$self selected]
          lappend message "elements [llength [$group elements]]"
          set class [lunique [$group elements info class]]
          if {[llength $class] == 1} then {
            lappend message "classes $class"
            switch -exact -- $class {
              line {
                set lineWidth [lunique [$group elements cget -width]]
                if {[llength $lineWidth] == 1} then {
                  lappend message "linewidth $lineWidth"
                }
                set lineColor [lunique [$group elements cget -outline]]
                if {[llength $lineColor] == 1} then {
                  lappend message "linecolor $lineColor"
                }
              }
              fill {
                set fillColor [lunique [$group elements cget -fill]]
                if {[llength $fillColor] == 1} then {
                  lappend message "fillcolor $fillColor"
                }
              }
            }
          }
        }
      }
      lassign [$object bbox] x0 y0 x1 y1
      lappend message\
        "width [- $x1 $x0]" "height [- $y1 $y0]"\
        "diagonale [hypot [- $x1 $x0] [- $y1 $y0]]"\
        "phi [* 180 [/ [atan2 [- $y1 $y0] [- $x1 $x0]] [acos -1]]]"
      $self statusLine [join $message "; "]
    }
    default {
      lassign [$self bbox] x0 y0 x1 y1
      lappend message\
        "[llength [my selection]] objects"
      set classes [lunique [$self selected info class]]
      if {[llength $classes] == 1} then {
        lappend message "Class $classes"
        switch -exact -- $classes {
          fill {
            set fills [lunique [$self selected cget -fill]]
            if {[llength $fills] == 1} then {
              lappend message [list color {*}$fills]
            }
          }
          line {
            set outlines [lunique [$self selected cget -outline]]
            if {[llength $outlines] == 1} then {
              lappend message [list linecolor {*}$outlines]
            }
            set widths [lunique [$self selected cget -width]]
            if {[llength $widths] == 1} then {
              lappend message [list linewidth {*}$widths]
            }
          }
        }
      }
      lappend message "width [- $x1 $x0]"\
        "height [- $y1 $y0]"\
        "diagonale [hypot [- $x1 $x0] [- $y1 $y0]]"
      $self statusLine [join $message "; "]
    }
  }
}

# Elemente, data, XML
obj method canvaseditor elements args {
  if {[lindex $args 0] eq "-all"} {
    set inactive no
    set args [lrange $args 1 end]
  } else {
    set inactive yes
  }
  set result {}
  foreach item [$self canvas find all] {
    if {$inactive &&\
        [$self canvas itemcget $item -state] eq "disabled"} continue
    foreach tag [$self canvas gettags $item] {
      if {[regexp (?:fill|line)(:.*) $tag - obj]} then {
        lappend result [$obj topgroup]
      }
    }
  }
  lmap obj [lunique $result] {$obj {*}$args}
}

# Hintergrundmodus Blinken
obj method canvaseditor blinking {{onoff on}} {
  blink [my canvas] stop
  if {$onoff} then {
    blink [my canvas] -color1 navy -color0 wheat -interval 15
  } else {
    $self elements blink off
  }
}

# XML

obj inscope canvaseditor proc xmlElement {name attribute args} {
  dict create type element name $name attribute $attribute content $args
}

obj inscope canvaseditor proc xmlComment text {
  dict create type comment content $text
}

obj inscope canvaseditor proc pcData args {
  dict create type pcdata content $args
}

obj method canvaseditor data {} {
  set elements [xmlElement elements {} {*}[$self elements data]]
  set stack [xmlElement stack {} {*}[lmap obj [$self stackSequence] {
        set data [$obj data]
        list type element name item\
          attribute [list ref [dict get $data attribute id]]\
          content {}
      }]]
  xmlElement [$self info class]\
    [my settings]\
    $elements $stack
}

obj method canvaseditor canvasToXML {} {
  ::xml unparse [$self data] -pp
}

obj method canvaseditor selectionToXML {} {
  global env
  set elements [xmlElement elements {} {*}[lmap obj [my selection] {
        $obj data
      }]]
  set stackList {}
  foreach obj [$self stackSequence] {
    if {[$obj topgroup] in [my selection]} then {
      set id [dict get [$obj data] attribute id]
      lappend stackList [xmlElement item [list ref $id]]
    }
  }
  set meta [xmlComment "
      user: $env(USERNAME)
      time: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]
  "]
  set stack [xmlElement stack {} {*}$stackList]
  xml unparse [xmlElement selection {} $meta $elements $stack] -pp
}

# XML Einlesen

obj method canvaseditor processXML src {
  set tree [xml parse $src]
  foreach {att val} [dict get $tree attribute] {
    if {$att ne "id"} then {
      $self setting $att $val
      switch -exact -- $att {
        width - height - background - bg {
          $self canvas configure -$att $val
        }
      }
    }
  }
  if {[dict get $tree name] eq "canvaseditor"} then {
    $self canvas configure -scrollregion\
      "0 0 [$self canvas cget -width] [$self canvas cget -height]"
  }
  set id2obj {}
  # dot
  foreach path [::xml findElementsByName $tree dot] {
    set dotTree [::xml getElement $tree {*}$path]
    set dotID [dict get $dotTree attribute id]
    if {![dict exists $id2obj $dotID]} then {
      set code "obj new dot\
          -x [dict get $dotTree attribute x]\
          -y [dict get $dotTree attribute y]"
      dict set id2obj $dotID [eval $code]
    }
  }
  # line
  foreach path [::xml findElementsByName $tree line] {
    set lineTree [::xml getElement $tree {*}$path]
    set lineID [dict get $lineTree attribute id]
    if {![dict exists $id2obj $lineID]} then {
      set code "obj new line"
      foreach {key val} [dict get $lineTree attribute] {
        if {$key ni {id}} then {
          lappend code -$key $val
        }
      }
      foreach dotTree [dict get $lineTree content] {
        set dotID [dict get $dotTree attribute id]
        lappend code [dict get $id2obj $dotID]
      }
      dict set id2obj $lineID [eval $code]
    }
  }
  # fill
  foreach path [::xml findElementsByName $tree fill] {
    set fillTree [::xml getElement $tree {*}$path]
    set fillID [dict get $fillTree attribute id]
    set code "obj new fill"
    lappend code\
      -fill [dict get $fillTree attribute fill]\
      -constraint [dict get $fillTree attribute constraint]
    foreach lineTree [dict get $fillTree content] {
      set lineID [dict get $lineTree attribute id]
      lappend code [dict get $id2obj $lineID]
    }
    if {![dict exists $id2obj $fillID]} then {
      dict set id2obj $fillID [eval $code]
    }
  }
  # group
  foreach path [lreverse [::xml findElementsByName $tree group]] {
    set groupTree [::xml getElement $tree {*}$path]
    set groupID [dict get $groupTree attribute id]
    set code "obj new group"
    if {[dict exists $groupTree attribute constraint]} then {
      lappend code -constraint [dict get $groupTree attribute constraint]
    }
    foreach elTree [dict get $groupTree content] {
      set elID [dict get $elTree attribute id]
      lappend code [dict get $id2obj $elID]
    }
    if {![dict exists $id2obj $groupID]} then {
      dict set id2obj $groupID [eval $code]
    }
  }
  set lines {}
  # elements
  foreach path [::xml findElementsByName $tree elements] {
    set elementTree [::xml getElement $tree {*}$path]
    foreach objTree [dict get $elementTree content] {
      set id [dict get $objTree attribute id]
      lappend lines "[dict get $id2obj $id] draw"
    }
  }
  set line "$self raiseTags"
  # stack
  foreach path [::xml findElementsByName $tree stack] {
    set elementTree [::xml getElement $tree {*}$path]
    foreach objTree [dict get $elementTree content] {
      set id [dict get $objTree attribute ref]
      set obj [dict get $id2obj $id]
      set tag [$obj info class]$obj
      lappend line $tag
    }
  }
  lappend lines $line
  eval [join $lines \n]
}

# --- Copy & Paste ---

obj method canvaseditor copyToClipboard {} {
  clipboard clear
  clipboard append [$self selectionToXML]
}

obj method canvaseditor pasteFromClipboard {{xml {}}} {
  if {$xml eq {}} then {
    set xml [clipboard get]
  }
  set undoList {}
  set redoList {}
  set before [$self elements]
  $self processXML $xml
  set after [$self elements]
  foreach obj $after {
    if {$obj ni $before} then {
      $self select $obj
      lappend undoList "$obj draw no"
      lappend redoList "$obj draw"
    }
  }
  set undoStr \n[join $undoList \n]\n
  set redoStr \n[join $redoList \n]\n
  append redoStr \n [$self undoRedoCode] \n
  $self initUndoRedo $undoStr $redoStr
}

# =====================================

#{main

cd [file dirname [info script]]

pack [canvas .c -scrollregion "0 0 400 300"] -expand yes -fill both

set e [obj new canvaseditor .c {
    set xml [$self canvasToXML]
    set ch [open .dump.vectorleaf w]
    puts $ch $xml
    close $ch
  }]

if {
  $argv in {{} {{source /home/wolf/bin/Projekte/vectorleaf/vectorleaf.tcl}}}
} then {
  wm protocol . WM_DELETE_WINDOW "
    $e destroy
    update
    destroy .
    "  
  if [file exists .dump.vectorleaf] then {
    apply {
      self {
        set ch [open .dump.vectorleaf r]
        if {[catch {
              $self processXML [read $ch]
            } err]} then {
          tk_messageBox -type ok -title Problem -icon error -message\
            [string cat "Sorry. Problems on Loading .dump.vectorleaf:"\
              \n\n $err \n\n "Start with empty workspace!"]
        }
        close $ch
      }
    } $e 
  } else {
    $e setting width 380 height 267
    $e processXML {<selection>
  <!--
      user: wolf
      time: 2021-05-06 08:16:57
  -->
  <elements>
    <group id="group-3" constraint="">
      <line id="line-55" width="2.0" outline="black" smooth="no" constraint="">
        <dot id="dot-125" x="291.86954756838213" y="235.29100512224835" />
        <dot id="dot-126" x="295.827947997797" y="253.499647097557" />
      </line>
      <line id="line-56" width="2.0" outline="black" smooth="no" constraint="">
        <dot id="dot-127" x="270.42054059038963" y="235.35149894940884" />
        <dot id="dot-128" x="272.5509753729983" y="245.15149894940885" />
      </line>
      <line id="line-57" width="2.0" outline="black" smooth="no" constraint="">
        <dot id="dot-129" x="315.1596710251722" y="232.44779524570515" />
        <dot id="dot-130" x="318.01340156730856" y="245.5749557395323" />
      </line>
      <line id="line-58" width="5.0" outline="#4b8800" smooth="yes" constraint="">
        <dot id="dot-131" x="289.77856528174766" y="156.70952364076686" />
        <dot id="dot-132" x="272.2353554052045" y="208.1292767271866" />
        <dot id="dot-133" x="268.00078750396983" y="230.51199277656934" />
        <dot id="dot-134" x="300.6674541706366" y="220.8329804308903" />
      </line>
      <line id="line-59" width="5.0" outline="#ff0000" smooth="yes" constraint="">
        <dot id="dot-135" x="243.1983183681674" y="215.9934742580508" />
        <dot id="dot-136" x="264.37115787434027" y="249.2650791963224" />
        <dot id="dot-137" x="341.80325663977237" y="243.820634751878" />
        <dot id="dot-138" x="364.18597268915505" y="177.27742487533476" />
      </line>
      <line id="line-60" width="5.0" outline="#ff0000" smooth="yes" constraint="">
        <dot id="dot-139" x="265.5810344175501" y="241.4008816654582" />
        <dot id="dot-140" x="282.836898615081" y="272.34347425805083" />
        <dot id="dot-141" x="345.94405910890816" y="258.38149894940886" />
        <dot id="dot-142" x="364.18597268915505" y="189.37619030743355" />
      </line>
      <line id="line-61" width="2.0" outline="#0000ff" smooth="yes" constraint="">
        <dot id="dot-143" x="265.5810344175501" y="177.27742487533476" />
        <dot id="dot-144" x="275.86498503483404" y="157.3144619123718" />
        <dot id="dot-145" x="298.2477010842168" y="158.52433845558167" />
        <dot id="dot-146" x="309.13658997310563" y="177.27742487533476" />
      </line>
      <group id="group-2" constraint="">
        <fill id="fill-0" fill="#81ffff" constraint="">
          <line id="line-62" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-147" x="235.93905910890817" y="171.2280421592854" />
            <dot id="dot-148" x="269.21066404717976" y="171.2280421592854" />
          </line>
          <line id="line-63" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-148" x="269.21066404717976" y="171.2280421592854" />
            <dot id="dot-149" x="272.2353554052045" y="183.9317458629891" />
          </line>
          <line id="line-64" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-149" x="272.2353554052045" y="183.9317458629891" />
            <dot id="dot-150" x="238.96375046693282" y="183.9317458629891" />
          </line>
          <line id="line-65" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-150" x="238.96375046693282" y="183.9317458629891" />
            <dot id="dot-147" x="235.93905910890817" y="171.2280421592854" />
          </line>
        </fill>
        <fill id="fill-1" fill="#81ffff" constraint="">
          <line id="line-66" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-151" x="304.9020220718711" y="171.2280421592854" />
            <dot id="dot-152" x="338.1736270101427" y="171.2280421592854" />
          </line>
          <line id="line-67" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-152" x="338.1736270101427" y="171.2280421592854" />
            <dot id="dot-153" x="341.1983183681674" y="183.9317458629891" />
          </line>
          <line id="line-68" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-153" x="341.1983183681674" y="183.9317458629891" />
            <dot id="dot-154" x="307.9267134298958" y="183.9317458629891" />
          </line>
          <line id="line-69" width="2.0" outline="#0000ff" smooth="no" constraint="">
            <dot id="dot-154" x="307.9267134298958" y="183.9317458629891" />
            <dot id="dot-151" x="304.9020220718711" y="171.2280421592854" />
          </line>
        </fill>
      </group>
      <line id="line-70" width="2.0" outline="gray75" smooth="yes" constraint="">
        <dot id="dot-155" x="349.0625158990316" y="174.857671788915" />
        <dot id="dot-156" x="371.4452319484143" y="163.3638446284212" />
        <dot id="dot-157" x="374.469923306439" y="187.5613754926187" />
        <dot id="dot-158" x="364.79091096076" y="220.2280421592854" />
      </line>
    </group>
    <group id="group-17" constraint="">
      <group id="group-16" constraint="">
        <line id="line-12" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-22" x="220.87722230100883" y="10.0" />
          <dot id="dot-23" x="220.87722230100883" y="29.081949164512878" />
        </line>
        <line id="line-13" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-24" x="214.1551720271463" y="17.589411599522165" />
          <dot id="dot-25" x="220.87722230100883" y="10.0" />
        </line>
        <line id="line-14" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-26" x="214.1551720271463" y="29.081949164512878" />
          <dot id="dot-27" x="227.5992725748713" y="29.081949164512878" />
        </line>
      </group>
      <group id="group-15" constraint="">
        <line id="line-15" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-28" x="202.12053363361832" y="10.0" />
          <dot id="dot-29" x="198.46792492933594" y="10.0" />
          <dot id="dot-30" x="195.50690352546326" y="14.271637435094952" />
          <dot id="dot-31" x="195.50690352546326" y="19.54097458225644" />
        </line>
        <line id="line-16" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-31" x="195.50690352546326" y="19.54097458225644" />
          <dot id="dot-32" x="195.50690352546326" y="24.810311729417926" />
          <dot id="dot-33" x="198.46792492933594" y="29.081949164512878" />
          <dot id="dot-34" x="202.12053363361832" y="29.081949164512878" />
        </line>
        <line id="line-17" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-34" x="202.12053363361832" y="29.081949164512878" />
          <dot id="dot-35" x="205.77314233790065" y="29.081949164512878" />
          <dot id="dot-36" x="208.73416374177333" y="24.810311729417926" />
          <dot id="dot-37" x="208.73416374177333" y="19.54097458225644" />
        </line>
        <line id="line-18" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-37" x="208.73416374177333" y="19.54097458225644" />
          <dot id="dot-38" x="208.73416374177333" y="14.271637435094952" />
          <dot id="dot-39" x="205.77314233790065" y="10.0" />
          <dot id="dot-28" x="202.12053363361832" y="10.0" />
        </line>
      </group>
      <group id="group-14" constraint="">
        <line id="line-19" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-40" x="152.78935823672424" y="29.081949164512878" />
          <dot id="dot-41" x="160.7040303333688" y="10.0" />
        </line>
        <line id="line-20" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-42" x="168.6187024300133" y="29.081949164512878" />
          <dot id="dot-43" x="160.7040303333688" y="10.0" />
        </line>
        <line id="line-21" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-44" x="155.21772339458226" y="23.227260216310064" />
          <dot id="dot-45" x="158.87526127165427" y="23.227260216310064" />
          <dot id="dot-46" x="162.53279914872633" y="23.227260216310064" />
          <dot id="dot-47" x="166.19033702579833" y="23.227260216310064" />
        </line>
      </group>
      <group id="group-13" constraint="">
        <line id="line-22" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-48" x="53.49991392168333" y="10.0" />
          <dot id="dot-49" x="48.277516963818165" y="10.0" />
          <dot id="dot-50" x="44.043932032142294" y="14.233584931675871" />
          <dot id="dot-51" x="44.043932032142294" y="19.455981889541036" />
        </line>
        <line id="line-23" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-51" x="44.043932032142294" y="19.455981889541036" />
          <dot id="dot-52" x="44.043932032142294" y="24.678378847406208" />
          <dot id="dot-53" x="48.277516963818165" y="28.911963779082072" />
          <dot id="dot-54" x="53.49991392168333" y="28.911963779082072" />
        </line>
        <line id="line-24" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-54" x="53.49991392168333" y="28.911963779082072" />
          <dot id="dot-55" x="54.92487578387963" y="28.911963779082072" />
          <dot id="dot-56" x="56.276220248246034" y="28.59677191459501" />
          <dot id="dot-57" x="57.48803229441079" y="28.032303205992605" />
        </line>
        <line id="line-25" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-58" x="57.48803229441079" y="10.87966057308947" />
          <dot id="dot-59" x="56.276220248246034" y="10.315191864487065" />
          <dot id="dot-60" x="54.92487578387963" y="10.0" />
          <dot id="dot-48" x="53.49991392168333" y="10.0" />
        </line>
      </group>
      <group id="group-12" constraint="">
        <line id="line-26" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-61" x="28.64826850168304" y="10.0" />
          <dot id="dot-62" x="28.64826850168304" y="29.081949164512878" />
        </line>
        <line id="line-27" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-63" x="28.64826850168304" y="21.709377896405627" />
          <dot id="dot-64" x="39.49028507242899" y="21.709377896405627" />
        </line>
        <line id="line-28" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-65" x="28.64826850168304" y="29.081949164512878" />
          <dot id="dot-66" x="41.00816739233343" y="29.081949164512878" />
        </line>
        <line id="line-29" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-67" x="28.64826850168304" y="10.0" />
          <dot id="dot-68" x="41.00816739233343" y="10.0" />
        </line>
      </group>
      <group id="group-11" constraint="">
        <line id="line-30" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-69" x="171.4376267384073" y="29.081949164512878" />
          <dot id="dot-70" x="171.4376267384073" y="10.0" />
        </line>
        <line id="line-31" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-71" x="171.4376267384073" y="10.0" />
          <dot id="dot-72" x="183.79752562905765" y="10.0" />
        </line>
        <line id="line-32" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-73" x="171.4376267384073" y="18.239932593766923" />
          <dot id="dot-74" x="182.2796433091532" y="18.239932593766923" />
        </line>
      </group>
      <group id="group-10" constraint="">
        <line id="line-33" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-75" x="121.78119084439078" y="29.081949164512878" />
          <dot id="dot-76" x="133.92424940362628" y="29.081949164512878" />
        </line>
        <line id="line-34" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-77" x="121.78119084439078" y="10.0" />
          <dot id="dot-78" x="121.78119084439078" y="29.081949164512878" />
        </line>
      </group>
      <group id="group-9" constraint="">
        <line id="line-35" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-79" x="89.36356129786039" y="10.0" />
          <dot id="dot-80" x="84.09422415069889" y="10.0" />
          <dot id="dot-81" x="79.82258671560395" y="14.271637435094952" />
          <dot id="dot-82" x="79.82258671560395" y="19.54097458225644" />
        </line>
        <line id="line-36" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-82" x="79.82258671560395" y="19.54097458225644" />
          <dot id="dot-83" x="79.82258671560395" y="24.810311729417926" />
          <dot id="dot-84" x="84.09422415069889" y="29.081949164512878" />
          <dot id="dot-85" x="89.36356129786039" y="29.081949164512878" />
        </line>
        <line id="line-37" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-85" x="89.36356129786039" y="29.081949164512878" />
          <dot id="dot-86" x="94.63289844502187" y="29.081949164512878" />
          <dot id="dot-87" x="98.90453588011682" y="24.810311729417926" />
          <dot id="dot-88" x="98.90453588011682" y="19.54097458225644" />
        </line>
        <line id="line-38" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-88" x="98.90453588011682" y="19.54097458225644" />
          <dot id="dot-89" x="98.90453588011682" y="14.271637435094952" />
          <dot id="dot-90" x="94.63289844502187" y="10.0" />
          <dot id="dot-79" x="89.36356129786039" y="10.0" />
        </line>
      </group>
      <group id="group-8" constraint="">
        <group id="group-7" constraint="">
          <line id="line-39" width="2.0" outline="navy" smooth="no" constraint="">
            <dot id="dot-91" x="104.32554416548979" y="10.0" />
            <dot id="dot-92" x="104.32554416548979" y="29.081949164512878" />
          </line>
          <line id="line-40" width="2.0" outline="navy" smooth="yes" constraint="">
            <dot id="dot-93" x="110.05012891484368" y="21.449169498707718" />
            <dot id="dot-94" x="113.21173120314059" y="21.449169498707718" />
            <dot id="dot-95" x="115.7747136641975" y="18.886187037650785" />
            <dot id="dot-96" x="115.7747136641975" y="15.724584749353859" />
          </line>
          <line id="line-41" width="2.0" outline="navy" smooth="yes" constraint="">
            <dot id="dot-96" x="115.7747136641975" y="15.724584749353859" />
            <dot id="dot-97" x="115.7747136641975" y="12.56298246105698" />
            <dot id="dot-98" x="113.21173120314059" y="10.0" />
            <dot id="dot-99" x="110.05012891484368" y="10.0" />
          </line>
          <line id="line-42" width="2.0" outline="navy" smooth="no" constraint="">
            <dot id="dot-99" x="110.05012891484368" y="10.0" />
            <dot id="dot-91" x="104.32554416548979" y="10.0" />
          </line>
          <line id="line-43" width="2.0" outline="navy" smooth="no" constraint="">
            <dot id="dot-100" x="104.32554416548979" y="21.449169498707718" />
            <dot id="dot-93" x="110.05012891484368" y="21.449169498707718" />
          </line>
        </group>
        <line id="line-44" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-101" x="111.13360992217142" y="21.34677626113605" />
          <dot id="dot-102" x="115.7747136641975" y="29.081949164512878" />
        </line>
        <line id="line-45" width="2.0" outline="navy" smooth="yes" constraint="">
          <dot id="dot-103" x="111.13360980855647" y="21.346776769544384" />
          <dot id="dot-104" x="113.77713415346122" y="20.840364733935843" />
          <dot id="dot-105" x="115.7747136641975" y="18.51575583501642" />
          <dot id="dot-106" x="115.7747136641975" y="15.724584749353859" />
        </line>
      </group>
      <group id="group-6" constraint="">
        <line id="line-46" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-107" x="61.1743182139209" y="10.0" />
          <dot id="dot-108" x="76.13630108155031" y="10.0" />
        </line>
        <line id="line-47" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-109" x="68.6553096477356" y="29.081949164512878" />
          <dot id="dot-110" x="68.6553096477356" y="10.0" />
        </line>
      </group>
      <group id="group-5" constraint="">
        <line id="line-48" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-111" x="10.0" y="10.0" />
          <dot id="dot-112" x="17.372571268107247" y="29.081949164512878" />
        </line>
        <line id="line-49" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-113" x="24.745142536214495" y="10.0" />
          <dot id="dot-114" x="17.372571268107247" y="29.081949164512878" />
        </line>
      </group>
      <group id="group-4" constraint="">
        <line id="line-50" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-115" x="137.39369470626497" y="10.0" />
          <dot id="dot-116" x="137.39369470626497" y="29.081949164512878" />
        </line>
        <line id="line-51" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-117" x="137.39369470626497" y="21.709377896405627" />
          <dot id="dot-118" x="148.23571127701092" y="21.709377896405627" />
        </line>
        <line id="line-52" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-119" x="137.39369470626497" y="29.081949164512878" />
          <dot id="dot-120" x="149.75359359691538" y="29.081949164512878" />
        </line>
        <line id="line-53" width="2.0" outline="navy" smooth="no" constraint="">
          <dot id="dot-121" x="137.39369470626497" y="10.0" />
          <dot id="dot-122" x="149.75359359691538" y="10.0" />
        </line>
      </group>
      <line id="line-54" width="2.0" outline="navy" smooth="no" constraint="">
        <dot id="dot-123" x="210.89371165523426" y="26.815154098595727" />
        <dot id="dot-124" x="210.89371165523426" y="29.081949164512878" />
      </line>
    </group>
  </elements>
  <stack>
    <item ref="line-12" />
    <item ref="line-13" />
    <item ref="line-14" />
    <item ref="line-15" />
    <item ref="line-16" />
    <item ref="line-17" />
    <item ref="line-18" />
    <item ref="line-19" />
    <item ref="line-20" />
    <item ref="line-21" />
    <item ref="line-22" />
    <item ref="line-23" />
    <item ref="line-24" />
    <item ref="line-25" />
    <item ref="line-26" />
    <item ref="line-29" />
    <item ref="line-28" />
    <item ref="line-27" />
    <item ref="line-30" />
    <item ref="line-31" />
    <item ref="line-32" />
    <item ref="line-34" />
    <item ref="line-33" />
    <item ref="line-35" />
    <item ref="line-36" />
    <item ref="line-37" />
    <item ref="line-38" />
    <item ref="line-39" />
    <item ref="line-40" />
    <item ref="line-41" />
    <item ref="line-42" />
    <item ref="line-43" />
    <item ref="line-45" />
    <item ref="line-44" />
    <item ref="line-46" />
    <item ref="line-47" />
    <item ref="line-48" />
    <item ref="line-49" />
    <item ref="line-50" />
    <item ref="line-53" />
    <item ref="line-52" />
    <item ref="line-51" />
    <item ref="line-54" />
    <item ref="line-55" />
    <item ref="line-56" />
    <item ref="line-57" />
    <item ref="line-58" />
    <item ref="line-59" />
    <item ref="line-60" />
    <item ref="line-61" />
    <item ref="fill-0" />
    <item ref="line-62" />
    <item ref="line-63" />
    <item ref="line-64" />
    <item ref="line-65" />
    <item ref="fill-1" />
    <item ref="line-66" />
    <item ref="line-67" />
    <item ref="line-68" />
    <item ref="line-69" />
    <item ref="line-70" />
  </stack>
</selection>}
    update
    $e buildInfoWindow
  }
} else {
  wm geometry . +0+0
  set ch [open {*}$argv r]
  $e processXML [read $ch]
  close $ch
}

#main}