signature TRANSFORM_LIBRARY = sig (** * Generate an OCL constraint guaranteeing that source is unique over the * supplied associations. In case of binary associations, the aend is checked * for a multiplicity of 1. Else this is enforced via OCL. * @params {source,associations} * @param source classifier that needs a uniqueness constraint * @param associations associations the uniqueness constraint should be * defined over. An n-ary association are not a valid * argument. * @return an OCL constraint expressing the uniqueness requirement *) val uniquenessOclConstraint : Rep.Classifier -> Rep.association list -> Rep.constraint (** * @params {source,multis,aends} *) val multiplicityOclConstraints: Rep.Classifier -> (int*int) list list -> Rep.associationend list -> Rep.constraint list val consistencyOclConstraint: Rep.Classifier -> Rep.Classifier -> Rep.associationend -> Rep.associationend list -> Rep.associationend list -> (Rep.Classifier * Rep.constraint list) (** * Works through the list of classifiers and updates uses of oldAssoc * to the appropriate association in newAssocs. This function only handles * the case where the classifiers aren't changed, i.e. source type, target type * and role remain the same. The qualifier transformation is not covered, for * instance. * * params {classifiers,[(oldAssoc,newAssocs)]} * @param classifiers * @param oldAssoc the association that has been removed from the model * @param newAssocs the associations that have replaced oldAssoc * @return the list of classifiers with references to the old association * removed *) val updateAssociationReferences: Rep.Classifier list -> (Rep.association * Rep.association list) list -> Rep.Classifier list (** * If newly created classifiers take the place of already existing classifiers, * references may need to be updated to * a) pass-through the new classifier * b) retain their meaning (i.e. qualifier split) * params {[association,[(Hike,D1,f1,f2)]],classifiers} * @param oldAssoc the original association with the original types * @param newAssoc the new association with the modified types but same * role names *) val updateQualifierReferences: Rep.Classifier list -> (Rep.association * (Rep_OclType.OclType * Rep_OclType.OclType * (Rep_OclType.OclType -> Rep_OclTerm.OclTerm list -> Rep_OclType.OclType) * (Rep_OclType.OclType -> Rep_OclType.OclType) ) list) list -> Rep.Classifier list (** * @params {association,assocMembers} * @param association n-ary association that should be split into it's binary * links. * @param assocMembers defines the ordering of the returned values, namely it * defines the ordering of clsses. * @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.association -> Rep.Classifier list -> (Rep.Classifier list * string list * Rep.associationend list list * Rep.association list list * Rep.association 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.associationend list -> Rep.associationend list -> Rep.associationend list (** * {association pool,source,roles} *) val matchAendsFromClassifier: Rep.association list -> Rep.Classifier -> string list -> Rep.associationend list val matchClassifiersAtAend: Rep.associationend list -> Rep.Classifier list -> (Rep.Classifier list * Rep.Classifier list ) val findClassifier: Rep.Classifier list -> Rep_OclType.Path -> (Rep.Classifier * Rep.Classifier list) val mapCalls: (Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm) -> Rep.Classifier list -> Rep.Classifier list (** * @params source sourceRole (target,targetRole) *) val binaryAssociations : Rep.Classifier -> string option -> (Rep.Classifier * string option) list -> (Rep.association list * Rep.associationend list) (** * Form binary associations between * @params {source,targets,aends} * @param source one of the ends for each of the binary associations * @param targets each target is the second aend in exactly one of the * resulting associations * @param aends original associationends at the targets. The returned * associationends. oppRefAends are in the same order as the * supplied aends and denote the new association ends * @return (binaryAssocs,oppRefAends) *) val orderedBinaryAssociations: Rep.Classifier -> Rep.Classifier list -> Rep.associationend list -> (Rep.association list * Rep.associationend list) val nextUid: unit -> string (** * Helper function for generating new, unique classes within a given * package. *) val newDummyClass: Rep_OclType.Path -> Rep.Classifier val newDummyAssociationClass: Rep_OclType.Path -> Rep.Classifier (** * Generate a new Class for the given package and having the given name. * @params {package, name} * @param package the packgae the new class should belong to * @param name the name of the new class. Will be suffixed to ensure * uniqueness * @return returns a new class for the given package having a unique name * starting with the given name *) val newNamedClass: Rep_OclType.Path -> string -> Rep.Classifier val fixAends: Rep_OclTerm.OclTerm -> Rep.associationend list -> (Rep_OclTerm.OclTerm * Rep_OclTerm.OclTerm list) (* Filters *) val isPureNAryAssoc : Rep.association -> bool (** * For filtering pure qualified associations. At the moment, only binary * associations are supported. * @params {association} * @param association test association for being purely qualified, meaning * no other adornments, such as aggregation, partitioning, etc * @return true iff the association is purely qualified *) val isPureQualifier : Rep.association -> bool val isPureAcAssoc : Rep.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.association -> bool val multiplicities_of_aend : Rep.associationend -> (int*int) list val stripMultiplicityOfAend: Rep.associationend -> Rep.associationend (** * Remove all multiplicities from the association * @params {assoc} * @param assoc association * @return assoc with all multiplicities removed *) val stripMultiplicities : Rep.association -> Rep.association val modifyAssociationsOfClassifier: Rep_Core.association list -> Rep_Core.association list -> Rep_Core.Classifier -> Rep_Core.Classifier val updateClassifiersWithConstraints: Rep_Core.Classifier list -> Rep_OclType.OclType -> Rep_Core.constraint list -> Rep_Core.Classifier list val uid: int ref val setAssociationOfAssociationClass: Rep.Classifier -> Rep_OclType.Path -> Rep.Classifier val setAssociationClassOfAssociation: Rep.association -> Rep_OclType.Path -> Rep.association val aend_of_association: Rep.association -> Rep_OclType.Path -> Rep.associationend val qualifier_of_path :Rep_OclType.Path -> Rep_OclType.Path val name_of_attribute : Rep.attribute -> string val addAttribute : Rep.Classifier -> Rep.attribute -> Rep.Classifier val addAttributes : Rep.Classifier -> Rep.attribute list -> Rep.Classifier val multiplicity_of_aend: Rep.associationend -> (int * int) list val associationClassOfAssociation: Rep.association -> Rep_OclType.Path val package_of_aend: Rep.associationend -> Rep_OclType.Path val package_of_association: Rep.association -> Rep_OclType.Path val variableFromOclType: Rep_OclType.OclType -> Rep_OclTerm.OclTerm val variableFromAend: Rep.associationend -> Rep_OclTerm.OclTerm val variableFromClassifier: Rep.Classifier -> Rep_OclTerm.OclTerm val quantifyForAll: Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm val zip3 : 'a list * 'b list * 'c list -> ('a * 'b * 'c) list exception InvalidArguments of string end structure Transform_Library:TRANSFORM_LIBRARY = struct open Rep_Helper open StringHandling open Rep_OclTerm open Rep_OclHelper open Rep_Core exception InvalidArguments of string val uid = ref 0 fun nextUid () = (uid := !uid + 1; "_S"^(Int.toString (!uid))) fun zip3(a::ass,b::bs,c::cs) = (a,b,c)::zip3(ass,bs,cs) fun get_short_name (path:Path):string = List.last path fun stripMultiplicityOfAend {name,aend_type,multiplicity,visibility, ordered,init} = {name=name, aend_type=aend_type, multiplicity=[], visibility=visibility, ordered=ordered, init=init} fun stripMultiplicities ({name,aends,qualifiers,aclass}:association): association = {name = name, aends = map stripMultiplicityOfAend aends, qualifiers = qualifiers, aclass = aclass} fun multiplicity_of_aend ({aend_type,multiplicity,...}:associationend) = multiplicity fun associationClassOfAssociation {name,aends,qualifiers,aclass=SOME path} = path fun aend_of_association {name,aends,qualifiers,aclass} path = let val [aend] = List.filter (fn ({name,aend_type,...}:associationend) => name=path) aends in aend end fun package_of_aend ({name,aend_type,...}:associationend) = List.take(name, List.length name - 2) fun package_of_association ({name,aends,qualifiers,aclass}:association) = List.take(name, List.length name - 1) fun qualifier_of_path path = List.take(path, List.length path - 1) (* (JD) -> Rep_Core? *) fun multiplicities_of_aend ({aend_type,multiplicity,...}:associationend) = multiplicity fun short_name_of_aend ({name,aend_type,...}:associationend) = short_name_of_path name fun name_of_attribute ({name,...}:attribute) = name fun addAttributes (Class {name,parent,attributes,operations,associations, invariant,stereotypes,interfaces,thyname, activity_graphs,visibility}) newAttributes = Class {name=name, parent=parent, attributes=newAttributes@attributes, operations=operations, associations=associations, invariant=invariant, visibility=visibility, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, activity_graphs=activity_graphs} | addAttributes (AssociationClass {name,parent,attributes,operations, associations,association,invariant, stereotypes,interfaces,thyname, visibility,activity_graphs}) newAttributes = AssociationClass {name=name, parent=parent, attributes=newAttributes@attributes, operations=operations, associations=associations, association=association, invariant=invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, visibility=visibility, activity_graphs=activity_graphs} | addAttributes (Template {parameter,classifier}) newAttributes= Template {parameter=parameter, classifier=addAttributes classifier newAttributes} fun addAttribute classifier attribute = addAttributes classifier [attribute] fun quantifyForAll variables body = let fun quantify (variable as Variable(_,varType),body) = ocl_forAll (ocl_allInstances (Literal (List.last (path_of_OclType varType), varType))) [variable] body in (* right most variable at the inner most position *) foldr quantify body variables end fun findClassifier allClassifiers path = let val ([match],rem ) = List.partition (fn x => name_of x = path) allClassifiers in (match,rem) end fun isPureBinAssoc {name,aends=[a,b],qualifiers=[],aclass=NONE} = true | isPureBinAssoc _ = false fun isPureNAryAssoc {name,aends,qualifiers=[],aclass=NONE} = List.length aends > 2 | isPureNAryAssoc _ = false fun isPureQualifier {name,aends=[a,b],qualifiers,aclass=NONE} = List.length qualifiers > 0 | isPureQualifier _ = false fun isPureAcAssoc {name,aends,qualifiers=[],aclass=SOME ac} = List.length aends > 1 | isPureAcAssoc _ = false fun newDummyClass package = Class{name=Classifier (package@["Dummy"^ nextUid ()]), parent=NONE, attributes=[], operations=[], associations=[], invariant=[], stereotypes=[], visibility=XMI.public (* FIXME: private? *), interfaces=[], thyname=NONE, activity_graphs=[]} fun newDummyAssociationClass package = AssociationClass{name=Classifier (package@["DummyAC"^ nextUid ()]), parent=NONE, attributes=[], operations=[], associations=[], association=["dummyPath"], invariant=[], stereotypes=[], visibility=XMI.public (* FIXME: private? *), interfaces=[], thyname=NONE, activity_graphs=[]} fun newNamedClass package name = Class{name=Classifier (package@[name^ nextUid ()]), parent=NONE, attributes=[], operations=[], associations=[], visibility=XMI.public (* FIXME: private? *), invariant=[], stereotypes=[], interfaces=[], thyname=NONE, activity_graphs=[]} fun addAssociations (newAssocs:Path list) (associations:Path list) = let fun replaceAssoc (newAssoc:Path,oldAssociations:Path list) = newAssoc ::(List.filter (fn x => x <> newAssoc) oldAssociations) in foldl replaceAssoc associations newAssocs end fun removeAssociations oldAssocs associations = let fun removeAssoc (oldAssoc,oldAssociations) = List.filter (fn x => x <> oldAssoc) oldAssociations in foldl removeAssoc associations oldAssocs end fun setAssociationOfAssociationClass (AssociationClass {name,parent,attributes,operations, associations,association, invariant,stereotypes,interfaces, visibility,thyname, activity_graphs}) associationPath = AssociationClass {name=name, parent=parent, attributes=attributes, operations=operations, associations=associations, association=associationPath, invariant=invariant, stereotypes=stereotypes, interfaces=interfaces, visibility=visibility, thyname=thyname, activity_graphs=activity_graphs} fun setAssociationClassOfAssociation {name,aends,qualifiers,aclass} associationClassPath = {name=name, aends=aends, qualifiers=qualifiers, aclass=SOME associationClassPath} fun updateQualifierReferences classifiers [] = classifiers | updateQualifierReferences classifiers ((association,updates)::xs) = let val modifiedClassifiers = classifiers (* FIXME *) in updateQualifierReferences modifiedClassifiers xs end (** aendCall, attrCall, qualiCall *) fun mapCalls f [] = [] | mapCalls f (classifier::classifiers) = let fun handleConstraint f (name,term) = (name,mapOclCalls f term) fun modifyClassifier f (Class{name,parent,attributes,operations, associations,invariant,stereotypes, interfaces,thyname,visibility, activity_graphs}) = Class{name=name, parent=parent, attributes=attributes, operations=operations, visibility=visibility, associations= associations, invariant=map (handleConstraint f) invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, activity_graphs=activity_graphs} | modifyClassifier f (AssociationClass{name,parent,attributes, operations,associations, invariant,association, stereotypes,interfaces, visibility,thyname, activity_graphs}) = AssociationClass{name=name, parent=parent, attributes=attributes, operations=operations, visibility=visibility, associations= associations, association=association, invariant=map (handleConstraint f) invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, activity_graphs=activity_graphs} | modifyClassifier f (Template{parameter,classifier})= Template{parameter=parameter, classifier=modifyClassifier f classifier} in modifyClassifier f classifier :: (mapCalls f classifiers) end (* FIXME: CollectionParts? *) fun updateAssociationReferences classifiers [] = classifiers | updateAssociationReferences classifiers updates = let val _ = Logger.debug2 "updateAssociationReferences\n" fun findNewPath oldAssoc newAssocs source path = let fun selectAend source role ({name,aends=[a,b],qualifiers,aclass}, selected) = if (type_of_aend a = source) andalso role_of_aend b = role then b::selected else if (type_of_aend b = source) andalso role_of_aend a = role then a::selected else selected val role = short_name_of_path path val sourceType = if is_Collection source then collection_type_of_OclType source else source val {name=newPath,aend_type,...} = hd(foldl(selectAend sourceType role) [] newAssocs) in newPath end fun traverseOcl oldAssoc newAssocs (If(cond,condType,thenn,thennType, elsee,elseeType,resultType))= If(traverseOcl oldAssoc newAssocs cond,condType, traverseOcl oldAssoc newAssocs thenn,thennType, traverseOcl oldAssoc newAssocs elsee,elseeType, resultType) | traverseOcl (oldAssoc as{name,aends,qualifiers,aclass}) newAssocs (QualifiedAssociationEndCall (source,sourceType, qualifierVals,path, resultType)) = (* qualifiers are illegal on n-ary associations *) QualifiedAssociationEndCall(traverseOcl oldAssoc newAssocs source, sourceType,qualifierVals,path, resultType) | traverseOcl (oldAssoc as{name,aends,qualifiers,aclass}) newAssocs (AssociationEndCall(source,sourceType,path, resultType)) = let (* match path and resultType to the correct newAssocs *) val newPath = if qualifier_of_path path <> name then path else findNewPath oldAssoc newAssocs sourceType path in AssociationEndCall(traverseOcl oldAssoc newAssocs source, sourceType,newPath,resultType) end | traverseOcl oldAssoc newAssocs (AttributeCall(source,sourceType, path,resultType)) = AttributeCall(traverseOcl oldAssoc newAssocs source,sourceType, path,resultType) | traverseOcl oldAssoc newAssocs (OperationCall(source,sourceType, path,parameters, resultType)) = let fun handleParameters (term,termType) = (traverseOcl oldAssoc newAssocs term,termType) in OperationCall(traverseOcl oldAssoc newAssocs source,sourceType, path,map handleParameters parameters,resultType) end | traverseOcl oldAssoc newAssocs (OperationWithType(source,sourceType, var,varType, resulType)) = OperationWithType(traverseOcl oldAssoc newAssocs source,sourceType, var,varType,resulType) | traverseOcl oldAssoc newAssocs (Let(name,nameType,rhs,rhsType,body, bodyType)) = Let(name,nameType, traverseOcl oldAssoc newAssocs rhs,rhsType, traverseOcl oldAssoc newAssocs body,bodyType) | traverseOcl oldAssoc newAssocs (Iterate (vars,name,nameType,nameTerm, source,sourceType,body, bodyType,resultType)) = Iterate (vars, name,nameType,traverseOcl oldAssoc newAssocs nameTerm, traverseOcl oldAssoc newAssocs source,sourceType, traverseOcl oldAssoc newAssocs body,bodyType, resultType) | traverseOcl oldAssoc newAssocs (Iterator (name,vars,source, sourceType,body,bodyType, resultType)) = Iterator (name,vars, traverseOcl oldAssoc newAssocs source, sourceType, traverseOcl oldAssoc newAssocs body,bodyType, resultType) | traverseOcl oldAssoc newAssocs x = x fun handleConstraint oldAssoc newAssocs (name,term) = let val _ = Logger.debug2 "handleConstraint\n" in (name,traverseOcl oldAssoc newAssocs term) end fun modifyClassifier oldAssoc newAssocs (Class{name,parent,attributes, operations,associations, invariant,stereotypes, interfaces,thyname, visibility, activity_graphs}) = Class{name=name, parent=parent, attributes=attributes, operations=operations, visibility=visibility, associations= associations, invariant=map (handleConstraint oldAssoc newAssocs) invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, activity_graphs=activity_graphs} | modifyClassifier oldAssoc newAssocs (AssociationClass {name,parent,attributes, operations,associations, invariant,association, stereotypes,interfaces, visibility,thyname, activity_graphs}) = AssociationClass{name=name, parent=parent, attributes=attributes, operations=operations, visibility=visibility, associations= associations, association=association, invariant=map (handleConstraint oldAssoc newAssocs) invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, activity_graphs=activity_graphs} | modifyClassifier oldAssoc newAssocs (Template{parameter,classifier})= Template{parameter=parameter, classifier=modifyClassifier oldAssoc newAssocs classifier} fun updateReferences ((oldAssoc,newAssocs),tmpClassifiers) = let val _ = Logger.debug2 "updateReferences\n" in map (modifyClassifier oldAssoc newAssocs) tmpClassifiers end in foldl updateReferences classifiers updates end fun updateClassifiersWithConstraints classifiers oclType constraints = let val (match,rem) = List.partition (fn cls => type_of cls = oclType) classifiers in map (addInvariants constraints) match @ rem end fun modifyAssociationsOfClassifier (newAssociations:association list) (oldAssociations:association list) (Class{name,parent,attributes, operations,associations,invariant, stereotypes,interfaces,thyname, visibility,activity_graphs}) = Class{name=name, parent=parent, attributes=attributes, operations=operations, associations= addAssociations (map path_of_association newAssociations) (removeAssociations (map path_of_association oldAssociations) associations), invariant=invariant, stereotypes=stereotypes, visibility=visibility, interfaces=interfaces, thyname=thyname, activity_graphs=activity_graphs} | modifyAssociationsOfClassifier newAssociations oldAssociations (AssociationClass{name,parent,attributes, operations,associations, invariant,association, stereotypes,interfaces, visibility,thyname,activity_graphs}) = AssociationClass{name=name, parent=parent, attributes=attributes, operations=operations, associations= addAssociations (map path_of_association newAssociations) (removeAssociations (map path_of_association oldAssociations) associations), association=association, invariant=invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname, visibility=visibility, activity_graphs=activity_graphs} | modifyAssociationsOfClassifier newAssociations oldAssociations (Primitive{name,parent,operations, associations,invariant, stereotypes,interfaces, thyname}) = Primitive {name=name, parent=parent, operations=operations, associations= addAssociations (map path_of_association newAssociations) (removeAssociations (map path_of_association oldAssociations) associations), invariant=invariant, stereotypes=stereotypes, interfaces=interfaces, thyname=thyname} fun uniquenessOclConstraint (source:Classifier) (associations:association list) = let val _ = Logger.debug2 "uniquenessOclConstraint\n" fun assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends=[a,b], qualifiers, aclass} = let (* FIXME: reflexiv *) val [{name,aend_type,multiplicity,...}] = filter (fn {aend_type,name,multiplicity,ordered,visibility, init} => Rep_OclHelper.type_of self <> aend_type) [a,b] val selfCall = ocl_aendcall self name (Collection aend_type) val iterCall = ocl_aendcall iter name (Collection aend_type) val sizeCall = ocl_eq (ocl_size selfCall) (Literal("1",Rep_OclType.Integer)) in if multiplicity = [(1,1)] orelse multiplicity = [(0,1)] then ocl_eq selfCall iterCall else ocl_and (ocl_eq selfCall iterCall) sizeCall end | assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends,qualifiers, aclass} = (* n-ary case *) let fun match self iter (role,roleType) = let val selfCall = ocl_aendcall self role (Collection roleType) val iterCall = ocl_aendcall iter role (Collection roleType) val sizeCall = ocl_eq (ocl_size selfCall) (Literal("1",Rep_OclType.Integer)) in [ocl_eq selfCall iterCall,sizeCall] end (* FIXME: reflexive? *) val ([selfAend],others) = List.partition (fn x => Rep_OclHelper.type_of self = type_of_aend x) aends val pairs = map (fn x => (path_of_aend x, type_of_aend x)) others val parts = List.concat (map (match self iter) pairs) in ocl_and_all parts end val selfVar = self (type_of source) val iterVar = Variable ("other"^nextUid (),type_of source) val aendCalls = map (assocAendCalls selfVar iterVar) associations val oclBody = ocl_implies (ocl_and_all aendCalls) (ocl_eq selfVar iterVar) val constr = quantifyForAll [iterVar] oclBody in (SOME "Uniqueness", constr) end fun binaryAssociations (source:Classifier) (sourceRole:string option) (targetRolePairs:(Classifier*string option) list): (association list * associationend list)= let val _ = Logger.debug2 "binaryAssociations\n" fun generateAssociation srcRole (target,roleOpt): (association * associationend)= let val role = if isSome roleOpt then valOf roleOpt else uncapitalize (short_name_of target) val assocName = package_of source @ ["BinaryAssoc"^nextUid ()] val oppAend = {name=assocName@[role], aend_type=type_of target, multiplicity=[(1,1)], ordered=false, visibility=XMI_DataTypes.public, init=NONE}:associationend in ({name= assocName, aends=[{name=assocName@ [srcRole], aend_type=type_of source, multiplicity=[], ordered=false, visibility=XMI_DataTypes.public, init=NONE}, oppAend], qualifiers=[], aclass=NONE}, oppAend) end val srcRole = if isSome sourceRole then valOf sourceRole else uncapitalize (short_name_of source) val pairs = map (generateAssociation srcRole) targetRolePairs in ListPair.unzip pairs end fun orderedBinaryAssociations (source:Classifier) (targets:Classifier list) aends: (association list * associationend list)= let val _ = Logger.debug2 "orderedBinaryAssociations\n" fun order [] [] = [] | order [] (x::xs) = raise InvalidArguments ("binaryAssociations.order:"^ "arguments don't agree\n") | order (x::xs) [] = raise InvalidArguments ("binaryAssociations.order:"^ "arguments don't agree\n") | order pairs (({name=refName,aend_type,multiplicity, ordered,init,visibility}:associationend)::aends) = let val ([oppAend],rem) = List.partition (fn (_,aend) => role_of_aend aend = short_name_of_path refName) pairs in (oppAend :: (order rem aends)) end (* TODO: role names *) val pairList = binaryAssociations source NONE (ListPair.zip(targets, (map(SOME o role_of_aend) aends))) in ListPair.unzip (order (ListPair.zip pairList) aends) end fun variableFromOclType oclType = Variable (short_name_of_OclType oclType^nextUid (),oclType) fun variableFromAend ({name,aend_type,...}:associationend) = Variable (toLower (short_name_of_path name)^nextUid (),aend_type) fun variableFromClassifier (cls:Classifier) = Variable (toLower (short_name_of cls)^nextUid () ,type_of cls) fun roleToAend source ({name,aend_type,...}:associationend) = ocl_aendcall source name (Collection aend_type) fun fixAends source (aends:associationend list) = 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 (ListPair.zip (roles,vars))) val sourceType = Rep_OclHelper.type_of source val ocl = ocl_select (ocl_allInstances (Literal (short_name_of_OclType sourceType, sourceType))) source body in (ocl,vars) end fun multiplicityOclConstraints source multis oppAends = let val _ = Logger.debug2 "multiplicityOclConstraint\n" fun bound set (low,high) = if low = high then ocl_eq (ocl_size set) (Literal(Int.toString high,Integer)) else ocl_and (ocl_leq (ocl_size set) (Literal(Int.toString high,Integer))) (ocl_geq (ocl_size set) (Literal(Int.toString low,Integer))) 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",quantifyForAll vars body):: (iterate source ys (a::done) xs) end val selfVar = self (type_of source) in iterate selfVar multis [] oppAends end (** * @params {source,reference,selfAend,roles,refRoles} * @param source source of the new binary association * @param reference dummy class used for constraints * @param selfAend aend from dummy class to source * @param roles aends from source to targets * @param refRoles aends from dummy to same targets as roles *) fun consistencyOclConstraint source reference selfAend roles refRoles = let val _ = Logger.debug2 "consistencyOclConstraint\n" fun implies selfVar refVar {name=selfPath,aend_type=selfType, multiplicity,init,visibility,ordered} ((role as {name=newPath,aend_type=newType,ordered=ord2, init=init2,multiplicity=mult2,visibility=vis2}), {name=refPath,aend_type=refType,multiplicity=multi3, init=init3,visibility=vis3,ordered=ord3}) = let val var = variableFromAend role val refVarType = Rep_OclHelper.type_of refVar val refLit = Literal (short_name_of_OclType refVarType, refVarType) (* new binary link *) val link = ocl_exists (ocl_aendcall selfVar newPath (Set newType)) var ocl_true (* links from dummy class *) val refOther = ocl_aendcall refVar refPath newType (* mult of 1 *) val refSelf = ocl_aendcall refVar selfPath selfType (* mult of 1 *) (* combining all *) val included = ocl_exists (ocl_allInstances refLit) refVar (ocl_and (ocl_eq refOther refVar) (ocl_eq refSelf selfVar)) val body = ocl_implies link included in (SOME "ConsistencyConstraint", quantifyForAll [var] body) end val selfVar = self (type_of source) val refVar = variableFromClassifier reference in (source, map (implies selfVar refVar selfAend ) (ListPair.zip (roles,refRoles))) end fun splitNAryAssociation (association as {name,qualifiers,aends=[a,b], aclass}) classifiers = let val modifiedClassifiers = List.filter (fn cls => type_of cls = type_of_aend a) classifiers val modifiedClassifiers = modifiedClassifiers @ (List.filter (fn cls => type_of cls = type_of_aend b) classifiers) val roleNames = [role_of_aend a, role_of_aend b] in (modifiedClassifiers, roleNames,[[b],[a]], [[association],[association]], [association]) end | splitNAryAssociation (association as {name,qualifiers, aends,aclass}) classifiers = let val _ = Logger.debug2 "splitNAryAssociation\n" fun updateClassifier ((clsType,newAssocs),classifiers) = let val ([cls],rem) = List.partition (fn x => type_of x = clsType ) classifiers val modifiedCls = modifyAssociationsOfClassifier newAssocs [association] cls in modifiedCls::rem end fun group assocs (aend as {name,aend_type,multiplicity,ordered, visibility,init}) = let fun collectPairs (((a,b),newAssoc),(oppAends,binaryAssocs)) = (* need to check type and role in case of reflexive * associations *) if (type_of_aend a = aend_type) andalso role_of_aend a = role_of_aend aend then (b::oppAends,newAssoc::binaryAssocs) else if (type_of_aend b = aend_type) andalso role_of_aend b = role_of_aend aend then (a::oppAends,newAssoc::binaryAssocs) else (oppAends,binaryAssocs) val (oppAends,binaryAssocs) = foldl collectPairs ([],[]) assocs val role = role_of_aend aend in (aend_type,role,oppAends,binaryAssocs) end fun iterate [a] = [] | iterate ((aend as {name,aend_type,multiplicity,ordered, visibility,init})::xs) = let fun makeAssoc (targetAend as {name=targetName,aend_type=targetType, init=init2,ordered=ord2, multiplicity=mult2, visibility=vis2}) = let val assocPath = package_of_aend aend val assocName = short_name_of_path (association_of_aend aend) val newAssocName = assocPath@[assocName^ nextUid ()] val sourceRole = role_of_aend aend val targetRole = role_of_aend targetAend val targetAend = {name=newAssocName@[targetRole], aend_type=targetType, multiplicity=[], ordered=ord2, visibility=vis2, init=init2} val sourceAend = {name=newAssocName@[sourceRole], aend_type=aend_type, multiplicity=[], ordered=ordered, visibility=visibility, init=init} val binaryAssoc = {name=newAssocName, aends=[sourceAend,targetAend], qualifiers=[], aclass=NONE} in ((sourceAend,targetAend),binaryAssoc) end in map makeAssoc xs @ (iterate xs) end fun order [] [] = [] | order [] (x::xs) = raise InvalidArguments ("splitNAryAssociation.order:"^ "arguments don't agree\n") | order (x::xs) [] = raise InvalidArguments ("splitNAryAssociation.order:"^ "arguments don't agree\n") | order pairs (cls::clsses) = let val ([oppAend],rem) = List.partition (fn (oppType,_,_,_) => type_of cls = oppType) pairs in oppAend :: (order rem clsses) end fun unzip4 [] = ([],[],[],[]) | unzip4 ((a,b,c,d)::xs) = let val (az,bs,cs,ds) = unzip4 xs in (a::az,b::bs,c::cs,d::ds) end fun getAssoc ((_,_),assoc) = assoc (* generate new associations *) val namedAssocs = iterate aends val pairs = map (group namedAssocs) aends val (types,roleNames,oppAends,splitAssocs) = unzip4 (order pairs classifiers) val assocs = map getAssoc namedAssocs (* update associations in classifiers to the new names *) val modifiedClassifiers = foldl updateClassifier classifiers (ListPair.zip (types,splitAssocs)) in (modifiedClassifiers, roleNames, oppAends, splitAssocs, assocs) end (* target type and role name is unqiue, even with reflexive links *) fun matchAends (oppRefAends:associationend list) oppAends = let fun findMatch {aend_type=oppAendType,name=oppName,multiplicity,init, ordered,visibility} = hd (List.filter (fn {aend_type=refAendType,name=refName,ordered, visibility,init,multiplicity} => oppAendType = refAendType andalso List.last oppName = List.last refName) oppRefAends) in map findMatch oppAends end fun matchClassifiersAtAend aends classifiers = let fun match {name,aend_type,ordered,init,multiplicity,visibility} = hd (List.filter (fn cls => type_of cls = aend_type) classifiers) fun remove (cls,classifiers) = #2 (List.partition (fn x => type_of x = type_of cls) classifiers) val matched = map match aends val rem = foldl remove classifiers matched in (matched,rem) end (* source type and role name is still unqiue for classifiers and role *) fun matchAendsFromClassifier (assocs:association list) source roles = let fun matchAend aendPairs cls role = let val [(_,b)] = List.filter (fn (a,b) => type_of_aend a = type_of cls andalso role_of_aend b = role ) aendPairs in b end fun mirror {name,aends=[a,b],qualifiers,aclass} = [(a,b),(b,a)] val aendPairs = List.concat (map mirror assocs) in map (matchAend aendPairs source) roles end end