# Description: Objet Domain TCL script for document generation
# Module:      gendocs.tcl
# Author:      Chris Turner
# Created:     13 March 1996
# Version:     1.1
# release: 001 13 MAR 96 by CDT - initial release
# release: 002 24 MAR 96 by CDT - modified to output in RTF format
# release: 003 05 APR 96 by CDT - enhanced functionality

# SCCS Version Control:
# %Z% %M% 1.%I% %E% Chris Turner

# Copyright (c) 1996 All Rights Reserved.
# This module may be used of modified as required without prior
# permission of the author. Please send bug reports and suggestions
# to chris@skipoles.demon.co.uk

# Generates system documentation in RTF format
# This can be used by all good wordprocessors

# ----------------------------------------------------------------------
# dump_attributes
# Write the attribute information to the file
proc dump_attributes {fp cls exportControl} {
  set attlist [$cls get attributes]
  foreach att $attlist {
    if {[$att get exportControl] == $exportControl} {
      puts -nonewline $fp "\\par \\plain\\f2\\fs20\\tab "
      if {[$att get isStatic] == 1} {puts -nonewline $fp "static "}
      if {[$att get isConst] == 1} {puts -nonewline $fp "const "}

      puts -nonewline $fp "[$att get className] "
      if {[$att get isPointer] == 1} {puts -nonewline $fp "*"}
      if {[$att get isReference] == 1} {puts -nonewline $fp "&"}
      puts -nonewline $fp "[$att get name]"
      if {[llength [$att get defaultValue]] != 0} {
        puts -nonewline $fp " = [$att get defaultValue]"
      }
      puts $fp " "
    }
  }
  puts $fp "\\plain\\f1\\fs20"
}

# ----------------------------------------------------------------------
# dump_operations
# Write the operations information to the file
proc dump_operations {fp cls exportControl details} {
  set oplist [$cls get operations]
  foreach op $oplist {
    if {[$op get exportControl] == $exportControl} {
      puts $fp "\\par \{\\i Prototype:\}"
      puts -nonewline $fp "\\par \\plain\\f2\\fs20\\tab "

      set proto " "
      if {[$op get isStatic] == 1} {append proto "static "}
      if {[$op get isVirtual] == 1} {append proto "virtual "}
      if {[$op get isReturnTypeConst] == 1} {append proto "const "}

      set proto "$proto[$op get returnType]"
      if {[$op get isReturnTypePointer] == 1} {append proto " *"}
      if {[$op get isReturnTypeReference] == 1} {append protot " &"}

      set proto "$proto [$op get name]("
      puts -nonewline $fp $proto
      set par_list [$op get parameters]
      set count 0
      foreach p $par_list {
        if {$count==0} {
          puts -nonewline $fp "[$p get name]"
        } else {
          puts -nonewline $fp ",\n\\par \\tab "
          set loopcnt 0
          while {$loopcnt<[string length $proto]} {
            puts -nonewline $fp " "
            incr loopcnt
          }
          puts $fp "[$p get name]"
        }
        incr count
      }
      puts -nonewline $fp ")"
      if {[$op get isConst] == 1} {puts -nonewline $fp " const"}
      if {[$op get isPure] == 1} {puts -nonewline $fp "=0"}
      if {[$op get isInline] == 1} {puts -nonewline $fp " \{ \}"}
      puts $fp " "

      # now dump additional information
      # starting with the description
      puts $fp "\\par \\plain\\f1\\fs20\{\\i Description:\}"
      set desc [$op get description]
      if [expr [llength $desc]] {
        puts -nonewline $fp "\\par "
        foreach word $desc {
          puts -nonewline $fp "$word "
        }
        puts $fp " "
      }
      
      # now do the preconditions
      set desc [$op get precondition]
      if [expr [llength $desc]] {
        puts $fp "\\par \\plain\\f1\\fs20\{\\i Preconditions:\}"
        set count 0
        set max [string length $desc]
        puts -nonewline $fp "\\par \\plain\\f2\\fs20"
        while {$count<$max} {
          if {[string index $desc $count]=="\n"} {
            puts -nonewline $fp "\\par "
          } else {
            puts -nonewline $fp "[string index $desc $count]"
          }
          incr count
        }
        puts $fp " "
      }

      # now the post conditions
      set desc [$op get postcondition]
      if [expr [llength $desc]] {
        puts $fp "\\par \\plain\\f1\\fs20\{\\i Postconditions:\}"
        set count 0
        set max [string length $desc]
        puts -nonewline $fp "\\par \\plain\\f2\\fs20"
        while {$count<$max} {
          if {[string index $desc $count]=="\n"} {
            puts -nonewline $fp "\\par "
          } else {
            puts -nonewline $fp "[string index $desc $count]"
          }
          incr count
        }
        puts $fp " "
      }

      # now the semantics
      set desc [$op get semantics]
      if [expr [llength $desc]] {
        puts $fp "\\par \\plain\\f1\\fs20\{\\i Semantics:\}"
        set count 0
        set max [string length $desc]
        puts -nonewline $fp "\\par \\plain\\f2\\fs20"
        while {$count<$max} {
          if {[string index $desc $count]=="\n"} {
            puts -nonewline $fp "\\par "
          } else {
            puts -nonewline $fp "[string index $desc $count]"
          }
          incr count
        }
        puts $fp " "
      }

      # now the exceptions
      set desc [$op get exceptions]
      if [expr [llength $desc]] {
        puts -nonewline $fp "\\par \\plain\\f1\\fs20 \{\\i Exceptions:\}"
        puts $fp "\\tab [$op get exceptions]"
      }

      puts $fp "\\plain\\f1\\fs20"   

      # dump extra details
      if {$details=="YES"} {
        # dump concurrency
        puts $fp "\\par \{\\i Concurrency:\}\\tab [$op get concurrency]"

        # dump qualification
        if {[llength [$op get qualification]] != 0} {
          puts $fp "\\par \{\\i Qualification:\} \\tab [$op get qualification]"
        }

        # dump protocol
        if {[llength [$op get protocol]] != 0} {
          puts $fp "\\par \{\\i Protocol:\}\\tab [$op get protocol]"
        }

        # dump space
        if {[llength [$op get space]] != 0} {
          puts $fp "\\par \{\\i Space:\}\\tab \\tab [$op get space]"
        }

        # dump time
        if {[llength [$op get time]] != 0} {
          puts $fp "\\par \{\\i Time:\}\\tab \\tab [$op get time]"
        }
      }
      puts $fp "\\par \\plain\\f1\\fs20"   
    }
  }
}

