###############################################################################
#                                                                             #
#  genptl.tcl                                                                 #
#  This script generates a Rational Rose File for the current Document        #
#  Rational Rose is a trademark of Rational Software corp.                    #
#  This script is just an example of the scripting capabilities in Object     #
#  domain, and is currently not a full translation                            #
#  Version 1.0                                                                #
###############################################################################


proc petal_header {fp} {
   puts $fp "(object Petal version 34)"
   puts $fp "(object Design \"<Top Level>\""
   puts $fp "  is_unit TRUE"
   # we could put some defaults here but I don;t know the exact meaning of all these
}


#################################################################################
#										#
#    petal_has_relationship                                                     #
#										#
#################################################################################
proc petal_has_relationship {fp attribute} {
  puts $fp "      (object Has_Relationship"
  set str [$attribute get name]
  if [string length $str] {
	puts $fp "        label \"$str\""
  }
  set str [$attribute get className]
  if [string length $str] {
	puts $fp "        supplier \"$str\""
  }
  puts $fp "      exportControl \"[$attribute get exportControl]\""
  puts $fp "      )"
}

#################################################################################
#										#
#    petal_has_relationship2                                                     #
#										#
#################################################################################
proc petal_has_relationship2 {fp rel} {
  puts $fp "      (object Has_Relationship"
  set str [$rel get name]
  if [string length $str] {
	puts $fp "        label \"$str\""
  }
  set to [$rel get to]
  set str [$to get name]
  if [string length $str] {
	puts $fp "        supplier \"$str\""
  }
  set str [$rel get fromCardinality]
  if [string length $str] {
	if {$str  != "unspecified"} {
	  puts $fp "        client_cardinality  (value cardinality \"$str\")"
	}
  }
  set str [$rel get toCardinality]
  if [string length $str] {
	if {$str  != "unspecified"} {
	  puts $fp "        supplier_cardinality  (value cardinality \"$str\")"
	}
  }
  set str [$rel get containment]
  if [string length $str] {
	puts $fp "        Containment \"by $str\""
  }
  puts $fp "      exportControl \"[$rel get exportControl]\""
  # check if static
  set str [$rel get relationProperty]
  if {$str == "static"} {
	puts $fp "        static   TRUE"

  } 
  puts $fp "      )"
}

#################################################################################
#										#
#    petal_uses_relationship                                                    #
#										#
#################################################################################
proc petal_uses_relationship {fp rel} {
  puts $fp "      (object Uses_Relationship"
  set str [$rel get name]
  if [string length $str] {
	puts $fp "        label \"$str\""
  }
  set to [$rel get to]
  set str [$to get name]
  if [string length $str] {
	puts $fp "        supplier \"$str\""
  }
  set str [$rel get fromCardinality]
  if [string length $str] {
	if {$str  != "unspecified"} {
	  puts $fp "        client_cardinality  (value cardinality \"$str\")"
        }
  }
  set str [$rel get toCardinality]
  if [string length $str] {
      if {$str  != "unspecified"} {
	puts $fp "        supplier_cardinality  (value cardinality \"$str\")"
      }
  }
  puts $fp "      exportControl \"[$rel get exportControl]\""
  # check if friend
  set str [$rel get relationProperty]
  if {$str == "friend"} {
	puts $fp "        friend   TRUE"

  } 
  puts $fp "      )"
}

#################################################################################
#										#
#    petal_operation                                                            #
#										#
#################################################################################
proc petal_operation {fp op} {
	puts $fp "      (object Operation \"[$op get name]\""


   puts $fp "      )"

}


