diff --git a/su4sml/src/rep_transform.sml b/su4sml/src/rep_transform.sml index 8e90463..bdaf0a8 100644 --- a/su4sml/src/rep_transform.sml +++ b/su4sml/src/rep_transform.sml @@ -66,104 +66,36 @@ type modelTransformation = Rep_Core.transform_model * transformFlag list (* (JD) maybe not all of the following functions need to be exported. - * e.g., generate_pairs, ... *) -val transformClassifiers_ext : Rep_Core.transform_model -> Rep.Model +val transformClassifiersExt : Rep_Core.transform_model -> Rep.Model val transformClassifiers : Rep_Core.transform_model -> Rep.Classifier list val transformFile : string -> Rep.Model (* transforms *) -val transform_association_classes: Rep_Core.transform_model -> +val transformAssociationClasses: Rep_Core.transform_model -> Rep_Core.transform_model (* split an association classe into a class and an association*) -val transform_qualifiers : Rep_Core.transform_model -> Rep_Core.transform_model -val transform_aggregation: Rep_Core.transform_model -> Rep_Core.transform_model -val transform_n_ary_associations : Rep_Core.transform_model -> +val transformQualifiers : Rep_Core.transform_model -> Rep_Core.transform_model +val transformAggregation: Rep_Core.transform_model -> Rep_Core.transform_model +val transformNAryAssociations : Rep_Core.transform_model -> Rep_Core.transform_model (* remove n-ary associations *) -val transform_multiplicities : Rep_Core.transform_model -> +val transformMultiplicities : Rep_Core.transform_model -> Rep_Core.transform_model (* remove multiplicities *) (* helper functions *) -(** - * returns the path of an association end. The path of an association end - * is @[]. - * @params {aend} - * @param aend association end - * @return path of association end - *) -val path_of_aend : Rep_Core.associationend -> Rep_OclType.Path -val role_of_aend : Rep_Core.associationend -> string -(** - * returns the type of the classifier this association end belongs to. - * @params {aend} - * @param aend association end - * @return type of the classifier at the association end - *) -val type_of_aend : Rep_Core.associationend -> Rep_OclType.OclType -(** - * returns the association this association end belongs to. - * @params {aend} - * @param aend association end - * @return the path of the enclosing association - *) -val association_of_aend : Rep_Core.associationend -> Rep_OclType.Path -(** - * returns the name of the association end. The name of the association - * end is the last part of the association end's path. - * @params {aend} - * @param aend association end - * @return name of the association end as string. - *) -val name_of_aend : Rep_Core.associationend -> string -(** - * returns the list of specified multiplicities for this association end. - * @params {aend} - * @param aend association end - * @return the list of multiplicities of this association end. If there are - * no multiplicities, an empty list is returned. - *) -val multiplicities_of_aend : Rep_Core.associationend -> (int*int) list -(** - * returns the qualifying part of the (fully) qualified name. - * @params {qualifiedName} - * @param qualifiedName path denoting a name - * @return all but the last part of qualifiedName - *) -val get_qualifier : Rep_OclType.Path -> Rep_OclType.Path - -(** - * Remove all multiplicities from the association - * @params {assoc} - * @param assoc association - * @return assoc with all multiplicities removed - *) -val stripMultiplicities : Rep_Core.association -> Rep_Core.association -val generate_pairs : 'a list -> ('a * 'a) list (* including symmetry *) -val update_classifier_with_constraint : Rep_Core.constraint -> - Rep_Core.Classifier -> Rep_Core.Classifier -(* single: exactly 1 match *) -val update_classifiers_single : Rep_Core.Classifier list -> Rep_OclType.OclType -> (Rep_Core.Classifier -> Rep_Core.Classifier) -> Rep_Core.Classifier list val updateClassifiersWithConstraints: Rep_Core.Classifier list -> Rep_OclType.OclType -> Rep_Core.constraint list -> Rep_Core.Classifier list val get_association : Rep_Core.association list -> Rep_OclType.Path -> Rep_Core.association -val split_on_association: Rep_Core.association list -> Rep_OclType.Path -> - Rep_Core.association * Rep_Core.association list (* only one of the below will remain *) val get_other_associationends: Rep_Core.association list -> Rep_OclType.Path -> Rep_OclType.OclType -> Rep_Core.associationend list val get_other_associationends_alt : Rep_Core.association list -> Rep_OclType.OclType -> Rep_OclType.Path -> Rep_Core.associationend list val get_associationends : Rep_Core.association list -> Rep_OclType.Path -> Rep_Core.associationend list val associationends_of : Rep_Core.association -> Rep_Core.associationend list -(* result: (Variable list , OCL expression for set intersection)*) -val reachable_set : Rep_Core.associationend -> Rep_Core.associationend list -> (Rep_OclTerm.OclTerm list * Rep_OclTerm.OclTerm) -val within_bounds : Rep_OclTerm.OclTerm -> (int*int) -> Rep_OclTerm.OclTerm -val within_aend_multiplicities : Rep_Core.associationend -> Rep_Core.associationend list -> string -> Rep_Core.constraint -val injective_constraint : Rep_OclType.Path -> Rep_OclType.OclType -> Rep_Core.associationend list -> string -> Rep_Core.constraint - exception NotYetImplemented of string exception InvalidArguments of string @@ -175,6 +107,9 @@ struct datatype transformFlag = BinaryAssociationsOnly type modelTransformation = Rep_Core.transform_model * transformFlag list -> Rep_Core.transform_model * transformFlag list + +open List +open ListPair open library open Transform_Library open Rep_OclTerm @@ -182,6 +117,7 @@ open Rep_OclType open Rep_OclHelper open Rep_Core + infix |>> fun (x |>> f) = (f x) @@ -194,130 +130,6 @@ exception InvalidArguments of string § ***********************************) val triv_expr = Rep_OclTerm.Literal ("true",Rep_OclType.Boolean) -(* (JD) -> Rep_OclType? *) -fun get_short_name (path:Path):string = - List.last path - -fun stripMultiplicities ({name,aends,aclass}:association):association = - let - fun handleAend {name,aend_type,multiplicity,visibility, - ordered,init} = - {name=name, - aend_type=aend_type, - multiplicity=[], - visibility=visibility, - ordered=ordered, - init=init} - in - {name = name, - aends = map handleAend aends, - aclass = aclass} - end - -fun generate_pairs [] = - error "in generate_pairs: argument list is empty" (* or simply return []? *) - | generate_pairs [a] = - [(a,a)] - | generate_pairs [a,b] = - (* not necessary *) - [(a,b),(b,a)] - | generate_pairs (x::xs) = - let - val pairs = map (fn a => (x,a)) xs - val rev_pairs = map (fn a => (a,x)) xs - in - pairs@rev_pairs@(generate_pairs xs) - end - -fun update_classifier_with_constraint constraint (Class{name,parent,attributes, - operations,associations,invariant,stereotypes,interfaces,thyname, - activity_graphs}) = - Class {name = name, - parent = parent, - attributes = attributes, - operations = operations, - associations = associations, - invariant = constraint::invariant, - stereotypes = stereotypes, - interfaces = interfaces, - thyname = thyname, - activity_graphs = activity_graphs} - | update_classifier_with_constraint constraint (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 = constraint::invariant, - stereotypes = stereotypes, - interfaces = interfaces, - thyname = thyname, - activity_graphs = activity_graphs} - | update_classifier_with_constraint constraint (Interface {name,parents, - operations,stereotypes,invariant,thyname}) = - Interface {name=name, - parents=parents, - operations=operations, - stereotypes=stereotypes, - invariant=constraint::invariant, - thyname=thyname} - | update_classifier_with_constraint constraint (Enumeration {name,parent, - operations,literals,invariant,stereotypes,interfaces,thyname}) = - Enumeration {name = name, - parent = parent, - operations = operations, - literals=literals, - invariant = constraint::invariant, - stereotypes = stereotypes, - interfaces = interfaces, - thyname = thyname} - | update_classifier_with_constraint constraint (Primitive {name,parent, - operations,associations,invariant,stereotypes,interfaces,thyname}) = - Primitive{name = name, - parent = parent, - operations = operations, - associations = associations, - invariant = constraint::invariant, - stereotypes = stereotypes, - interfaces = interfaces, - thyname = thyname} - | update_classifier_with_constraint constraint (Template {parameter, - classifier}) = - Template{parameter=parameter, - classifier = update_classifier_with_constraint - constraint classifier} (* sensible? *) - -fun update_classifiers_single (all_classifiers:Classifier list) - (classifier:OclType) (update:Classifier -> Classifier) :Classifier list= - let - val (match,rest) = List.partition - (fn (Class {name,...}) => name=classifier - | (AssociationClass {name,...}) => name=classifier - | (Interface {name,...}) => name=classifier - | (Enumeration {name,...}) => name=classifier - | (Primitive {name,...}) => name=classifier - | _ => false ) all_classifiers - in - case match of - [x] => (update x)::rest - | [] => error "in update_classifiers_single: no match found" - | _ => error "in update_classifiers_single: more than 1 match found" - end - -fun update_classifiers_with_constraints (all_classifiers:Classifier list) - (classifier:OclType) (con::constraints:constraint list) :Classifier list = - let - val modified_clsses = update_classifiers_single all_classifiers classifier - (update_classifier_with_constraint con) - in - update_classifiers_with_constraints modified_clsses classifier - constraints - end - | update_classifiers_with_constraints all_classifiers _ [] = all_classifiers - fun get_association (all_assocs: Rep_Core.association list) (assoc_path:Path): association = let @@ -362,100 +174,6 @@ fun associationends_of (assoc:association):associationend list = #aends assoc end -fun reachable_set (_:associationend) ([]:associationend list) = error "rep_transform.get_reachable_set: empty source list" - | reachable_set (target:associationend) ([source]:associationend list) = - let - val src_var = Variable(name_of_aend source ,type_of_aend source) - in - ([src_var], ocl_aendcall src_var (path_of_aend target) (type_of_aend target)) - end - | reachable_set (target:associationend) ((source::rest):associationend list) = - let - val (old_vars,intermediate) = reachable_set target rest - val src_var = Variable(name_of_aend source ,type_of_aend source) - val new_set = ocl_aendcall src_var (path_of_aend target) (type_of_aend target) - in - (src_var::old_vars ,ocl_intersection_set new_set intermediate) - end - - -fun within_bounds (set:Rep_OclTerm.OclTerm) ((lower,upper):int*int):Rep_OclTerm.OclTerm = - let - val size = ocl_size set - val lower_lit = Literal (Int.toString lower,Integer) - val upper_lit = Literal (Int.toString upper,Integer) - val lower_bound = ocl_geq size lower_lit - val upper_bound = ocl_leq size upper_lit - in - ocl_and lower_bound upper_bound - end - -fun withinAendMultiplicities targetAend sourceAends name = - let - val _ = trace function_calls "withinAendMultiplicities\n" - val tgt_multiplicities = multiplicities_of_aend target - val tgt_name = name_of_aend target - val tgt_type = type_of_aend target - val (variables,set) = reachable_set target sources - val constr_body = ocl_or_all (map (within_bounds set) tgt_multiplicities) - val tgt_variable = Variable(tgt_name,tgt_type) - val allInstances = ocl_allInstances tgt_variable - val constr_complete = ocl_forAll allInstances variables constr_body - val constraint = (SOME name,constr_complete) - in - constraint - end - -fun injective_constraint (source_path:Path) (source_type:OclType) (targets:associationend list) (name:string):constraint = - let - val source_name = get_short_name source_path - val src_var = Variable(source_name,source_type) - fun role_bounds src_var aend = - let - val name = path_of_aend aend - val aend_type = type_of_aend aend - val set = ocl_aendcall src_var name aend_type - val size = ocl_size set - val bounds = ocl_eq size (Literal("1",Integer)) - in - bounds - end - fun role_equals src_var src2_var aend = - let - val name = path_of_aend aend - val aend_type = type_of_aend aend - val set = ocl_aendcall src_var name aend_type - val size = ocl_size set - val match = ocl_eq size (Literal("1",Integer)) - in - match - end - val roles = map (role_bounds src_var) targets - val roles_part = ocl_and_all roles - val allInstances = ocl_allInstances src_var - val src_var2 = Variable(source_name^"2",source_type) - val matches = map (role_equals src_var src_var2) targets - val matches_anded = ocl_and_all roles - val matches_equal = ocl_eq src_var src_var2 - val matches_imp = ocl_implies matches_anded matches_equal - val allInstances2 = ocl_allInstances src_var2 - val matches_part = ocl_forAll allInstances2 [src_var2] matches_imp - val constr_body = ocl_and roles_part matches_part - val constr_complete = ocl_forAll allInstances [src_var] constr_body - in - (SOME name,constr_complete) - end - -fun split_on_association (associations:association list) (path:Path): (association * association list) = - let - fun belonging_association tgt {name,aends,aclass} = tgt = name - val ([assoc],others) = List.partition (belonging_association path) - associations - in - (assoc, others) - end - - (**************************** ******** Transforms ******** ****************************) @@ -467,7 +185,7 @@ fun split_on_association (associations:association list) (path:Path): (associati * generates: constraint, AssociationClass * removes: qualifier *) -fun transform_qualifiers ((all_classifiers,all_associations):transform_model): +fun transformQualifiers ((all_classifiers,all_associations):transform_model): transform_model = (all_classifiers,all_associations) (*dummy*) @@ -476,8 +194,8 @@ fun transform_qualifiers ((all_classifiers,all_associations):transform_model): * generates: constraint * removes: aggregation *) -fun transform_aggregation ((all_classifiers,all_associations):transform_model):transform_model = - (all_classifiers,all_associations) (*dummy*) +fun transformAggregation (allClassifiers,allAssociations) = + (allClassifiers,allAssociations) (*dummy*) (*****************************************************************************) @@ -499,20 +217,85 @@ fun transform_aggregation ((all_classifiers,all_associations):transform_model):t *) fun transformAssociationClassIntoClass (AssociationClass {name,parent,attributes,operations, - associations,association, + associations,association, invariant,stereotypes,interfaces, thyname,activity_graphs}) = (trace function_calls "transformAssociationClassIntoClass\n", Class { name = name, - parent = parent, - attributes = attributes, - operations = operations, - associations = associations, - invariant = constraint::invariant, - stereotypes = stereotypes, - interfaces = interfaces, - thyname = thyname, - activity_graphs = activity_graphs}) + parent = parent, + attributes = attributes, + operations = operations, + associations = associations, + invariant = invariant, + stereotypes = stereotypes, + interfaces = interfaces, + thyname = thyname, + activity_graphs = activity_graphs}) + +(** + * Process an association: add the dummy class, generate the matching- + * constraint and update the classifiers with that constraint. + *) +fun generalTransfromNAryAssociation dummy (association as {name,aends, + aclass=NONE}, + (classifiers,processedAssocs)) = + let + val _ = trace function_calls "transformNAryAssociation\n" + fun modifyClassifier ((assocs,classifier),classifiers) = + let + val ([cls],rem) = partition (fn x => name_of x = name_of + classifier) + classifiers + in + modifyAssociationsOfClassifier assocs [association] cls ::rem + end + + fun consistency [] refer [] [] [] = [] + | consistency (source::xs) refer (selfAend::ys) (roles::zs) + (refRoles::us) = + consistencyOclConstraint source refer selfAend roles refRoles :: + (consistency xs refer ys zs us) + + fun addOcl ((classifier,ocls), classifiers) = + let + val ([cls],rem) = partition (fn x => classifier = x) classifiers + in + addInvariants ocls cls :: rem + end + + (* extract participants/members and form associations *) + val (assocMembers,rem) = matchClassifiersAtAend aends classifiers + val (binaryAssocs,oppRefAends) = binaryAssociations dummy assocMembers + aends + val (clsses,roleNames, oppAends, splitAssocs) = splitNAryAssociation + association + assocMembers + val assocMemberPairs = zip (map (fn x => [x]) binaryAssocs,assocMembers) + val splitMemberPairs = zip (splitAssocs,assocMembers) + + (* update association membership info in classifiers *) + val modifiedClassifiers = foldl modifyClassifier classifiers + (assocMemberPairs @ splitMemberPairs) + val dummy = modifyAssociationsOfClassifier binaryAssocs [] dummy + + (* generate and add OCL constraints *) + val uniquenessOCL = uniquenessOclConstraint dummy binaryAssocs + val selfAends = matchAends oppRefAends (zip (clsses,roleNames)) + val refRoles = map (matchAends oppRefAends) oppAends + val namedConsistencyOCLs = consistency clsses dummy selfAends oppAends + refRoles + val multiplicitiesOCL = + multiplicityOclConstraint dummy (map multiplicity_of_aend aends) + oppRefAends + val dummy = addInvariants (uniquenessOCL::multiplicitiesOCL) dummy + val modifiedClassifiers = foldl addOcl modifiedClassifiers + namedConsistencyOCLs + + (* update references to removed associations *) + (*val modifiedClassifiers = TODO *) + in + (dummy::modifiedClassifiers, binaryAssocs@splitAssocs@processedAssocs) + end (** * Transform an AssociationClass into a Class and an Association @@ -529,13 +312,15 @@ fun transformAssociationClasses (allClassifiers,allAssociations) = val ([dummy],rem) = List.partition (fn x => name_of x = aClass) classifiers in - generalTransfromNAryAssociation dummy ({name=name,aends=aends,aclass=NONE}, + generalTransfromNAryAssociation dummy ({name=name,aends=aends, + aclass=NONE}, (rem,procAssocs)) end fun stripAcAssoc ({name,aends,aclass=SOME aClass},classifiers) = let - val (ac,rem) = List.partition (fn x => name_of x = aClass) classifiers + val (ac,rem) = List.partition (fn x => name_of x = aClass) + classifiers in transformAssociationClassIntoClass ac ::rem end @@ -548,77 +333,6 @@ fun transformAssociationClasses (allClassifiers,allAssociations) = (modifiedClassifiers,modifiedAssociations@rem) end -fun transformNAryAssociation (association,(classifiers,procAssocs)) = - generalTransfromNAryAssociation (newDummyClass o package_of_association - association) - (association,(classifiers,procAssocs)) - -(** - * Process an association: add the dummy class, generate the matching- - * constraint and update the classifiers with that constraint. - *) -fun generalTransfromNAryAssociation dummy (association as {name,aends,NONE}, - (classifiers,processedAssocs)) = - let - val _ = trace function_calls "transformNAryAssociation\n" - fun modifyClassifiers ((assoc,classifier),classifiers) = - let - val ([cls],rem) = partition (fn x => name_of x = name_of - classifier) - classifiers - in - modifyAssociationsOfClassifier [assoc] [association] cls ::rem - end - - fun consistency [] ref [] [] [] = [] - | consistency (source::xs) ref (selfAend::ys) (roles::zs) - (refRoles::us) = - consistencyOclConstraint source ref selfAend roles refRoles :: - (consistency xs ref ys zs us) - - fun addOcl ((classifier,ocls), classifiers) = - let - val ([cls],rem) = partition (fn x => classifier = x) classifiers - in - addInvariants ocls cls :: rem - end - - fun matchClassifiers oppRefAends (cls,role) = - matchClassifier oppRefAends cls role - - (* extract participants/members and form associations *) - val (assocMembers,rem) = matchClassifierAtAend classifiers aends - val (binaryAssocs,oppRefAends) = binaryAssociations dummy assocMembers - aends - val (clsses,roleNames, oppAends, splitAssocs) = splitNAryAssociation - association - assocMembers - val assocMemberPairs = zip binaryAssocs assocMembers - val splitMemberPairs = zip splitAssocs assocMembers - - (* update association membership info in classifiers *) - val modifiedClassifiers = foldl modifyClassifiers classifiers - (assocMemberPairs@splitMemeberPairs) - val dummy = modifyAssociationsOfClassifier binaryAssocs [] dummy - - (* generate and add OCL constraints *) - val uniquenessOCL = uniquenessOclConstraint dummy binaryAssocs - val selfAends = matchClassifiers oppRefAends (zip clsses roleNames) - val refRoles = map (matchAends oppRefAends) oppAends - val namedConsistencyOCLs = consistency clsses dummy selfAends oppAends - refRoles - val multiplicitiesOCL = - multiplicityOclConstraint dummy (map multiplicity_of_aend aends) - binaryAssocs - val dummy = addInvariants (uniquenessOCL::multiplicitiesOCL) dummy - val modifiedClassifiers = foldl addOcl modifiedClassifiers - namedConsistencyOCLs - - (* update references to removed associations *) - (*val modifiedClassifiers = TODO *) - in - (dummy::modifiedClassifiers, binaryAssocs@splitAssocs@processedAssocs) - end (** * We need OCL constraints and an additional dummy class to handle the broken @@ -634,6 +348,11 @@ fun generalTransfromNAryAssociation dummy (association as {name,aends,NONE}, fun transformNAryAssociations (allClassifiers,allAssociations) = let val _ = trace function_calls "transform_n_ary_associations\n" + fun transformNAryAssociation (association,(classifiers,procAssocs)) = + generalTransfromNAryAssociation + (newDummyClass (package_of_association association)) + (association,(classifiers,procAssocs)) + val (nAryAssocs,rem) = partition isPureNAryAssoc allAssociations val (modifiedClassifiers,modifiedAssociations) = foldl transformNAryAssociation (allClassifiers,[]) nAryAssocs @@ -672,47 +391,48 @@ fun transformMultiplicities (allClassifiers,allAssociations) = (SOME name, term) end - fun addMultiplicityConstraints (assoc as {name,aends=[a,b],NONE}, + fun addMultiplicityConstraints (assoc as {name,aends=[a,b],aclass=NONE}, localClassifiers) = let - val _ = trace function_calls "addMultiplicityConstraints\n" - val aType = type_of_aend a - val bType = type_of_aend b + val _ = trace function_calls "addMultiplicityConstraints\n" + val aType = type_of_aend a + val bType = type_of_aend b val aPath = path_of_aend a val bPath = path_of_aend b - val aName = name_of_aend a - val bName = name_of_aend b - val aConstrName = "BinaryMultiplicity"^a_name - val bConstrName = "BinaryMultiplicity"^b_name - val modifiedTmp = + val aName = name_of_aend a + val bName = name_of_aend b + val aConstrName = "BinaryMultiplicity"^aName + val bConstrName = "BinaryMultiplicity"^bName + val modifiedTmp = (case (multiplicities_of_aend a) of [] => localClassifiers | multis => let - val aConstraint = binaryConstraint aType bType bPath + val aConstraint = binaryConstraint aType bType bPath multis aConstrName - in - updateClassifiersWithConstraints classifiers aType + in + updateClassifiersWithConstraints localClassifiers aType [aConstraint] - end) - val modifiedClassifiers = + end) + val modifiedClassifiers = (case (multiplicities_of_aend b) of [] => modifiedTmp | multis => - let - val bConstraint = binaryConstraint bType aType aPath + let + val bConstraint = binaryConstraint bType aType aPath multis bConstrName - in - updateClassifiersWithConstraints modifiedTmp bType + in + updateClassifiersWithConstraints modifiedTmp bType [bConstraint] - end) - in - modifiedClassifiers - end - + end) + in + modifiedClassifiers + end + (* filter the valid associations *) - val (binaryAssociations,rem) = partition isPureBinAssoc allAssociations - + val (binaryAssociations,rem) = List.partition isPureBinAssoc + allAssociations + (* add the constraints to the classifiers *) val modifiedClassifiers = foldl addMultiplicityConstraints allClassifiers binaryAssociations @@ -745,7 +465,7 @@ fun transformClassifiersExt (model:Rep_Core.transform_model):Rep_Core.transform_ transformNAryAssociations fun transformClassifiers (model:transform_model):Rep.Classifier list = - fst (transformClassifiers_ext model) (* return classifiers *) + fst (transformClassifiersExt model) (* return classifiers *) (** @@ -753,7 +473,8 @@ fun transformClassifiers (model:transform_model):Rep.Classifier list = * @return a list of rep classifiers, or nil in case of problems *) fun transformFile f:transform_model = (info ("opening "^f); - (normalize_ext o transformClassifiers_ext o RepParser.transformXMI_ext o XmiParser.readFile) f) + (normalize_ext o transformClassifiersExt o + RepParser.transformXMI_ext o XmiParser.readFile) f) (* handle ex as (IllFormed msg) => raise ex *) exception FileNotFound of string diff --git a/su4sml/src/transform_library.sml b/su4sml/src/transform_library.sml index 509bb83..e22bba7 100644 --- a/su4sml/src/transform_library.sml +++ b/su4sml/src/transform_library.sml @@ -18,8 +18,14 @@ val uniquenessOclConstraint : Rep_Core.Classifier -> * @params {source,multis,binaryAssocs} *) val multiplicityOclConstraint: Rep_Core.Classifier -> (int*int) list list -> - Rep_Core.association list -> + Rep_Core.associationend list -> Rep_Core.constraint list +val consistencyOclConstraint: Rep_Core.Classifier -> + Rep_Core.Classifier -> + Rep_Core.associationend -> + Rep_Core.associationend list -> + Rep_Core.associationend list -> + (Rep_Core.Classifier * Rep_Core.constraint list) (** * @params {association,assocMembers} @@ -60,9 +66,14 @@ val matchAends: Rep_Core.associationend list -> (** * *) -val matchClassifiers: Rep_Core.associationend list -> - (Rep_Core.Classifier * string) list - -> Rep_Core.associationend list +val matchAendsAtClassifier: Rep_Core.associationend list -> + (Rep_Core.Classifier * string) list + -> Rep_Core.associationend list + +val matchClassifiersAtAend: Rep_Core.associationend list -> + Rep_Core.Classifier list -> + (Rep_Core.Classifier list * + Rep_Core.Classifier list ) (** * Form binary associations between @@ -102,12 +113,77 @@ val isPureNAryAssoc: Rep_Core.association -> bool *) val isPureBinAssoc : Rep_Core.association -> bool +(** + * returns the path of an association end. The path of an association end + * is @[]. + * @params {aend} + * @param aend association end + * @return path of association end + *) +val path_of_aend : Rep_Core.associationend -> Rep_OclType.Path + +val role_of_aend : Rep_Core.associationend -> string +(** + * returns the type of the classifier this association end belongs to. + * @params {aend} + * @param aend association end + * @return type of the classifier at the association end + *) +val type_of_aend : Rep_Core.associationend -> Rep_OclType.OclType +(** + * returns the association this association end belongs to. + * @params {aend} + * @param aend association end + * @return the path of the enclosing association + *) +val association_of_aend : Rep_Core.associationend -> Rep_OclType.Path +(** + * returns the name of the association end. The name of the association + * end is the last part of the association end's path. + * @params {aend} + * @param aend association end + * @return name of the association end as string. + *) +val name_of_aend : Rep_Core.associationend -> string +(** + * returns the list of specified multiplicities for this association end. + * @params {aend} + * @param aend association end + * @return the list of multiplicities of this association end. If there are + * no multiplicities, an empty list is returned. + *) +val multiplicities_of_aend : Rep_Core.associationend -> (int*int) list + +(** + * Remove all multiplicities from the association + * @params {assoc} + * @param assoc association + * @return assoc with all multiplicities removed + *) +val stripMultiplicities : Rep_Core.association -> Rep_Core.association +(* result: (Variable list , OCL expression for set intersection)*) +val reachableSet : Rep_Core.associationend -> Rep_Core.associationend list -> (Rep_OclTerm.OclTerm list * Rep_OclTerm.OclTerm) + + + +val modifyAssociationsOfClassifier: Rep_Core.association list -> + Rep_Core.association list -> + Rep_Core.Classifier -> Rep_Core.Classifier + + +val withinBounds : Rep_OclTerm.OclTerm -> (int*int) -> Rep_OclTerm.OclTerm +val withinAendMultiplicities : Rep_Core.associationend -> Rep_Core.associationend list -> string -> Rep_Core.constraint +val injectiveConstraint : Rep_OclType.Path -> Rep_OclType.OclType -> Rep_Core.associationend list -> string -> Rep_Core.constraint +val updateClassifiersWithConstraints: Rep_Core.Classifier list -> + Rep_OclType.OclType -> + Rep_Core.constraint list -> + Rep_Core.Classifier list + + + val uid: int ref -val path_of_aend: Rep_Core.associationend -> Rep_OclType.Path -val role_of_aend: Rep_Core.associationend -> string -val type_of_aend: Rep_Core.associationend -> Rep_OclType.OclType -val association_of_aend: Rep_Core.associationend -> Rep_OclType.Path +val multiplicity_of_aend: Rep_Core.associationend -> (int * int) list val package_of_aend: Rep_Core.associationend -> Rep_OclType.Path val name_of_association: Rep_Core.association -> Rep_OclType.Path val package_of_association: Rep_Core.association -> Rep_OclType.Path @@ -124,11 +200,8 @@ structure Transform_Library:TRANSFORM_LIBRARY = struct open library -open ListPair -open List open StringHandling open Rep_OclTerm -open Rep_OclType open Rep_OclHelper open Rep_Core @@ -138,31 +211,56 @@ val uid = ref 0 fun nextUid () = (uid := !uid + 1; "_S"^(Int.toString (!uid))) +fun get_short_name (path:Path):string = + List.last path + +fun stripMultiplicities ({name,aends,aclass}:association):association = + let + fun handleAend {name,aend_type,multiplicity,visibility, + ordered,init} = + {name=name, + aend_type=aend_type, + multiplicity=[], + visibility=visibility, + ordered=ordered, + init=init} + in + {name = name, + aends = map handleAend aends, + aclass = aclass} + end + +fun multiplicity_of_aend ({aend_type,multiplicity,...}:associationend) = + multiplicity (* (JD) -> Rep_Core? *) -fun path_of_aend {name,aend_type,...} = name +fun path_of_aend ({name,aend_type,...}:associationend) = name +fun name_of_aend ({name,aend_type,...}:associationend) = + short_name_of_path name -fun role_of_aend {name,aend_type,...} = List.last name +fun role_of_aend ({name,aend_type,...}:associationend) = List.last name (* (JD) -> Rep_Core? *) -fun type_of_aend {name,aend_type,...} = aend_type +fun type_of_aend ({name,aend_type,...}:associationend) = aend_type (* (JD) -> Rep_Core? *) -fun association_of_aend {name,aend_type,...} = +fun association_of_aend ({name,aend_type,...}:associationend) = List.take(name, (List.length name)-1) -fun package_of_aend {name,aend_type,...} = +fun package_of_aend ({name,aend_type,...}:associationend) = List.take(name, List.length name - 2) -fun name_of_association {name,aends,aclass} = name +fun name_of_association ({name,aends,aclass}:association) = name -fun package_of_association {name,aends,aclass} = +fun package_of_association ({name,aends,aclass}:association) = List.take(name, List.length name - 1) (* (JD) -> Rep_Core? *) -fun multiplicities_of_aend {aend_type,multiplicity,...} = multiplicity +fun multiplicities_of_aend ({aend_type,multiplicity,...}:associationend) = + multiplicity -fun short_name_of_aend {name,aend_type,...} = List.last name +fun short_name_of_aend ({name,aend_type,...}:associationend) = + short_name_of_path name fun quantifyForAll variables body = @@ -213,7 +311,103 @@ fun removeAssociations oldAssocs associations = associations (* FIXME *) end -fun modifyAssociationsOfClassifier newAssociations oldAssociations +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 reachableSet (_:associationend) ([]:associationend list) = + error "rep_transform.get_reachableSet: empty source list" + | reachableSet (target:associationend) ([source]:associationend list) = + let + val src_var = Variable(name_of_aend source ,type_of_aend source) + in + ([src_var], ocl_aendcall src_var (path_of_aend target) + (type_of_aend target)) + end + | reachableSet (target:associationend) (source::rest) = + let + val (old_vars,intermediate) = reachableSet target rest + val src_var = Variable(name_of_aend source ,type_of_aend source) + val new_set = ocl_aendcall src_var (path_of_aend target) + (type_of_aend target) + in + (src_var::old_vars ,ocl_intersection_set new_set intermediate) + end + + +fun withinBounds (set:Rep_OclTerm.OclTerm) ((lower,upper):int*int):Rep_OclTerm.OclTerm = + let + val size = ocl_size set + val lower_lit = Literal (Int.toString lower,Integer) + val upper_lit = Literal (Int.toString upper,Integer) + val lower_bound = ocl_geq size lower_lit + val upper_bound = ocl_leq size upper_lit + in + ocl_and lower_bound upper_bound + end + +fun withinAendMultiplicities targetAend sourceAends name = + let + val _ = trace function_calls "withinAendMultiplicities\n" + val tgtMultiplicities = multiplicities_of_aend targetAend + val tgtName = name_of_aend targetAend + val tgtType = type_of_aend targetAend + val (variables,set) = reachableSet targetAend sourceAends + val constrBody = ocl_or_all (map (withinBounds set) tgtMultiplicities) + val tgtVariable = Variable(tgtName^nextUid (),tgtType) + val allInstances = ocl_allInstances tgtVariable + val constrComplete = ocl_forAll allInstances variables constrBody + val constraint = (SOME name,constrComplete) + in + constraint + end + +fun injectiveConstraint (source_path:Path) (source_type:OclType) (targets:associationend list) (name:string):constraint = + let + val source_name = get_short_name source_path + val src_var = Variable(source_name,source_type) + fun role_bounds src_var aend = + let + val name = path_of_aend aend + val aend_type = type_of_aend aend + val set = ocl_aendcall src_var name aend_type + val size = ocl_size set + val bounds = ocl_eq size (Literal("1",Integer)) + in + bounds + end + fun role_equals src_var src2_var aend = + let + val name = path_of_aend aend + val aend_type = type_of_aend aend + val set = ocl_aendcall src_var name aend_type + val size = ocl_size set + val match = ocl_eq size (Literal("1",Integer)) + in + match + end + val roles = map (role_bounds src_var) targets + val roles_part = ocl_and_all roles + val allInstances = ocl_allInstances src_var + val src_var2 = Variable(source_name^"2",source_type) + val matches = map (role_equals src_var src_var2) targets + val matches_anded = ocl_and_all roles + val matches_equal = ocl_eq src_var src_var2 + val matches_imp = ocl_implies matches_anded matches_equal + val allInstances2 = ocl_allInstances src_var2 + val matches_part = ocl_forAll allInstances2 [src_var2] matches_imp + val constr_body = ocl_and roles_part matches_part + val constr_complete = ocl_forAll allInstances [src_var] constr_body + in + (SOME name,constr_complete) + end + +fun modifyAssociationsOfClassifier (newAssociations:association list) + (oldAssociations:association list) (Class{name,parent,attributes, operations,associations,invariant, stereotypes,interfaces,thyname, @@ -266,12 +460,13 @@ fun modifyAssociationsOfClassifier newAssociations oldAssociations interfaces=interfaces, thyname=thyname} -fun uniquenessOclConstraint source associations = +fun uniquenessOclConstraint (source:Classifier) (associations:association list) = let - fun assocAendCalls (self:OclTerm) iter {name,aends,aclass} = + fun assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends,aclass} = let - val [{name,aend_type,...}] = filter (fn {aend_type,...} => - aend_type <> Rep_OclHelper.type_of self) + val [{name,aend_type,...}] = filter (fn {aend_type,name,multiplicity,ordered,visibility,init} => + Rep_OclHelper.type_of self + <> aend_type) aends val selfCall = ocl_aendcall self name (Collection aend_type) val iterCall = ocl_aendcall iter name (Collection aend_type) @@ -291,12 +486,12 @@ fun uniquenessOclConstraint source associations = end -fun binaryAssociations source targets aends= +fun binaryAssociations (source:Classifier) (targets:Classifier list) aends= let val _ = trace function_calls "binaryAssociations\n" fun generateAssociation target = let - val assocName = package_of_aend source @ + val assocName = package_of source @ ["BinaryAssoc"^nextUid ()] val oppAend = {name=assocName@[short_name_of target], aend_type=type_of target, @@ -323,11 +518,12 @@ fun binaryAssociations source targets aends= | order (x::xs) [] = raise InvalidArguments ("binaryAssociations.order:"^ "arguments don't agree\n") - | order pairs ({name=refName,aend_type,...}::aends) = + | order pairs ({name=refName,aend_type,multiplicity,ordered,init,visibility}::aends) = let val ([oppAend],rem) = List.partition (fn (_,{name=oppAendName, - aend_type,...}:Rep_Core.associationend) => - oppAendName = refName) pairs + aend_type,multiplicity,ordered,visibility,init}) => + oppAendName = refName) + pairs in oppAend :: (order rem aends) end @@ -335,25 +531,25 @@ fun binaryAssociations source targets aends= val pairs = map generateAssociation targets in - unzip (order pairs aends) + ListPair.unzip (order pairs aends) end -fun variableFromAend {name,aend_type,...} = +fun variableFromAend ({name,aend_type,...}:associationend) = Variable (toLower (short_name_of_path name)^nextUid (),aend_type) -fun variableFromClassifier cls = +fun variableFromClassifier (cls:Classifier) = Variable (toLower (short_name_of cls)^nextUid () ,type_of cls) -fun roleToAend source {name,aend_type,...} = +fun roleToAend source ({name,aend_type,...}:associationend) = ocl_aendcall source name (Collection aend_type) -fun fixAends source aends = +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 (zip (roles,vars))) + 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, @@ -363,7 +559,7 @@ fun fixAends source aends = (ocl,vars) end -fun multiplicityOclConstraint source multis binaryAssocs = +fun multiplicityOclConstraint source multis oppAends = let val _ = trace function_calls "multiplicityOclConstraint\n" fun bound set (low,high) = @@ -382,15 +578,18 @@ fun multiplicityOclConstraint source multis binaryAssocs = val selfVar = self (type_of source) in - iterate selfVar multis [] binaryAssocs + iterate selfVar multis [] oppAends end fun consistencyOclConstraint source reference selfAend roles refRoles = let val _ = trace function_calls "consistencyOclConstraint\n" - fun implies selfVar refVar {name=selfPath,aend_type=selfType,...} - ((role as {name=newPath,aend_type=newType,...}), - {name=refPath,aend_type=refType,...}) = + 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 @@ -413,30 +612,33 @@ fun consistencyOclConstraint source reference selfAend roles refRoles = val refVar = variableFromClassifier reference in - (source, map (implies selfVar refVar selfAend ) (zip (roles,refRoles))) + (source, map (implies selfVar refVar selfAend ) + (ListPair.zip (roles,refRoles))) end -fun splitNAryAssociation (association as {name as (qualifier::assocName), +fun splitNAryAssociation (association as {name=qualifier::assocName, aends,aclass}) classifiers = let val _ = trace function_calls "splitNAryAssociation\n" - fun updateClassifier ((clsType,newPaths),classifiers) = + fun updateClassifier ((clsType,newAssocs),classifiers) = let - val ([cls],rem) = List.partition (fn x => type_of x = clsType ) - classifiers - val modifiedCls = modifyAssociationsOfClassifier newPaths + val ([cls],rem) = List.partition (fn x => type_of x = clsType ) + classifiers + val modifiedCls = modifyAssociationsOfClassifier newAssocs [association] cls in - modifiedCls::rem + modifiedCls::rem end - + fun iterate done [] = [] | iterate done ((aend as {name,aend_type,multiplicity,ordered, - visibility,init})::xs) = + visibility,init})::xs) = let - fun makeAssoc (sourceAend as {name,aend_type,...}) - {name=targetName,aend_type=targetType,...} = + fun makeAssoc (sourceAend as {name,aend_type,multiplicity,init, + ordered,visibility}) + {name=targetName,aend_type=targetType,init=init2, + ordered=ord2,multiplicity=mult2,visibility=vis2} = let val assocPath = package_of_aend sourceAend val assocName = short_name_of_path (association_of_aend @@ -462,9 +664,9 @@ fun splitNAryAssociation (association as {name as (qualifier::assocName), (oppAend,binaryAssoc) end - val (oppAends,binaryAssocs) = unzip (map (makeAssoc aend) - (done@xs)) - val role = short_name_of name + val (oppAends,binaryAssocs) = ListPair.unzip (map (makeAssoc aend) + (done@xs)) + val role = short_name_of_path name in (aend_type,role,oppAends,binaryAssocs):: (iterate (aend::done) xs) @@ -478,9 +680,8 @@ fun splitNAryAssociation (association as {name as (qualifier::assocName), "arguments don't agree\n") | order pairs (cls::clsses) = let - val ([oppAend],rem) = List.partition (fn (oppCls,_,_,_) => - name_of oppCls = - name_of cls) + val ([oppAend],rem) = List.partition (fn (oppType,_,_,_) => + type_of cls = oppType) pairs in oppAend :: (order rem clsses) @@ -498,39 +699,55 @@ fun splitNAryAssociation (association as {name as (qualifier::assocName), (* generate new associations *) val pairs = iterate [] aends - val (clsses,roleNames,oppAends,splitAssocs) = unzip4 (order pairs + val (types,roleNames,oppAends,splitAssocs) = unzip4 (order pairs classifiers) (* update associations in classifiers to the new names *) val modifiedClassifiers = foldl updateClassifier classifiers - (zip (map type_of clsses, - map getPaths splitAssocs)) + (ListPair.zip (types,splitAssocs)) in (modifiedClassifiers, roleNames, oppAends, splitAssocs) end (* target type and role name is unqiue, even with reflexive links *) -fun matchAends oppRefAends oppAends = +fun matchAends (oppRefAends:associationend list) oppAends = let - fun findMatch {aend_type=oppAendType,name=oppName,...} = - hd (List.filter (fn {aend_type=refAendType,name=refName, - ...} => oppAendType = refAendType andalso - List.last oppName = List.last refName) + 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 + map findMatch oppAends end - -(* target type and role name is still unqiue for classifiers and role *) -fun matchClassifiers oppRefAends pairs = +fun matchClassifiersAtAend aends classifiers = let - fun matchClassifier (cls,role) = - hd (filter (fn {aend_type,name,...} => + 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 + +(* target type and role name is still unqiue for classifiers and role *) +fun matchAendsAtClassifier oppRefAends pairs = + let + fun matchAend (cls,role) = + hd (filter (fn {aend_type,name,multiplicity,init, + ordered,visibility} => type_of cls = aend_type andalso role = short_name_of_path name) oppRefAends) in - map matchClassifier pairs + map matchAend pairs end