# ----------------------------------------------------------------------
# dump_class
# Writes the class information to the file
proc dump_class {class fp details} {
  # Dump class name
  puts -nonewline $fp "\\par \\plain\\f1\\fs20\{\\b Class Name:\}"
  puts -nonewline $fp "\\tab \\tab [$class get name]"
  if {[$class get type] != "class"} {
    puts -nonewline $fp " (type=[$class get type])"
  }
  if {[$class get isAbstract] == 1} { puts -nonewline $fp " (Abstract)" }
  puts $fp " "

  # Dump superclasses
  set superclasses [$class get superclasses]
  if [expr [llength $superclasses]] {
    puts -nonewline $fp "\\par \{\\b Superclasses:\}"
    set count 0
    foreach sc $superclasses {
      if {$count > 0} {
        puts -nonewline $fp ","
      } else {
        puts -nonewline $fp " \\tab \\tab "
      }
      set clsi [expr [llength $sc] - 1]
      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 -nonewline $fp [$scls get name]
      incr count
    }
    puts $fp " "
  }
    
  # Dump parameter details
  if {[$class get type] == "parameterized_class"} {
    puts -nonewline $fp "\\par \{\\b Parameters:\}"
    set plist [$class get parameters]
    set count 0
    foreach p $plist {
      if {$count > 0} {
        puts -nonewline $fp ","
      } else {
        puts -nonewline $fp "\\tab \\tab "
      }
      puts -nonewline $fp [$p get name]
      incr count
    }
    puts $fp " "
  }

  # Dump responsibilities
  puts $fp "\\par \{\\b Responsibilities:\}"
  set desc [$class get responsibilities]
  if [expr [llength $desc]] {
    puts -nonewline $fp "\\par "
    foreach word $desc {
      puts -nonewline $fp "$word "
    }
    puts $fp " "
  }

  # Dump export control
  puts -nonewline $fp "\\par \{\\b Export Control:\}"
  puts $fp " \\tab [$class get exportControl]"

  if {$details=="YES"} {
    # Dump persistence
    puts $fp "\\par \{\\b Persistence:\}\\tab \\tab [$class get persistence]"

    # Dump concurrency
    puts $fp "\\par \{\\b Concurrency:\}\\tab \\tab [$class get concurrency]"

    # Dump cardinality
    if {[llength [$class get cardinality]] != 0} {
      puts $fp "\\par \{\\b Cardinality:\}\\tab \\tab [$class get cardinality]"
    }

    # Dump space
    if {[llength [$class get space]] != 0} {
      puts $fp "\\par \{\\b Space:\}\\tab \\tab \\tab [$class get space]"
    }
  }

  # Dump attributes
  set attlist [$class get attributes]
  if {[llength $attlist] != 0} {
    puts $fp "\\par \{\\b Attributes:\}"
  }
  set count 0
  foreach att $attlist {
    if {[$att get exportControl] == "private"} {incr count}
  }
  if {$count != 0} {
    puts $fp "\\par \{\\b\\i private\}"
  }
  dump_attributes $fp $class private
  set count 0
  foreach att $attlist {
    if {[$att get exportControl] == "protected"} {incr count}
  }
  if {$count != 0} {
    puts $fp "\\par \{\\b\\i protected\}"
  }
  dump_attributes $fp $class protected
  set count 0
  foreach att $attlist {
    if {[$att get exportControl] == "public"} {incr count}
  }
  if {$count != 0} {
    puts $fp "\\par \{\\b\\i public\}"
  }
  dump_attributes $fp $class public
  
  # Dump operations
  set oplist [$class get operations]
  if {[llength $oplist] != 0} {
    puts $fp "\\par \{\\b Operations:\}"
  }
  set count 0
  foreach op $oplist {
    if {[$op get exportControl] == "private"} {incr count}
  }
  if {$count != 0} {
    puts $fp "\\par \{\\b\\i private\}"
  }
  dump_operations $fp $class private $details
  set count 0
  foreach op $oplist {
    if {[$op get exportControl] == "protected"} {incr count}
  }
  if {$count != 0} {
    puts $fp "\\par \{\\b\\i protected\}"
  }
  dump_operations $fp $class protected $details
  set count 0
  foreach op $oplist {
    if {[$op get exportControl] == "public"} {incr count}
  }
  if {$count != 0} {
    puts $fp "\\par \{\\b\\i public\}"
  }
  dump_operations $fp $class public $details

  puts $fp "\\par"
}  