#################################################################################
#										#
#    petal_class                                                                #
#										#
#################################################################################
proc petal_class {fp class_view} {
   # get the real class object from this class view
  set class [$class_view get class]
  puts $fp "(object Class \"[$class get name]\""
  # get all the attributes of this class
  set attribute_list [$class get attributes]
  set count 0
  if  [expr [llength $attribute_list]] {
    puts $fp "fields (list has_relationship_list"
  
  }
  foreach attribute $attribute_list {
    incr count
    petal_has_relationship $fp $attribute

  }
  # we also have to generate has relations from the ones in the diagrams
  # object domain does not automatically generate these in the attribute_list
  set connection_list [$class_view get connections]
  foreach con $connection_list {
	set ctype [$con get objectType]
	if {$ctype == "relation"} {
	  set rtype [$con get relationType]
	  if {$rtype == "has"} {
	    # check if this is the from side
		 if {[$con get from] == $class_view } {
			if {$count == 0} {
			  puts $fp "fields (list has_relationship_list"
			}
			incr count
			petal_has_relationship2 $fp $con
		 }
	  }
	}
  }
  if {$count != 0} {
	# put the closing brace for the has list
	puts $fp ")"
  }
  set count 0
  # dump the used nodes
  foreach con $connection_list {
	set ctype [$con get objectType]
	if {$ctype == "relation"} {
	  set rtype [$con get relationType]
	  if {$rtype == "use"} {
		 if {$count == 0} {
		puts $fp "used_nodes 	(list uses_relationship_list"
	    }
		 incr count
	    petal_uses_relationship $fp $con
	  }
        }
  }

 if {$count != 0} {
	# put the closing brace for the uses list
	puts $fp ")"
  }
 # superclasses
  set su_cls [$class get superclasses]
  if  [expr [llength $su_cls]] {
     puts $fp "superclasses 	(list inheritance_relationship_list"
     foreach sc $su_cls {
       puts $fp "(object Inheritance_Relationship"
       set clsi [expr [llength $sc] - 1 ]
       set scls [lindex $sc $clsi]
       puts $fp "supplier   	\"[$scls get name]\""
       puts $fp " exportControl  \"[ lindex $sc 0 ]\""
       if {$clsi == 2} { puts $fp "virtual    	TRUE" }
       puts $fp ")"
    }
    puts $fp ")"
  }
  # the operations
  set op_list [$class get operations]
  if  [expr [llength $op_list]] {
    puts $fp "  operations 	(list Operations"
  
  }
  foreach op $op_list {
      petal_operation $fp $op
  }
  if  [expr [llength $op_list]] {
	#end of the operation list
	puts $fp "  )"
  }
  # end of the class record
  puts $fp ")"


}

#################################################################################
#										#
#    petal_classview                                                       #
#										#
#################################################################################
proc petal_classview {fp classview} {
	 global  item_index_lst
	 global  petal_scale
	 lappend item_index_lst $classview
	 set ndx  [llength $item_index_lst]
	 set class [$classview get class]
	 set ptl_type [$class get type]
	 switch $ptl_type {
		class { set ptl_type "Class" }
		class_utility { set ptl_type "Class Utility" }
		parameterized_class { set ptl_type "Parameterized Class" }
		instantiated_class { set ptl_type "Instantiated Class" }
		parameterized_class_utility { set ptl_type "Parameterized Class Utility" }
		instantiated_class_utility { set ptl_type "Instantiated Class Utility" }
		metaclass { set ptl_type "Metaclass" }

	 }
	 puts $fp "			    (object ClassView \"$ptl_type\" \"[$classview get name]\" \@$ndx"
	 set origin [$classview get origin]
	 set box [$classview get bbx]
	 set max_width [expr $petal_scale *([lindex $box 2] - [lindex $box 0])]
	 set label_y [expr [lindex $box 3] - [lindex $box 1]]
	 set label_y [expr $petal_scale *(($label_y)/2 + [lindex $box 1])]

	 puts $fp "                location ( [expr $petal_scale * [lindex $origin 0]], [expr $petal_scale * [lindex $origin 1]] )"
	 puts $fp "                  label     ( object ItemLabel"
	 puts $fp "                       label \"[$classview get name]\")"
	 puts $fp "				annotation 	8)"

}

#################################################################################
#										#
#    petal_categoryview                                                       #
#										#
#################################################################################
proc petal_categoryview {fp catview} {
	 global  item_index_lst
	 global  petal_scale
	 lappend item_index_lst $catview
	 set ndx  [llength $item_index_lst]

	 puts $fp "		    (object CategoryView \"[$catview get name]\" @$ndx"
	 set origin [$catview get origin]
	 set box [$catview get  bbx]
	 set max_width [expr $petal_scale *([lindex $box 2] - [lindex $box 0])]
	 set label_y [expr [lindex $box 3] - [lindex $box 1]]
	 set label_y [expr $petal_scale *(($label_y)/2 + [lindex $box 1])]
	 puts $fp "                location ( [expr $petal_scale *[lindex $origin 0]], [expr $petal_scale *[lindex $origin 1]] )"
	 puts $fp "                  label     ( object ItemLabel"
	 puts $fp "                       label \"[$catview get name]\")"
	 puts $fp "			width      	[expr $petal_scale *([lindex $box 2] - [lindex $box 0])]"
	 puts $fp "			height     	[expr $petal_scale *([lindex $box 3] - [lindex $box 1])])"

}

