###############################################################################
#                                                                             #
#  gendoc.tcl                                                                 #
#  This script generates documentation for all classes in the design          #
#  Version 1.0                                                                #
###############################################################################

###############################################################################
#
#  dump_att_doc : generates the documentation for a class attribute
#
###############################################################################

 proc dump_att_doc { fp att} {
	 puts -nonewline $fp "    Attribute : "
	 puts $fp [$att get name]
	 puts -nonewline $fp "      ClassName : "
	 puts $fp [$att get className]
	 puts -nonewline $fp "      defaultValue : "
	 puts $fp [$att get defaultValue]
	 puts -nonewline $fp "      export control : "
	 puts $fp [$att get exportControl]
 }

###############################################################################
#
#  dump_op_doc : generates the documentation for a class operation
#
###############################################################################
 proc dump_op_doc { fp op} {
	 puts -nonewline $fp "    Operation : "
	 puts $fp [$op get name]
	 set par_list [$op get parameters]
	 if  [expr [llength $par_list]] {
		# dump the parameters
		puts $fp  "      Parameters :"
	 }
	 foreach par $par_list {
		puts -nonewline $fp "        "
		puts $fp [$par get name]
	 }
	 puts -nonewline $fp "      return type : "
	 puts $fp [$op get returnType]
	 puts -nonewline $fp "      Description : "
	 puts $fp [$op get description]
	 puts -nonewline $fp "      Export Control : "
	 puts $fp [$op get exportControl]
	 puts -nonewline $fp "      Concurrency : "
	 puts $fp [$op get concurrency]
	 puts -nonewline $fp "      Qualification : "
	 puts $fp [$op get qualification]
	 puts -nonewline $fp "      Protocol : "
	 puts $fp [$op get protocol]
	 puts -nonewline $fp "      Exceptions : "
	 puts $fp [$op get exceptions]
	 puts -nonewline $fp "      Space : "
	 puts $fp [$op get space]
	 puts -nonewline $fp "      Time : "
	 puts $fp [$op get time]
	 puts -nonewline $fp "      PreCondition : "
	 puts $fp [$op get precondition]
	 puts -nonewline $fp "      Semantics : "
	 puts $fp [$op get semantics]
	 puts -nonewline $fp "      PostCondition : "
	 puts $fp [$op get postcondition]
}

###############################################################################
#
#  dump_relations : prints out all the classes has relations
#
###############################################################################

proc dump_relations { fp cls rtype} {
  set item_list [$cls get views];
  foreach  cv $item_list {
	 # check all the relations connected to this
	 set rel_list [$cv  get connections]
	 foreach rel $rel_list {
		if { [$rel get objectType] == "relation" } {
		  set scls [$rel get to]
		  if {[$scls get class] == $cls} continue
		  # check if a relation of the correct type relations
		  if { [$rel get relationType] == $rtype} {
                       puts $fp "   [$scls get name]"
                  }
                }
          }
   }

}


