Require csObject.tcl
Require sortedlist.tcl

csObject Subclass Group {
  SortedList Instance Objects

  Method ListParts {} {
    set list {}
    foreach name [Self Objects list] {
      lappend list $name
      set list [concat $list [$name ListParts]]
    }
    return $list
  }

  Method Add {args} {eval Self Objects add $args}
  Method Remove {args} {Self Objects remove $args}

  Method NewAddition {args} {
    if {[Self isTop]} {
      foreach object $args {$object Object set status selected}
    } else {
      foreach object $args {$object Object set status always}
    }
  }

  Method Select {} {
    .mbar.object.menu entryconfigure Add* -state normal
    .mbar.color.menu entryconfigure "by Coordinate" -state disabled
    .mbar.color.menu entryconfigure Normalize -state disabled
    .mbar.color.menu entryconfigure Wrap* -state disabled
  }

  Method Unselect {} {
    .mbar.object.menu entryconfigure Add* -state disabled
    .mbar.color.menu entryconfigure "by Coordinate" -state normal
    .mbar.color.menu entryconfigure Normalize -state normal
    .mbar.color.menu entryconfigure Wrap* -state normal
  }

  Method RestoreParts {base part} {
    Vars widget-list
    regsub {\) } $base {/} base
    regsub {\(} $base {} base
    foreach object [Self Objects list] \
      {$object $part AddWidgets 0 "($base[file tail $object]) "}
  }

  Method ColorMenus {} {
    global _color
    if {[string range $_color(by-old) 0 2] == "set" ||
	$_color(by-old) == ""} {set _color(by) { }}
    .mbar.color.menu entryconfigure "by Coordinate" -state disabled
    set _color(normalize) 0
  }

  Method _AddNew {name type} {
    _File Changed 1
    if ![regexp {/} $name] {set name "[Self]/$name"}
    Self _New $name $type
  }

#
#  No longer needed now that there is an OBJECT/ADD menu item
#
#  Method _New {name type} {
#    _File Changed 1
#    set self [Self]
#    if ![regexp {/} $name] {
#      if ![Confirm "Add '$name' to group '$self'?"] {set name "$self/$name"}
#    }
#    Parent _New $name $type
#  }

  Method _Delete {} {
    Message Set "Deleting Objects..."
    foreach name [Self Objects list] {$name _Delete}
    Parent _Delete
    Message Clear
  }

  Method _Rename {new} {
    set old [Self]
    Self Save
    if {[string compare $old $new] != 0} {
      Self CheckName $new
      _Object SetCurrent [_Default]
      set prefix [string range $new 0 [string length $old]]
      if {[string compare $prefix "$old/"] == 0} \
	  {Error "Can't form recursive group structures"}
      set new [$old Parent Create $new [$old Pack]]
      $new Reference Rename $old
      Message Set "Renaming Objects..."
      foreach object [Self Objects list] \
	  {$new Objects add [$object _Rename "$new/[file tail $object]"]}
      Message Clear
      $old _Delete
      _File Changed 1
    }
    return $new
  }

  Method _Duplicate {new} {
    Self CheckName $new
    set new [Parent _Duplicate $new]
    set old [Self]
    $new Reference Duplicate $old
    $new Reference LoadBegin $old
    Message Set "Duplicating Objects"
    foreach object [Self Objects list] \
	{$new Objects add [$object _Duplicate "$new/[file tail $object]"]}
    Message Clear
    $new Reference LoadEnd $old
    return $new
  }

  Method Referrers {{name ""}} {
    if {$name == ""} {set name [Self]}
    set refs [Parent Referrers $name]
    foreach object [Self Objects list] \
      {set refs [concat $refs [$object Referrers $name]]}
    return $refs
  }

  Method WriteCS {file {base ""}} {
    Parent WriteCS $file $base
    foreach name [Self Objects list] {$name WriteCS $file $base}
  }

  Method Import {} {
    _fname(OldFile) "Import objects from file:" "" \
	"[Self] _Load {%N}" .cs [_File get pwd]
  }
  Method _Load {name} {
    set base [Self]
    _fname(Close)
    if {$base != [_Default]} \
      {if [Confirm "Import into group '$base'?"] {set base [Self Group]}}
    _File _Load $name {} $base
  }

  Method Compute {} {
    foreach object [Self Objects list] {uplevel "$object Recompute 0"}
  }

  Method Recolor {{group 1}} {
    foreach object [Self Objects list] {uplevel "$object HandleColor"}
  }

  Method WriteOOGL {file} {
    puts $file "{ LIST"
    foreach object [Self Objects list] {
      set status [$object Object get status]
      set show [$object get showme]
      if {$show && ($status == "always" || ($status == "selected" &&
	   [string compare $object [_Current]] == 0))} {
	if {$file == "stdout"} {
	  if [$object get written] {
	    puts "{ : G:$object }"
	  } else {
	    puts "{ define G:$object"
	    puts "  appearance {"
	    $object WriteAppearance $file
	    puts "  }"
	    puts "  { LIST { define O:$object"
	    $object WriteObject $file
	    puts "  }}"
	    puts "}"
	    $object set written 1
	  }
	} else {
	  puts $file "{"
	  puts $file "  appearance {"
	  $object WriteAppearance $file
	  puts $file "  }"
	  puts $file "  { LIST {"
	  $object WriteObject $file
	  puts $file "  }}"
	  puts $file "}"
	}
      }
    }
    puts $file "}"
  }
}

Group Register
