Updating to the new transforms
git-svn-id: https://projects.brucker.ch/su4sml/svn/su4sml/trunk@7151 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Martin Bill
parent
942c22a41f
commit
928a9a21ef
|
|
@ -55,32 +55,32 @@ type operation = { name : string,
|
|||
visibility : Visibility
|
||||
}
|
||||
|
||||
type associationend = {name : Rep_OclType.Path (* path_of_association @ [aend_name]*),
|
||||
aend_type : Rep_OclType.OclType, (* participant type *)
|
||||
multiplicity: (int * int) list,
|
||||
ordered: bool,
|
||||
visibility: Visibility,
|
||||
init: Rep_OclTerm.OclTerm option
|
||||
}
|
||||
type associationend= {name: Rep_OclType.Path (* pathOfAssociation@[aendName]*),
|
||||
aend_type : Rep_OclType.OclType (* participant type *),
|
||||
multiplicity: (int * int) list,
|
||||
ordered: bool,
|
||||
visibility: Visibility,
|
||||
init: Rep_OclTerm.OclTerm option
|
||||
}
|
||||
|
||||
type attribute = {
|
||||
name : string,
|
||||
attr_type : Rep_OclType.OclType,
|
||||
visibility : Visibility,
|
||||
scope: Scope,
|
||||
stereotypes: string list,
|
||||
stereotypes: string list,
|
||||
init : Rep_OclTerm.OclTerm option
|
||||
}
|
||||
|
||||
type association = { name: Rep_OclType.Path (* path_of_package @ [assoc_name] *),
|
||||
type association = { name: Rep_OclType.Path (* pathOfPackage@[assocName] *),
|
||||
aends: associationend list,
|
||||
aclass: Rep_OclType.Path option
|
||||
aclass: Rep_OclType option
|
||||
}
|
||||
|
||||
type constraint = (string option * Rep_OclTerm.OclTerm)
|
||||
|
||||
datatype Classifier =
|
||||
Class of
|
||||
Class of
|
||||
{ name : Rep_OclType.OclType,
|
||||
parent : Rep_OclType.OclType option,
|
||||
attributes : attribute list,
|
||||
|
|
@ -92,7 +92,7 @@ datatype Classifier =
|
|||
thyname : string option,
|
||||
activity_graphs : Rep_ActivityGraph.ActivityGraph list
|
||||
}
|
||||
| AssociationClass of (* billk_tag *)
|
||||
| AssociationClass of (* billk_tag *)
|
||||
{ name : Rep_OclType.OclType,
|
||||
parent : Rep_OclType.OclType option,
|
||||
attributes : attribute list,
|
||||
|
|
@ -101,9 +101,9 @@ datatype Classifier =
|
|||
stereotypes : string list,
|
||||
interfaces : Rep_OclType.OclType list,
|
||||
thyname : string option,
|
||||
activity_graphs : Rep_ActivityGraph.ActivityGraph list,
|
||||
(* visibility : Visibility,
|
||||
isActive : bool,
|
||||
activity_graphs : Rep_ActivityGraph.ActivityGraph list,
|
||||
(* visibility : Visibility,
|
||||
isActive : bool,
|
||||
generalizations : string list,
|
||||
taggedValue : TaggedValue list,
|
||||
clientDependency : string list,
|
||||
|
|
@ -197,15 +197,18 @@ val connected_classifiers_of : association list -> Classifier -> Classifier list
|
|||
val aend_to_attr_type : associationend -> Rep_OclType.OclType
|
||||
|
||||
val update_thyname : string -> Classifier -> Classifier
|
||||
val update_invariant : (string option * Rep_OclTerm.OclTerm) list -> Classifier -> Classifier
|
||||
val update_invariant : (string option * Rep_OclTerm.OclTerm) list ->
|
||||
Classifier -> Classifier
|
||||
val update_operations : operation list -> Classifier -> Classifier
|
||||
|
||||
val update_precondition : (string option * Rep_OclTerm.OclTerm) list -> operation -> operation
|
||||
val update_postcondition : (string option * Rep_OclTerm.OclTerm) list -> operation -> operation
|
||||
val update_precondition : (string option * Rep_OclTerm.OclTerm) list ->
|
||||
operation -> operation
|
||||
val update_postcondition : (string option * Rep_OclTerm.OclTerm) list ->
|
||||
operation -> operation
|
||||
|
||||
val addInvariant : constraint -> Classifier -> Classifier
|
||||
val addInvariants: constraint list -> Classifier -> Classifier
|
||||
val addOperation : operation -> Classifier -> Classifier
|
||||
|
||||
|
||||
|
||||
exception InvalidArguments of string
|
||||
|
||||
|
|
@ -249,8 +252,8 @@ type attribute = {
|
|||
|
||||
|
||||
type association = { name: Rep_OclType.Path,
|
||||
aends: associationend list,
|
||||
aclass: Rep_OclType.Path option
|
||||
aends: associationend list,
|
||||
aclass: Rep_OclType.Path option
|
||||
}
|
||||
|
||||
type constraint = (string option * Rep_OclTerm.OclTerm)
|
||||
|
|
@ -1004,36 +1007,100 @@ fun addInvariant inv (Class {name, parent, attributes, operations,
|
|||
stereotypes=stereotypes, interfaces=interfaces,
|
||||
thyname=thyname, activity_graphs=activity_graphs}
|
||||
| addInvariant inv (AssociationClass {name, parent, attributes,
|
||||
operations, associations,
|
||||
association, invariant,
|
||||
stereotypes, interfaces,
|
||||
thyname, activity_graphs})
|
||||
= AssociationClass {name=name, parent=parent, attributes=attributes,
|
||||
operations=operations, associations=associations,
|
||||
association=association, invariant=inv::invariant,
|
||||
stereotypes=stereotypes, interfaces=interfaces,
|
||||
thyname=thyname, activity_graphs=activity_graphs}
|
||||
operations, associations,
|
||||
association, invariant,
|
||||
stereotypes, interfaces,
|
||||
thyname, activity_graphs})
|
||||
= AssociationClass {name=name, parent=parent, attributes=attributes,
|
||||
operations=operations, associations=associations,
|
||||
association=association, invariant=inv::invariant,
|
||||
stereotypes=stereotypes, interfaces=interfaces,
|
||||
thyname=thyname, activity_graphs=activity_graphs}
|
||||
| addInvariant inv (Interface {name, parents, operations,
|
||||
invariant, stereotypes, thyname})
|
||||
invariant, stereotypes, thyname})
|
||||
= Interface {name=name, parents=parents, operations=operations,
|
||||
invariant=inv::invariant, stereotypes=stereotypes, thyname=thyname}
|
||||
invariant=inv::invariant, stereotypes=stereotypes,
|
||||
thyname=thyname}
|
||||
| addInvariant inv (Enumeration {name, parent, operations,
|
||||
literals, invariant, stereotypes,
|
||||
interfaces, thyname})
|
||||
= Enumeration{name=name, parent=parent, operations=operations,literals=literals,
|
||||
invariant=inv::invariant, stereotypes=stereotypes,
|
||||
literals, invariant, stereotypes,
|
||||
interfaces, thyname})
|
||||
= Enumeration{name=name, parent=parent, operations=operations,
|
||||
literals=literals,invariant=inv::invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces, thyname=thyname}
|
||||
| addInvariant inv (Primitive {name, parent, operations,
|
||||
associations, invariant,
|
||||
stereotypes, interfaces, thyname})
|
||||
associations, invariant,
|
||||
stereotypes, interfaces, thyname})
|
||||
= Primitive{name=name, parent=parent, operations=operations,
|
||||
associations=associations, invariant=inv::invariant,
|
||||
stereotypes=stereotypes, interfaces=interfaces, thyname=thyname}
|
||||
stereotypes=stereotypes, interfaces=interfaces,
|
||||
thyname=thyname}
|
||||
| addInvariant inv (Template {parameter, classifier})
|
||||
= Template { parameter=parameter,
|
||||
classifier=addInvariant inv classifier
|
||||
}
|
||||
|
||||
fun addInvariants invs (Class {name, parent, attributes, operations,
|
||||
associations, invariant, stereotypes,
|
||||
interfaces, thyname, activity_graphs}) =
|
||||
Class {name=name,
|
||||
parent=parent,
|
||||
attributes=attributes,
|
||||
operations=operations,
|
||||
associations=associations,
|
||||
invariant=invs@invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname,
|
||||
activity_graphs=activity_graphs}
|
||||
| addInvariant invs (AssociationClass {name, parent, attributes,
|
||||
operations, associations,
|
||||
association, invariant,
|
||||
stereotypes, interfaces,
|
||||
thyname, activity_graphs}) =
|
||||
AssociationClass {name=name,
|
||||
parent=parent,
|
||||
attributes=attributes,
|
||||
operations=operations,
|
||||
associations=associations,
|
||||
association=association,
|
||||
invariant=invs@invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname,
|
||||
activity_graphs=activity_graphs}
|
||||
| addInvariant invs (Interface {name, parents, operations,
|
||||
invariant, stereotypes, thyname}) =
|
||||
Interface {name=name,
|
||||
parents=parents,
|
||||
operations=operations,
|
||||
invariant=inv@invariant,
|
||||
stereotypes=stereotypes,
|
||||
thyname=thyname}
|
||||
| addInvariant invs (Enumeration {name, parent, operations,
|
||||
literals, invariant, stereotypes,
|
||||
interfaces, thyname}) =
|
||||
Enumeration{name=name,
|
||||
parent=parent,
|
||||
operations=operations,
|
||||
literals=literals,
|
||||
invariant=inv::invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname}
|
||||
| addInvariant invs (Primitive {name, parent, operations,
|
||||
associations, invariant,
|
||||
stereotypes, interfaces, thyname}) =
|
||||
Primitive{name=name,
|
||||
parent=parent,
|
||||
operations=operations,
|
||||
associations=associations,
|
||||
invariant=invs@invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname}
|
||||
| addInvariant invs (Template {parameter, classifier}) =
|
||||
Template {parameter=parameter,
|
||||
classifier=addInvariants invs classifier}
|
||||
|
||||
(** adds an operation to a classifier. *)
|
||||
fun addOperation oper (Class {name, parent, attributes, operations,
|
||||
|
|
|
|||
|
|
@ -184,12 +184,12 @@ struct
|
|||
open Rep_OclType
|
||||
|
||||
datatype OclTerm =
|
||||
Literal of string * OclType (* Literal with type *)
|
||||
Literal of string * OclType (* Literal with type *)
|
||||
| CollectionLiteral of CollectionPart list * OclType (* content with type *)
|
||||
| If of OclTerm * OclType (* condition *)
|
||||
* OclTerm * OclType (* then *)
|
||||
* OclTerm * OclType (* else *)
|
||||
* OclType (* result type *)
|
||||
| If of OclTerm * OclType (* condition *)
|
||||
* OclTerm * OclType (* then *)
|
||||
* OclTerm * OclType (* else *)
|
||||
* OclType (* result type *)
|
||||
| AssociationEndCall of OclTerm * OclType (* source *)
|
||||
* Path (* assoc.-enc *)
|
||||
* OclType (* result type *)
|
||||
|
|
@ -269,8 +269,8 @@ fun ocl_opcall source f args t = OperationCall (source, type_of source, f,
|
|||
map (fn x => (x,type_of x)) args,
|
||||
t)
|
||||
fun ocl_attcall source att t = AttributeCall (source, type_of source, att, t)
|
||||
fun ocl_aendcall source aend t = AssociationEndCall (source, type_of source, aend,
|
||||
t)
|
||||
fun ocl_aendcall source aend t = AssociationEndCall (source, type_of source,
|
||||
aend, t)
|
||||
fun ocl_opwithtype source f t s = OperationWithType (source, type_of source, f,
|
||||
t, s)
|
||||
|
||||
|
|
@ -361,15 +361,15 @@ fun ocl_collect source var body = Iterator ("collect", [(var,type_of source)],
|
|||
Bag (type_of body))
|
||||
|
||||
(* source::Collection/Set/..., variables:: Variable list , body:: expression to be evaluated *)
|
||||
(* body must be Boolean *)
|
||||
(* body must evaluate to Boolean *)
|
||||
fun ocl_forAll (source:OclTerm) (variables:OclTerm list) (body:OclTerm) =
|
||||
let
|
||||
fun strip_var (Variable(name,var_type)) = (name,var_type)
|
||||
fun strip_var (Variable(name,var_type)) = (name,var_type)
|
||||
in
|
||||
Iterator ("forAll", map strip_var variables,
|
||||
source, type_of source,
|
||||
body, type_of body,
|
||||
Bag (type_of body))
|
||||
Iterator ("forAll", map strip_var variables,
|
||||
source, type_of source,
|
||||
body, type_of body,
|
||||
Bag (type_of body))
|
||||
end
|
||||
|
||||
fun ocl_select (source:OclTerm) (Variable variable) (body:OclTerm) = Iterator ("select", [variable],
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -46,6 +46,9 @@ struct
|
|||
(** returns the string in all caps. *)
|
||||
fun toUpper (s:string) = String.map Char.toUpper s
|
||||
|
||||
(** returns the string in all non-caps. *)
|
||||
fun toLower (s:string) = String.map Char.toLower s
|
||||
|
||||
(** returns the uncapitalized string.
|
||||
* Returns the given string with the first letter changed to lower case
|
||||
*)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,420 @@
|
|||
signature TRANSFORM_LIBRARY =
|
||||
sig
|
||||
|
||||
(**
|
||||
* Generate an OCL constraint guaranteeing that source is unique over the
|
||||
* supplied binary associations.
|
||||
* @params {source,associations}
|
||||
* @param source classifier that needs a uniqueness constraint
|
||||
* @param associations binary associations the uniqueness constraint is
|
||||
* defined over. An n-ary association are not a valid argument.
|
||||
* @return an OCL constraint expressing the uniqueness requirement
|
||||
*)
|
||||
val uniquenessOclConstraint: Rep_OclType.OclType -> Rep_Core.association list
|
||||
-> Rep_OclTerm.OclTerm
|
||||
|
||||
(**
|
||||
* @params {source,multis,binaryAssocs}
|
||||
*)
|
||||
val multiplicityOclConstraint: Rep_OclType.OclType -> (int*int) list list ->
|
||||
Rep_Core.association list -> Rep_Core.constraint
|
||||
|
||||
(**
|
||||
* @params {association}
|
||||
* @param association n-ary association that should be split into it's binary
|
||||
* links.
|
||||
* @return a tuple containting a list classifiers, a list of role names, a list
|
||||
* of association ends and a list of binary associations:
|
||||
* (clsses, roleNames, oppAends, splitAssocs).
|
||||
* Each "line" is associated with a classifier of clsses: roleName 1, oppAends
|
||||
* 1 and splitAssocs 1 belong to clsses 1.
|
||||
* Each element of the result lists:
|
||||
* clsses: Classifiers of the association
|
||||
* roleNames: unqualified role name that denoted the associated classifier in
|
||||
* the original association
|
||||
* oppAends: the opposite aends of the newly generated binary associations,
|
||||
* that the associated classifier from clsses is part of.
|
||||
* splitAssocs: ass oppAends, only the full binary association
|
||||
*)
|
||||
val splitNAryAssociation: Rep_Core.association -> (Rep_Core.Classifier list *
|
||||
string list * Rep_Core.aend list list *
|
||||
Rep_Core.association list list)
|
||||
|
||||
(**
|
||||
* Rearrange the oppRefAends to mirror the ordering of oppAends
|
||||
* @params {oppRefAends,oppAends}
|
||||
* @param oppRefAends
|
||||
* @param oppAends
|
||||
* @return the elements of oppRefAends in the same order as oppAends, given
|
||||
* the classifier and the role name
|
||||
*)
|
||||
val matchAends: Rep_Core.aend list -> Rep_Core.aend list -> Rep_Core.aend list
|
||||
|
||||
(**
|
||||
*
|
||||
*)
|
||||
val matchClassifiers: Rep_Core.aend list -> (Rep_Core.Classifier * string) list
|
||||
|
||||
val binaryAssociations: Rep_Core.Classifier -> Rep_Core.Classifier list ->
|
||||
Rep_Core.aends ->
|
||||
(Rep_Core.association list * Rep_Core.aend list)
|
||||
|
||||
(**
|
||||
* Helper function for generating new, unique classes within a given
|
||||
* package.
|
||||
*)
|
||||
val newDummyClass: Rep_OclType.Path -> Rep_OclType.Classifier
|
||||
|
||||
val isPureNAryAssoc: Rep_Core.association -> bool
|
||||
|
||||
(**
|
||||
* returns true iif assoc is purely a binary association, without any
|
||||
* additional adornments, such as aggregation, qualifier, association class,
|
||||
* etc.
|
||||
* @params {assoc}
|
||||
* @param assoc association to be tested
|
||||
* @return true iif assoc is a pure binary association
|
||||
*)
|
||||
val isPureBinAssoc : Rep_Core.association -> bool
|
||||
|
||||
|
||||
end
|
||||
|
||||
open library
|
||||
open StringHandling
|
||||
|
||||
structure Transform_Library:TRANSFORM_LIBRARY =
|
||||
struct
|
||||
|
||||
fun isPureBinAssoc (_,[a,b],NONE) =
|
||||
let
|
||||
(* TODO: update when qualifiers added *)
|
||||
val _ = trace function_calls "isPureBinAssoc\n"
|
||||
in
|
||||
true
|
||||
end
|
||||
| isPureBinAssoc (_,_,_)= false
|
||||
|
||||
fun addAssociations newAssocs associations =
|
||||
let
|
||||
in
|
||||
end
|
||||
|
||||
fun removeAssociations oldAssocs associations =
|
||||
let
|
||||
in
|
||||
end
|
||||
|
||||
fun modifyAssociationOfClassifier newAssociations olAssociations
|
||||
(Class{name,parent,attributes,
|
||||
operations,associations,invariant,
|
||||
stereotypes,interfaces,thyname,
|
||||
activity_graphs}) =
|
||||
Class{name=name,
|
||||
parent=parent,
|
||||
attributes=attributes,
|
||||
operations=operations,
|
||||
associations= addAssociations newAssociations (removeAssociations
|
||||
oldassociations
|
||||
associations),
|
||||
invariant=invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname,
|
||||
activity_graphs=activity_graphs}
|
||||
| modifyAssociationToClassifier newAssociations oldAssociation
|
||||
(AssociationClass{name,parent,attributes,
|
||||
operations,associations,
|
||||
invariant,associationclass,
|
||||
stereotypes,interfaces,
|
||||
thyname,activity_graphs}) =
|
||||
AssociationClass{name=name,
|
||||
parent=parent,
|
||||
attributes=attributes,
|
||||
operations=operations,
|
||||
associations= addAssociations newAssociations
|
||||
(removeAssociations oldassociations
|
||||
associations),
|
||||
associationclass=associationclass,
|
||||
invariant=invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname,
|
||||
activity_graphs=activity_graphs}
|
||||
|
||||
| modifyAssociationToClassifier newAssociations oldAssociations
|
||||
(Primitive{name,parent,operations,
|
||||
associations,invariant,
|
||||
stereotypes,interfaces,
|
||||
thyname}) =
|
||||
Primitive {name=name,
|
||||
parent=parent,
|
||||
operations=operations,
|
||||
associations= addAssociations newAssociations
|
||||
(removeAssociations oldassociations
|
||||
associations),
|
||||
invariant=invariant,
|
||||
stereotypes=stereotypes,
|
||||
interfaces=interfaces,
|
||||
thyname=thyname}
|
||||
|
||||
fun quantifyForAll variables body =
|
||||
let
|
||||
fun quantify (variable,body) =
|
||||
ocl_forAll (ocl_allInstances (Literal (type_of variable)))
|
||||
[variable] body
|
||||
in
|
||||
(* right most variable at the inner most position *)
|
||||
foldr quantify body variables
|
||||
end
|
||||
|
||||
fun uniquenessOclConstraint source associations =
|
||||
let
|
||||
fun assocAendCalls self iter {_,aends,_} =
|
||||
let
|
||||
val [{name,aend_type,...}] = filter (fn x => type_of_aend x =/=
|
||||
type_of self) aends
|
||||
val selfCall = ocl_aendcall self name (Collection aend_type)
|
||||
val iterCall = ocl_aendcall iter name (Collection aend_type)
|
||||
in
|
||||
ocl_eq selfCall iterCall
|
||||
end
|
||||
|
||||
val _ = trace function_calls "uniquenessOclConstraint\n"
|
||||
val selfVar = self (type_of source)
|
||||
val iterVar = Variable ("other",type_of source)
|
||||
val aendCalls = map (assocAendCalls selfVar iterVar) associations
|
||||
val oclBody = ocl_implies (ocl_and_all aendsCalls) (ocl_eq selfVar
|
||||
iterVar)
|
||||
val constr = quantifyForAll [iterVar] oclBody
|
||||
in
|
||||
(SOME "Uniqueness", constr)
|
||||
end
|
||||
|
||||
|
||||
fun binaryAssociations source targets =
|
||||
let
|
||||
val _ = trace function_calls "binaryAssociations\n"
|
||||
fun generateAssociation target =
|
||||
let
|
||||
val assocName = path_of_package source::
|
||||
[("dummyBinaryAssoc"^nextUID)]
|
||||
in
|
||||
{name= assocName,
|
||||
aends=[{name=assocName:: (short_name_of source),
|
||||
aend_type=type_of source,
|
||||
multiplicity=[],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE,},
|
||||
{name=assocName:: (short_name_of target),
|
||||
aend_type=type_of target,
|
||||
multiplicity=[(1,1)],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE,
|
||||
],
|
||||
aclass=NONE}
|
||||
end
|
||||
in
|
||||
map generateAssociation targets
|
||||
end
|
||||
|
||||
fun variableFromAend {name,aend_type,...} =
|
||||
Variable((toLower o get_short_name name)^nextUID,aend_type)
|
||||
|
||||
fun roleToAend source {name,aend_type,...} =
|
||||
ocl_aendcall source name (Collection aend_type)
|
||||
|
||||
fun fixAends source aends =
|
||||
let
|
||||
fun equal (a,b) = ocl_eq a b
|
||||
|
||||
val vars = map variableFromAend aends
|
||||
val roles = map (roleToAend source) aends
|
||||
val body = ocl_and_all (map equal (zip roles vars))
|
||||
val ocl = ocl_select (ocl_allInstances (Literal (type_of source)))
|
||||
source body
|
||||
in
|
||||
(ocl,vars)
|
||||
end
|
||||
|
||||
fun multiplicityOclConstraint source multis binaryAssocs =
|
||||
let
|
||||
val _ = trace_function_calls "multiplicityOclConstraint\n"
|
||||
fun bound set (low,high) =
|
||||
ocl_and (ocl_leq (ocl_size set) high)
|
||||
(ocl_geq (ocl_size set) low)
|
||||
|
||||
fun iterate _ [] done [] = []
|
||||
| iterate source multi::ys done a::xs =
|
||||
let
|
||||
val (set,vars) = fixAends source (xs@done)
|
||||
val body = ocl_or_all (map (bound set) multi)
|
||||
in
|
||||
(SOME "MultiplicityConstraint",quantifyAll vars body)::
|
||||
(iterate self ys (a::done) xs)
|
||||
end
|
||||
|
||||
val selfVar = self (type_of source)
|
||||
in
|
||||
iterate selfVar multis [] binaryAssocs
|
||||
end
|
||||
|
||||
fun consistencyOclConstraint source reference selfAend roles refRoles =
|
||||
let
|
||||
val _ = trace function_calls "consistencyOclConstraint\n"
|
||||
fun implies self ref {name=selfPath,aend_type,...}
|
||||
((role as {name=newPath,aend_type=newType,...}),
|
||||
{name=refPath,aend_type=refType,...}) =
|
||||
let
|
||||
val var = variableFromAend role
|
||||
val refLit = Literal (type_of ref)
|
||||
val link = ocl_exists (ocl_aendcall self newPath
|
||||
(Collection newType))
|
||||
var ocl_true
|
||||
val refOther = ocl_aendcall ref refPath (Collection newType)
|
||||
val refSelf = ocl_aendcall ref selfPath (Collection selfType)
|
||||
val included = ocl_exists (ocl_allInstances refLit) ref
|
||||
(ocl_and (ocl_eq refOther ref)
|
||||
(ocl_eq refSelf self))
|
||||
val body = ocl_implies link included
|
||||
in
|
||||
(SOME "ConsistencyConstraint", quantifyAll [var] body)
|
||||
end
|
||||
|
||||
val self = self (type_of source)
|
||||
val ref = variableFromClassifier reference
|
||||
|
||||
in
|
||||
(source, map (self ref selfAend ) (zip roles refRoles))
|
||||
end
|
||||
|
||||
fun splitNAryAssociation {name as (qualifier::assocName),aends,aclass}
|
||||
classifiers =
|
||||
let
|
||||
val _ = trace function_calls "splitNAryAssociation\n"
|
||||
fun updateClassifier ((clsType,newPaths),classifiers) =
|
||||
let
|
||||
val ([cls],rem) = List.partition (fn x => type_of x = clsType )
|
||||
classifiers
|
||||
val modifiedCls = modifyAssociationsOfClassifier newPaths
|
||||
[association]
|
||||
cls
|
||||
in
|
||||
modifiedCls@rem
|
||||
end
|
||||
|
||||
fun iterate done [] = []
|
||||
| iterate done (aend as {name,aend_type,...}::xs) =
|
||||
let
|
||||
fun makeAssoc {name=assocPath@assocName::[role],aend_type,...}
|
||||
{name=_@[targetRole],aend_type=targetType,...} =
|
||||
let
|
||||
val newAssocName = assocPath@[assocName^nextUid]
|
||||
val oppAend = {name=newAssocName@[targetRole],
|
||||
aend_type=targetType,
|
||||
multiplicity=[],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE}
|
||||
val binaryAssoc = {name=newAssocName,
|
||||
aends=[{name=newAssocName@[role],
|
||||
aend_type=aend_type,
|
||||
multiplicity=[],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE},
|
||||
oppAend],
|
||||
aclass=NONE}
|
||||
in
|
||||
(oppAend,binaryAssoc)
|
||||
end
|
||||
|
||||
val (oppAends,binaryAssocs) = unzip o map (makeAssoc aend)
|
||||
(done@xs)
|
||||
val role = short_name_of name
|
||||
in
|
||||
(aend_type,role,oppAends,binaryAssocs)::
|
||||
(iterate (aend::done) xs)
|
||||
end
|
||||
|
||||
fun unzip4 [] = []
|
||||
| unzip4 (a,b,c,d)::xs =
|
||||
let
|
||||
val (az,bs,cs,ds) = unzip xs
|
||||
in
|
||||
(a::az,b::bs,c::cs,d::ds)
|
||||
end
|
||||
|
||||
fun getPaths assocs = map name_of_assoc assocs
|
||||
|
||||
(* generate new associations *)
|
||||
val (clsses,roleNames,oppAends,splitAssocs) =
|
||||
unzip4 o iterate classifiers [] aends
|
||||
|
||||
(* update associations in classifiers to the new names *)
|
||||
val modifiedClassifiers = foldl updateClassifier classifiers
|
||||
(zip (map type_of clssses)
|
||||
(map getPaths splitAssocs))
|
||||
in
|
||||
(modifiedClassifiers, roleNames, oppAends, splitAssocs)
|
||||
end
|
||||
|
||||
(* target type and role name is unqiue, even with reflexive links *)
|
||||
fun matchAends oppRefAends oppAends =
|
||||
map (fn x => hd o filter (fn y => type_of_aend x = type_of_aend y
|
||||
andalso short_name_of_aend x =
|
||||
short_name of_aend y)
|
||||
oppRefAends) oppAends
|
||||
|
||||
(* target type and role name is still unqiue for classifiers and role *)
|
||||
fun matchClassifiers oppRefAends pairs =
|
||||
let
|
||||
fun matchClassifier oppRefAends (cls,role) =
|
||||
hd o filter (fn x => type_of cls = type_of_aend x andalso
|
||||
role = short_name_of_aend) oppRefAends
|
||||
in
|
||||
map (matchClassifier oppRefAends) pairs
|
||||
end
|
||||
|
||||
|
||||
fun binaryAssociations source targets aends =
|
||||
let
|
||||
val _ = trace function_calls "binaryAssociations\n"
|
||||
fun generateAssociation target =
|
||||
let
|
||||
val assocName = path_of_package source::
|
||||
("dummyBinaryAssoc"^nextUID )
|
||||
in
|
||||
({name= assocName,
|
||||
aends=[{name=assocName:: (short_name_of source),
|
||||
aend_type=type_of source,
|
||||
multiplicity=[],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE,},
|
||||
{name=assocName:: (short_name_of target),
|
||||
aend_type=type_of target,
|
||||
multiplicity=[(1,1)],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE}],
|
||||
aclass=NONE},
|
||||
{name=assocName:: (short_name_of target),
|
||||
aend_type=type_of target,
|
||||
multiplicity=[(1,1)],
|
||||
ordered=false,
|
||||
visibility=public,
|
||||
init=NONE}
|
||||
)
|
||||
end
|
||||
|
||||
val (assocs,refAends) = unzip (map generateAssociation target)
|
||||
val oppAends = matchAends refAends aends
|
||||
in
|
||||
(assocs, oppAends)
|
||||
end
|
||||
|
||||
|
||||
end
|
||||
Loading…
Reference in New Issue