home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / class_gens.tcl < prev    next >
Text File  |  1997-01-09  |  4KB  |  162 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #    (c) Cadre Technologies Inc. 1995
  4. #
  5. #    File:        @(#)class_gens.tcl    /main/titanic/1
  6. #    Author:        Harm Leijendeckers
  7. #    Description:    Report on class generalizations
  8. #    Usage in:    SystemVersion and CAD editor
  9. #
  10. #---------------------------------------------------------------------------
  11. # SccsId = @(#)class_gens.tcl    /main/titanic/1    9 Jan 1997    Copyright 1995 Cadre Technologies Inc.
  12.  
  13.  
  14. eval [$cc getCustomFileContents semanticbase tcl reports]
  15.  
  16.  
  17. #---------------------------------------------------------------------------
  18.  
  19. Class BaseClass : {GCObject} {
  20.     constructor
  21.  
  22.     attribute class
  23.     attribute nrIn
  24. }
  25.  
  26. constructor BaseClass {class this cl} {
  27.     set this [GCObject::constructor $class $this]
  28.  
  29.     $this class $cl
  30.  
  31.     $this nrIn [llength [$cl getOppositeObjectsIn $OMT_CAD_CB_GenConn \
  32.                           $OMT_CAD_CB_Generalization]]
  33.     return $this
  34. }
  35.  
  36. #---------------------------------------------------------------------------
  37.  
  38.  
  39. Class ReportClassGens : {SemanticBase} {
  40.     constructor
  41.     method systemReport
  42.     method doReport
  43.  
  44.     method doClass
  45.  
  46.     attribute done
  47. }
  48.  
  49.  
  50. constructor ReportClassGens {class this} {
  51.     set this [SemanticBase::constructor $class $this]
  52.  
  53.     $this reportName "Class Generalizations"
  54.  
  55.     return $this
  56. }
  57.  
  58.  
  59. method ReportClassGens::systemReport {this} {
  60.     return [$this phaseReport]
  61. }
  62.  
  63.  
  64. method ReportClassGens::doReport {this model} {
  65.     # get all CAD Classes
  66.     set classes [concat [$model getSMObjects $OMT_CAD_CB_Class]]
  67.     if [lempty $classes] { return 0 }
  68.  
  69.     set all [concat [query "getItem.isNil == 1" $classes] \
  70.             [osort getItem.name [query "getItem.isNil == 0" $classes]]]
  71.  
  72.     foreach class [sortSMObjects classes] {
  73.     lappend allBases [BaseClass new $class]
  74.     }
  75.  
  76.     set allDone ""
  77.     set allBasesWithNoIns [query -s class "nrIn == 0" $allBases]
  78.     foreach base [sortSMObjects allBasesWithNoIns] {
  79.     set done ""
  80.     $this doClass $base 0 Normal done
  81.     [$this report] line
  82.     set allDone [concat $allDone $done]
  83.     }
  84.  
  85.     # If there are classes left, they are part of a 'loop'. This is considered
  86.     # as a design error. Therefor the algorythm to print it is very straight-
  87.     # forward: Print a generalizationtree foreach class in the loop.
  88.     if { $allDone != "" } {
  89.     foreach base [query "! class in {$allDone}" $allBases] {
  90.         set done ""
  91.         $this doClass [$base class] 0 Normal done
  92.         [$this report] line
  93.     }
  94.     }
  95.  
  96.     [$this report] page
  97.     return 0
  98. }
  99.  
  100. method ReportClassGens::doClass {this class level type _done} {
  101.     upvar 1 $_done done
  102.  
  103.     if { [lsearch -exact $done $class] != -1 } {
  104.     return
  105.     }
  106.     lappend done $class
  107.  
  108.     set report [$this report]
  109.     set allNormalGens  [$class getOppositeObjectsOut $OMT_CAD_GenConn \
  110.                              $OMT_CAD_Generalization]
  111.     set allOverlapGens [$class getOppositeObjectsOut $OMT_CAD_OverlapGenConn \
  112.                              $OMT_CAD_OverlapGen]
  113.  
  114.     # print nothing if there are no subclasses
  115.     #if { $level == 0 && [lempty $allNormalGens] && [lempty $allOverlapGens] } {
  116.     #return
  117.     #}
  118.  
  119.     # print lines iso spaces
  120.     #$report print "   |" [expr $level * 4] fill
  121.  
  122.     $report space [expr $level * 4]
  123.     if { $type == "Normal" } {
  124.     $report print "- "
  125.     } else {
  126.     $report print "* "
  127.     }
  128.  
  129.     $report print [$this objName $class] line
  130.  
  131.     # all generalizations
  132.     foreach gen $allNormalGens {
  133.     set allSubs [$gen getOppositeObjectsOut $OMT_CAD_GenConn \
  134.                         $OMT_CAD_CB_Class]
  135.     foreach sub [sortSMObjects allSubs] {
  136.         $this doClass $sub [expr $level+1] Normal done
  137.     }
  138.     }
  139.  
  140.     # all generalizations
  141.     foreach gen [$class getOppositeObjectsOut $OMT_CAD_OverlapGenConn \
  142.                         $OMT_CAD_OverlapGen] {
  143.     set allSubs [$gen getOppositeObjectsOut $OMT_CAD_OverlapGenConn \
  144.                         $OMT_CAD_CB_Class]
  145.     foreach sub [sortSMObjects allSubs] {
  146.         $this doClass $sub [expr $level+1] Overlap done
  147.     }
  148.     }
  149. }
  150.  
  151.  
  152. proc sortSMObjects {_orig } {
  153.     upvar 1 $_orig orig
  154.     return [concat [query "getItem.isNil == 1" $orig] \
  155.            [osort getItem.name [query "getItem.isNil == 0" $orig]]]
  156. }
  157.  
  158.  
  159. # ----------------------------------------------------------------------
  160. #
  161. set executeMe [ReportClassGens new]
  162.