###############################################################################
#
#  dump_class_doc : generates the documentation for a class
#
###############################################################################
 proc dump_class_doc { fp cls} {
  # write the class name
  puts $fp "class : [$cls get name]"
  puts $fp "  Type : [$cls get type]"
  # get the class super classes
  # this returns a list of lists
  # the length of each sublist is 2 or 3
  # the first element  is the export control : public,private,protected
  # in case of three elements in the second field is virtual
  # the last element is a class element
  set su_cls [$cls get superclasses]
  if  [expr [llength $su_cls]] {
	  puts $fp  "  superclasses :"
  }
  foreach sc $su_cls {
	  set clsi [expr [llength $sc] - 1 ]
	  puts -nonewline $fp "    "
	  switch $clsi {
		  1 { puts -nonewline $fp [ lindex $sc 0 ] }
		  2 { puts -nonewline $fp [ lrange $sc 0 1 ] }
	  }
	  puts -nonewline $fp " "
	  set scls [lindex $sc $clsi]
	  puts $fp  [$scls get name]
  }
  set par_list [$cls get parameters]
  if  [expr [llength $par_list]] {
	  # dump the parameters
	  puts $fp  "  parameters :"
  }
  foreach par $par_list {
	  puts  $fp "    [$par get name]"
  }
  if [$cls get isAbstract] {
	  puts $fp  "  class is abstract"
  }
  # dump the attibutes
  set att_list [$cls get attributes]
  if  [expr [llength $att_list]] {
	  puts $fp  "  attributes :"
  }
  foreach att $att_list {
	dump_att_doc $fp $att
	puts $fp  " "
  }
  puts $fp "  has relations "
  dump_relations $fp $cls "has"

  puts $fp "  uses relations "
  dump_relations $fp $cls "use"

  # dump the operations
  set op_list [$cls get operations]
  if  [expr [llength $op_list]] {
	  puts $fp  "  operations :"
  }
  foreach op $op_list {
	dump_op_doc $fp $op
	puts $fp  " "
  }
  # dump the constraints
  set con_list [$cls get constraints]
  if  [expr [llength $con_list]] {
	  puts $fp  "  constraints :"
  }
  foreach con $con_list {
	  puts -nonewline $fp "    [$con get name]"
  }
  if  [expr [llength $con_list]] {
	  puts $fp  "  "
  }
  puts $fp "  stateMachine : [$cls get stateMachine]"
  puts $fp "  Cardinality : [$cls get cardinality]"
  puts $fp "  Persistence : [$cls get persistence]"
  puts $fp "  Concurrency : [$cls get concurrency]"
  puts $fp "  Export Control : [$cls get exportControl]"
  puts $fp "  Responsibilities : "
  puts $fp [$cls get responsibilities]
  puts $fp "  Space : [$cls get space]"

  # dump all the diagrams in which this diagram is visible

  set v_list [$cls get views]
  puts $fp "  Shown in the following categories : "

 foreach v $v_list {
			puts  -nonewline $fp "    "
			set dia [$v get diagram]
			puts $fp [$dia get name]

  }


}



###############################################################################
#
#  dump_class_superclasses : generates a list of all the classes superclasses
#  this procedure does not use the builtin "get superclasses" routine
#  but extracts this information by navigating through the diagrams!
#
###############################################################################

proc dump_class_superclasses { fp cls} {

  puts -nonewline $fp "class : "
  puts $fp [$cls get name]
  set scc 0
  # find out the inheritance
  # this is currently not directly accessible from the script
  set item_list [$cls get views];
  foreach  cv $item_list {
	 # check all the relations connected to this
	 set rel_list [$cv  get connections]
	 foreach rel $rel_list {
		if { [$rel get objectType] == "relation" } {
		  set scls [$rel get to]
		  if {[$scls get class] == $cls} continue
		  # check if an inherits relations
		  if { [$rel get relationType] == "inherits"} {
			 if {$scc == 0} {puts $fp "  superclasses :"  }
			 incr scc
			 puts -nonewline $fp "      "
			 if { [$rel  get relationProperty] == "virtual" } {
				puts -nonewline  $fp "virtual "
			 }
			 puts -nonewline $fp [$rel get exportControl]
			 puts -nonewline $fp " "
			 # put the name of the other class
			 puts $fp [$scls get name]
		  }
		  if { [$rel get relationType] == "instantiates"} {
			 if ($scc == 0) { puts $fp "    superclasses :" }
			 incr scc
			 puts -nonewline $fp "      "
			 if { [$rel  get relationProperty] == "virtual" } {
				  puts -nonewline $fp "virtual "
			 }
			 puts -nonewline $fp [$rel get exportControl]
			 puts -nonewline  $fp "virtual "
			 # put the name of the other class
			 puts -nonewline $fp { [$scls get name ]  "<" }
			 # dump all the parameters
			 set par_list [$cls get parameters]
			 set pc 0
			 foreach par $par_list {
				if { $pc > 0} puts -nonewline $fp ","
				puts -nonewline $fp $par 
				incr pc
			 }
		  }
		}
	 }
  }
}



###############################################################################
#
#   THIS IS THE ACTUAL START OF THE SCRIPT !
#
###############################################################################

# prompt for a file name

set filename [OD_getFile "Documenation File" "*.txt|*.txt" "*.txt"]


if [string length filename] {
set fp [open $filename w]


puts $fp "documentation generated by Object Domain"
puts $fp "****************************************\r\n"
flush $fp
set cl [OD_getClasses]

 foreach c $cl {
	dump_class_doc $fp $c
	puts $fp "\n**************************************************************\n"

 }
}
close $fp

