isidorus-cvs
Threads by month
- ----- 2026 -----
- February
- January
- ----- 2025 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
April 2010
- 1 participants
- 38 discussions
11 Apr '10
Author: lgiessmann
Date: Sun Apr 11 09:16:12 2010
New Revision: 272
Log:
service-registry: added the file textgrid.xtm which constraints an ontology for isidorus used as textgrid-service-registry; ajax: fixed a bug when there are no players available for role-player-constraints; ajax: fixed a bug when there are no players available for other-role-player-constraints
Added:
trunk/src/unit_tests/textgrid.xtm
Modified:
trunk/src/ajax/javascripts/tmcl_tools.js
Modified: trunk/src/ajax/javascripts/tmcl_tools.js
==============================================================================
--- trunk/src/ajax/javascripts/tmcl_tools.js (original)
+++ trunk/src/ajax/javascripts/tmcl_tools.js Sun Apr 11 09:16:12 2010
@@ -209,6 +209,7 @@
for(var k = 0; k !== rpcs[j].playerType.length; ++k){
for(var l = 0; l !== rpcs[j].playerType[k].length; ++l){
if(instanceOfsPsis.indexOf(rpcs[j].playerType[k][l]) !== -1){
+ if(!rpcs[j].players) rpcs[j].players = new Array();
rpcs[j].players.push(new Array(CURRENT_TOPIC));
break;
}
@@ -224,6 +225,7 @@
for(var k = 0; k !== orcs[j].playerType.length; ++k){
for(var l = 0; l !== orcs[j].playerType[k].length; ++l){
if(instanceOfsPsis.indexOf(orcs[j].playerType[k][l]) !== -1){
+ if(!orcs[j].players) orcs[j].players = new Array();
orcs[j].players.push(new Array(CURRENT_TOPIC));
break;
}
@@ -232,6 +234,7 @@
for(var k = 0; k !== orcs[j].otherPlayerType.length; ++k){
for(var l = 0; l !== orcs[j].otherPlayerType[k].length; ++l){
if(instanceOfsPsis.indexOf(orcs[j].otherPlayerType[k][l]) !== -1){
+ if (!orcs[j].otherPlayers) orcs[j].otherPlayers = new Array();
orcs[j].otherPlayers.push(new Array(CURRENT_TOPIC));
break;
}
Added: trunk/src/unit_tests/textgrid.xtm
==============================================================================
--- (empty file)
+++ trunk/src/unit_tests/textgrid.xtm Sun Apr 11 09:16:12 2010
@@ -0,0 +1,1667 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/">
+ <!-- ===================================================================== -->
+ <!-- === TMCL meta-model topics ========================================== -->
+ <!-- ===================================================================== -->
+ <tm:topic id="topictype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/topic-type"/> <!-- naming of psis: Prague, March 25-27, 2008, page 12 -->
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="occurrencetype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/occurrence-type"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="associationtype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/association-type"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="roletype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/role-type"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="nametype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/name-type"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="scopetype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/scope-type"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- role types used to include the topictype metatypes in associations -->
+ <tm:topic id="topictype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/topic-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="occurrencetype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/occurrence-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="associationtype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/association-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="roletype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/role-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="otherroletype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/other-role-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="othertopictype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/other-topic-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="nametype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/name-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="scopetype-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/scope-type-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- the constraint roletype -->
+ <tm:topic id="constraint-role">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/constraint-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- ===================================================================== -->
+ <!-- === TMCL model topics =============================================== -->
+ <!-- ===================================================================== -->
+
+ <!-- the constraint topic is the common supertype of all constraint types
+ defined by TMCL. -->
+ <tm:topic id="constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- this occurrence type is used to type a single occurrence on each
+ constraint type. This occurrence holds the TMQL value used to
+ evaluate constraint instances for validity. -->
+ <tm:topic id="validation-expression">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/validation-expression"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- the association type used to bind different components into a
+ constraint -->
+ <tm:topic id="applies-to">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/applies-to"/>
+ <tm:instanceOf><tm:topicRef href="#associationtype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- the card min facet is used on many constraint types -->
+ <tm:topic id="card-min">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/card-min"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- the card max facet is used on many constraint types -->
+ <tm:topic id="card-max">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/card-max"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- the reg exp facet is used on many constraint types -->
+ <tm:topic id="regexp">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/reg-exp"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- the datatype facet is used on many constraint types -->
+ <tm:topic id="datatype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/datatype"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- ===================================================================== -->
+ <!-- === topics for super-subtype-associations (ako) ===================== -->
+ <!-- ===================================================================== -->
+
+ <tm:topic id="supertype-subtype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype-subtype"/>
+ </tm:topic>
+
+ <tm:topic id="supertype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype"/>
+ </tm:topic>
+
+ <tm:topic id="subtype">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/subtype"/>
+ </tm:topic>
+
+
+ <!-- ===================================================================== -->
+ <!-- === schema type and schema definitions ============================== -->
+ <!-- ===================================================================== -->
+
+ <!-- constraints can be bound to a schema -->
+ <tm:topic id="schema">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/schema"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+
+ <!-- ===================================================================== -->
+ <!-- === TMCL constraint types =========================================== -->
+ <!-- ===================================================================== -->
+
+ <!-- topictype-constraint -->
+ <tm:topic id="topictype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/topic-type-constraint"/>
+ </tm:topic> <!-- standard constraints doesn't own a valiadtion-expression-occurrence: Prague, March 25-27, 2008, page 34-36 -->
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#topictype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- associationtype-constraint -->
+ <tm:topic id="associationtype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/association-type-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#associationtype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- roletype-constraint -->
+ <tm:topic id="roletype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/role-type-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#roletype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- occurrencetype-constraint -->
+ <tm:topic id="occurrencetype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/occurrence-type-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#occurrencetype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- nametype-constraint -->
+ <tm:topic id="nametype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/name-type-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#nametype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- abstract-topictype-constraint -->
+ <tm:topic id="abstract-topictype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/abstract-topic-type-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#abstract-topictype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- exclusive-instance -->
+ <tm:topic id="exclusive-instance">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/exclusive-instance"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#exclusive-instance"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- ===================================================================== -->
+ <!-- === subjectidentifier/locator constraints =========================== -->
+ <!-- ===================================================================== -->
+
+ <!-- subjectlocator-constraint -->
+ <tm:topic id="subjectlocator-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/subject-locator-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#subjectlocator-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- subjectidentifier-constraint -->
+ <tm:topic id="subjectidentifier-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/subject-identifier-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#subjectidentifier-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- ===================================================================== -->
+ <!-- === names/occurrences/associations/association roles ================ -->
+ <!-- ===================================================================== -->
+
+ <!-- topicname-constraint -->
+ <tm:topic id="topicname-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/topic-name-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#topicname-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- topicoccurrence-constraint -->
+ <tm:topic id="topicoccurrence-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/topic-occurrence-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#topicoccurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- occurrencedatatype-constraint -->
+ <tm:topic id="occurrencedatatype-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/occurrence-datatype-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#occurrencedatatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- uniqueoccurrence-constraint -->
+ <tm:topic id="uniqueoccurrence-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/unique-occurrence-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#uniqueoccurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- associationrole-constraint -->
+ <tm:topic id="associationrole-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/association-role-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#associationrole-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- roleplayer-constraint -->
+ <tm:topic id="roleplayer-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/role-player-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#roleplayer-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- otherrole-constraint -->
+ <tm:topic id="otherrole-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/other-role-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#otherrole-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- ===================================================================== -->
+ <!-- === scopes ========================================================== -->
+ <!-- ===================================================================== -->
+
+ <!-- nametypescope-constraint -->
+ <tm:topic id="nametypescope-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/name-type-scope-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#nametypescope-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- occurrencetypescope-constraint -->
+ <tm:topic id="occurrencetypescope-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/occurrence-type-scope-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#occurrencetypescope-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- associationtypescope-constraint -->
+ <tm:topic id="associationtypescope-constraint">
+ <tm:subjectIdentifier href="http://psi.topicmaps.org/tmcl/association-type-scope-constraint"/>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#subtype"/></tm:type>
+ <tm:topicRef href="#associationtypescope-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#supertype"/></tm:type>
+ <tm:topicRef href="#constraint"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: type handling ==================================== -->
+ <!-- ===================================================================== -->
+
+ <!-- only topics that are instances of topictype are allowed as topic
+ types -->
+ <tm:topic id="ttc">
+ <tm:subjectIdentifier href="http://some.where/constraint-psis/ttc"/>
+ <tm:instanceOf><tm:topicRef href="#topictype-constraint"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- only topics that are instances of associationtype are allowed as
+ association types -->
+ <tm:topic id="atc">
+ <tm:subjectIdentifier href="http://some.where/constraint-psis/atc"/>
+ <tm:instanceOf><tm:topicRef href="#associationtype-constraint"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- only topics that are instances of roletype are allowed as
+ association role types -->
+ <tm:topic id="rtc">
+ <tm:subjectIdentifier href="http://some.where/constraint-psis/rtc"/>
+ <tm:instanceOf><tm:topicRef href="#roletype-constraint"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- only topics that are instances of occurrencetype are allowed as
+ occurrence types -->
+ <tm:topic id="otc">
+ <tm:subjectIdentifier href="http://some.where/constraint-psis/otc"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype-constraint"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- only topics that are instances of nametype are allowed as
+ name types -->
+ <tm:topic id="ntc">
+ <tm:subjectIdentifier href="http://some.where/constraint-psis/ntc"/>
+ <tm:instanceOf><tm:topicRef href="#nametype-constraint"/></tm:instanceOf>
+ </tm:topic>
+
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: base types ======================================= -->
+ <!-- ===================================================================== -->
+
+ <!-- service -->
+ <tm:topic id="service">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="service-name">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-name"/>
+ <tm:instanceOf><tm:topicRef href="#nametype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="description">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/description"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="service-type">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-type"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="service-environment">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-environment"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="service-key">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-key"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- url -->
+ <tm:topic id="url">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/url"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="url-content">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/url-content"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- parameter -->
+ <tm:topic id="parameter">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/parameter"/>
+ <tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="parameter-name">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/parameter-name"/>
+ <tm:instanceOf><tm:topicRef href="#nametype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- description is already defined for the topic-type "service" -->
+
+ <tm:topic id="default-value">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/default-value"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- association service - url -->
+ <tm:topic id="has-url">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/has-url"/>
+ <tm:instanceOf><tm:topicRef href="#associationtype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="service-role">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:topic id="url-role">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/url-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- association url - parameter -->
+ <tm:topic id="has-parameter">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/has-parameter"/>
+ <tm:instanceOf><tm:topicRef href="#associationtype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- url-role is already defined for has-url associations -->
+ <tm:topic id="parameter-role">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/parameter-role"/>
+ <tm:instanceOf><tm:topicRef href="#roletype"/></tm:instanceOf>
+ </tm:topic>
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: exclusive type constraint ======================== -->
+ <!-- ===================================================================== -->
+ <!-- same instances of the type service, url and parameter are not allowed -->
+ <tm:topic id="exc">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/exc"/>
+ <tm:instanceOf><tm:topicRef href="#exclusive-instance"/></tm:instanceOf>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#exc"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#exc"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#exc"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#description"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: subjectIdentifier constraints ==================== -->
+ <!-- ===================================================================== -->
+ <!-- topictype "service":
+ *psis: 1:1:"^http://textgrid.org/isidorus/.+/.+$"
+ topictype "url":
+ *psis: 1:1:"^http://textgrid.org/isidorus/url/.+$"
+ topictype "parameter"
+ *psis: 1:1:"^http://textgrid.org/isidorus/parameter/.+$" -->
+
+ <!-- subjectidentifier of service -->
+ <tm:topic id="sic-service">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/sic-service"/>
+ <tm:instanceOf><tm:topicRef href="#subjectidentifier-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^http://textgrid.org/isidorus/.+/.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#sic-service"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- subjectidentifier of url -->
+ <tm:topic id="sic-url">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/sic-url"/>
+ <tm:instanceOf><tm:topicRef href="#subjectidentifier-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^http://textgrid.org/isidorus/url/.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#sic-url"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- subjectidentifier of parameter -->
+ <tm:topic id="sic-parameter">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/sic-parameter"/>
+ <tm:instanceOf><tm:topicRef href="#subjectidentifier-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^http://textgrid.org/isidorus/parameter/.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#sic-parameter"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#parameter"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: subjectLocator constraints ======================= -->
+ <!-- ===================================================================== -->
+ <!-- topictype "service":
+ *locators: 0
+ topictype "url":
+ *locators: 0
+ topictype "parameter"
+ *locators: 0 -->
+
+ <tm:topic id="slc-service-url-parameter">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/slc-service-url-parameter"/>
+ <tm:instanceOf><tm:topicRef href="#subjectlocator-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">0</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">0</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.*$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#slc-service-url-parameter"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#slc-service-url-parameter"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#slc-service-url-parameter"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#parameter"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: name constraints ================================= -->
+ <!-- ===================================================================== -->
+ <!-- topictype "service":
+ *names: service-name:1:1:"^.+$"
+ topictype "param":
+ *names: param-name:1:1:"^.+$" -->
+
+ <!-- service-name -->
+ <tm:topic id="service-name-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-name-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicname-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-name-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-name-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#nametype-role"/></tm:type>
+ <tm:topicRef href="#service-name"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- parameter-name -->
+ <tm:topic id="parameter-name-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/parameter-name-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicname-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#parameter-name-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#parameter"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#parameter-name-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#nametype-role"/></tm:type>
+ <tm:topicRef href="#parameter-name"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: occurence constraints ============================ -->
+ <!-- ===================================================================== -->
+ <!-- topictype "service":
+ *occurrences: service-key:1:1:"^.+$":xml:string
+ *occurrences: description:0:1:".*":xml:string
+ *occurrences: service-type:0:1:".*":xml:string
+ *occurrences: service-environment:1:1:"^.+$":xml:string
+ topictype "url":
+ *occurrences: url-content:1:1:"^.+$"
+ topictype "param":
+ *occurrences: description:0:1:".*"
+ *occurrences: default-value:0:1:".*" -->
+
+ <!-- service-key occurrence -->
+ <tm:topic id="service-key-occurrence-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-key-occurrence-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicoccurrence-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-key-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#service-key"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-key-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <!-- description occurrence -->
+ <tm:topic id="description-occurrence-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/description-occurrence-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicoccurrence-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">0</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">.*</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#description-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#description"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#description-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#description-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#parameter"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- string datatype -->
+ <tm:topic id="string-datatype-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/string-datatype-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencedatatype-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#datatype"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">http://www.w3.org/2001/XMLSchema#string</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#string-datatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#description"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#string-datatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#service-type"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#string-datatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#service-environment"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#string-datatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#default-value"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#string-datatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#service-key"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- anyUri datatype -->
+ <tm:topic id="anyUri-datatype-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/anyUri-datatype-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencedatatype-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#datatype"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">http://www.w3.org/2001/XMLSchema#anyUri</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#anyUri-datatype-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#url-content"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- service-type occurrence -->
+ <tm:topic id="service-type-occurrence-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-type-occurrence-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicoccurrence-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">0</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.*$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-type-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#service-type"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-type-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- service-environment occurrence -->
+ <tm:topic id="service-environment-occurrence-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-environment-occurrence-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicoccurrence-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-environment-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#service-environment"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-environment-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- url-content occurrence -->
+ <tm:topic id="url-content-occurrence-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/url-content-occurrence-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicoccurrence-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">^.+$</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-content-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#url-content"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-content-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- default-value occurrence -->
+ <tm:topic id="default-value-occurrence-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/default-value-occurrence-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#topicoccurrence-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">0</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#regexp"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">.*</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#default-value-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type>
+ <tm:topicRef href="#default-value"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#default-value-occurrence-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#parameter"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- ===================================================================== -->
+ <!-- === own datamodel: association (-role) constraints ================== -->
+ <!-- ===================================================================== -->
+ <!-- association "has-url":
+ *roles: service-role:service:1:1
+ *roles: url-role:url:1:1
+ association "has-param"
+ *roles: url-role:url:1:1
+ *roles: parameter-role:parameter:1:1 -->
+
+ <!-- the service-role has to appear exactly once in an association of type
+ has-url -->
+ <tm:topic id="service-role-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-role-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#associationrole-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-role-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#associationtype-role"/></tm:type>
+ <tm:topicRef href="#has-url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-role-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#roletype-role"/></tm:type>
+ <tm:topicRef href="#service-role"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- the service-role owns a player of the type servie -->
+ <tm:topic id="service-role-player-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/service-role-player-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#roleplayer-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-role-player-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-role-player-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#associationtype-role"/></tm:type>
+ <tm:topicRef href="#has-url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#service-role-player-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#roletype-role"/></tm:type>
+ <tm:topicRef href="#service-role"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- otherrole-constraint:
+ If there is a role of the type service-role with a player of the type
+ service there must be another role of the type url-role with a player
+ of the type url. -->
+ <tm:topic id="has-url-otherrole-constraint-for-service">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/has-url-otherrole-constraint-for-service"/>
+ <tm:instanceOf><tm:topicRef href="#otherrole-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type>
+ <tm:topicRef href="#card-min"/>
+ </tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type>
+ <tm:topicRef href="#card-max"/>
+ </tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-url-otherrole-constraint-for-service"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#associationtype-role"/></tm:type>
+ <tm:topicRef href="#has-url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-url-otherrole-constraint-for-service"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#roletype-role"/></tm:type>
+ <tm:topicRef href="#service-role"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-url-otherrole-constraint-for-service"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#service"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-url-otherrole-constraint-for-service"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#otherroletype-role"/></tm:type>
+ <tm:topicRef href="#url-role"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-url-otherrole-constraint-for-service"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#othertopictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- the url-role has to appear exactly once in an association of type
+ has-parameter -->
+ <tm:topic id="url-role-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/url-role-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#associationrole-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-role-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#associationtype-role"/></tm:type>
+ <tm:topicRef href="#has-parameter"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-role-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#roletype-role"/></tm:type>
+ <tm:topicRef href="#url-role"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- the service-role owns a player of the type servie -->
+ <tm:topic id="url-role-player-constraint">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/url-role-player-constraint"/>
+ <tm:instanceOf><tm:topicRef href="#roleplayer-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-min"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#card-max"/></tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-role-player-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-role-player-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#associationtype-role"/></tm:type>
+ <tm:topicRef href="#has-parameter"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#url-role-player-constraint"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#roletype-role"/></tm:type>
+ <tm:topicRef href="#url-role"/>
+ </tm:role>
+ </tm:association>
+
+
+ <!-- otherrole-constraint:
+ If there is a role of the type url-role with a player of the type
+ url there must be another role of the type parameter-role with a player
+ of the type parameter. -->
+ <tm:topic id="has-parameter-otherrole-constraint-for-url">
+ <tm:subjectIdentifier href="http://textgrid.org/isidorus/tmcl/has-parameter-otherrole-constraint-for-url"/>
+ <tm:instanceOf><tm:topicRef href="#otherrole-constraint"/></tm:instanceOf>
+ <tm:occurrence>
+ <tm:type>
+ <tm:topicRef href="#card-min"/>
+ </tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type>
+ <tm:topicRef href="#card-max"/>
+ </tm:type>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData>
+ </tm:occurrence>
+ </tm:topic>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-parameter-otherrole-constraint-for-url"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#associationtype-role"/></tm:type>
+ <tm:topicRef href="#has-parameter"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-parameter-otherrole-constraint-for-url"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#roletype-role"/></tm:type>
+ <tm:topicRef href="#url-role"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-parameter-otherrole-constraint-for-url"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#topictype-role"/></tm:type>
+ <tm:topicRef href="#url"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-parameter-otherrole-constraint-for-url"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#otherroletype-role"/></tm:type>
+ <tm:topicRef href="#parameter-role"/>
+ </tm:role>
+ </tm:association>
+
+ <tm:association>
+ <tm:type><tm:topicRef href="#applies-to"/></tm:type>
+ <tm:role>
+ <tm:type><tm:topicRef href="#constraint-role"/></tm:type>
+ <tm:topicRef href="#has-parameter-otherrole-constraint-for-url"/>
+ </tm:role>
+ <tm:role>
+ <tm:type><tm:topicRef href="#othertopictype-role"/></tm:type>
+ <tm:topicRef href="#parameter"/>
+ </tm:role>
+ </tm:association>
+</tm:topicMap>
1
0
09 Apr '10
Author: lgiessmann
Date: Fri Apr 9 11:36:02 2010
New Revision: 271
Log:
new-datamodel: added some unit-tests; fixed bugs in "add-name", "add-occurrence", "add-role" and "find-oldest-construct"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Fri Apr 9 11:36:02 2010
@@ -157,16 +157,18 @@
+;;TODO: modify 2x add-parent --> use add-characteristic and add-role
+;;TODO: call merge-if-equivalent in 2x add-parent
;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
;; versioned-construct of the called construct, same for add-xy ???
+;; and associations of player
;;TODO: check for duplicate identifiers after topic-creation/merge
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
;; and the parent's parent construct + the reifier constructs),
;; add-psi, add-locator (--> duplicate-identifier-error)
-;;TODO: implement a macro "with-merge-construct" that merges constructs
-;; after some data-operations are completed (should be passed as body)
-;; and a merge should be done
+;;TODO: implement a macro with-merge-constructs, that merges constructs
+;; after all operations in the body were called
@@ -840,6 +842,19 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric merge-if-equivalent (new-characteristic parent-construct
+ &key revision)
+ (:documentation "Merges the new characteristic/role with one equivalent of the
+ parent's charateristics/roles instead of adding the entire new
+ characteristic/role to the parent."))
+
+
+(defgeneric parent (construct &key revision)
+ (:documentation "Returns the parent construct of the passed object that
+ corresponds with the given revision. The returned construct
+ can be a TopicC or a NameC."))
+
+
(defgeneric delete-if-not-referenced (construct)
(:documentation "Calls delete-construct for the given object if it is
not referenced by any other construct."))
@@ -1672,20 +1687,22 @@
:referenced-construct name
:existing-reference (parent name :revision revision)
:new-reference construct)))
- (let ((all-names
- (map 'list #'characteristic (slot-p construct 'names))))
- (if (find name all-names)
- (let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
- when (eql (parent-construct name-assoc)
- construct)
- return name-assoc)))
- (add-to-version-history name-assoc :start-revision revision))
- (make-construct 'NameAssociationC
- :parent-construct construct
- :characteristic name
- :start-revision revision)))
- (add-to-version-history construct :start-revision revision)
- construct))
+ (if (merge-if-equivalent name construct :revision revision)
+ construct
+ (let ((all-names
+ (map 'list #'characteristic (slot-p construct 'names))))
+ (if (find name all-names)
+ (let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
+ when (eql (parent-construct name-assoc)
+ construct)
+ return name-assoc)))
+ (add-to-version-history name-assoc :start-revision revision))
+ (make-construct 'NameAssociationC
+ :parent-construct construct
+ :characteristic name
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
(defgeneric delete-name (construct name &key revision)
@@ -1730,19 +1747,21 @@
:referenced-construct occurrence
:existing-reference (parent occurrence :revision revision)
:new-reference construct))
- (let ((all-occurrences
- (map 'list #'characteristic (slot-p construct 'occurrences))))
- (if (find occurrence all-occurrences)
- (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
- when (eql (parent-construct occ-assoc) construct)
- return occ-assoc)))
- (add-to-version-history occ-assoc :start-revision revision))
- (make-construct 'OccurrenceAssociationC
- :parent-construct construct
- :characteristic occurrence
- :start-revision revision)))
- (add-to-version-history construct :start-revision revision)
- construct))
+ (if (merge-if-equivalent occurrence construct :revision revision)
+ construct
+ (let ((all-occurrences
+ (map 'list #'characteristic (slot-p construct 'occurrences))))
+ (if (find occurrence all-occurrences)
+ (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
+ when (eql (parent-construct occ-assoc) construct)
+ return occ-assoc)))
+ (add-to-version-history occ-assoc :start-revision revision))
+ (make-construct 'OccurrenceAssociationC
+ :parent-construct construct
+ :characteristic occurrence
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
(defgeneric delete-occurrence (construct occurrence &key revision)
@@ -2000,8 +2019,9 @@
;;; CharacteristicC
(defmethod delete-if-not-referenced ((construct CharacteristicC))
(let ((references (slot-p construct 'parent)))
- (when (and (<= (length references) 1)
- (marked-as-deleted-p (first references)))
+ (when (or (not references)
+ (and (= (length references) 1)
+ (marked-as-deleted-p (first references))))
(delete-construct construct))))
@@ -2099,16 +2119,12 @@
t))
-(defgeneric parent (construct &key revision)
- (:documentation "Returns the parent construct of the passed object that
- corresponds with the given revision. The returned construct
- can be a TopicC or a NameC.")
- (:method ((construct CharacteristicC) &key (revision *TM-REVISION*))
- (let ((valid-associations
- (filter-slot-value-by-revision construct 'parent
- :start-revision revision)))
- (when valid-associations
- (parent-construct (first valid-associations))))))
+(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*))
+ (let ((valid-associations
+ (filter-slot-value-by-revision construct 'parent
+ :start-revision revision)))
+ (when valid-associations
+ (parent-construct (first valid-associations)))))
(defmethod add-parent ((construct CharacteristicC)
@@ -2290,19 +2306,21 @@
:referenced-construct variant
:existing-reference (parent variant :revision revision)
:new-reference construct)))
- (let ((all-variants
- (map 'list #'characteristic (slot-p construct 'variants))))
- (if (find variant all-variants)
- (let ((variant-assoc
- (loop for variant-assoc in (slot-p construct 'variants)
- when (eql (characteristic variant-assoc) variant)
- return variant-assoc)))
- (add-to-version-history variant-assoc :start-revision revision))
- (make-construct 'VariantAssociationC
- :characteristic variant
- :parent-construct construct
- :start-revision revision)))
- construct))
+ (if (merge-if-equivalent variant construct :revision revision)
+ construct
+ (let ((all-variants
+ (map 'list #'characteristic (slot-p construct 'variants))))
+ (if (find variant all-variants)
+ (let ((variant-assoc
+ (loop for variant-assoc in (slot-p construct 'variants)
+ when (eql (characteristic variant-assoc) variant)
+ return variant-assoc)))
+ (add-to-version-history variant-assoc :start-revision revision))
+ (make-construct 'VariantAssociationC
+ :characteristic variant
+ :parent-construct construct
+ :start-revision revision))
+ construct))))
(defgeneric delete-variant (construct variant &key revision)
@@ -2417,20 +2435,22 @@
(:documentation "Adds the given role to the passed association-construct.")
(:method ((construct AssociationC) (role RoleC)
&key (revision *TM-REVISION*))
- (let ((all-roles
- (map 'list #'role (slot-p construct 'roles))))
- (if (find role all-roles)
- (let ((role-assoc
- (loop for role-assoc in (slot-p construct 'roles)
- when (eql (role role-assoc) role)
- return role-assoc)))
- (add-to-version-history role-assoc :start-revision revision))
- (make-construct 'RoleAssociationC
- :role role
- :parent-construct construct
- :start-revision revision)))
- (add-to-version-history construct :start-revision revision)
- construct))
+ (if (merge-if-equivalent role construct :revision revision)
+ construct
+ (let ((all-roles
+ (map 'list #'role (slot-p construct 'roles))))
+ (if (find role all-roles)
+ (let ((role-assoc
+ (loop for role-assoc in (slot-p construct 'roles)
+ when (eql (role role-assoc) role)
+ return role-assoc)))
+ (add-to-version-history role-assoc :start-revision revision))
+ (make-construct 'RoleAssociationC
+ :role role
+ :parent-construct construct
+ :start-revision revision))
+ (add-to-version-history construct :start-revision revision)
+ construct))))
(defgeneric delete-role (construct role &key revision)
@@ -2457,8 +2477,9 @@
;;; RoleC
(defmethod delete-if-not-referenced ((construct RoleC))
(let ((references (slot-p construct 'parent)))
- (when (and (<= (length references) 1)
- (marked-as-deleted-p (first references)))
+ (when (or (not references)
+ (and (= (length references) 1)
+ (marked-as-deleted-p (first references))))
(delete-construct construct))))
@@ -2988,7 +3009,7 @@
(:method ((construct ScopableC) (theme-topic TopicC)
&key (revision (error (make-condition 'missing-argument-error
:message "From delete-theme(): revision must be set"
- :argument-symbol 'revsion
+ :argument-symbol 'revision
:function-symbol 'delete-theme))))
(let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
when (eql (theme-topic theme-assoc) theme-topic)
@@ -3388,7 +3409,7 @@
(not start-revision))
(error (make-condition 'missing-argument-error
:message "From make-characteristic(): start-revision must be set"
- :argument-symbol 'start-revsion
+ :argument-symbol 'start-revision
:function-symbol 'make-characgteristic)))
(let ((characteristic
(let ((existing-characteristic
@@ -3895,4 +3916,59 @@
(move-referenced-constructs newer-role older-role
:revision revision)
(delete-if-not-referenced newer-role)
- older-role)))))))
\ No newline at end of file
+ older-role)))))))
+
+
+(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((possible-roles
+ (remove-if #'(lambda(role)
+ (when (parent role :revision revision)
+ role))
+ (map 'list #'role (slot-p parent-construct 'roles)))))
+ (let ((equivalent-role
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(role)
+ (when
+ (strictly-equivalent-constructs role new-role
+ :revision revision)
+ role))
+ possible-roles))))
+ (when equivalent-role
+ (merge-constructs (first equivalent-role) new-role
+ :revision revision)))))
+
+
+(defmethod merge-if-equivalent ((new-characteristic CharacteristicC)
+ (parent-construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or TopicC NameC) parent-construct))
+ (let ((all-existing-characteristics
+ (map 'list #'characteristic
+ (cond ((typep new-characteristic 'OccurrenceC)
+ (slot-p parent-construct 'occurrences))
+ ((typep new-characteristic 'NameC)
+ (slot-p parent-construct 'names))
+ ((typep new-characteristic 'VariantC)
+ (slot-p parent-construct 'variants))))))
+ (let ((possible-characteristics ;all characteristics that are not referenced
+ ;other constructs at the given revision
+ (remove-if #'(lambda(char)
+ (parent char :revision revision))
+ all-existing-characteristics)))
+ (let ((equivalent-construct
+ (remove-if
+ #'null
+ (map 'list
+ #'(lambda(char)
+ (when
+ (strictly-equivalent-constructs char new-characteristic
+ :revision revision)
+ char))
+ possible-characteristics))))
+ (when equivalent-construct
+ (merge-constructs (first equivalent-construct) new-characteristic
+ :revision revision))))))
\ No newline at end of file
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Fri Apr 9 11:36:02 2010
@@ -2741,53 +2741,67 @@
(test test-find-oldest-construct ()
"Tests the generic find-oldest-construct."
(with-fixture with-empty-db (*db-dir*)
- (let ((top-1 (make-instance 'TopicC))
- (top-2 (make-instance 'TopicC))
- (tm-1 (make-instance 'TopicMapC))
- (tm-2 (make-instance 'TopicMapC))
- (assoc-1 (make-instance 'AssociationC))
- (assoc-2 (make-instance 'AssociationC))
- (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
- (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
- (variant-1 (make-instance 'VariantC))
- (variant-2 (make-instance 'VariantC))
- (name-1 (make-instance 'NameC))
- (name-2 (make-instance 'NameC))
- (role-1 (make-instance 'RoleC))
- (role-2 (make-instance 'RoleC))
- (rev-1 100)
+ (let ((rev-1 100)
(rev-2 200)
(rev-3 300))
- (setf *TM-REVISION* rev-1)
- (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (add-item-identifier top-1 ii-1 :revision rev-3)
- (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (add-item-identifier assoc-1 ii-2 :revision rev-2)
- (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
- (add-item-identifier top-2 ii-1 :revision rev-1)
- (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (add-variant name-1 variant-1 :revision rev-3)
- (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (add-variant name-1 variant-2 :revision rev-2)
- (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2)))
- (add-variant name-2 variant-1 :revision rev-1)
- (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (add-role assoc-1 role-1 :revision rev-3)
- (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (add-role assoc-1 role-2 :revision rev-2)
- (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
- (add-role assoc-2 role-1 :revision rev-1)
- (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
- (d::add-to-version-history tm-1 :start-revision rev-3)
- (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
- (d::add-to-version-history tm-2 :start-revision rev-1)
- (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
- (d::add-to-version-history tm-1 :start-revision rev-1)
- (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
- (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))
+ (let ((theme-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-2 (make-construct 'TopicC :start-revision rev-1))
+ (player-1 (make-construct 'TopicC :start-revision rev-1))
+ (player-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((top-1 (make-instance 'TopicC))
+ (top-2 (make-instance 'TopicC))
+ (tm-1 (make-instance 'TopicMapC))
+ (tm-2 (make-instance 'TopicMapC))
+ (assoc-1 (make-instance 'AssociationC))
+ (assoc-2 (make-instance 'AssociationC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (variant-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "var-1"
+ :themes (list theme-1)))
+ (variant-2 (make-construct 'VariantC
+ :start-revision rev-1
+ :charvalue "var-2"
+ :themes (list theme-2)))
+ (name-1 (make-instance 'NameC))
+ (name-2 (make-instance 'NameC))
+ (role-1 (make-construct 'RoleC
+ :start-revision rev-1
+ :player player-1))
+ (role-2 (make-construct 'RoleC
+ :start-revision rev-1
+ :player player-2)))
+ (setf *TM-REVISION* rev-1)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier top-1 ii-1 :revision rev-3)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier assoc-1 ii-2 :revision rev-2)
+ (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
+ (add-item-identifier top-2 ii-1 :revision rev-1)
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (add-variant name-1 variant-1 :revision rev-3)
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (add-variant name-1 variant-2 :revision rev-2)
+ (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) ;x
+ (add-variant name-2 variant-1 :revision rev-1)
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+ (add-role assoc-1 role-1 :revision rev-3)
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2))) ;x
+ (add-role assoc-1 role-2 :revision rev-2)
+ (is (eql role-2 (d::find-oldest-construct role-1 role-2)))
+ (add-role assoc-2 role-1 :revision rev-1)
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-1 :start-revision rev-3)
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-2 :start-revision rev-1)
+ (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
+ (d::add-to-version-history tm-1 :start-revision rev-1)
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
+ (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))))
(test test-move-referenced-constructs-ReifiableConstructC ()
1
0
08 Apr '10
Author: lgiessmann
Date: Thu Apr 8 11:00:35 2010
New Revision: 270
Log:
new-datamodel: modified "move-referenced-constructs" --> "NameC"; added some unti-tests
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 8 11:00:35 2010
@@ -3539,28 +3539,30 @@
(move-identifiers source destination :revision revision)
(let ((source-reifier (reifier source :revision revision))
(destination-reifier (reifier destination :revision revision)))
- (list
- (cond ((and source-reifier destination-reifier)
- (delete-reifier (reified-construct source-reifier
- :revision revision)
- source-reifier :revision revision)
- (delete-reifier (reified-construct destination-reifier
- :revision revision)
- destination-reifier :revision revision)
- (let ((merged-reifier
- (merge-constructs source-reifier destination-reifier
- :revision revision)))
- (add-reifier destination merged-reifier :revision revision)
- merged-reifier))
- (source-reifier
- (delete-reifier (reified-construct source-reifier
- :revision revision)
- source-reifier :revision revision)
- (add-reifier destination source-reifier :revision revision)
- source-reifier)
- (destination-reifier
- (add-reifier destination destination-reifier :revision revision)
- destination-reifier)))))))
+ (let ((result
+ (cond ((and source-reifier destination-reifier)
+ (delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (delete-reifier (reified-construct destination-reifier
+ :revision revision)
+ destination-reifier :revision revision)
+ (let ((merged-reifier
+ (merge-constructs source-reifier destination-reifier
+ :revision revision)))
+ (add-reifier destination merged-reifier :revision revision)
+ merged-reifier))
+ (source-reifier
+ (delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (add-reifier destination source-reifier :revision revision)
+ source-reifier)
+ (destination-reifier
+ (add-reifier destination destination-reifier :revision revision)
+ nil))))
+ (when result
+ (list result)))))))
(defmethod move-referenced-constructs ((source NameC) (destination NameC)
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Thu Apr 8 11:00:35 2010
@@ -79,7 +79,8 @@
:test-make-AssociationC
:test-make-TopicC
:test-find-oldest-construct
- :test-move-referenced-constructs-ReifiableConstructC))
+ :test-move-referenced-constructs-ReifiableConstructC
+ :test-move-referenced-constructs-NameC))
;;TODO: test merge-constructs
@@ -2836,6 +2837,86 @@
(is-true (d::marked-as-deleted-p reifier-1)))))))
+(test test-move-referenced-constructs-NameC ()
+ "Tests the generic move-referenced-constructs corresponding to NameC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200))
+ (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (reifier-1 (make-construct 'TopicC :start-revision rev-1))
+ (reifier-2 (make-construct 'TopicC :start-revision rev-2))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((variant-1 (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list theme-1)
+ :charvalue "var-1"
+ :item-identifiers (list ii-1)
+ :reifier reifier-2))
+ (variant-2 (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list theme-1)
+ :charvalue "var-2+4"))
+ (variant-3 (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list theme-2)
+ :charvalue "var-3"))
+ (variant-4 (make-construct 'VariantC
+ :start-revision rev-1
+ :themes (list theme-1)
+ :charvalue "var-2+4")))
+ (let ((name-1 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name"
+ :variants (list variant-1 variant-2)
+ :instance-of type-1
+ :item-identifiers (list ii-2)))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name"
+ :variants (list variant-3 variant-4)
+ :instance-of type-1
+ :reifier reifier-1)))
+ (setf *TM-REVISION* rev-1)
+ (is (= (length (union (list variant-1 variant-2)
+ (variants name-1))) 2))
+ (is (= (length (union (list variant-3 variant-4)
+ (variants name-2))) 2))
+ (is-false (reifier name-1))
+ (is (eql reifier-1 (reifier name-2)))
+ (is (= (length
+ (union (list variant-1 variant-2 ii-2)
+ (d::move-referenced-constructs name-1 name-2
+ :revision rev-2)))
+ 3))
+ (is-false (item-identifiers name-1 :revision rev-2))
+ (is-false (reifier name-1 :revision rev-2))
+ (is-false (variants name-1 :revision rev-2))
+ (is (= (length (item-identifiers name-2 :revision rev-2)) 1))
+ (is (= (length (union (list ii-2)
+ (item-identifiers name-2 :revision rev-2)))
+ 1))
+ (is (eql (reifier name-2 :revision rev-2) reifier-1))
+ (is (= (length (variants name-2 :revision rev-2)) 3))
+ (is (= (length (union (list variant-1 variant-3 variant-4)
+ (variants name-2 :revision rev-2)))
+ 3))
+ (is-true
+ (find-if
+ #'(lambda(var)
+ (and (= (length (item-identifiers var :revision rev-2)) 1)
+ (string= (uri (first (item-identifiers var
+ :revision rev-2)))
+ "ii-1")))
+ (variants name-2 :revision rev-2)))
+ (is-true
+ (find-if #'(lambda(var)
+ (eql (reifier var :revision rev-2) reifier-2))
+ (variants name-2 :revision rev-2)))))))))
+
+
(defun run-datamodel-tests()
@@ -2895,4 +2976,5 @@
(it.bese.fiveam:run! 'test-make-TopicC)
(it.bese.fiveam:run! 'test-find-oldest-construct)
(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
+ (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
)
\ No newline at end of file
1
0
08 Apr '10
Author: lgiessmann
Date: Thu Apr 8 07:21:50 2010
New Revision: 269
Log:
new-datamodel: fixed 2 bugs in "move-referenced-constructs" --> "ReifiableConstructC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 8 07:21:50 2010
@@ -3539,26 +3539,28 @@
(move-identifiers source destination :revision revision)
(let ((source-reifier (reifier source :revision revision))
(destination-reifier (reifier destination :revision revision)))
- (cond ((and source-reifier destination-reifier)
- (delete-reifier (reified-construct source-reifier
- :revision revision)
- source-reifier :revision revision)
- (delete-reifier (reified-construct destination-reifier
- :revision revision)
- destination-reifier :revision revision)
- (let ((merged-reifier
- (merge-constructs source-reifier destination-reifier
- :revision revision)))
- (add-reifier destination merged-reifier :revision revision)))
- (source-reifier
- (delete-reifier (reified-construct source-reifier
- :revision revision)
- source-reifier :revision revision)
- (add-reifier destination source-reifier :revision revision)
- source-reifier)
- (destination-reifier
- (add-reifier destination destination-reifier :revision revision)
- destination-reifier))))))
+ (list
+ (cond ((and source-reifier destination-reifier)
+ (delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (delete-reifier (reified-construct destination-reifier
+ :revision revision)
+ destination-reifier :revision revision)
+ (let ((merged-reifier
+ (merge-constructs source-reifier destination-reifier
+ :revision revision)))
+ (add-reifier destination merged-reifier :revision revision)
+ merged-reifier))
+ (source-reifier
+ (delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (add-reifier destination source-reifier :revision revision)
+ source-reifier)
+ (destination-reifier
+ (add-reifier destination destination-reifier :revision revision)
+ destination-reifier)))))))
(defmethod move-referenced-constructs ((source NameC) (destination NameC)
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Thu Apr 8 07:21:50 2010
@@ -18,7 +18,8 @@
duplicate-identifier-error
missing-argument-error
tm-reference-error
- object-not-found-error)
+ object-not-found-error
+ not-mergable-error)
(:import-from :constants
*xml-string*
*xml-uri*)
@@ -77,7 +78,8 @@
:test-make-TopicMapC
:test-make-AssociationC
:test-make-TopicC
- :test-find-oldest-construct))
+ :test-find-oldest-construct
+ :test-move-referenced-constructs-ReifiableConstructC))
;;TODO: test merge-constructs
@@ -2787,6 +2789,53 @@
(is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))
+(test test-move-referenced-constructs-ReifiableConstructC ()
+ "Tests the generic move-referenced-constructs corresponding to ReifiableConstructC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-1 100)
+ (rev-2 200)
+ (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")))
+ (let ((reifier-1 (make-construct 'TopicC :start-revision rev-2))
+ (reifier-2 (make-construct 'TopicC :start-revision rev-1))
+ (theme-1 (make-construct 'TopicC :start-revision rev-1))
+ (theme-2 (make-construct 'TopicC :start-revision rev-1))
+ (type-1 (make-construct 'TopicC :start-revision rev-1))
+ (type-2 (make-construct 'TopicC :start-revision rev-1)))
+ (let ((occ-1 (make-construct 'OccurrenceC
+ :start-revision rev-1
+ :item-identifiers (list ii-1 ii-2)
+ :reifier reifier-1
+ :instance-of type-2
+ :themes (list theme-1 theme-2)
+ :charvalue "occ"))
+ (occ-2 (make-construct 'OccurrenceC
+ :start-revision rev-2
+ :item-identifiers (list ii-3)
+ :charvalue "occ"
+ :instance-of type-1
+ :themes (list theme-1 theme-2)
+ :reifier reifier-2)))
+ (setf *TM-REVISION* rev-1)
+ (delete-type occ-1 type-2 :revision rev-2)
+ (add-type occ-1 type-1 :revision rev-2)
+ (is (eql reifier-1 (reifier occ-1 :revision rev-2)))
+ (is (eql reifier-2 (reifier occ-2 :revision rev-2)))
+ (is (= (length (union (list ii-1 ii-2 reifier-2)
+ (d::move-referenced-constructs occ-1 occ-2
+ :revision rev-2)))
+ 3))
+ (is (= (length (item-identifiers occ-2 :revision rev-2)) 3))
+ (is (= (length (union (item-identifiers occ-2 :revision rev-2)
+ (list ii-1 ii-2 ii-3)))
+ 3))
+ (is-false (item-identifiers occ-1 :revision rev-2))
+ (is-false (reifier occ-1 :revision rev-2))
+ (is (eql (reifier occ-2 :revision rev-2) reifier-2))
+ (is-true (d::marked-as-deleted-p reifier-1)))))))
+
+
(defun run-datamodel-tests()
@@ -2845,4 +2894,5 @@
(it.bese.fiveam:run! 'test-make-AssociationC)
(it.bese.fiveam:run! 'test-make-TopicC)
(it.bese.fiveam:run! 'test-find-oldest-construct)
+ (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
)
\ No newline at end of file
1
0
08 Apr '10
Author: lgiessmann
Date: Thu Apr 8 05:55:12 2010
New Revision: 268
Log:
new-datamodel: fixed a versioning-problem in all "delete-<xy>\ generics; added the exceptions "tm-reference-error", "missing-argument-error" and "not-mergable-error"; adapt the data-model'S unit-tests to the last modifications
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/model/exceptions.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 8 05:55:12 2010
@@ -11,12 +11,13 @@
(:use :cl :elephant :constants)
(:nicknames :d)
(:import-from :exceptions
- duplicate-identifier-error)
- (:import-from :exceptions
- object-not-found-error)
- (:import-from :constants
- *xml-string*)
+ duplicate-identifier-error
+ object-not-found-error
+ missing-argument-error
+ not-mergable-error
+ tm-reference-error)
(:import-from :constants
+ *xml-string*
*instance-psi*)
(:export ;;classes
:TopicMapConstructC
@@ -155,15 +156,9 @@
(in-package :datamodel)
-;;TODO: call delete-construct for all child-constructs that are:
-;; *exist-in-revision-history => nil
-;; *are not referenced by other constructs
-;; --> iis, psis, sls, tids, names, occs, variants, roles
-;;TODO: mark-as-deleted should call mark-as-deleted for every owned
-;; versioned-construct of the called construct
-;;TODO: add: add-to-version-history (parent) to all
-;; "add-<construct>"/"delete-<construct>" generics
-;; ===>> adapt exist-in-revision-history
+
+;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
+;; versioned-construct of the called construct, same for add-xy ???
;;TODO: check for duplicate identifiers after topic-creation/merge
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
@@ -172,8 +167,6 @@
;;TODO: implement a macro "with-merge-construct" that merges constructs
;; after some data-operations are completed (should be passed as body)
;; and a merge should be done
-;;TODO: use some exceptions --> more than one type,
-;; identifier, not-mergable merges, missing-init-args...
@@ -261,7 +254,11 @@
:accessor uri
:inherit t
:type string
- :initform (error "From PointerC(): uri must be set for a pointer")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PointerC(): uri must be set for a pointer"
+ :argument-symbol 'uri
+ :function-symbol ':uri))
:index t
:documentation "The actual value of a pointer, i.e. uri or ID.")
(identified-construct :associate (PointerAssociationC identifier)
@@ -281,7 +278,11 @@
((xtm-id :initarg :xtm-id
:accessor xtm-id
:type string
- :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier"
+ :argument-symbol 'xtm-id
+ :function-symbol ':xtm-id))
:index t
:documentation "ID of the TM this identification came from."))
(:index t)
@@ -439,13 +440,21 @@
(defpclass TypeAssociationC(VersionedAssociationC)
((type-topic :initarg :type-topic
:accessor type-topic
- :initform (error "From TypeAssociationC(): type-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From TypeAssociationC(): type-topic must be set"
+ :argument-symbol 'type-topic
+ :function-symbol ':type-topic))
:associate TopicC
:documentation "Associates this object with a topic that is used
as type.")
(typable-construct :initarg :typable-construct
:accessor typable-construct
- :initform (error "From TypeAssociationC(): typable-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From TypeAssociationC(): typable-construct must be set"
+ :argument-symbol 'typable-construct
+ :function-symbol ':typable-construct))
:associate TypableC
:documentation "Associates this object with the typable
construct that is typed by the
@@ -458,13 +467,21 @@
(defpclass ScopeAssociationC(VersionedAssociationC)
((theme-topic :initarg :theme-topic
:accessor theme-topic
- :initform (error "From ScopeAssociationC(): theme-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ScopeAssociationC(): theme-topic must be set"
+ :argument-symbol 'theme-topic
+ :function-symbol ':theme-topic))
:associate TopicC
:documentation "Associates this opbject with a topic that is a
scopable construct.")
(scopable-construct :initarg :scopable-construct
:accessor scopable-construct
- :initform (error "From ScopeAssociationC(): scopable-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ScopeAssociationC(): scopable-construct must be set"
+ :argument-symbol 'scopable-construct
+ :function-symbol ':scopable-construct))
:associate ScopableC
:documentation "Associates this object with the socpable
construct that is scoped by the
@@ -477,13 +494,21 @@
(defpclass ReifierAssociationC(VersionedAssociationC)
((reifiable-construct :initarg :reifiable-construct
:accessor reifiable-construct
- :initform (error "From ReifierAssociation(): reifiable-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ReifierAssociation(): reifiable-construct must be set"
+ :argument-symbol 'reifiable-construct
+ :function-symbol ':reifiable-construct))
:associate ReifiableConstructC
:documentation "The actual construct which is reified
by a topic.")
(reifier-topic :initarg :reifier-topic
:accessor reifier-topic
- :initform (error "From ReifierAssociationC(): reifier-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ReifierAssociationC(): reifier-topic must be set"
+ :argument-symbol 'reifier-topic
+ :function-symbol ':reifier-topic))
:associate TopicC
:documentation "The reifier-topic that reifies the
reifiable-construct."))
@@ -496,7 +521,11 @@
((identifier :initarg :identifier
:accessor identifier
:inherit t
- :initform (error "From PointerAssociationC(): identifier must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PointerAssociationC(): identifier must be set"
+ :argument-symbol 'identifier
+ :function-symbol ':identifier))
:associate PointerC
:documentation "The actual data that is associated with
the pointer-association's parent."))
@@ -507,7 +536,11 @@
(defpclass SubjectLocatorAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From SubjectLocatorAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-symbol))
:associate TopicC
:documentation "The actual topic which is associated
with the subject-locator."))
@@ -518,7 +551,11 @@
(defpclass PersistentIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PersistentIdAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "The actual topic which is associated
with the subject-identifier/psi."))
@@ -529,7 +566,11 @@
(defpclass TopicIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From TopicIdAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-arguement-error
+ :message "From TopicIdAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "The actual topic which is associated
with the topic-identifier."))
@@ -540,7 +581,11 @@
(defpclass ItemIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ItemIdAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate ReifiableConstructC
:documentation "The actual parent which is associated
with the item-identifier."))
@@ -553,7 +598,11 @@
((characteristic :initarg :characteristic
:accessor characteristic
:inherit t
- :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From CharacteristicCAssociation(): characteristic must be set"
+ :argument-symbol 'characteristic
+ :function-symbol ':characteristic))
:associate CharacteristicC
:documentation "Associates this object with the actual
characteristic object."))
@@ -564,7 +613,11 @@
(defpclass VariantAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From VariantAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From VariantAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate NameC
:documentation "Associates this object with a name."))
(:documentation "Associates variant objects with name obejcts.
@@ -574,7 +627,11 @@
(defpclass NameAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From NameAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From NameAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "Associates this object with a topic."))
(:documentation "Associates name objects with their parent topics.
@@ -584,7 +641,11 @@
(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From OccurrenceAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "Associates this object with a topic."))
(:documentation "Associates occurrence objects with their parent topics.
@@ -596,13 +657,21 @@
((player-topic :initarg :player-topic
:accessor player-topic
:associate TopicC
- :initform (error "From PlayerAssociationC(): player-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PlayerAssociationC(): player-topic must be set"
+ :argument-symbol 'player-topic
+ :function-symbol ':player-topic))
:documentation "Associates this object with a topic that is
a player.")
(parent-construct :initarg :parent-construct
:accessor parent-construct
:associate RoleC
- :initform (error "From PlayerAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PlayerAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:documentation "Associates this object with the parent-association."))
(:documentation "This class associates roles and their player in given
revisions."))
@@ -612,12 +681,20 @@
((role :initarg :role
:accessor role
:associate RoleC
- :initform (error "From RoleAssociationC(): role must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From RoleAssociationC(): role must be set"
+ :argument-symbol 'role
+ :function-symbol ':role))
:documentation "Associates this objetc with a role-object.")
(parent-construct :initarg :parent-construct
:accessor parent-construct
:associate AssociationC
- :initform (error "From RoleAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From RoleAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:documentation "Assocates thius object with an
association-object."))
(:documentation "Associates roles with assoications and adds some
@@ -763,6 +840,11 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric delete-if-not-referenced (construct)
+ (:documentation "Calls delete-construct for the given object if it is
+ not referenced by any other construct."))
+
+
(defgeneric add-characteristic (construct characteristic &key revision)
(:documentation "Adds the passed characterisitc to the given topic by calling
add-name or add-occurrences.
@@ -955,7 +1037,11 @@
(defgeneric add-to-version-history (construct &key start-revision end-revision)
(:documentation "Adds version history to a versioned construct")
(:method ((construct VersionedConstructC)
- &key (start-revision (error "From add-to-version-history(): start revision must be present"))
+ &key (start-revision (error
+ (make-condition 'missing-argument-error
+ :message "From add-to-version-history(): start revision must be present"
+ :argument-symbol 'start-revision
+ :function-symbol 'add-to-version-history)))
(end-revision 0))
(let ((eql-version-info
(find-if #'(lambda(vi)
@@ -1370,7 +1456,6 @@
construct xtm-id))))
(uri (first possible-identifiers)))
(concatenate 'string "t" (write-to-string (internal-id construct))))))
-
(defgeneric topic-identifiers (construct &key revision)
@@ -1422,13 +1507,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
- &key (revision (error "From delete-topic-identifier(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-topic-identifier(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-topic-identifier))))
(let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers)
when (eql (identifier ti-assoc) topic-identifier)
return ti-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1478,13 +1566,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (psi PersistentIdC)
- &key (revision (error "From delete-psi(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-psi(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-psi))))
(let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis)
when (eql (identifier psi-assoc) psi)
return psi-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1535,13 +1626,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (locator SubjectLocatorC)
- &key (revision (error "From delete-locator(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-locator(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-locator))))
(let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators)
when (eql (identifier loc-assoc) locator)
return loc-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1572,8 +1666,12 @@
&key (revision *TM-REVISION*))
(when (and (parent name :revision revision)
(not (eql (parent name :revision revision) construct)))
- (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
- name construct (parent name :revision revision)))
+ (error (make-condition 'tm-reference-error
+ :message (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ name construct (parent name :revision revision))
+ :referenced-construct name
+ :existing-reference (parent name :revision revision)
+ :new-reference construct)))
(let ((all-names
(map 'list #'characteristic (slot-p construct 'names))))
(if (find name all-names)
@@ -1594,13 +1692,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (name NameC)
- &key (revision (error "From delete-name(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-name(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-name))))
(let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
when (eql (characteristic name-assoc) name)
return name-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1623,8 +1724,12 @@
&key (revision *TM-REVISION*))
(when (and (parent occurrence :revision revision)
(not (eql (parent occurrence :revision revision) construct)))
- (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
- occurrence construct (parent occurrence :revision revision)))
+ (error 'tm-reference-error
+ :message (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+ occurrence construct (parent occurrence :revision revision))
+ :referenced-construct occurrence
+ :existing-reference (parent occurrence :revision revision)
+ :new-reference construct))
(let ((all-occurrences
(map 'list #'characteristic (slot-p construct 'occurrences))))
(if (find occurrence all-occurrences)
@@ -1644,13 +1749,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (occurrence OccurrenceC)
- &key (revision (error "From delete-occurrence(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-occurrence(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-construct))))
(let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
when (eql (characteristic occ-assoc) occurrence)
return occ-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1777,7 +1885,9 @@
(when (find-item-by-revision top-from-oid revision)
top-from-oid))))))
(if (and error-if-nil (not result))
- (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)
+ (error (make-condition 'object-not-found-error
+ :message (format nil "No such item (id: ~a, tm: ~a, rev: ~a)"
+ topic-id xtm-id revision)))
result)))
@@ -1802,12 +1912,13 @@
:uri uri)))
(identified-construct (first possible-ids)
:revision revision)))))
- ;no revision need not to be checked, since the revision
+ ;no revision need to be checked, since the revision
;is implicitely checked by the function identified-construct
(if result
result
(when error-if-nil
- (error "No such item is bound to the given identifier uri.")))))
+ (error (make-condition 'object-not-found-error
+ :message "No such item is bound to the given identifier uri."))))))
(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*)
@@ -1887,6 +1998,13 @@
;;; CharacteristicC
+(defmethod delete-if-not-referenced ((construct CharacteristicC))
+ (let ((references (slot-p construct 'parent)))
+ (when (and (<= (length references) 1)
+ (marked-as-deleted-p (first references)))
+ (delete-construct construct))))
+
+
(defmethod find-oldest-construct ((construct-1 CharacteristicC)
(construct-2 CharacteristicC))
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
@@ -2003,8 +2121,12 @@
return parent-assoc)))
(when (and already-set-parent
(not (eql already-set-parent parent-construct)))
- (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
- construct parent-construct already-set-parent))
+ (error (make-condition 'tm-reference-error
+ :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ construct parent-construct already-set-parent)
+ :referenced-construct construct
+ :existing-reference (parent construct :revision revision)
+ :new-reference parent-construct)))
(cond (already-set-parent
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
@@ -2032,15 +2154,18 @@
(defmethod delete-parent ((construct CharacteristicC)
(parent-construct ReifiableConstructC)
- &key (revision (error "From delete-parent(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-parent(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-parent))))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
when (eql (parent-construct parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (when (typep parent-construct 'VersionedConstructC)
- (add-to-version-history parent-construct :start-revision revision))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (when (typep parent-construct 'VersionedConstructC)
+ (add-to-version-history parent-construct :start-revision revision)))
construct))
@@ -2159,8 +2284,12 @@
&key (revision *TM-REVISION*))
(when (and (parent variant :revision revision)
(not (eql (parent variant :revision revision) construct)))
- (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
- variant construct (parent variant :revision revision)))
+ (error (make-condition 'tm-reference-error
+ :message (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
+ variant construct (parent variant :revision revision))
+ :referenced-construct variant
+ :existing-reference (parent variant :revision revision)
+ :new-reference construct)))
(let ((all-variants
(map 'list #'characteristic (slot-p construct 'variants))))
(if (find variant all-variants)
@@ -2180,7 +2309,10 @@
(:documentation "Deletes the passed variant by marking it's association as
deleted in the passed revision.")
(:method ((construct NameC) (variant VariantC)
- &key (revision (error "From delete-variant(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-variant(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-variant))))
(let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
'variants)
when (eql (characteristic variant-assoc) variant)
@@ -2305,13 +2437,16 @@
(:documentation "Deletes the passed role by marking it's association as
deleted in the passed revision.")
(:method ((construct AssociationC) (role RoleC)
- &key (revision (error "From delete-role(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-role(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-role))))
(let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles)
when (eql (role role-assoc) role)
return role-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -2320,6 +2455,13 @@
;;; RoleC
+(defmethod delete-if-not-referenced ((construct RoleC))
+ (let ((references (slot-p construct 'parent)))
+ (when (and (<= (length references) 1)
+ (marked-as-deleted-p (first references)))
+ (delete-construct construct))))
+
+
(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
(vi-2 (find-version-info (slot-p construct-2 'parent))))
@@ -2429,8 +2571,12 @@
return parent-assoc)))
(when (and already-set-parent
(not (eql already-set-parent parent-construct)))
- (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
- construct parent-construct already-set-parent))
+ (error (make-condition 'tm-reference-error
+ :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ construct parent-construct already-set-parent)
+ :referenced-construct construct
+ :existing-reference (parent construct :revision revision)
+ :new-reference parent-construct)))
(cond (already-set-parent
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
@@ -2450,14 +2596,17 @@
(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
- &key (revision (error "From delete-parent(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-parent(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-parent))))
(let ((assoc-to-delete
(loop for parent-assoc in (slot-p construct 'parent)
when (eql (parent-construct parent-assoc) parent-construct)
return parent-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (add-to-version-history parent-construct :start-revision revision)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history parent-construct :start-revision revision))
construct))
@@ -2483,8 +2632,12 @@
return player-assoc)))
(when (and already-set-player
(not (eql already-set-player player-topic)))
- (error "From add-player(): ~a can't be played by ~a since it is played by ~a"
- construct player-topic already-set-player))
+ (error (make-condition 'tm-reference-error
+ :message (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a"
+ construct player-topic already-set-player)
+ :referenced-construct construct
+ :existing-reference (player construct :revision revision)
+ :new-reference player-topic)))
(cond (already-set-player
(let ((player-assoc
(loop for player-assoc in (slot-p construct 'player)
@@ -2505,7 +2658,10 @@
(:documentation "Deletes the passed topic as a player of the passed role
object by marking its association-object as deleted.")
(:method ((construct RoleC) (player-topic TopicC)
- &key (revision (error "From delete-parent(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-parent(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-player))))
(let ((assoc-to-delete
(loop for player-assoc in (slot-p construct 'player)
when (eql (parent-construct player-assoc) construct)
@@ -2652,14 +2808,17 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
- &key (revision (error "From delete-item-identifier(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-item-identifier(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-item-identifier))))
(let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers)
when (eql (identifier ii-assoc) item-identifier)
return ii-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history construct :start-revision revision))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision revision)))
construct)))
@@ -2706,14 +2865,17 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct ReifiableConstructC) (reifier TopicC)
- &key (revision (error "From delete-reifier(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-reifier(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-reifier))))
(let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier)
when (eql (reifier-topic reifier-assoc) reifier)
return reifier-assoc)))
(when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- (when (typep construct 'VersionedConstructC)
- (add-to-version-history construct :start-revision revision))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision revision)))
construct)))
@@ -2824,7 +2986,10 @@
(:documentation "Deletes the passed theme by marking it's association as
deleted in the passed revision.")
(:method ((construct ScopableC) (theme-topic TopicC)
- &key (revision (error "From delete-theme(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-theme(): revision must be set"
+ :argument-symbol 'revsion
+ :function-symbol 'delete-theme))))
(let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
when (eql (theme-topic theme-assoc) theme-topic)
return theme-assoc)))
@@ -2873,8 +3038,12 @@
return type-assoc)))
(when (and already-set-type
(not (eql type-topic already-set-type)))
- (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
- construct type-topic already-set-type))
+ (error (make-condition 'tm-reference-error
+ :message (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
+ construct type-topic already-set-type)
+ :referenced-construct construct
+ :existing-reference (instance-of construct :revision revision)
+ :new-reference type-topic)))
(cond (already-set-type
(let ((type-assoc
(loop for type-assoc in (slot-p construct 'instance-of)
@@ -2897,7 +3066,10 @@
(:documentation "Deletes the passed type by marking it's association as
deleted in the passed revision.")
(:method ((construct TypableC) (type-topic TopicC)
- &key (revision (error "From delete-type(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-type(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-type))))
(let ((assoc-to-delete
(loop for type-assoc in (slot-p construct 'instance-of)
when (eql (type-topic type-assoc) type-topic)
@@ -2986,7 +3158,10 @@
(and (ReifiableConstructC-p class-symbol)
(or (getf args :item-identifiers) (getf args :reifier))))
(not (getf args :start-revision)))
- (error "From make-construct(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-construct(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-construct)))
(let ((construct
(cond
((PointerC-p class-symbol)
@@ -3034,7 +3209,10 @@
(roles (getf args :roles)))
(when (and (or roles instance-of themes)
(not start-revision))
- (error "From make-association(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-association(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-association)))
(let ((association
(let ((existing-associations
(remove-if
@@ -3071,7 +3249,10 @@
(start-revision (getf args :start-revision)))
(when (and (or instance-of player parent)
(not start-revision))
- (error "From make-role(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-role(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-role)))
(let ((role
(let ((existing-roles
(when parent
@@ -3109,7 +3290,10 @@
(start-revision (getf args :start-revision)))
(when (and (or item-identifiers reifier)
(not start-revision))
- (error "From make-tm(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-tm(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-tm)))
(let ((tm
(let ((existing-tms
(remove-if
@@ -3146,7 +3330,10 @@
(when (and (or psis locators item-identifiers topic-identifiers
names occurrences)
(not start-revision))
- (error "From make-topic(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-topic(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-topic)))
(let ((topic
(let ((existing-topics
(remove-if
@@ -3199,7 +3386,10 @@
(parent (getf args :parent)))
(when (and (or instance-of themes variants parent)
(not start-revision))
- (error "From make-characteristic(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-characteristic(): start-revision must be set"
+ :argument-symbol 'start-revsion
+ :function-symbol 'make-characgteristic)))
(let ((characteristic
(let ((existing-characteristic
(when parent
@@ -3235,12 +3425,21 @@
(identified-construct (getf args :identified-construct))
(err "From make-pointer(): "))
(when (and identified-construct (not start-revision))
- (error "~astart-revision must be set" err))
+ (error (make-condition 'missing-argument-error
+ :message (format nil "~astart-revision must be set" err)
+ :argument-symbol 'start-revision
+ :function-symbol 'make-pointer)))
(unless uri
- (error "~auri must be set" err))
+ (error (make-condition 'missing-argument-error
+ :message (format nil "~auri must be set" err)
+ :argument-symbol 'uri
+ :function-symbol 'make-pointer)))
(when (and (TopicIdentificationC-p class-symbol)
(not xtm-id))
- (error "~axtm-id must be set" err))
+ (error (make-condition 'missing-argument-error
+ :message (format nil "~axtm-id must be set" err)
+ :argument-symbol 'xtm-id
+ :function-symbol 'make-pointer)))
(let ((identifier
(let ((existing-pointer
(remove-if
@@ -3396,8 +3595,11 @@
(destination-reified (reified-construct destination
:revision revision)))
(unless (eql (type-of source-reified) (type-of destination-reified))
- (error "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
- source destination source-reified destination-reified))
+ (error (make-condition 'not-mergable-error
+ :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
+ source destination source-reified destination-reified)
+ :construct-1 source
+ :construct-2 destination)))
(cond ((and source-reified destination-reified)
(delete-reifier source-reified source :revision revision)
(delete-reifier destination-reified destination :revision revision)
@@ -3551,8 +3753,11 @@
(parent-2 (parent newer-char :revision revision)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
+ (error (make-condition 'not-mergable-error
+ :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2)
+ :construct-1 construct-1
+ :construct-2 construct-2)))
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-char older-char
:revision revision)
@@ -3585,10 +3790,12 @@
(let ((dst (if parent-1 older-char newer-char))
(src (if parent-1 newer-char older-char)))
(move-referenced-constructs src dst :revision revision)
+ (delete-if-not-referenced src)
dst))
(t
(move-referenced-constructs newer-char older-char
:revision revision)
+ (delete-if-not-referenced newer-char)
older-char)))))))
@@ -3622,8 +3829,11 @@
construct-1)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
+ (error (make-condition 'not-mergable-error
+ :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2)
+ :construct-1 construct-1
+ :construct-2 construct-2)))
(move-referenced-constructs newer-assoc older-assoc)
(dolist (newer-role (roles newer-assoc :revision revision))
(let ((equivalent-role
@@ -3652,8 +3862,11 @@
construct-1)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
+ (error (make-condition 'not-mergable-error
+ :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2)
+ :construct-1 construct-1
+ :construct-2 construct-2)))
(let ((parent-1 (parent older-role :revision revision))
(parent-2 (parent newer-role :revision revision)))
(cond ((and parent-1 (eql parent-1 parent-2))
@@ -3672,8 +3885,10 @@
(let ((dst (if parent-1 older-role newer-role))
(src (if parent-1 newer-role older-role)))
(move-referenced-constructs src dst :revision revision)
+ (delete-if-not-referenced src)
dst))
(t
(move-referenced-constructs newer-role older-role
:revision revision)
+ (delete-if-not-referenced newer-role)
older-role)))))))
\ No newline at end of file
Modified: branches/new-datamodel/src/model/exceptions.lisp
==============================================================================
--- branches/new-datamodel/src/model/exceptions.lisp (original)
+++ branches/new-datamodel/src/model/exceptions.lisp Thu Apr 8 05:55:12 2010
@@ -13,7 +13,10 @@
:missing-reference-error
:no-identifier-error
:duplicate-identifier-error
- :object-not-found-error))
+ :object-not-found-error
+ :not-mergable-error
+ :missing-argument-error
+ :tm-reference-error))
(in-package :exceptions)
@@ -22,6 +25,7 @@
:initarg :message
:accessor message)))
+
(define-condition missing-reference-error(error)
((message
:initarg :message
@@ -31,6 +35,7 @@
:initarg :reference))
(:documentation "thrown is a reference is missing"))
+
(define-condition duplicate-identifier-error(error)
((message
:initarg :message
@@ -40,12 +45,14 @@
:initarg :reference))
(:documentation "thrown if the same identifier is already in use"))
+
(define-condition object-not-found-error(error)
((message
:initarg :message
:accessor message))
(:documentation "thrown if the object could not be found"))
+
(define-condition no-identifier-error(error)
((message
:initarg :message
@@ -54,3 +61,48 @@
:initarg :internal-id
:accessor internal-id))
(:documentation "thrown if the topic has no identifier"))
+
+
+(define-condition not-mergable-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (construc-1
+ :initarg :construct-1
+ :accessor construct-1)
+ (construc-2
+ :initarg :construct-2
+ :accessor construct-2))
+ (:documentation "Thrown if two constructs are not mergable since
+ they have e.g. difference types."))
+
+
+(define-condition missing-argument-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (argument-symbol
+ :initarg :argument-symbol
+ :accessor argument-symbol)
+ (function-symbol
+ :initarg :function-symbol
+ :accessor function-symbol))
+ (:documentation "Thrown if a argument is missing in a function."))
+
+
+(define-condition tm-reference-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (referenced-construct
+ :initarg :referenced-construct
+ :accessor referenced-construct)
+ (existing-reference
+ :initarg :existing-reference
+ :accessor existing-reference)
+ (new-reference
+ :initarg :new-reference
+ :accessor new-reference))
+ (:documentation "Thrown of the referenced-construct is already owned by another
+ TM-construct (existing-reference) and is going to be referenced
+ by a second TM-construct (new-reference) at the same time."))
\ No newline at end of file
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Thu Apr 8 05:55:12 2010
@@ -15,7 +15,10 @@
:fixtures
:unittests-constants)
(:import-from :exceptions
- duplicate-identifier-error)
+ duplicate-identifier-error
+ missing-argument-error
+ tm-reference-error
+ object-not-found-error)
(:import-from :constants
*xml-string*
*xml-uri*)
@@ -166,7 +169,7 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct ii-1))
- (signals error (make-instance 'ItemIdentifierC))
+ (signals missing-argument-error (make-instance 'ItemIdentifierC))
(is-false (item-identifiers topic-1))
(add-item-identifier topic-1 ii-1)
(is (= (length (d::versions topic-1)) 1))
@@ -232,7 +235,7 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct psi-1))
- (signals error (make-instance 'PersistentIdC))
+ (signals missing-argument-error (make-instance 'PersistentIdC))
(is-false (psis topic-1))
(add-psi topic-1 psi-1)
(is (= (length (d::versions topic-1)) 1))
@@ -296,7 +299,7 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct sl-1))
- (signals error (make-instance 'SubjectLocatorC))
+ (signals missing-argument-error (make-instance 'SubjectLocatorC))
(is-false (locators topic-1))
(add-locator topic-1 sl-1)
(is (= (length (d::versions topic-1)) 1))
@@ -362,9 +365,9 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct ti-1))
- (signals error (make-instance 'TopicIdentificationC
+ (signals missing-argument-error (make-instance 'TopicIdentificationC
:uri "ti-1"))
- (signals error (make-instance 'TopicIdentificationC
+ (signals missing-argument-error (make-instance 'TopicIdentificationC
:xtm-id "xtm-id-1"))
(is-false (topic-identifiers topic-1))
(add-topic-identifier topic-1 ti-1)
@@ -436,11 +439,10 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-top-id" :revision rev-0))
- (signals error (is-false (get-item-by-id
- "any-top-id" :xtm-id "any-xtm-id"
- :error-if-nil t)))
- (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t
- :revision rev-0)))
+ (signals object-not-found-error
+ (get-item-by-id "any-top-id" :xtm-id "any-xtm-id" :error-if-nil t))
+ (signals object-not-found-error
+ (get-item-by-id "any-top-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id"))
(add-topic-identifier top-1 top-id-3-1 :revision rev-1)
(add-topic-identifier top-1 top-id-3-2 :revision rev-1)
@@ -497,12 +499,12 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-ii-id"))
- (signals error (is-false (get-item-by-item-identifier
- "any-ii-id" :error-if-nil t
- :revision rev-1)))
- (signals error (is-false (get-item-by-item-identifier
- "any-ii-id" :error-if-nil t
- :revision rev-1)))
+ (signals object-not-found-error
+ (get-item-by-item-identifier
+ "any-ii-id" :error-if-nil t :revision rev-1))
+ (signals object-not-found-error
+ (get-item-by-item-identifier
+ "any-ii-id" :error-if-nil t :revision rev-1))
(is-false (get-item-by-item-identifier "any-ii-id"))
(add-item-identifier top-1 ii-3-1 :revision rev-1)
(add-item-identifier top-1 ii-3-2 :revision rev-1)
@@ -542,12 +544,10 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-sl-id"))
- (signals error (is-false (get-item-by-locator
- "any-sl-id" :error-if-nil t
- :revision rev-0)))
- (signals error (is-false (get-item-by-locator
- "any-sl-id" :error-if-nil t
- :revision rev-0)))
+ (signals object-not-found-error
+ (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
+ (signals object-not-found-error
+ (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-locator "any-sl-id" :revision rev-0))
(add-locator top-1 sl-3-1 :revision rev-1)
(add-locator top-1 sl-3-2 :revision rev-1)
@@ -587,12 +587,10 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-psi-id"))
- (signals error (is-false (get-item-by-locator
- "any-psi-id" :error-if-nil t
- :revision rev-0)))
- (signals error (is-false (get-item-by-locator
- "any-psi-id" :error-if-nil t
- :revision rev-0)))
+ (signals object-not-found-error
+ (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0))
+ (signals object-not-found-error
+ (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-locator "any-psi-id"))
(add-psi top-1 psi-3-1 :revision rev-1)
(add-psi top-1 psi-3-2 :revision rev-1)
@@ -699,7 +697,7 @@
(add-occurrence top-1 occ-1 :revision rev-4)
(is (= (length (union (list occ-2 occ-1)
(occurrences top-1 :revision rev-0))) 2))
- (signals error (add-occurrence top-2 occ-1 :revision rev-4))
+ (signals tm-reference-error (add-occurrence top-2 occ-1 :revision rev-4))
(delete-occurrence top-1 occ-1 :revision rev-5)
(is (= (length (union (list occ-2)
(occurrences top-1 :revision rev-5))) 1))
@@ -769,7 +767,7 @@
(add-variant name-1 v-1 :revision rev-4)
(is (= (length (union (list v-2 v-1)
(variants name-1 :revision rev-0))) 2))
- (signals error (add-variant name-2 v-1 :revision rev-4))
+ (signals tm-reference-error (add-variant name-2 v-1 :revision rev-4))
(delete-variant name-1 v-1 :revision rev-5)
(is (= (length (union (list v-2)
(variants name-1 :revision rev-5))) 1))
@@ -844,7 +842,7 @@
(add-name top-1 name-1 :revision rev-4)
(is (= (length (union (list name-2 name-1)
(names top-1 :revision rev-0))) 2))
- (signals error (add-name top-2 name-1 :revision rev-4))
+ (signals tm-reference-error (add-name top-2 name-1 :revision rev-4))
(delete-name top-1 name-1 :revision rev-5)
(is (= (length (union (list name-2)
(names top-1 :revision rev-5))) 1))
@@ -893,7 +891,7 @@
(is (eql top-1 (instance-of name-1)))
(is-false (instance-of name-1 :revision revision-0-5))
(is (eql top-1 (instance-of name-1 :revision revision-2)))
- (signals error (add-type name-1 top-2 :revision revision-0))
+ (signals tm-reference-error (add-type name-1 top-2 :revision revision-0))
(add-type name-2 top-1 :revision revision-2)
(is (= (length (union (list name-1 name-2)
(used-as-type top-1 :revision revision-0))) 2))
@@ -998,7 +996,7 @@
(is (eql (parent role-1 :revision rev-0) assoc-1))
(is (eql (parent role-2 :revision rev-2) assoc-1))
(is-false (parent role-2 :revision rev-1))
- (signals error (add-parent role-2 assoc-2 :revision rev-2))
+ (signals tm-reference-error (add-parent role-2 assoc-2 :revision rev-2))
(delete-role assoc-1 role-1 :revision rev-3)
(is (= (length (d::versions assoc-1)) 3))
(is-true (find-if #'(lambda(vi)
@@ -1056,7 +1054,7 @@
(is (eql top-1 (player role-1 :revision revision-0)))
(is-false (player role-1 :revision revision-0-5))
(is (eql top-1 (player role-1 :revision revision-2)))
- (signals error (add-player role-1 top-2))
+ (signals tm-reference-error (add-player role-1 top-2))
(add-player role-2 top-1 :revision revision-2)
(is (= (length (union (list role-1 role-2)
(player-in-roles top-1 :revision revision-0))) 2))
@@ -2097,11 +2095,12 @@
:start-revision rev-1
:identifier psi-1
:parent-construct top-1)))
- (signals error (make-construct 'd::PersistentIdAssociationC
- :start-revision rev-1
- :identifier psi-1))
+ (signals missing-argument-error
+ (make-construct 'd::PersistentIdAssociationC
+ :start-revision rev-1
+ :identifier psi-1))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'VersionedConstructC))
+ (signals missing-argument-error (make-construct 'VersionedConstructC))
(is (= (length (d::versions vc)) 1))
(is-true (find-if #'(lambda(vi)
(and (= (d::start-revision vi) rev-2)
@@ -2127,13 +2126,14 @@
:uri "tid-2" :xtm-id "xtm-id-2"
:identified-construct top-1
:start-revision rev-1)))
- (signals error (make-construct 'TopicIdentificationC
+ (signals missing-argument-error (make-construct 'TopicIdentificationC
:uri "uri"))
- (signals error (make-construct 'TopicIdentificationC
+ (signals missing-argument-error (make-construct 'TopicIdentificationC
:xtm-id "xtm-id"))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'TopicIdentificationC :uri "uri"
- :identified-construct top-1))
+ (signals missing-argument-error
+ (make-construct 'TopicIdentificationC :uri "uri"
+ :identified-construct top-1))
(is (string= (uri tid-1) "tid-1"))
(is (string= (xtm-id tid-1) "xtm-id-1"))
(is-false (d::slot-p tid-1 'd::identified-construct))
@@ -2168,8 +2168,8 @@
:identified-construct top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'PersistentIdC))
- (signals error (make-construct 'PersistentIdC :uri "uri"
+ (signals missing-argument-error (make-construct 'PersistentIdC))
+ (signals missing-argument-error (make-construct 'PersistentIdC :uri "uri"
:identified-construct top-1))
(is (string= (uri psi-1) "psi-1"))
(is-false (d::slot-p psi-1 'd::identified-construct))
@@ -2203,8 +2203,8 @@
:identified-construct top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'SubjectLocatorC))
- (signals error (make-construct 'SubjectLocatorC :uri "uri"
+ (signals missing-argument-error (make-construct 'SubjectLocatorC))
+ (signals missing-argument-error (make-construct 'SubjectLocatorC :uri "uri"
:identified-construct top-1))
(is (string= (uri sl-1) "sl-1"))
(is-false (d::slot-p sl-1 'd::identified-construct))
@@ -2238,8 +2238,8 @@
:identified-construct top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'ItemIdentifierC))
- (signals error (make-construct 'ItemIdentifierC :uri "uri"
+ (signals missing-argument-error (make-construct 'ItemIdentifierC))
+ (signals missing-argument-error (make-construct 'ItemIdentifierC :uri "uri"
:identified-construct top-1))
(is (string= (uri ii-1) "ii-1"))
(is-false (d::slot-p ii-1 'd::identified-construct))
@@ -2287,12 +2287,16 @@
:parent top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'OccurrenceC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'OccurrenceC :reifier reifier-1))
- (signals error (make-construct 'OccurrenceC :parent top-1))
- (signals error (make-construct 'OccurrenceC :instance-of type-1))
- (signals error (make-construct 'OccurrenceC :themes (list theme-1)))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :parent top-1))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :instance-of type-1))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :themes (list theme-1)))
(is (string= (charvalue occ-1) ""))
(is (string= (datatype occ-1) *xml-string*))
(is-false (item-identifiers occ-1))
@@ -2344,13 +2348,18 @@
:parent top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'NameC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'NameC :reifier reifier-1))
- (signals error (make-construct 'NameC :parent top-1))
- (signals error (make-construct 'NameC :instance-of type-1))
- (signals error (make-construct 'NameC :themes (list theme-1)))
- (signals error (make-construct 'NameC :variants (list variant-1)))
+ (signals missing-argument-error
+ (make-construct 'NameC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'NameC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'NameC :parent top-1))
+ (signals missing-argument-error
+ (make-construct 'NameC :instance-of type-1))
+ (signals missing-argument-error
+ (make-construct 'NameC :themes (list theme-1)))
+ (signals missing-argument-error
+ (make-construct 'NameC :variants (list variant-1)))
(is (string= (charvalue name-1) ""))
(is-false (item-identifiers name-1))
(is-false (reifier name-1))
@@ -2399,11 +2408,14 @@
:parent name-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'VariantC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'VariantC :reifier reifier-1))
- (signals error (make-construct 'VariantC :parent name-1))
- (signals error (make-construct 'VariantC :themes (list theme-1)))
+ (signals missing-argument-error
+ (make-construct 'VariantC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'VariantC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'VariantC :parent name-1))
+ (signals missing-argument-error
+ (make-construct 'VariantC :themes (list theme-1)))
(is (string= (charvalue variant-1) ""))
(is (string= (datatype variant-1) *xml-string*))
(is-false (item-identifiers variant-1))
@@ -2448,12 +2460,16 @@
:parent assoc-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'RoleC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'RoleC :reifier reifier-1))
- (signals error (make-construct 'RoleC :parent assoc-1))
- (signals error (make-construct 'RoleC :instance-of type-1))
- (signals error (make-construct 'RoleC :player player-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'RoleC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :parent assoc-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :instance-of type-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :player player-1))
(is-false (item-identifiers role-1))
(is-false (reifier role-1))
(is-false (instance-of role-1))
@@ -2496,7 +2512,7 @@
:start-revision rev-1
:item-identifiers (list ii-3))))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'TopicMapC))
+ (signals missing-argument-error (make-construct 'TopicMapC))
(is (eql (reifier tm-1) reifier-1))
(is (= (length (item-identifiers tm-1)) 2))
(is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2))
@@ -2566,12 +2582,12 @@
:roles (list role-1 role-2 role-2-2)))
(assoc-2 (make-construct 'AssociationC :start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'AssociationC))
- (signals error (make-construct 'AssociationC
- :start-revision rev-1
- :roles (list
- (list :player player-1
- :instance-of r-type-1))))
+ (signals missing-argument-error (make-construct 'AssociationC))
+ (signals missing-argument-error
+ (make-construct 'AssociationC
+ :start-revision rev-1
+ :roles (list (list :player player-1
+ :instance-of r-type-1))))
(is (eql (instance-of assoc-1) type-1))
(is-true (themes assoc-1))
(is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2))
@@ -2684,7 +2700,7 @@
:names (list name-1)
:occurrences (list occ-1))))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'TopicC))
+ (signals missing-argument-error (make-construct 'TopicC))
(is-false (item-identifiers top-1))
(is-false (psis top-1))
(is-false (locators top-1))
1
0
Author: lgiessmann
Date: Tue Apr 6 16:09:58 2010
New Revision: 267
Log:
new-datamodel: added "merge-constructs" --> "RoleC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 16:09:58 2010
@@ -155,6 +155,10 @@
(in-package :datamodel)
+;;TODO: call delete-construct for all child-constructs that are:
+;; *exist-in-revision-history => nil
+;; *are not referenced by other constructs
+;; --> iis, psis, sls, tids, names, occs, variants, roles
;;TODO: mark-as-deleted should call mark-as-deleted for every owned
;; versioned-construct of the called construct
;;TODO: add: add-to-version-history (parent) to all
@@ -3636,20 +3640,40 @@
(delete-construct newer-assoc))
older-assoc))))
-;TODO: merge-constructs: RoleC (merge parents), AssociationC
-
-
-
-
-
-;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC)
&key (revision *TM-REVISION*))
- (or revision)
- (if construct-1 construct-1 construct-2))
-
-
-
-
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (declare (integer *TM-REVISION*))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-role (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-role (if (eql older-role construct-1)
+ construct-2
+ construct-1)))
+ (unless (strictly-equivalent-constructs construct-1 construct-2
+ :revision revision)
+ (error "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2))
+ (let ((parent-1 (parent older-role :revision revision))
+ (parent-2 (parent newer-role :revision revision)))
+ (cond ((and parent-1 (eql parent-1 parent-2))
+ (move-referenced-constructs newer-role older-role
+ :revision revision)
+ (delete-role newer-role parent-2 :revision revision)
+ (add-role older-role parent-1 :revision revision))
+ ((and parent-1 parent-2)
+ (let ((active-assoc (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (if (find older-role (roles active-assoc
+ :revision revision))
+ older-role
+ newer-role)))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-role newer-role))
+ (src (if parent-1 newer-role older-role)))
+ (move-referenced-constructs src dst :revision revision)
+ dst))
+ (t
+ (move-referenced-constructs newer-role older-role
+ :revision revision)
+ older-role)))))))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Tue Apr 6 15:56:27 2010
New Revision: 266
Log:
new-datamodel: added "merge-constructs" --> "AssociationC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 15:56:27 2010
@@ -3607,7 +3607,34 @@
older-tm))))
-
+(defmethod merge-constructs ((construct-1 AssociationC) (construct-2 AssociationC)
+ &key revision)
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-assoc (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-assoc (if (eql older-assoc construct-1)
+ construct-2
+ construct-1)))
+ (unless (strictly-equivalent-constructs construct-1 construct-2
+ :revision revision)
+ (error "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2))
+ (move-referenced-constructs newer-assoc older-assoc)
+ (dolist (newer-role (roles newer-assoc :revision revision))
+ (let ((equivalent-role
+ (find-if #'(lambda(older-role)
+ (strictly-equivalent-constructs
+ older-role newer-role :revision revision))
+ (roles older-assoc :revision revision))))
+ (move-referenced-constructs newer-role equivalent-role
+ :revision revision)
+ (delete-role newer-assoc newer-role :revision revision)
+ (add-role older-assoc equivalent-role :revision revision)))
+ (mark-as-deleted newer-assoc :revision revision)
+ (when (exist-in-revision-history-? newer-assoc)
+ (delete-construct newer-assoc))
+ older-assoc))))
;TODO: merge-constructs: RoleC (merge parents), AssociationC
1
0
Author: lgiessmann
Date: Tue Apr 6 15:44:44 2010
New Revision: 265
Log:
new-datamodel: added "merge-constructs" --> "TopicMapC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 15:44:44 2010
@@ -155,11 +155,12 @@
(in-package :datamodel)
-;;TODO: mark-as-deleted should call mark as deleted for every owned
+;;TODO: mark-as-deleted should call mark-as-deleted for every owned
;; versioned-construct of the called construct
-;;TODO: check for duplicate identifiers after topic-creation/merge
;;TODO: add: add-to-version-history (parent) to all
;; "add-<construct>"/"delete-<construct>" generics
+;; ===>> adapt exist-in-revision-history
+;;TODO: check for duplicate identifiers after topic-creation/merge
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
;; and the parent's parent construct + the reifier constructs),
@@ -871,7 +872,7 @@
;;; VersionedConstructC
-(defgeneric does-not-exist-in-revision-history (versioned-construct)
+(defgeneric exist-in-revision-history-? (versioned-construct)
(:documentation "Returns t if the passed construct does not exist in any
revision, i.e. the construct has no version-infos or exactly
one whose start-revision is equal to its end-revision.")
@@ -3527,7 +3528,7 @@
(move-reified-construct newer-topic older-topic :revision revision)
(merge-changed-constructs older-topic :revision revision)
(mark-as-deleted newer-topic :revision revision)
- (when (does-not-exist-in-revision-history newer-topic)
+ (when (exist-in-revision-history-? newer-topic)
(delete-construct newer-topic))
older-topic))))
@@ -3587,9 +3588,28 @@
older-char)))))))
+(defmethod merge-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-tm (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-tm (if (eql older-tm construct-1)
+ construct-2
+ construct-1)))
+ (move-referenced-constructs newer-tm older-tm :revision revision)
+ (dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm)))
+ (add-to-tm top-or-assoc top-or-assoc))
+ (add-to-version-history older-tm :start-revision revision)
+ (mark-as-deleted newer-tm :revision revision)
+ (when (exist-in-revision-history-? newer-tm)
+ (delete-construct newer-tm))
+ older-tm))))
+
+
-;TODO: merge-constructs: RoleC (merge parents), AssociationC, TopicMapC,
+;TODO: merge-constructs: RoleC (merge parents), AssociationC
1
0
06 Apr '10
Author: lgiessmann
Date: Tue Apr 6 15:32:40 2010
New Revision: 264
Log:
new-datamodel: apat the datamodel's unit-tests to the last modifactions of "find-odlest-construct"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 15:32:40 2010
@@ -3589,20 +3589,13 @@
+;TODO: merge-constructs: RoleC (merge parents), AssociationC, TopicMapC,
-
-
-;TODO: merge-constructs: RoleC (merge parents and return the active role object),
-;; AssociationC, TopicMapC,
-
-
-
-
;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
&key (revision *TM-REVISION*))
@@ -3613,9 +3606,3 @@
;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-
-
-;TODO: --> include move-yx in move-referenced-constructs
\ No newline at end of file
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Tue Apr 6 15:32:40 2010
@@ -2740,28 +2740,28 @@
(rev-2 200)
(rev-3 300))
(setf *TM-REVISION* rev-1)
- (is-false (d::find-oldest-construct ii-1 ii-2))
+ (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
(add-item-identifier top-1 ii-1 :revision rev-3)
(is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
(add-item-identifier assoc-1 ii-2 :revision rev-2)
(is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
(add-item-identifier top-2 ii-1 :revision rev-1)
(is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
- (is-false (d::find-oldest-construct variant-1 variant-2))
+ (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
(add-variant name-1 variant-1 :revision rev-3)
(is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
(add-variant name-1 variant-2 :revision rev-2)
(is (eql variant-2 (d::find-oldest-construct variant-1 variant-2)))
(add-variant name-2 variant-1 :revision rev-1)
(is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
- (is-false (d::find-oldest-construct role-1 role-2))
+ (is (eql role-1 (d::find-oldest-construct role-1 role-2)))
(add-role assoc-1 role-1 :revision rev-3)
(is (eql role-1 (d::find-oldest-construct role-1 role-2)))
(add-role assoc-1 role-2 :revision rev-2)
(is (eql role-2 (d::find-oldest-construct role-1 role-2)))
(add-role assoc-2 role-1 :revision rev-1)
(is (eql role-1 (d::find-oldest-construct role-1 role-2)))
- (is-false (d::find-oldest-construct tm-1 tm-2))
+ (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
(d::add-to-version-history tm-1 :start-revision rev-3)
(is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
(d::add-to-version-history tm-2 :start-revision rev-1)
1
0
Author: lgiessmann
Date: Tue Apr 6 11:44:47 2010
New Revision: 263
Log:
new-datamodel: replaced "merge-cosntructs" --> "NameC", "OccurrenceC", "VariantC" by a generic for "CharacteristicC"; added the generics "add-characteristic" and "delete-characteristic" for "NameC", "VariantC", "OccurrenceC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 11:44:47 2010
@@ -758,6 +758,18 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric add-characteristic (construct characteristic &key revision)
+ (:documentation "Adds the passed characterisitc to the given topic by calling
+ add-name or add-occurrences.
+ Variants are added to names by calling add-name."))
+
+
+(defgeneric delete-characteristic (construct characteristic &key revision)
+ (:documentation "Deletes the passed characteristic oif the given topic by
+ calling delete-name or delete-occurrence.
+ Variants are deleted from names by calling delete-variant."))
+
+
(defgeneric mark-as-deleted (construct &key source-locator revision)
(:documentation "Mark a construct as deleted if it comes from the source
indicated by source-locator"))
@@ -832,7 +844,6 @@
The latest construct is either the one with
end-revision=0 or with the highest end-revision value."))
-
(defgeneric owned-p (construct)
(:documentation "Returns t if the passed construct is referenced by a parent
TM construct."))
@@ -1638,6 +1649,24 @@
construct)))
+(defmethod add-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (add-name construct characteristic :revision revision)
+ (add-occurrence construct characteristic :revision revision)))
+
+
+(defmethod delete-characteristic ((construct TopicC)
+ (characteristic CharacteristicC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision) (type (or NameC OccurrenceC) characteristic))
+ (if (typep characteristic 'NameC)
+ (delete-name construct characteristic :revision revision)
+ (delete-occurrence construct characteristic :revision revision)))
+
+
(defgeneric player-in-roles (construct &key revision)
(:documentation "Returns the RoleC-objects that correspond
with the passed construct and the passed version.")
@@ -2156,6 +2185,18 @@
construct)))
+(defmethod add-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (add-variant construct characteristic :revision revision))
+
+
+(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (delete-variant construct characteristic :revision revision))
+
+
;;; AssociationC
(defmethod equivalent-constructs ((construct-1 AssociationC)
(construct-2 AssociationC)
@@ -3287,33 +3328,48 @@
(defmethod move-referenced-constructs ((source ReifiableConstructC)
(destination ReifiableConstructC)
&key (revision *TM-REVISION*))
- (let ((source-reifier (reifier source :revision revision))
- (destination-reifier (reifier destination :revision revision)))
- (cond ((and source-reifier destination-reifier)
- (delete-reifier (reified-construct source-reifier :revision revision)
- source-reifier :revision revision)
- (delete-reifier (reified-construct destination-reifier
- :revision revision)
- destination-reifier :revision revision)
- (let ((merged-reifier
- (merge-constructs source-reifier destination-reifier
- :revision revision)))
- (add-reifier destination merged-reifier :revision revision)))
- (source-reifier
- (delete-reifier (reified-construct source-reifier :revision revision)
- source-reifier :revision revision)
- (add-reifier destination source-reifier :revision revision)
- source-reifier)
- (destination-reifier
- (add-reifier destination destination-reifier :revision revision)
- destination-reifier))))
+ (declare (integer revision))
+ (remove-if
+ #'null
+ (append
+ (move-identifiers source destination :revision revision)
+ (let ((source-reifier (reifier source :revision revision))
+ (destination-reifier (reifier destination :revision revision)))
+ (cond ((and source-reifier destination-reifier)
+ (delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (delete-reifier (reified-construct destination-reifier
+ :revision revision)
+ destination-reifier :revision revision)
+ (let ((merged-reifier
+ (merge-constructs source-reifier destination-reifier
+ :revision revision)))
+ (add-reifier destination merged-reifier :revision revision)))
+ (source-reifier
+ (delete-reifier (reified-construct source-reifier
+ :revision revision)
+ source-reifier :revision revision)
+ (add-reifier destination source-reifier :revision revision)
+ source-reifier)
+ (destination-reifier
+ (add-reifier destination destination-reifier :revision revision)
+ destination-reifier))))))
+
+
+(defmethod move-referenced-constructs ((source NameC) (destination NameC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (append (call-next-method)
+ (move-variants source destination :revision revision)))
(defmethod move-referenced-constructs ((source TopicC) (destination TopicC)
&key (revision *TM-REVISION*))
(let ((roles (player-in-roles source :revision revision))
(scopables (used-as-theme source :revision revision))
- (typables (used-as-type source :revision revision)))
+ (typables (used-as-type source :revision revision))
+ (ids (move-identifiers source destination :revision revision)))
(dolist (role roles)
(delete-player role source :revision revision)
(add-player role destination :revision revision))
@@ -3323,7 +3379,7 @@
(dolist (typable typables)
(delete-type typable source :revision revision)
(add-type typable destination :revision revision))
- (append roles scopables typables)))
+ (remove-if #'null (append roles scopables typables ids))))
(defgeneric move-reified-construct (source destination &key revision)
@@ -3373,7 +3429,6 @@
(if equivalent-occ
(progn
(add-occurrence destination equivalent-occ :revision revision)
- (move-identifiers occ equivalent-occ :revision revision)
(move-referenced-constructs occ equivalent-occ
:revision revision))
(add-occurrence destination occ :revision revision))))
@@ -3399,7 +3454,6 @@
(if equivalent-var
(progn
(add-variant destination equivalent-var :revision revision)
- (move-identifiers var equivalent-var :revision revision)
(move-referenced-constructs var equivalent-var
:revision revision))
(add-variant destination var :revision revision))))
@@ -3423,10 +3477,8 @@
destination-name))
(names destination :revision revision))))
(if equivalent-name
- (progn
- (move-variants name equivalent-name :revision revision)
+ (progn
(add-name destination equivalent-name :revision revision)
- (move-identifiers name equivalent-name :revision revision)
(move-referenced-constructs name equivalent-name
:revision revision))
(add-name destination name :revision revision))))
@@ -3467,7 +3519,6 @@
(let ((newer-topic (if (eql older-topic construct-1)
construct-2
construct-1)))
- (move-identifiers newer-topic older-topic :revision revision)
(dolist (tm (in-topicmaps newer-topic :revision revision))
(add-to-tm tm older-topic))
(move-names newer-topic older-topic :revision revision)
@@ -3481,52 +3532,77 @@
older-topic))))
-(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
+(defmethod merge-constructs ((construct-1 CharacteristicC)
+ (construct-2 CharacteristicC)
&key (revision *TM-REVISION*))
+ (declare (integer revision))
(if (eql construct-1 construct-2)
construct-1
- (progn
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
- (error "From merge-constructs(): ~a is not mergable with ~a"
- construct-1 construct-2))
- (let ((parent-1 (parent construct-1 :revision revision))
- (parent-2 (parent construct-2 :revision revision)))
- (when (not (and parent-1 parent-2))
- (error "From merge-constructs():~a and ~a must be associated with a topic"
- construct-1 construct-2))
- (if (and parent-1 (eql parent-1 parent-2))
- (let ((older-occ (find-oldest-construct construct-1 construct-2)))
- (let ((newer-occ (if (eql older-occ construct-1)
- construct-2
- construct-1)))
- (move-identifiers newer-occ older-occ :revision revision)
- (move-referenced-constructs newer-occ older-occ
- :revision revision)
- (delete-occurrence parent-1 construct-1 :revision revision)
- (add-occurrence parent-1 construct-2 :revision revision)
- older-occ))
- (let ((active-topic
- (merge-constructs parent-1 parent-2 :revision revision)))
- (if (find construct-1
- (occurrences active-topic :revision revision))
- construct-1
- construct-2)))))))
+ (let ((older-char (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-char (if (eql older-char construct-1)
+ construct-2
+ construct-1)))
+ (let ((parent-1 (parent older-char :revision revision))
+ (parent-2 (parent newer-char :revision revision)))
+ (unless (strictly-equivalent-constructs construct-1 construct-2
+ :revision revision)
+ (error "From merge-constructs(): ~a and ~a are not mergable"
+ construct-1 construct-2))
+ (cond ((and parent-1 (eql parent-1 parent-2))
+ (move-referenced-constructs newer-char older-char
+ :revision revision)
+ (delete-characteristic newer-char parent-2
+ :revision revision)
+ older-char)
+ ((and parent-1 parent-2)
+ (let ((active-parent (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (let ((found-older-char
+ (cond ((typep older-char 'OccurrenceC)
+ (find older-char
+ (occurrences
+ active-parent :revision revision)))
+ ((typep older-char 'NameC)
+ (find older-char
+ (names
+ active-parent :revision revision)))
+ ((typep older-char 'VariantC)
+ (find-if
+ #'(lambda(name)
+ (find older-char
+ (variants name
+ :revision revision)))
+ (names active-parent :revision revision))))))
+ (if found-older-char
+ older-char
+ newer-char))))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-char newer-char))
+ (src (if parent-1 newer-char older-char)))
+ (move-referenced-constructs src dst :revision revision)
+ dst))
+ (t
+ (move-referenced-constructs newer-char older-char
+ :revision revision)
+ older-char)))))))
+
-;TODO: merge-constructs: RoleC, AssociationC, TopicMapC,
-; OccurrenceC, NameC, VariantC --> call merge-constructs of the parent
-; and return the active construct on what merge-constructs was initialy
-; called
+;TODO: merge-constructs: RoleC (merge parents and return the active role object),
+;; AssociationC, TopicMapC,
+
+
+
+
;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
&key (revision *TM-REVISION*))
@@ -3539,80 +3615,7 @@
;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
- &key (revision *TM-REVISION*))
- (declare (integer revision))
- (if (eql construct-1 construct-2)
- construct-1
- (let ((older-var (find-oldest-construct construct-1 construct-2)))
- (let ((newer-var (if (eql older-var construct-1)
- construct-2
- construct-1)))
- (let ((parent-1 (parent older-var :revision revision))
- (parent-2 (parent newer-var :revision revision)))
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
- (cond ((and parent-1 parent-2)
- (let ((active-parent
- (merge-constructs parent-1 parent-2
- :revision revision)))
- (let ((all-names (names active-parent :revision revision)))
- (if (find-if #'(lambda(name)
- (find older-var (variants name :revision
- revision)))
- all-names)
- older-var
- newer-var))))
- ((or parent-1 parent-2)
- (let ((dst (if parent-1 older-var newer-var))
- (src (if parent-1 newer-var older-var)))
- (move-identifiers src dst :revision revision)
- (move-referenced-constructs src dst :revision revision)
- dst))
- (t
- (move-identifiers newer-var older-var :revision revision)
- (move-referenced-constructs newer-var older-var
- :revision revision)
- older-var)))))))
-
-(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC)
- &key (revision *TM-REVISION*))
- (declare (integer revision))
- (if (eql construct-1 construct-2)
- construct-1
- (let ((older-name (find-oldest-construct construct-1 construct-2)))
- (let ((newer-name (if (eql older-name construct-1)
- construct-2
- construct-1)))
- (let ((parent-1 (parent older-name :revision revision))
- (parent-2 (parent newer-name :revision revision)))
- (unless (strictly-equivalent-constructs construct-1 construct-2
- :revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
- (cond ((and parent-1 parent-2)
- (let ((active-parent (merge-constructs parent-1 parent-2
- :revision revision)))
- (if (find older-name (names active-parent
- :revision revision))
- older-name
- newer-name)))
- ((or parent-1 parent-2)
- (let ((dst (if parent-1 older-name newer-name))
- (src (if parent-1 newer-name older-name)))
- (move-identifiers src dst :revision revision)
- (move-referenced-constructs src dst :revision revision)
- (move-variants src dst :revision revision)
- dst))
- (t
- (move-identifiers newer-name older-name :revision revision)
- (move-referenced-constructs newer-name older-name
- :revision revision)
- (move-variants newer-name older-name :revision revision)
- older-name)))))))
;TODO: --> include move-yx in move-referenced-constructs
\ No newline at end of file
1
0