core/implementation/Tree.tcl


@implementation Tree {
  - init {} {
      $super init 
      set separator /
      set root /
    }

  - root: rootName {
      #- changing existing child info
      if {[string length $rootName] && ("$rootName" != "$root")} {
        if [string length [set oldroot $root]] {
          foreach field [array names properties ${root},*] {
            set f [join [lreplace [split $field ,] 0 0] ,]
            set properties($rootName,$f) [set properties($field)]
            unset properties($field)
          }
        } 
        set root $rootName
      }
    }

  - root {} {
      return $root
    }

  - separator: aCharacter {
      if {"$separator" != "$aCharacter"} {
        #- changing existing info
        foreach array {nodes childs} {
          foreach field [array names $array] {
            if {[llength [split $field $separator]] > 1} {
              set ${array}([join [split $field $separator] $aCharacter]) [set ${array}($field)]
              unset ${array}($field)
            }
          }
        }
        foreach field [array names properties] {
          set propertyName [lindex [split $field ,] end] 
          set aPath [join [lreplace [split $field ,] end end] ,]
          if {[llength [split $aPath $separator]] > 1 && "$aPath" != "$aCharacter" && "$aPath" != "$separator"} {
            set ${array}([join [split $aPath $separator] $aCharacter],$propertyName) \
              [set properties($field)]
            unset properties($field)
          }
        }
        set separator $aCharacter
      }
    }

  - separator {} {
      return $separator
    }

  - add: aNode { 
      set aNode [$self format: $aNode]

      if {[$self contains: $aNode]} {
        return [error "([info level 0]) \"$aNode\" already exist"]
      }
     
      set nodeName [$self nodeNameOf: $aNode]
      set parent [$self parentOf: $aNode]

      #- checking parent existence
      if {"$parent" == "$root"} {
        lappend rootChilds $nodeName 
      } else {
        if {![$self contains: $parent]} {
          return [error "([info level 0]) \"$parent\" doesn't exist"]
        } else {
          lappend childs($parent) $nodeName
        }
      } 
      set nodes($aNode) $nodeName
    }

   - addFull: aNode {
      set aNode [$self format: $aNode]
       set parent $aNode
       set parents {}
       while 1 {
         set parent \
           [join [lreplace [split $parent $separator] end end] $separator]
         if {![string length $parent]} { break }
         set parents [linsert $parents 0 $parent]
       }
       foreach parent $parents {
         if {![$self contains: $parent]} {
           $self add: $parent
         }
       }
       if {![$self contains: $aNode]} {
          $self add: $aNode
       }
     }

  - remove: aNode {
      set aNode [$self format: $aNode]
      if {"$aNode" == "$root"} { $self clear ; $self root: / ; return $self }

      #- already gone ?
      if {![$self contains: $aNode]} { 
        return [error "([info level 0]) \"$aNode\" doesn't exist"]
      }
      
      set nodeName [$self nodeNameOf: $aNode]
      set parent [$self parentOf: $aNode]

      #- removing node link from parent childs list
      if {"$parent" != "$root"} {
        if [string length $parent] {
           childs($parent) remove: $nodeName
        }
      } else {
        rootChilds remove: $nodeName
      }

      #- removing node
      unset nodes($aNode)

      #- removing childs
      if [info exists childs($aNode)] {
        foreach node $childs($aNode) {
          $self remove: [join [list $aNode $node] $separator]
        }
        unset childs($aNode)
      }

      #- removing properties
      foreach field [array names properties $aNode,*] {
        unset properties($field)
      }
    }

  - parentOf: aNode {
      set aNode [$self format: $aNode]
      if {"$aNode" == "$root"} { return }

      set parent [join [lreplace [split $aNode $separator] end end] $separator]
      if {![string length $parent]} {
        return $root
      } else {
        return $parent
      }
    } 

  - childsOf: aNode {
      set aNode [$self format: $aNode]
      if {"$aNode" == "$root"} {
        return $rootChilds
      }

      if {![$self contains: $aNode]} {
        return [error "([info level 0]) \"$aNode\" doesn't exist"]
      }
      set childsOfNode {}
      if [info exists childs($aNode)] {
        foreach node $childs($aNode) {
          lappend childsOfNode [join [list $aNode $node] $separator]
        }
      }
      return $childsOfNode
    }

  - allChilds {} {
       return [array names nodes]
     }

  - allChildsOf: aNode {
      set aNode [$self format: $aNode]

      if {"$aNode" == "$root"} {
        return [array names nodes]
      }

      if [$self contains: $aNode] {
        if {"$aNode" != "$separator"} {
           return [array names nodes [join [list ${aNode} *] $separator]]
        } else {
          return [array names nodes ${aNode}?*]
        }
      }
      return
    }

  - contains: aNode {
      set aNode [$self format: $aNode]
      if {"$aNode" == "$root"} { return 1 }
      if [info exists nodes($aNode)] { return 1 } else { return 0 }
    }

  - loadFromTree: aTree {
      $self clear
      $self root: [$aTree root]
      $self separator: [$aTree separator]
      foreach child [$aTree allChilds] {
        $self add: $child 
      }
    }

  - loadFromFile: aFile {
      set f [open $aFile r]
      while {![eof $f]} {
        set line [string trim [gets $f]]
        if [string length $line] {
          $self add: $line
        }
      }
      close $f
    }

  - saveToFile: aFile {
      set f [open $aFile w]
      foreach node [lsort [$self allChildsOf: $root]] {
        puts $f $node
      }
      close $f
    }

  - clear {} {
      foreach array {nodes childs properties} {
        foreach field [array names $array] {
          unset ${array}($field)
        }
      }
      $self root: $root
    }

  - nodeNameOf: aNode {
      set aNode [$self format: $aNode]
      if {"$aNode" == "$separator" && "$aNode" == "$root"} {
        return $aNode
      }
      return [lindex [split $aNode $separator] end]
    }

  - levelOf: aNode {
      set aNode [$self format: $aNode]
      if {"$aNode" == "$root"} { return 0 }
      set nodeLevel [llength [split $aNode $separator]]
      #incr nodeLevel 1
      return $nodeLevel
    }

  - property:of: {propertyName aNode} {
      set aNode [$self format: $aNode]
      if [info exists properties($aNode,$propertyName)] {
        return $properties($aNode,$propertyName)
      } else {
        return [error "([info level 0]) \"$aNode\" doesn't have any \"$propertyName\" property"]
      }
    }

  - property:of:to: {propertyName aNode aValue} {
      set aNode [$self format: $aNode]
      set properties($aNode,$propertyName) $aValue
    }

  - loadFromDirectory: aDirectory {
      if {![$self contains: $aDirectory]} {
        $self addFull: $aDirectory
      } 
      foreach child [glob -nocomplain $aDirectory/*] {
        $self loadFromDirectory: $child
      }
    }

  - format: aNode {
      if {"$aNode" != "/"} {
        if [regexp [join [list $root (.*)] $separator] $aNode -> node] {
          if [string length $node] {
            set aNode $node
          }
        }
        set aNode [string trimleft $aNode /]
      }
      return $aNode
    }
}