' Relocate Associations Script
'
' (c) 1999 by Michael Moors
'
' Author: Michael Moors
' Date: 29 Nov 1999
'
' Description:
' This script relocates all associations that are not in the same package
' as one of the Classes (or Use Cases).
' If the association is uni-directional, it will relocate to the package
' of the client class (the class that can 'see' the other class). 
'

Sub RelocateAssociation (Ass As Association, Rol As Role)
  Dim cat As Category
  Dim cls As Class
  Set cls = Rol.class
  If Not cls Is Nothing Then
    Set cat = cls.parentcategory
    If Not ass.parentcategory Is cat Then
      cat.relocateassociation ass
    End If
  Else ' probably UseCase
    Dim uc As UseCase
	Set uc = rol.UseCase
    If Not uc Is Nothing Then
      Set cat = uc.parentcategory
	  If Not ass.parentcategory Is cat Then
        cat.relocateassociation ass
	  End If
	Else 'I don't know, might be unloaded / dangling / unresolved
	   ' skip, we might log a warning
	End If
  End If
End Sub

Sub Main
  Dim asscol As New AssociationCollection
  Dim ass As Association

  Dim catcol As CategoryCollection
  Dim cat As Category
  Dim x As Long

  ' Create collection of all associations
  Set catcol = roseapp.currentmodel.getallcategories
  For x = 1 To catcol.count
    Set cat = catcol.getat(x)
    asscol.addcollection cat.associations
  Next x

  ' Relocate associations
  For x = 1 To asscol.count
    Set ass = asscol.getat(x)
	If ass.role1.navigable Then
	  If Not ass.role2.navigable Then
	    ' relocate with role 2 (opposite)
		RelocateAssociation ass, ass.role2
	  Else
	    ' both associations navigable, relocate with role 2 (opposite)
		RelocateAssociation ass, ass.role2
	  End If
	Else
	  If Not ass.role2.navigable Then
	    ' Non is navigable, relocate with role 2 (opposite)
		RelocateAssociation ass, ass.role2
	  Else
	    ' only Role 2 is navigable, relocate with role 1 (opposite)
		RelocateAssociation ass, ass.role1
	  End If
	End If
  Next x
End Sub