#################################################################################
#										#
#    petal_relationview                                                       #
#										#
#################################################################################
proc petal_relationview {fp relview} {
	 global  item_index_lst
	 global petal_scale
	 # get the petal view name for the relation type
	 set rtype [$relview get relationType]
	 set ptl_object ""
	 switch $rtype {
		 generic { set ptl_object "RelationView" }
		 has     { set ptl_object "HasView" }
		 use     { set ptl_object "UsesView" }
		 inherits {set ptl_object "InheritView" }
		 instantiates { set ptl_object "InstantiateView" }
		 metarelation { set ptl_object "MetaView" }

	 }
	 puts $fp "		    (object $ptl_object \"[$relview get name]\""
	 set relname [$relview get name]
	 if [string length $relname] {
		puts $fp "		label      	(object ItemLabel"
		set origin [$relview get origin]
#		puts $fp "		    location   	( [expr $petal_scale *[lindex $origin 0]], [expr $petal_scale *[lindex $origin 1]] )"
#		puts $fp "			 anchor_loc 	1"
#		puts $fp "		    nlines     	1"
#		puts $fp "		    max_width  	450"
#		puts $fp "		    justify    	0"
	   puts $fp "		    label      	\"$relname\")"
	 }
	 set client [$relview get from]
	 set supplier [$relview get to]
	 puts $fp "		client     	@[expr [lsearch $item_index_lst $client] + 1]"
	 puts $fp "		supplier     	@[expr [lsearch $item_index_lst $supplier] + 1])"


}


#################################################################################
#										#
#    petal_class_category                                                       #
#										#
#################################################################################
proc petal_class_category {fp diagram} {
	puts $fp "( object Class_Category \"[$diagram get name]\""
	puts $fp "   exportControl 	   \"Public\""
   puts $fp "   global             TRUE"
   puts $fp "  subsystem \"[$diagram get name]\""
	puts $fp "  logical_models 	(list unit_reference_list"
   # get all the items on this diagram
	set unit_list [$diagram get objects]
   # first dump the classes
   foreach unit $unit_list {
	set unit_type [$unit get objectType]
		if {$unit_type == "class"} {
			petal_class $fp $unit
		}


   }
	# next dump the categories
	foreach unit $unit_list {
	set unit_type [$unit get objectType]
	if {$unit_type == "category"} {
		 set sub_diagram [$unit get subDiagram]
		 petal_class_category $fp $sub_diagram
	}


	}
	#end unit_reference_list
	puts $fp " )"

	# now dump the views
	puts $fp "	logical_presentations 	(list unit_reference_list"
	puts $fp "    (object ClassDiagram \"[$diagram get name]\""
	puts $fp "	title      	\"[$diagram get name]\""
	puts $fp "	zoom       	100"
	puts $fp "	max_height 	28350"
	puts $fp "	max_width  	21600"
	puts $fp "	origin_x   	0"
	puts $fp "	origin_y   	0"
	puts $fp "			items      	(list diagram_item_list"

	foreach unit $unit_list {
	  set unit_type [$unit get objectType]
	  switch $unit_type {
		  class {
				petal_classview $fp $unit
		  }
		  category {
				petal_categoryview $fp $unit
		  }

	  }
	}
	foreach unit $unit_list {
	  set unit_type [$unit get objectType]
	  switch $unit_type {
		relation {
		  petal_relationview $fp $unit

		}
	  }

	}
	# end diagram_item_list
	puts $fp "      )"
	# end ClassDiagram
	puts $fp "    )"
	#end  logical_presentations
	puts $fp " )"
	# end category
	puts $fp ")"



   

}

#################################################################################
#										#
#    petal_class_root_category                                                  #
#										#
#################################################################################
proc petal_class_root_category {fp diagram} {
   puts -nonewline $fp "root_category "
   petal_class_category $fp $diagram 
}



#################################################################################
#										#
#   Main entry point for this script                                            #
#										#
#################################################################################

set cl [OD_getClasses]

set filename [OD_getFile "Rational Rose Petal File" "*.ptl|*.ptl" "*.ptl"]


if [string length $filename] {
  set fp [open $filename w]
  # generate the header
  petal_header $fp
  flush $fp
  # get all the diagrams
  set diagram_list [OD_getDiagrams]
  set item_index_lst ""
  set petal_scale 3
  # loop over each diagram and if it's a top level diagram dump it
  foreach diagram $diagram_list {
     set parent [$diagram get parent]
	  if ![string length $parent] {
		 # this is a top level diagram
		 # dump it
		 set diagram_type [$diagram get type]
		 switch $diagram_type {
			class  { petal_class_root_category $fp $diagram }

		 }
     }

  }
  

	puts $fp ")"
	close $fp

  



} 