# ----------------------------------------------------------------------
# Main script
set diagram [OD_getActiveDiagram]
set dt [$diagram get type]
if {"class" != $dt} {
  OD_giveMessage "Error" "Diagram is not a class diagram" exclamation
} else {
  set details [OD_giveMessage "Detail" "Document all details" question]

  # setup the document file
  set filename [OD_getFile "Destination filename" "*.rtf|*.rtf" "*.rtf"]
  set fp [open $filename w]

  # Standard RTF header for Ariel font
  puts $fp "\{\\rtf1\\ansi\\deff0\{\\fonttbl\{\\f0\\froman Times New Roman;\}\{\\f1\\fswiss Arial;\}\{\\f2\\fnill Courier New;\}\}"
  puts -nonewline $fp "\{\\colortbl\\red0\\green0\\blue0;\}"
  puts $fp "\\pard\\plain\\f1\\fs24\{\\b Class Category: [$diagram get name]\}"
  puts $fp "\\par"

  if {$details=="YES"} {
    OD_log "Documenting full details to file: $filename"
  } else {
    OD_log "Documenting partial details to file: $filename"
  }

  # loop over all classes in the diagram
  set items [$diagram get objects]
  foreach item $items {
    if {[$item get objectType] == "class"} {
      # only dump if object is selected
      if {[$item get isSelected] == 1} {
        OD_log "Adding class: [[$item get class] get name]"
        dump_class [$item get class] $fp $details
      }
    }
  }
  puts $fp "\}"
  close $fp
  OD_giveMessage "Generate Documentation" "RTF file has been generated" information
}



