From lgiessmann at common-lisp.net  Wed Feb  3 13:32:20 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 03 Feb 2010 08:32:20 -0500
Subject: [isidorus-cvs] r176 - trunk/src/rest_interface
Message-ID: <E1NcfLA-0005k9-6J@common-lisp.net>

Author: lgiessmann
Date: Wed Feb  3 08:32:19 2010
New Revision: 176

Log:
changed a variable in the restful interface that is needed for the generation of rdf-data

Modified:
   trunk/src/rest_interface/rest-interface.lisp
   trunk/src/rest_interface/set-up-json-interface.lisp

Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp	(original)
+++ trunk/src/rest_interface/rest-interface.lisp	Wed Feb  3 08:32:19 2010
@@ -27,6 +27,7 @@
            :start-tm-engine
 	   :shutdown-tm-engine
 	   :*json-get-prefix*
+	   :*get-rdf-prefix*
 	   :*json-commit-url*
 	   :*json-get-all-psis*
 	   :*json-get-summary-prefix*

Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp	(original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp	Wed Feb  3 08:32:19 2010
@@ -10,7 +10,7 @@
 (in-package :rest-interface)
 
 (defparameter *json-get-prefix* "/json/get/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi>
-(defparameter *json-get-rdf-prefix* "/json/get/rdf/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi>
+(defparameter *get-rdf-prefix* "/json/get/rdf/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi>
 (defparameter *json-commit-url* "/json/commit/?$") ;the url to commit a json fragment by "put" or "post"
 (defparameter *json-get-all-psis* "/json/psis/?$") ;the url to get all topic psis of isidorus -> localhost:8000/json/psis
 (defparameter *json-get-summary-url* "/json/summary/?$") ;the url to get a summary of all topic stored in isidorus; you have to set the GET-parameter "start" for the start index of all topics within elephant and the GET-paramter "end" for the last index of the topic sequence -> http://localhost:8000/json/summary/?start=12&end=13
@@ -28,7 +28,7 @@
 (defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files
 
 (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*)
-			      (json-get-rdf-prefix *json-get-rdf-prefix*)
+			      (get-rdf-prefix *get-rdf-prefix*)
 			      (json-get-all-psis *json-get-all-psis*)
 			      (json-commit-url *json-commit-url*)
 			      (json-get-summary-url *json-get-summary-url*)
@@ -82,7 +82,7 @@
    (create-regex-dispatcher json-get-prefix #'return-json-fragment)
    hunchentoot:*dispatch-table*)
   (push
-   (create-regex-dispatcher json-get-rdf-prefix #'return-json-rdf-fragment)
+   (create-regex-dispatcher get-rdf-prefix #'return-json-rdf-fragment)
    hunchentoot:*dispatch-table*)
   (push
    (create-regex-dispatcher json-get-topic-stub-prefix #'return-topic-stub-of-psi)



From lgiessmann at common-lisp.net  Wed Feb  3 14:54:03 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 03 Feb 2010 09:54:03 -0500
Subject: [isidorus-cvs] r177 - trunk/src/json
Message-ID: <E1NcgcF-0003lH-M1@common-lisp.net>

Author: lgiessmann
Date: Wed Feb  3 09:54:01 2010
New Revision: 177

Log:
fixed a problem in the json/ajax-interface: imported data can be restored after a system crash now -> the fragment is imported within the macro (elephant:ensure-transaction (:txn-nosync nil), since the store-controller can't be closed to ensure a succesful transaction

Modified:
   trunk/src/json/json_importer.lisp

Modified: trunk/src/json/json_importer.lisp
==============================================================================
--- trunk/src/json/json_importer.lisp	(original)
+++ trunk/src/json/json_importer.lisp	Wed Feb  3 09:54:01 2010
@@ -32,13 +32,13 @@
 	    (topicStubs-values (getf fragment-values :topicStubs))
 	    (associations-values (getf fragment-values :associations))
 	    (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment
-;	    (xtm-id "json-xtm"))
-	(xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids)))
-	  (loop for topicStub-values in (append topicStubs-values (list topic-values))
-	     do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id))
-	  (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id)
-	  (loop for association-values in associations-values
-	     do (json-to-association association-values rev :tm xml-importer::tm)))))))
+	(elephant:ensure-transaction (:txn-nosync nil) 
+	  (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids)))
+	    (loop for topicStub-values in (append topicStubs-values (list topic-values))
+	       do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id))
+	    (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id)
+	    (loop for association-values in associations-values
+	       do (json-to-association association-values rev :tm xml-importer::tm))))))))
 
 
 (defun json-to-association (json-decoded-list start-revision



From lgiessmann at common-lisp.net  Wed Feb  3 15:54:09 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 03 Feb 2010 10:54:09 -0500
Subject: [isidorus-cvs] r178 - trunk/src/ajax/javascripts
Message-ID: <E1NchYP-0007oY-M3@common-lisp.net>

Author: lgiessmann
Date: Wed Feb  3 10:54:09 2010
New Revision: 178

Log:
ajax-client: fixed a bug in the dblClickHandler of TextrowC; fixed a bug in the removeHandler of IdentifierC

Modified:
   trunk/src/ajax/javascripts/datamodel.js

Modified: trunk/src/ajax/javascripts/datamodel.js
==============================================================================
--- trunk/src/ajax/javascripts/datamodel.js	(original)
+++ trunk/src/ajax/javascripts/datamodel.js	Wed Feb  3 10:54:09 2010
@@ -105,12 +105,14 @@
                                          checkRemoveAddButtons(owner, min, max, null);
                                          var myself = this;
                                          setRemoveAddHandler(this, true, owner, min, max, function(){
-					     return new TextrowC("", regexp, owner, min, max, cssTitle, dblClickHandler);
+					     return new TextrowC("", regexp, owner, min, max, cssTitle, this.__dblClickHandler__);
 					 });
     
-                                         this.getFrame().observe("dblclick", function(event){
-					     dblClickHandler(owner, event);
-					 });
+					 if(this.__dblClickHandler__){
+					     this.getFrame().observe("dblclick", function(event){
+						     this.__dblClickHandler__(owner, event);
+						 });
+					 }
                                       },
 				     "dblClick" : function(){
 					 if(this.__dblClickHandler__) this.__dblClickHandler__(this.__owner__);
@@ -494,8 +496,8 @@
 								    if(min === 0) dblClickHandler = dblClickHandlerF;
 								    var _content = "";
 								    if(_contents && _contents.length > j) _content = _contents[j];
-								    var row = new TextrowC(_content, constraints[i].regexp, this.__containers__[i],
-											   min === 0 ? 1 : min, max === MMAX_INT ? -1 : max, cssTitle, dblClickHandler);
+								    
+								    var row = new TextrowC(_content, constraints[i].regexp, this.__containers__[i], min === 0 ? 1 : min, max === MMAX_INT ? -1 : max, cssTitle, dblClickHandler);
 								    if(!_content) row.dblClick();
 								    this.__error__.insert({"before" : row.getFrame()});
 								}
@@ -1440,9 +1442,11 @@
 					      
 					      addSecondShowHandler(this);
 
-					      this.getFrame().observe("dblclick", function(event){
-						  dblClickHandler(owner, event);
-					      });
+					      if(dblClickHandler){
+						  this.getFrame().observe("dblclick", function(event){
+							  dblClickHandler(owner, event);
+						      });
+					      }
                                           }
                                           catch(err){
                                       	      alert("From NameC(): " + err);
@@ -1817,9 +1821,11 @@
 						    }
 						    makeResource(this, contents, constraint, dataType, cssTitle, {"rows" : 5, "cols" : 70});
 
-						    this.getFrame().observe("dblclick", function(event){
-							dblClickHandler(owner, event);
-						    });
+						    if(dblClickHandler){
+							this.getFrame().observe("dblclick", function(event){
+								dblClickHandler(owner, event);
+							    });
+						    }
 						}
                                                 catch(err){
 						    alert("From OccurrenceC(): " + err);
@@ -3918,7 +3924,7 @@
 	if(disabled === false){
 	    var newElem = call();
 	    myself.append(newElem.getFrame());
-	    if((remove === true && min !== -1 && owner.__frames__.length > min) || !constraint){
+	    if((myself.remove === true && min !== -1 && owner.__frames__.length > min) || !constraint){
 		for(var i = 0; i != owner.__frames__.length; ++i){
 		    owner.__frames__[i].showRemoveButton();
 		}



From lgiessmann at common-lisp.net  Wed Feb  3 16:42:26 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 03 Feb 2010 11:42:26 -0500
Subject: [isidorus-cvs] r179 - trunk/src/ajax/javascripts
Message-ID: <E1NciJ8-0004BN-Hq@common-lisp.net>

Author: lgiessmann
Date: Wed Feb  3 11:42:25 2010
New Revision: 179

Log:
ajax-client: fixed a bug with the dblClickHandler of the IdentifierC class

Modified:
   trunk/src/ajax/javascripts/datamodel.js

Modified: trunk/src/ajax/javascripts/datamodel.js
==============================================================================
--- trunk/src/ajax/javascripts/datamodel.js	(original)
+++ trunk/src/ajax/javascripts/datamodel.js	Wed Feb  3 11:42:25 2010
@@ -110,7 +110,7 @@
     
 					 if(this.__dblClickHandler__){
 					     this.getFrame().observe("dblclick", function(event){
-						     this.__dblClickHandler__(owner, event);
+						     myself.__dblClickHandler__(owner, event);
 						 });
 					 }
                                       },
@@ -496,7 +496,7 @@
 								    if(min === 0) dblClickHandler = dblClickHandlerF;
 								    var _content = "";
 								    if(_contents && _contents.length > j) _content = _contents[j];
-								    
+
 								    var row = new TextrowC(_content, constraints[i].regexp, this.__containers__[i], min === 0 ? 1 : min, max === MMAX_INT ? -1 : max, cssTitle, dblClickHandler);
 								    if(!_content) row.dblClick();
 								    this.__error__.insert({"before" : row.getFrame()});



From lgiessmann at common-lisp.net  Mon Feb  8 21:19:48 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 08 Feb 2010 16:19:48 -0500
Subject: [isidorus-cvs] r180 - trunk/src/model
Message-ID: <E1Neb1I-0003mf-Q1@common-lisp.net>

Author: lgiessmann
Date: Mon Feb  8 16:19:47 2010
New Revision: 180

Log:
datamodel: fixed a problem with the datamodel and elephant's/sb-mop's function finalize-inheritance when reading data of the type ItemIdentiferC and SubjectLocatorC after a system-restart without creating new objects of these types

Modified:
   trunk/src/model/datamodel.lisp

Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp	(original)
+++ trunk/src/model/datamodel.lisp	Mon Feb  8 16:19:47 2010
@@ -255,6 +255,93 @@
 (defgeneric get-most-recent-version-info (construct))
 
 
+;;;;;;;;;;;;;;
+;;
+;; ItemIdentifierC
+
+(elephant:defpclass ItemIdentifierC (IdentifierC) 
+  ()
+  (:index t)
+  (:documentation "Represents an item identifier"))
+
+
+;;;;;;;;;;;;;;
+;;
+;; SubjectLocator
+
+(elephant:defpclass SubjectLocatorC (IdentifierC)
+  ((identified-construct :accessor identified-construct
+                         :initarg :identified-construct
+                         :associate TopicC))
+  (:index t)
+  (:documentation "Represents a subject locator"))
+
+
+;;;;;;;;;;;;;;
+;;
+;; IdentifierC
+
+(elephant:defpclass IdentifierC (PointerC)
+  ()
+  (:documentation "Abstract base class for ItemIdentifierC and
+  PersistentIdC, primarily in view of the equality rules"))
+
+
+;;;;;;;;;;;;;;
+;;
+;; PointerC
+
+(elephant:defpclass PointerC (TopicMapConstructC)
+  ((uri :accessor uri
+        :initarg :uri
+        :type string
+        :initform (error "The uri must be set for a pointer")
+        :index t)
+   (identified-construct :accessor identified-construct
+                         :initarg :identified-construct
+                         :associate ReifiableConstructC))
+  (:documentation "Abstract base class for all types of pointers and identifiers"))
+
+(defmethod delete-construct :before ((construct PointerC))
+  (delete-1-n-association construct 'identified-construct))
+
+(defmethod find-all-equivalent ((construct PointerC))
+  (delete construct
+          (elephant:get-instances-by-value (class-of construct)
+                                           'uri
+                                           (uri construct))
+          :key #'internal-id))
+(defgeneric uri-p (construct)
+  (:documentation "Check if the slot uri is bound in an identifier and not nil")
+  (:method ((identifier PointerC)) (slot-predicate identifier 'uri)))
+
+(defgeneric identified-construct-p (construct)
+  (:documentation "Check if the slot identified-construct is bound in an identifier and not nil")
+  (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct)))
+
+(defmethod print-object ((identifier PointerC) stream)
+  (format stream 
+          "~a(href: ~a; Construct: ~a)"
+          (class-name (class-of identifier))
+          (if (uri-p identifier)
+              (uri identifier)
+              "URI UNDEFINED")
+          (if (identified-construct-p identifier)
+              (identified-construct identifier) 
+              "SLOT UNBOUND")))
+
+(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC))
+  (string= (uri identifier1) (uri identifier2)))
+
+(defmethod initialize-instance :around ((identifier PointerC) &key
+                                        (start-revision (error "Start revision must be present") )
+                                        (end-revision 0))
+  (call-next-method)
+  (add-to-version-history identifier
+                          :start-revision start-revision
+                          :end-revision end-revision)
+  identifier)
+
 
 ;;;;;;;;;;;;;;
 ;;
@@ -448,110 +535,6 @@
   (slot-value construct (find-symbol "OID" 'elephant)))
 
 
-
-;;;;;;;;;;;;;;
-;;
-;; PointerC
-
-(elephant:defpclass PointerC (TopicMapConstructC)
-  ((uri :accessor uri
-        :initarg :uri
-        :type string
-        :initform (error "The uri must be set for a pointer")
-        :index t)
-   (identified-construct :accessor identified-construct
-                         :initarg :identified-construct
-                         :associate ReifiableConstructC))
-  (:documentation "Abstract base class for all types of pointers and identifiers"))
-
-(defmethod delete-construct :before ((construct PointerC))
-  (delete-1-n-association construct 'identified-construct))
-
-(defmethod find-all-equivalent ((construct PointerC))
-  (delete construct
-          (elephant:get-instances-by-value (class-of construct)
-                                           'uri
-                                           (uri construct))
-          :key #'internal-id))
-(defgeneric uri-p (construct)
-  (:documentation "Check if the slot uri is bound in an identifier and not nil")
-  (:method ((identifier PointerC)) (slot-predicate identifier 'uri)))
-
-(defgeneric identified-construct-p (construct)
-  (:documentation "Check if the slot identified-construct is bound in an identifier and not nil")
-  (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct)))
-
-(defmethod print-object ((identifier PointerC) stream)
-  (format stream 
-          "~a(href: ~a; Construct: ~a)"
-          (class-name (class-of identifier))
-          (if (uri-p identifier)
-              (uri identifier)
-              "URI UNDEFINED")
-          (if (identified-construct-p identifier)
-              (identified-construct identifier) 
-              "SLOT UNBOUND")))
-
-(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC))
-  (string= (uri identifier1) (uri identifier2)))
-
-(defmethod initialize-instance :around ((identifier PointerC) &key
-                                        (start-revision (error "Start revision must be present") )
-                                        (end-revision 0))
-  (call-next-method)
-  (add-to-version-history identifier
-                          :start-revision start-revision
-                          :end-revision end-revision)
-  identifier)
-
-;;;;;;;;;;;;;;
-;;
-;; IdentifierC
-
-(elephant:defpclass IdentifierC (PointerC)
-  ()
-  (:documentation "Abstract base class for ItemIdentifierC and
-  PersistentIdC, primarily in view of the equality rules"))
-
-
-;;;;;;;;;;;;;;
-;;
-;; ItemIdentifierC
-
-(elephant:defpclass ItemIdentifierC (IdentifierC) 
-  ()
-  (:index t)
-  (:documentation "Represents an item identifier"))
-
-
-;;;;;;;;;;;;;;
-;;
-;; PSI
-
-(elephant:defpclass PersistentIdC (IdentifierC) 
-  ((identified-construct :accessor identified-construct
-                         :initarg :identified-construct
-                         :associate TopicC))
-  (:index t)
-  (:documentation "Represents a PSI"))
-
-
-
-;;(defmethod print-object ((psi PersistentIdC) stream)
-;;  (format stream "PSI(URI: ~a; TopicId: ~a)" (uri psi) (topicid (identified-construct psi))))
-
-
-;;;;;;;;;;;;;;
-;;
-;; SubjectLocator
-
-(elephant:defpclass SubjectLocatorC (IdentifierC)
-  ((identified-construct :accessor identified-construct
-                         :initarg :identified-construct
-                         :associate TopicC))
-  (:index t)
-  (:documentation "Represents a subject locator"))
-
 ;;;;;;;;;;;;;;
 ;;
 ;; TopicIdentificationC
@@ -600,6 +583,19 @@
   (elephant:get-instance-by-value 'TopicIdentificationC
                                   'xtm-id xtm-id))
 
+
+;;;;;;;;;;;;;;
+;;
+;; PSI
+
+(elephant:defpclass PersistentIdC (IdentifierC) 
+  ((identified-construct :accessor identified-construct
+                         :initarg :identified-construct
+                         :associate TopicC))
+  (:index t)
+  (:documentation "Represents a PSI"))
+
+
 ;;;;;;;;;;;;;;
 ;;
 ;; ReifiableConstructC



From lgiessmann at common-lisp.net  Mon Feb  8 21:30:50 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 08 Feb 2010 16:30:50 -0500
Subject: [isidorus-cvs] r181 - branches/new-datamodel
Message-ID: <E1NebBy-0004kL-Ok@common-lisp.net>

Author: lgiessmann
Date: Mon Feb  8 16:30:50 2010
New Revision: 181

Log:
created a private branch for the new datamodel to ensure stable checkouts

Added:
   branches/new-datamodel/
      - copied from r180, /trunk/



From lgiessmann at common-lisp.net  Mon Feb  8 21:36:41 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 08 Feb 2010 16:36:41 -0500
Subject: [isidorus-cvs] r182 - branches/new-datamodel/docs
Message-ID: <E1NebHd-0004pJ-Pj@common-lisp.net>

Author: lgiessmann
Date: Mon Feb  8 16:36:41 2010
New Revision: 182

Log:
datamodel: added a UML of the new class hierarchy to the branch

Added:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd   (contents, props changed)
Removed:
   branches/new-datamodel/docs/isidorus_classes.pdf

Added: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files (empty file) and branches/new-datamodel/docs/isidorus_data_model.pdf	Mon Feb  8 16:36:41 2010 differ

Added: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary file. No diff available.



From lgiessmann at common-lisp.net  Thu Feb 11 19:21:41 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 11 Feb 2010 14:21:41 -0500
Subject: [isidorus-cvs] r183 - in branches/new-datamodel/src: . model
	unit_tests
Message-ID: <E1Nfebd-0006iK-2v@common-lisp.net>

Author: lgiessmann
Date: Thu Feb 11 14:21:40 2010
New Revision: 183

Log:
new-datamodel: started to implement the new datamodel --> added some base classes

Added:
   branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified:
   branches/new-datamodel/src/isidorus.asd
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/unit_tests/fixtures.lisp

Modified: branches/new-datamodel/src/isidorus.asd
==============================================================================
--- branches/new-datamodel/src/isidorus.asd	(original)
+++ branches/new-datamodel/src/isidorus.asd	Thu Feb 11 14:21:40 2010
@@ -147,6 +147,8 @@
 					    :depends-on ("fixtures"))
 				     (:file "rdf_exporter_test"
 					    :depends-on ("fixtures"))
+				     (:file "datamodel_test"
+					    :depends-on ("fixtures"))
 				     (:file "reification_test"
 					    :depends-on ("fixtures" "unittests-constants")))
 			:depends-on ("atom"

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Thu Feb 11 14:21:40 2010
@@ -7,1670 +7,1962 @@
 ;;+-----------------------------------------------------------------------------
 
 
-;-*- standard-indent: 2; indent-tabs-mode: nil -*-
 (defpackage :datamodel
   (:use :cl :elephant :constants)
-  (:nicknames :d)
-  (:import-from :exceptions
-                missing-reference-error
-                no-identifier-error
-                duplicate-identifier-error
-                object-not-found-error)
-  (:export :AssociationC ;; types
-           :CharacteristicC
-           :FragmentC
-           :IdentifierC
-           :IdentityC 
-           :ItemIdentifierC
-           :NameC
-           :OccurrenceC
-           :PersistentIdC
-           :ReifiableConstructC
-           :RoleC
-           :ScopableC
-           :SubjectLocatorC
-           :TopicC
-           :TopicIdentificationC
-           :TopicMapC
-	   :TopicMapConstructC 
-	   :TypableC
-	   :VariantC
-
-           ;; functions and slot accessors
-           :in-topicmaps
-           :add-to-topicmap
-           :add-source-locator
-           :associations
-           :changed-p
-           :charvalue
-           :check-for-duplicate-identifiers
-           :datatype
-           :equivalent-constructs
-           :find-item-by-revision
-           :find-most-recent-revision
-           :get-all-revisions
-           :get-all-revisions-for-tm
-           :get-fragment
-           :get-fragments
-           :get-revision
-           :get-item-by-content
-           :get-item-by-id
-           :get-item-by-item-identifier
-           :get-item-by-psi
-           :identified-construct
-           :identified-construct-p
-           :in-topicmap
-           :internal-id
-           :instance-of
-           :instance-of-p
-           :item-identifiers
-           :item-identifiers-p
-           :list-instanceOf
-	   :list-super-types
-           :locators
-           :locators-p
-           :make-construct
-           :mark-as-deleted
-           :names
-           :namevalue
-           :occurrences
-	   :name
-           :parent
-           :player
-           :player-in-roles
-           :players
-           :psis
-           :psis-p
-           :referenced-topics
-           :revision
-           :RoleC-p
-           :roleid
-           :roles
-           :themes
-           :xtm-id
-           :xtm-id-p
-           :topic
-           :topicid
-           :topic-identifiers
-           :topics
-           :unique-id
-	   :uri 
-	   :uri-p
-	   :used-as-type
-	   :used-as-theme
-	   :variants
-	   :xor
-           :create-latest-fragment-of-topic
-	   :reified
-	   :reifier
-	   :add-reifier
-	   :remove-reifier
-
-           :*current-xtm* ;; special variables
-           :*TM-REVISION*
+  (:nicknames :d))
 
-           :with-revision ;;macros
+(in-package :datamodel)
 
-	   :string-starts-with ;;helpers
-           ))
 
-(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))
-(in-package :datamodel)
+;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun slot-p (instance slot-symbol)
+  "Returns t if the slot depending on slot-symbol is bound and not nil."
+  (and (slot-boundp instance slot-symbol)
+       (slot-value instance slot-symbol)))
+
 
-(defparameter *current-xtm* nil "Represents the currently active TM")
+(defun delete-1-n-association(instance slot-symbol)
+  (when (slot-p instance slot-symbol)
+    (remove-association
+     instance slot-symbol (slot-value instance slot-symbol))))
 
-(defmacro find-max-elem (candidate-list &key (relop #'> relop-p) (key #'identity key-p))
-  "Given a non-empty list, return the maximum element in the list.
-   If provided, then relop must be a relational operator that determines the ordering;
-   else #'> is used. The keyword parameter key may name a function that is used to extract
-   the sort key; otherwise the elements themselves are the sort keys."
-  (let
-      ((candidate-list-value-name (gensym))
-       (relop-value-name (gensym))
-       (key-value-name (gensym))
-       (best-seen-cand-name (gensym))
-       (max-key-name (gensym))
-       (inspected-cand-name (gensym))
-       (inspected-key-name (gensym)))
-    (let
-        ((max-key-init (if key-p
-                           `(funcall ,key-value-name ,best-seen-cand-name)
-                           best-seen-cand-name))
-         (inspected-key-init (if key-p
-                                 `(funcall ,key-value-name ,inspected-cand-name)
-                                 inspected-cand-name))
-         (relexp (if relop-p
-                     `(funcall ,relop-value-name ,inspected-key-name ,max-key-name)
-                     `(> ,inspected-key-name ,max-key-name))))
-      (let
-          ((initializers `((,candidate-list-value-name ,candidate-list)
-                           (,best-seen-cand-name (first ,candidate-list-value-name))
-                           (,max-key-name ,max-key-init))))
-        (when relop-p
-          (push `(,relop-value-name ,relop) initializers))
-        (when key-p
-          (push `(,key-value-name ,key) initializers))
-        `(let*
-          ,initializers
-          (dolist (,inspected-cand-name (rest ,candidate-list-value-name))
-            (let
-                ((,inspected-key-name ,inspected-key-init))
-              (when ,relexp
-                (setf ,best-seen-cand-name ,inspected-cand-name)
-                (setf ,max-key-name ,inspected-key-name))))
-          ,best-seen-cand-name)))))
-
-(defvar *TM-REVISION* 0)
-
-(defmacro with-revision (revision &rest body)
-  `(let
-    ((*TM-REVISION* ,revision))
-                                        ;(format t "*TM-REVISION* is ~a~&" *TM-REVISION*)
-    , at body))
-    
-
-(defmacro slot-predicate (instance slot)
-  (let
-      ((inst-name (gensym))
-       (slot-name (gensym)))
-    `(let
-      ((,inst-name ,instance)
-       (,slot-name ,slot))
-      (and (slot-boundp ,inst-name ,slot-name)
-       (slot-value ,inst-name ,slot-name)))))
-
-(defmacro delete-1-n-association (instance slot)
-  (let
-      ((inst-name (gensym))
-       (slot-name (gensym)))
-    `(let
-      ((,inst-name ,instance)
-       (,slot-name ,slot))
-      (when (slot-predicate ,inst-name ,slot-name)
-        (elephant:remove-association ,inst-name ,slot-name (slot-value ,inst-name ,slot-name))))))
-
-(defun xor (a1 a2)
-  (and (or a1 a2) (not (and a1 a2)))
-  )
-
-(defun remove-nil-values (plist)
-  (let
-      ((result nil))
-    (do* ((rest plist (cddr rest))
-          (key (first rest) (first rest))
-          (val (second rest) (second rest)))
-         ((null rest))
-      (when val
-        (pushnew val result)
-        (pushnew key result)))
-    result))
-
-(defun get-revision ()
-  "TODO: replace by something that does not suffer from a 1 second resolution."
-  (get-universal-time))
 
 (defgeneric delete-construct (construct)
-  (:documentation "drops recursively construct and all its dependent objects from the elephant store"))
+  (:documentation "Drops recursively construct and all its dependent objects
+                   from the elephant store."))
+
 
 (defmethod delete-construct ((construct elephant:persistent))
   nil)
 
+
 (defmethod delete-construct :after ((construct elephant:persistent))
-  (elephant:drop-instance construct))
+  (drop-instance construct))
 
-(defgeneric find-all-equivalent (construct)
-  (:method ((construct t)) nil)
-  (:documentation "searches an existing object that is equivalent (but not identical) to construct"))
 
+;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass VersionInfoC()
+  ((start-revision :initarg :start-revision
+		   :accessor start-revision
+		   :type integer
+		   :initform 0
+		   :documentation "The start-revision of the version's
+                                   interval of a versioned object.")
+   (end-revision :initarg :end-revision
+		 :accessor end-revision
+		 :type integer
+		 :initform 0
+		 :documentation "The end-revision of the version's interval
+                                 of a versioned object.")
+   (versioned-construct :initarg :versioned-construct
+			:accessor versioned-construct
+			:associate VersionedConstructC
+			:documentation "The reference of the versioned
+                                        object that is described by this
+                                        VersionInfoC-object."))
+  (:documentation "A VersionInfoC-object describes the revision information
+                   of a versioned object in intervals starting by the value
+                   start-revision and ending by the value end-revision - 1.
+                   end-revision=0 means always the latest version."))
+
+
+(defmethod delete-construct :before ((version-info VersionInfoC))
+  (delete-1-n-association version-info 'versioned-construct))
+
+
+(defgeneric versioned-construct-p (version-info)
+  (:documentation "Returns t if the passed object is already bound to a
+                   VersionedObjectC.")
+  (:method ((version-info VersionInfoC))
+    (slot-p version-info 'versioned-construct)))
+
+
+;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass VersionedConstructC()
+  ((versions :initarg :versions
+	     :accessor versions
+	     :associate (VersionInfoC versioned-construct)
+	     :documentation "Version infos for former versions of this base
+                             class.")))
+
+
+(defmethod delete-construct :before ((construct VersionedConstructC))
+  (dolist (version-info (versions construct))
+    (delete-construct version-info)))
+
+
+(defgeneric get-most-recent-version-info (construct)
+  (:documentation "Returns the latest VersionInfoC object of the passed
+                   versioned construct.
+                   The latest construct is either the one with
+                   end-revision=0 or with the highest end-revision value."))
 
-;;;;;;;;;;;;;;
-;;
-;; VersionInfoC
 
+(defmethod get-most-recent-version-info ((construct VersionedConstructC))
+  (let ((result (find 0 (versions construct) :key #'end-revision)))
+    (if result
+	result ;current version-info -> end-revision = 0
+	(let ((sorted-list (sort (versions construct)
+				 #'(lambda(x y)
+				     (> (end-revision x) (end-revision y))))))
+	  (when sorted-list
+	    (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
 
-(elephant:defpclass VersionInfoC ()
-  ((start-revision :accessor start-revision
-                   :initarg :start-revision
-                   :type integer
-                   :initform 0          ;TODO: for now
-                   :documentation "The first revison this AssociationC instance is associated with.")
-   (end-revision :accessor end-revision
-                 :initarg :end-revision
-                 :type integer
-                 :initform 0            ;TODO: for now
-                 :documentation "The first revison this AssociationC instance is no longer associated with.")
-   (versioned-construct :associate TopicMapConstructC
-                        :accessor versioned-construct
-                        :initarg :versioned-construct
-                        :documentation "reifiable construct that is described by this info"))
-  (:documentation "Version Info for individual revisions"))
 
-(defgeneric versioned-construct-p (vi)
-  (:documentation "t if this version info is already bound to a TM construct")
-  (:method ((vi VersionInfoC)) (slot-predicate vi 'versioned-construct)))
+(defgeneric add-to-version-history (construct &key start-revision end-revision)
+  (:documentation "Adds version history to a versioned construct"))
 
-(defmethod delete-construct :before ((vi VersionInfoC))
-  (delete-1-n-association vi 'versioned-construct))
 
-(defgeneric get-most-recent-version-info (construct))
+(defmethod add-to-version-history ((construct VersionedConstructC)
+				   &key (start-revision (error "From add-to-version-history(): start revision must be present"))
+				   (end-revision 0))
+  (let ((eql-version-info
+	 (find-if #'(lambda(vi)
+		      (and (= (start-revision vi) start-revision)
+			   (= (end-revision vi) end-revision)))
+		  (versions construct))))
+    (if eql-version-info
+	eql-version-info
+	(let ((current-version-info
+	       (get-most-recent-version-info construct)))
+	  (cond
+	    ((and current-version-info
+		  (= (end-revision current-version-info) start-revision))
+	     (setf (end-revision current-version-info) 0)
+	     current-version-info)
+	    ((and current-version-info
+		  (= (end-revision current-version-info) 0))
+	     (setf (end-revision current-version-info) start-revision)
+	     (make-instance 'VersionInfoC 
+			    :start-revision start-revision
+			    :end-revision end-revision
+			    :versioned-construct construct))
+	    (t
+	     (make-instance 'VersionInfoC 
+			    :start-revision start-revision
+			    :end-revision end-revision
+			    :versioned-construct construct)))))))
+
+
+;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; SubjectLocatorAssociationC
+;;; PersistentIdAssociationC
+;;; TopicIdAssociationC
+;;; ItemIdAssociationC
+;;; PointerAssociationC
+;;; VersionedAssociationC
+(defpclass SubjectLocatorAssociationC(PointerAssociationC)
+  ((identified-construct :initarg :identified-construct
+			 :accessor identified-construct
+			 :associate TopicC
+			 :documentation "The actual topic which is associated
+                                         with the subject-locator."))
+  (:index t)
+  (:documentation "A pointer that associates subject-locators, versions
+                   and topics."))
 
 
-;;;;;;;;;;;;;;
-;;
-;; ItemIdentifierC
+(defpclass PersistentIdAssociationC(PointerAssociationC)
+  ((identified-construct :initarg :identified-construct
+			 :accessor identified-construct
+			 :associate TopicC
+			 :documentation "The actual topic which is associated
+                                         with the subject-identifier/psi."))
+  (:index t)
+  (:documentation "A pointer that associates subject-identifiers, versions
+                   and topics."))
+
 
-(elephant:defpclass ItemIdentifierC (IdentifierC) 
+(defpclass TopicIdAssociationC(PointerAssociationC)
+  ((identified-construct :initarg :identified-construct
+			 :accessor identified-construct
+			 :associate TopicC
+			 :documentation "The actual topic which is associated
+                                         with the topic-identifier."))
+  (:index t)
+  (:documentation "A pointer that associates topic-identifiers, versions
+                   and topics."))
+
+
+(defpclass ItemIdAssociationC(PointerAssociationC)
+  ((identified-construct :initarg :identified-construct
+			 :accessor identified-construct
+			 :associate ReifiableConstructC
+			 :documentation "The actual parent which is associated
+                                         with the item-identifier."))
+  (:index t)
+  (:documentation "A pointer that associates item-identifiers, versions
+                   and reifiable-constructs."))
+
+
+(defpclass PointerAssociationC (VersionedAssociationC)
+  ((identifier :initarg :identifier
+	       :accessor identifier
+	       :associate PointerC
+	       :documentation "The actual data that is associated with
+                               the pointer-association's parent."))
+  (:documentation "An abstract base class for all versioned
+                   pointer-associations."))
+
+
+(defpclass VersionedAssociationC()
+  ()
+  (:documentation "An abstract base class for all versioned associations."))
+
+
+;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; SubjectLocatorC
+;;; PersistentIdC
+;;; ItemIdentifierC
+;;; IdentifierC
+;;; TopicIdentificationC
+;;; PointerC
+(defpclass SubjectLocatorC(IdentifierC)
   ()
   (:index t)
-  (:documentation "Represents an item identifier"))
+  (:documentation "A subject-locator that contains an uri-value and an
+                   association to SubjectLocatorAssociationC's which are in
+                   turn associated with TopicC's."))
 
 
-;;;;;;;;;;;;;;
-;;
-;; SubjectLocator
+(defpclass PersistentIdC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-identifier that contains an uri-value and an
+                   association to PersistentIdAssociationC's which are in
+                   turn associated with TopicC's."))
 
-(elephant:defpclass SubjectLocatorC (IdentifierC)
-  ((identified-construct :accessor identified-construct
-                         :initarg :identified-construct
-                         :associate TopicC))
+
+(defpclass ItemIdentifierC(IdentifierC)
+  ()
   (:index t)
-  (:documentation "Represents a subject locator"))
+  (:documentation "An item-identifier that contains an uri-value and an
+                   association to ItemIdAssociationC's which are in turn
+                   associated with RiefiableConstructC's."))
 
 
-;;;;;;;;;;;;;;
-;;
-;; IdentifierC
+(defpclass IdentifierC(PointerC)
+  ()
+  (:documentation "An abstract base class for all TM-Identifiers."))
 
-(elephant:defpclass IdentifierC (PointerC)
+
+(defpclass TopicIdentificationC(PointerC)
+  ((xtm-id :initarg :xtm-id
+	   :accessor xtm-id
+	   :type string
+	   :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+	   :index t
+	   :documentation "ID of the TM this identification came from."))
+  (:index t)
+  (:documentation "Identify topic items through generalized topic-ids.
+                   A topic may have many original topicids, the class
+                   representing one of them."))
+
+
+(defpclass PointerC(TopicMapConstructC)
+  ((uri :initarg :uri
+	:accessor uri
+	:type string
+	:initform (error "From PointerC(): uri must be set for a pointer")
+	:index t
+	:documentation "The actual value of a pointer, i.e. uri or ID.")
+   (identified-construct :initarg :identified-construct
+			 :accessor identified-construct
+			 :associate (PointerAssociationC identifier)))
+  (:documentation "An abstract base class for all pointers."))
+
+
+;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass ReifiableConstructC(TopicMapConstructC)
+  ((item-identifiers :initarg :item-identifiers
+		     :associate (ItemIdAssociationC identified-construct)
+		     :documentation "A relation to all item-identifiers of
+                                     this construct.")
+   (reifier :initarg :reifier
+	    :associate (ReifierAssociationC reified-construct)
+	    :documentation "A relation to a reifier-topic."))
+  (:documentation "Reifiable constructs as per TMDM."))
+
+
+;;TODO: implement reader for item-identifiers and reifier (version)
+;;TODO: implement add-item-identifier and add-reifier (version)
+
+
+;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass TopicMapConstructC()
   ()
-  (:documentation "Abstract base class for ItemIdentifierC and
-  PersistentIdC, primarily in view of the equality rules"))
+  (:documentation "An abstract base class for all classes that describes
+                   Topic Maps data."))
 
 
-;;;;;;;;;;;;;;
-;;
-;; PointerC
 
-(elephant:defpclass PointerC (TopicMapConstructC)
-  ((uri :accessor uri
-        :initarg :uri
-        :type string
-        :initform (error "The uri must be set for a pointer")
-        :index t)
-   (identified-construct :accessor identified-construct
-                         :initarg :identified-construct
-                         :associate ReifiableConstructC))
-  (:documentation "Abstract base class for all types of pointers and identifiers"))
-
-(defmethod delete-construct :before ((construct PointerC))
-  (delete-1-n-association construct 'identified-construct))
-
-(defmethod find-all-equivalent ((construct PointerC))
-  (delete construct
-          (elephant:get-instances-by-value (class-of construct)
-                                           'uri
-                                           (uri construct))
-          :key #'internal-id))
-(defgeneric uri-p (construct)
-  (:documentation "Check if the slot uri is bound in an identifier and not nil")
-  (:method ((identifier PointerC)) (slot-predicate identifier 'uri)))
-
-(defgeneric identified-construct-p (construct)
-  (:documentation "Check if the slot identified-construct is bound in an identifier and not nil")
-  (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct)))
-
-(defmethod print-object ((identifier PointerC) stream)
-  (format stream 
-          "~a(href: ~a; Construct: ~a)"
-          (class-name (class-of identifier))
-          (if (uri-p identifier)
-              (uri identifier)
-              "URI UNDEFINED")
-          (if (identified-construct-p identifier)
-              (identified-construct identifier) 
-              "SLOT UNBOUND")))
-
-(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC))
-  (string= (uri identifier1) (uri identifier2)))
-
-(defmethod initialize-instance :around ((identifier PointerC) &key
-                                        (start-revision (error "Start revision must be present") )
-                                        (end-revision 0))
-  (call-next-method)
-  (add-to-version-history identifier
-                          :start-revision start-revision
-                          :end-revision end-revision)
-  identifier)
-
-
-;;;;;;;;;;;;;;
-;;
-;; TopicMapConstrucC
-
-
-(elephant:defpclass TopicMapConstructC ()
-  ((versions :associate (VersionInfoC versioned-construct)
-             :accessor versions
-             :initarg :versions
-             :documentation "version infos for former versions of this reifiable construct")))
-
-                                        ;TODO: if, one day, we allow merges of already existing constructs, we'll need
-                                        ;a tree of predecessors rather then just a list of versions. A case in point
-                                        ;may be if a newly imported topic carries the PSIs of two existing topics,
-                                        ;thereby forcing a merge post factum"
-
-(defmethod delete-construct :before ((construct TopicMapConstructC))
-  (dolist (versioninfo (versions construct))
-    (delete-construct versioninfo)))
 
 
-(defgeneric add-to-version-history (construct &key start-revision end-revision)
-  (:documentation "Add version history to a topic map construct"))
 
-(defmethod add-to-version-history ((construct TopicMapConstructC) 
-                                   &key 
-                                   (start-revision (error "Start revision must be present") )
-                                   (end-revision 0))
-  "Adds relevant information to a construct's version info"
-  (let
-      ((current-version-info
-        (get-most-recent-version-info construct)))
-    (cond
-      ((and current-version-info 
-           (= (end-revision current-version-info) start-revision)) ;the item was just marked as deleted
-       (setf (end-revision current-version-info) 0) ;just revitalize it, do not create a new version
-       current-version-info)  ;TODO: this is not quite correct, the topic
-                              ;might be recreated with new item
-                              ;identifiers. Consider adding a new parameter
-                              ;"revitalize"
-      ((and 
-        current-version-info 
-        (= (end-revision current-version-info) 0))
-       (setf (end-revision current-version-info) start-revision)
-       (make-instance 
-        'VersionInfoC 
-        :start-revision start-revision
-        :end-revision end-revision
-        :versioned-construct construct))
-      (t
-       (make-instance 
-        'VersionInfoC 
-        :start-revision start-revision
-        :end-revision end-revision
-        :versioned-construct construct)))))
-
-(defgeneric revision (constr)
-  (:documentation "Essentially a convenience method for start-revision"))
-
-(defmethod revision ((constr TopicMapConstructC))
-  (start-revision constr))
-
-(defmethod (setf revision) ((constr TopicMapConstructC) (revision integer))
-  (setf (start-revision constr) revision))
-
-
-(defgeneric find-item-by-revision (constr revision)
-  (:documentation "Get a given version of a construct (if any, nil if none can be found)"))
-
-(defmethod find-item-by-revision ((constr TopicMapConstructC) (revision integer))
-  (cond
-    ((= revision 0)
-     (find-most-recent-revision constr))
-    (t
-     (when (find-if
-            (lambda(version) 
-              (and (>= revision (start-revision version))
-                   (or
-		    (< revision (end-revision version))
-		    (= 0 (end-revision version)))))
-            (versions constr))
-       constr))))
-
-(defgeneric find-most-recent-revision (construct)
-  (:documentation "Get the most recent version of a construct (nil if
-the construct doesn't have versions yet or not anymore)"))
-
-(defmethod find-most-recent-revision ((construct TopicMapConstructC))
-  (when (find 0 (versions construct) :key #'end-revision)
-    construct))
-
-(defmethod delete-construct :before ((construct TopicMapConstructC))
-  (dolist (versionInfo (versions construct))
-    (delete-construct versionInfo)))
-
-
-(defgeneric check-for-duplicate-identifiers (top)
-  (:documentation "Check for possibly duplicate identifiers and signal an
-  duplicate-identifier-error is such duplicates are found"))
-
-(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC))
-  (declare (ignore construct))
-                                        ;do nothing
-  )
-
-(defgeneric filter-slot-value-by-revision (construct slot-name &key start-revision)
-  (:documentation "filter slot values by a given revision that is
-  either provided directly through the keyword argument start-revision
-  or through a bound variable named '*TM-REVISION*'"))
-
-(defmethod filter-slot-value-by-revision ((construct TopicMapConstructC) (slot-name symbol) &key (start-revision 0 start-revision-provided-p))
-  (let
-      ((revision            ;avoids warnings about undefined variables
-        (cond
-          (start-revision-provided-p
-           start-revision)
-          ((boundp '*TM-REVISION*)
-           (symbol-value '*TM-REVISION*))
-          (t 0)))
-       (properties (slot-value construct slot-name)))
-       ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision)
-    (cond
-      ((not properties) 
-       nil)   ;if we don't have any properties, we don't have to worry
-              ;about revisions
-      ((= 0 revision)
-       (remove 
-        nil
-        (map 'list #'find-most-recent-revision
-             properties)))
-      (t
-       (remove nil
-               (map 'list 
-                    (lambda (constr)
-                      (find-item-by-revision constr revision))
-                    properties))))))
-
-(defgeneric make-construct (classsymbol &key start-revision &allow-other-keys)
-  (:documentation "create a new topic map construct if necessary or
-retrieve an equivalent one if available and update the revision
-history accordingly. Return the object in question. Methods use
-specific keyword arguments for their purpose"))
-
-(defmethod make-construct ((classsymbol symbol) &rest args
-                           &key start-revision)
-  (let*
-      ((cleaned-args (remove-nil-values args))
-       (new-construct (apply #'make-instance classsymbol cleaned-args))
-       (existing-construct (first (find-all-equivalent new-construct))))
-    (if existing-construct
-        (progn
-                                        ;change over new item identifiers to the old construct
-          (when  (copy-item-identifiers
-                  new-construct existing-construct)
-                 ;an existing construct other than a topic (which is handled
-                 ;separatedly below) has changed only if it has received a new
-                 ;item identifier
-            (add-to-version-history existing-construct :start-revision start-revision))
-          (delete-construct new-construct)
-          existing-construct)
-        (progn
-          (add-to-version-history new-construct :start-revision start-revision)
-          (check-for-duplicate-identifiers new-construct)
-          new-construct))))
-    
-(defmethod get-most-recent-version-info ((construct TopicMapConstructC))
-  (let ((result (find 0 (versions construct) :key #'end-revision)))
-    (if result
-	result ;current version-info -> end-revision = 0
-	(let ((sorted-list (sort (versions construct)
-				 #'(lambda(x y)
-				     (> (end-revision x) (end-revision y))))))
-	  (when sorted-list
-	    (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
 
-(defgeneric equivalent-constructs (construct1 construct2)
-  (:documentation "checks if two topic map constructs are equal according to the TMDM equality rules"))
 
-(defgeneric strictly-equivalent-constructs (construct1 construct2)
-  (:documentation "checks if two topic map constructs are not identical but equal according to the TMDM equality rules")
-  (:method ((construct1 TopicMapConstructC) (construct2 TopicMapConstructC))
-    (and (equivalent-constructs construct1 construct2)
-         (not (eq construct1 construct2)))))
-
-(defgeneric internal-id (construct)
-  (:documentation "returns the internal id that uniquely identifies a
-  construct (currently simply its OID)"))
-
-(defmethod internal-id ((construct TopicMapConstructC))
-  (slot-value construct (find-symbol "OID" 'elephant)))
-
-
-;;;;;;;;;;;;;;
-;;
-;; TopicIdentificationC
-
-(elephant:defpclass TopicIdentificationC (PointerC) 
-  ((xtm-id 
-    :accessor xtm-id
-    :type string
-    :initarg :xtm-id
-    :index t
-    :documentation "ID of the TM this identification came from"))
-  (:documentation "Identify topic items through generalized
-  topicids. A topic may have many original topicids, the class
-  representing one of them") )
-
-(defmethod find-all-equivalent ((construct TopicIdentificationC))
-  (delete (xtm-id construct) (call-next-method) :key #'xtm-id :test #'string=))
-
-(defun init-topic-identification (top id xtm-id &key (revision *TM-REVISION*))
-  "create a TopicIdentification object (if necessary) and initialize it with the
-  combination of the current topicid and the ID of the current XTM id"
-                                        ;(declare (TopicC top))
-  (declare (string id))
-
-  (flet    ;prevent unnecessary copies of TopicIdentificationC objects
-      ((has-topic-identifier (top uri xtm-id)
-         (remove-if-not
-          (lambda (ident)
-            (and (string= (uri ident) uri)
-                 (string= (xtm-id ident) xtm-id)))
-          (topic-identifiers top))))
-    (unless (has-topic-identifier top id xtm-id)
-      (let
-          ((ti
-            (make-instance 
-             'TopicIdentificationC
-             :uri id
-             :xtm-id xtm-id
-             :identified-construct top
-             :start-revision revision)))
-           ;(add-to-version-history ti :start-revision revision)
-           ti))))
-
-(defun xtm-id-p (xtm-id)
-  "checks if a xtm-id has been used before"
-  (elephant:get-instance-by-value 'TopicIdentificationC
-                                  'xtm-id xtm-id))
-
-
-;;;;;;;;;;;;;;
-;;
-;; PSI
-
-(elephant:defpclass PersistentIdC (IdentifierC) 
-  ((identified-construct :accessor identified-construct
-                         :initarg :identified-construct
-                         :associate TopicC))
-  (:index t)
-  (:documentation "Represents a PSI"))
 
 
-;;;;;;;;;;;;;;
+;;  (:import-from :exceptions
+;;                missing-reference-error
+;;                no-identifier-error
+;;                duplicate-identifier-error
+;;                object-not-found-error)
+;;  (:export :AssociationC ;; types
+;;           :CharacteristicC
+;;           :FragmentC
+;;           :IdentifierC
+;;           :IdentityC 
+;;           :ItemIdentifierC
+;;           :NameC
+;;           :OccurrenceC
+;;           :PersistentIdC
+;;           :ReifiableConstructC
+;;           :RoleC
+;;           :ScopableC
+;;           :SubjectLocatorC
+;;           :TopicC
+;;           :TopicIdentificationC
+;;           :TopicMapC
+;;	   :TopicMapConstructC 
+;;	   :TypableC
+;;	   :VariantC
 ;;
-;; ReifiableConstructC
-
-(elephant:defpclass ReifiableConstructC (TopicMapConstructC)
-  ((item-identifiers 
-    :associate (ItemIdentifierC identified-construct)
-    :inherit t
-    :documentation "Slot that realizes a 1 to N
-                     relation between reifiable constructs and their
-                     identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")
-   (reifier
-    :associate TopicC
-    :inherit t
-    :documentation "Represents a reifier association to a topic, i.e.
-                   it stands for a 1:1 association between this class and TopicC"))
-  (:documentation "Reifiable constructs as per TMDM"))
-
-
-(defgeneric reifier (construct &key revision)
-  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
-    (when (slot-boundp construct 'reifier)
-      (slot-value construct 'reifier))))
-
-(defgeneric (setf reifier) (topic TopicC)
-  (:method (topic (construct ReifiableConstructC))
-    (setf (slot-value construct 'reifier) topic)))
-;    (setf (reified topic) construct)))
-
-(defgeneric item-identifiers (construct &key revision)
-  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))
-
-(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil))
-  "adds associations to these ids after the instance was initialized."
-  (declare (list item-identifiers))
-  (call-next-method)
-  (dolist (id item-identifiers)
-    (declare (ItemIdentifierC id))
-    (setf (identified-construct id) instance))
-  (when reifier
-    (add-reifier instance reifier))
-    ;(setf (reifier instance) reifier))
-  instance)
-
-(defmethod delete-construct :before ((construct ReifiableConstructC))
-  (dolist (id (item-identifiers construct))
-    (delete-construct id))
-  (when (reifier construct)
-    (let ((reifier-topic (reifier construct)))
-      (remove-reifier construct)
-      (delete-construct reifier-topic))))
-
-(defgeneric item-identifiers-p (constr)
-  (:documentation "Test for the existence of item identifiers")
-  (:method ((construct ReifiableConstructC)) (slot-predicate construct 'item-identifiers)))
-
-(defgeneric topicid (construct &optional xtm-id)
-  (:documentation "Return the ID of a construct"))
-
-(defmethod revision ((constr ReifiableConstructC))
-  (start-revision constr))
-
-(defgeneric (setf revision) (revision construct)
-  (:documentation "The corresponding setter method"))
-
-(defmethod (setf revision) ((revision integer) (constr ReifiableConstructC))
-  (setf (start-revision constr) revision))
-
-(defgeneric get-all-identifiers-of-construct (construct)
-  (:documentation "Get all identifiers that a given construct has"))
-
-(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC))
-  (item-identifiers construct))
-
-(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC))
-  (dolist (id (get-all-identifiers-of-construct construct))
-    (when (> (length 
-              (union 
-               (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id))
-               (union 
-                (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
-                (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
-             1)
-      (error 
-       (make-condition 'duplicate-identifier-error 
-                       :message (format nil "Duplicate Identifier ~a has been found" (uri id))
-                       :uri (uri id))))))
-
-(defmethod copy-item-identifiers ((from-construct ReifiableConstructC)
-                                  (to-construct ReifiableConstructC))
-  "Internal method to copy over item idenfiers from a construct to
-another on. Returns the set of new identifiers"
-  (mapc
-   (lambda (identifier)
-     (setf (identified-construct identifier) 
-           to-construct))
-   (set-difference (item-identifiers from-construct)
-                   (item-identifiers to-construct)
-                   :key #'uri :test #'string=)))
-
-;;;;;;;;;;;;;;
-;;
-;; ScopableC
-
-(elephant:defpclass ScopableC ()
-  ((themes :accessor themes
-           :associate (TopicC used-as-theme)
-           :inherit t
-           :many-to-many t
-           :documentation "list of this scope's themes; pseudo-initarg is :themes")))
-
-(defmethod initialize-instance :around ((instance ScopableC) &key (themes nil))
-  (declare (list themes))
-  (call-next-method)
-  (dolist (theme themes)
-    (elephant:add-association instance 'themes theme))
-  instance)
-
-(defmethod delete-construct :before ((construct ScopableC))
-  (dolist (theme (themes construct))
-    (elephant:remove-association construct 'themes theme)))
-
-
-;;;;;;;;;;;;;;
-;;
-;; TypableC
-
-(elephant:defpclass TypableC ()
-  ((instance-of :accessor instance-of
-                :initarg :instance-of
-                :associate TopicC
-                :inherit t
-                :documentation "topic that this construct is an instance of")))
-
-(defmethod delete-construct :before ((construct TypableC))
-  (when (instance-of-p construct)
-    (elephant:remove-association construct 'instance-of (instance-of construct))))
-
-(defgeneric instance-of-p (construct)
-  (:documentation "is the instance-of slot bound and not nil")
-  (:method ((construct TypableC)) (slot-predicate construct 'instance-of)))
-
-
-;; (defmethod equivalent-constructs ((scope1 ScopeC) (scope2 ScopeC))
-;;   "scopes are equal if their themes are equal"
-;;   (let
-;;       ((themes1 
-;;  (map 'list #'internal-id (themes scope1)))
-;;        (themes2
-;;  (map 'list #'internal-id (themes scope2))))
-;;     (not (set-exclusive-or themes1 themes2 :key #'internal-id))))
-
-;;;;;;;;;;;;;;
-;;
-;; CharacteristicC
-       
-
-(elephant:defpclass CharacteristicC (ReifiableConstructC ScopableC TypableC)
-  ((topic :accessor topic
-          :initarg :topic
-          :associate TopicC
-          :documentation "The topic that this characteristic belongs to")
-   (charvalue :accessor charvalue
-              :type string
-              :initarg :charvalue
-              :index t
-              :documentation "the value of the characteristic in the given scope"))
-  (:documentation "Scoped characteristic of a topic (meant to be used
-  as an abstract class)"))
-
-(defgeneric CharacteristicC-p (object)
-  (:documentation "test if object is a of type CharacteristicC")
-  (:method ((object t)) nil)
-  (:method ((object CharacteristicC)) object))
-
-(defmethod delete-construct :before ((construct CharacteristicC))
-  (delete-1-n-association construct 'topic))
-
-(defun get-item-by-content (content &key (revision *TM-REVISION*))
-  "Find characteristis by their (atomic) content"
-  (flet
-      ((get-existing-instances (classname)
-         (delete-if-not #'(lambda (constr)
-                            (find-item-by-revision constr revision))
-                        (elephant:get-instances-by-value classname 'charvalue content))))
-    (nconc (get-existing-instances 'OccurenceC)
-           (get-existing-instances 'NameC))))
-
-
-
-
-;;;;;;;;;;;;;;
-;;
-;; VariantC
-
-(elephant:defpclass VariantC (CharacteristicC)
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform nil
-             :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")
-   (name :accessor name
-	  :initarg :name
-	  :associate NameC
-	  :documentation "references the NameC instance which is the owner of this element")))
-
-
-(defgeneric VariantC-p (object)
-  (:documentation "test if object is a of type VariantC")
-  (:method ((object t)) nil)
-  (:method ((object VariantC)) object))
-
-
-(defmethod delete-construct :before ((construct VariantC))
-  (delete-1-n-association construct 'name))
-
-
-(defmethod find-all-equivalent ((construct VariantC))
-  (let ((parent (and (slot-boundp construct 'name)
-                     (name construct))))
-    (when parent
-      (delete-if-not #'(lambda(x)(strictly-equivalent-constructs construct x))
-                     (slot-value parent 'variants)))))
-
-
-(defmethod equivalent-constructs ((variant1 VariantC) (variant2 VariantC))
-  "variant items are (TMDM(5.5)-)equal if the values of their
-   [value], [datatype], [scope], and [parent] properties are equal"
-  (and (string= (charvalue variant1) (charvalue variant2))
-       (or (and (not (slot-boundp variant1 'datatype)) (not (slot-boundp variant2 'datatype)))
-           (and (slot-boundp variant1 'datatype) (slot-boundp variant2 'datatype)
-                (string= (datatype variant1) (datatype variant2))))
-       (not (set-exclusive-or (themes variant1) (themes variant2) :key #'internal-id))))
-
-                        
-
-         
-;;;;;;;;;;;;;;
-;;
-;; NameC
-
-(elephant:defpclass NameC (CharacteristicC)
-  ((variants ;:accessor variants
-	     :associate (VariantC name)))
-  (:documentation "Scoped name of a topic"))
-
-
-(defgeneric variants (name &key revision)
-  (:method ((name NameC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision name 'variants :start-revision revision)))
-
-
-(defgeneric NameC-p (object)
-  (:documentation "test if object is a of type NameC")
-  (:method ((object t)) nil)
-  (:method ((object NameC)) object))
-
-
-(defmethod find-all-equivalent ((construct NameC))
-  (let
-      ((parent (and (slot-boundp construct 'topic)
-                    (topic construct))))
-    (when parent
-      (delete-if-not 
-       #'(lambda (cand) (strictly-equivalent-constructs construct cand))
-       (slot-value parent 'names)))))
-
-
-(defmethod delete-construct :before ((construct NameC))
-  (dolist (variant (variants construct))
-    (delete-construct variant)))
-
-
-(defmethod equivalent-constructs ((name1 NameC) (name2 NameC))
-  "check for the equlity of two names by the TMDM's equality
-rules (5.4)"
-  (and
-   (string= (charvalue name1) (charvalue name2))
-   (or (and (instance-of-p name1)
-            (instance-of-p name2)
-            (= (internal-id (instance-of name1)) 
-               (internal-id (instance-of name2))))
-       (and (not (instance-of-p name1)) (not (instance-of-p name2))))
-   (not (set-exclusive-or (themes name1) (themes name2) :key #'internal-id))))
-           
-
-
-
-;;;;;;;;;;;;;;
-;;
-;; OccurrenceC
-
-(elephant:defpclass OccurrenceC (CharacteristicC)
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform nil
-             :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")))
-
-
-(defgeneric OccurrenceC-p (object)
-  (:documentation "test if object is a of type OccurrenceC")
-  (:method ((object t)) nil)
-  (:method ((object OccurrenceC)) object))
-
-(defmethod find-all-equivalent ((construct OccurrenceC))
-  (let
-      ((parent (and (slot-boundp construct 'topic)
-                    (topic construct))))
-    (when parent
-      (delete-if-not  #'(lambda (cand) (strictly-equivalent-constructs construct cand))
-                      (slot-value parent 'occurrences)))))
-
-(defmethod equivalent-constructs ((occ1 OccurrenceC) (occ2 OccurrenceC))
-  "Occurrence items are equal if the values of their [value], [datatype], [scope], [type], and [parent] properties are equal (TMDM 5.6)"
-  (and
-   (string= (charvalue occ1) (charvalue occ2))
-   (not (set-exclusive-or (themes occ1) (themes occ2) :key #'internal-id))
-   (= (internal-id (topic occ1)) (internal-id (topic occ2)))
-   (or 
-    (and (instance-of-p occ1) (instance-of-p occ2)
-         (= 
-          (internal-id (instance-of occ1))
-          (internal-id (instance-of occ2))))
-    (and (not (instance-of-p occ1)) (not (instance-of-p occ2))))))
-
-
-;;;;;;;;;;;;;;;;;
-;;
-;; TopicC
-
-(elephant:defpclass TopicC (ReifiableConstructC)
-  ((topic-identifiers
-    :accessor topic-identifiers
-    :associate (TopicIdentificationC identified-construct))
-   (psis                                ;accessor written below
-    :associate (PersistentIdC identified-construct)
-    :documentation "list of PSI objects associated with this
-         topic")
-   (locators
-                                        ;accessor written below
-    :associate (SubjectLocatorC identified-construct)
-    :documentation "an optional URL that (if given) means that this topic is a subject locator")
-   (names                               ;accessor written below
-    :associate (NameC topic)
-    :documentation "list of topic names (as TopicC objects)") 
-   (occurrences         ;accessor occurrences explicitly written below
-    :associate (OccurrenceC topic)
-    :documentation "list of occurrences (as OccurrenceC objects)")
-   (player-in-roles            ;accessor player-in-roles written below
-    :associate (RoleC player)
-    :documentation "the list of all role instances where this topic is a player in")
-   (used-as-type                  ;accessor used-as-type written below
-    :associate (TypableC instance-of)
-    :documentation "list of all constructs that have this topic as their type")
-   (used-as-theme                ;accessor used-as-theme written below
-    :associate (ScopableC themes)
-    :many-to-many t
-    :documentation "list of all scopable objects this topic is a theme in")
-   (in-topicmaps
-    :associate (TopicMapC topics)
-    :many-to-many t
-    :documentation "list of all topic maps this topic is part of")
-   (reified
-    :associate ReifiableConstructC
-    :documentation "contains a reified object, represented as 1:1 association"))
-  (:documentation "Topic in a Topic Map"))
-
-
-(defgeneric reified (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (when (slot-boundp topic 'reified)
-      (slot-value topic 'reified))))
-
-(defgeneric (setf reified) (reifiable ReifiableConstructC)
-  (:method (reifiable (topic TopicC))
-    (setf (slot-value topic 'reified) reifiable)))
-;    (setf (reifier reifiable) topic)))
-
-(defgeneric occurrences (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision topic 'occurrences :start-revision revision)))
-
-(defgeneric names (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision topic 'names :start-revision revision)))
-
-(defgeneric psis (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision 
-     topic 'psis :start-revision revision)))
-
-(defgeneric locators (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision 
-     topic 'locators :start-revision revision)))
-
-(defgeneric player-in-roles (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision 
-     topic 'player-in-roles :start-revision revision)))
-
-(defgeneric used-as-type (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision topic 'used-as-type :start-revision revision)))
-
-(defgeneric used-as-theme (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision)))
-
-(defgeneric in-topicmaps (topic &key revision)
-  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-    (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)))
-
-(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers))
-  "Moves all identifiers from the source-topic to the destination topic."
-  (declare (TopicC destination-topic source-topic))
-  (let ((all-source-identifiers
-	 (cond
-	   ((eql what 'item-identifiers)
-	    (item-identifiers source-topic))
-	   ((eql what 'locators)
-	    (locators source-topic))
-	   (t
-	    (psis source-topic))))
-	(all-destination-identifiers
-	 (cond
-	   ((eql what 'item-identifiers)
-	    (item-identifiers destination-topic))
-	   ((eql what 'locators)
-	    (locators destination-topic))
-	   ((eql what 'psis)
-	    (psis destination-topic))
-	   ((eql what 'topic-identifiers)
-	    (topic-identifiers destination-topic)))))
-    (let ((identifiers-to-move
-	   (loop for id in all-source-identifiers
-	      when (not (find-if #'(lambda(x)
-				     (if (eql what 'topic-identifiers)
-					 (string= (xtm-id x) (xtm-id id))
-					 (string= (uri x) (uri id))))
-				 all-destination-identifiers))
-	      collect id)))
-      (dolist (item identifiers-to-move)
-	(remove-association source-topic what item)
-	(add-association destination-topic what item)))))
-
-(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil))
-  "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators"
-  (declare (list psis))
-  (declare (list locators))
-  (call-next-method)
-  ;item-identifiers are handled in the around-method for ReifiableConstructs,
-  ;TopicIdentificationCs are handled in make-construct of TopicC
-  (dolist (persistent-id psis)
-    (declare (PersistentIdC persistent-id))
-    (setf (identified-construct persistent-id) instance))
-  (dolist (subject-locator locators)
-    (declare (SubjectLocatorC subject-locator))
-    (setf (identified-construct subject-locator) instance))
-  (when reified
-    (setf (reified instance) reified)))
-
-
-(defmethod delete-construct :before ((construct TopicC))
-  (dolist (dependent (append (topic-identifiers construct)
-                             (psis construct)
-                             (locators construct)
-                             (names construct)
-                             (occurrences construct)
-                             (player-in-roles construct)
-                             (used-as-type construct)))
-    (delete-construct dependent))
-  (dolist (theme (used-as-theme construct))
-    (elephant:remove-association construct 'used-as-theme theme))
-  (dolist (tm (in-topicmaps construct))
-    (elephant:remove-association construct 'in-topicmaps tm))
-  (when (reified construct)
-    (slot-makunbound (reified construct) 'reifier)))
-  
-(defun get-all-constructs-by-uri (uri)
-  (delete 
-   nil
-   (mapcar 
-    (lambda (identifier)
-      (and
-       (slot-boundp identifier 'identified-construct)
-       (identified-construct identifier)))
-    (union
-     (union
-      (elephant:get-instances-by-value 'ItemIdentifierC 'uri uri)
-      (elephant:get-instances-by-value 'PersistentIdC 'uri uri))
-     (elephant:get-instances-by-value 'SubjectLocatorC 'uri uri)))))
-
-
-(defun find-existing-topic (item-identifiers locators psis)
-  (let
-      ((uris 
-        (mapcar #'uri 
-               (union (union item-identifiers locators) psis)))
-       (existing-topics nil))
-    (dolist (uri uris)
-      (setf existing-topics
-            (nunion existing-topics
-                    (get-all-constructs-by-uri uri)
-                    :key #'internal-id)))
-    (assert (<= (length existing-topics) 1))
-    (first existing-topics)))
-
-
-(defmethod make-construct ((class-symbol (eql 'TopicC)) &rest args
-                           &key start-revision item-identifiers locators psis topicid xtm-id)
-  (let
-      ((existing-topic 
-        (find-existing-topic item-identifiers locators psis)))
-    (if existing-topic
-        (progn
-          ;our problem with topics is that we know only after the
-          ;addition of all the identifiers and characteristics if
-          ;anything has changed. We can't decide that here, so we must
-          ;add all revisions (real or imaginary) to version history
-          ;and decide the rest in changed-p. Maybe somebody can think
-          ;of a better way?
-          (add-to-version-history existing-topic
-                                  :start-revision start-revision)
-          (init-topic-identification existing-topic topicid xtm-id
-                                     :revision start-revision)
-          (let*                 ;add new identifiers to existing topics
-              ((all-new-identifiers 
-                (union (union item-identifiers locators) psis))
-               (all-existing-identifiers 
-                (get-all-identifiers-of-construct existing-topic)))
-            (mapc
-             (lambda (identifier)
-               (setf (identified-construct identifier) existing-topic))
-             (set-difference all-new-identifiers all-existing-identifiers
-                             :key #'uri :test #'string=))
-            (mapc #'delete-construct 
-                  (delete-if
-                   (lambda (identifier) 
-                     (slot-boundp identifier 'identified-construct))
-                   all-new-identifiers)))
-          (check-for-duplicate-identifiers existing-topic)
-          existing-topic)
-        (progn
-          (let*
-              ((cleaned-args (remove-nil-values args))
-               (new-topic 
-                (apply #'make-instance 'TopicC cleaned-args)))
-            
-            (init-topic-identification new-topic topicid xtm-id 
-                                       :revision start-revision)
-            (check-for-duplicate-identifiers new-topic)
-            (add-to-version-history new-topic
-                                    :start-revision start-revision)
-            new-topic)))))
-
-(defmethod make-construct :around ((class-symbol (eql 'TopicC))
-                                   &key start-revision &allow-other-keys)
-  (declare (ignorable start-revision))
-  (call-next-method))
-
-    
-(defmethod equivalent-constructs ((topic1 TopicC) (topic2 TopicC))
-  "TMDM, 5.3.5: Equality rule: Two topic items are equal if they have:
-
-* at least one equal string in their [subject identifiers] properties,
-
-* at least one equal string in their [item identifiers] properties,
-
-* at least one equal string in their [subject locators] properties,
-
-* an equal string in the [subject identifiers] property of the one
-topic item and the [item identifiers] property of the other, or the
-same information item in their [reified] properties (TODO: this rule
-is currently ignored)" 
-  ;(declare (optimize (debug 3)))
-  (let
-      ((psi-uris1
-        (map 'list #'uri (psis topic1)))
-       (psi-uris2
-        (map 'list #'uri (psis topic2)))
-       (ii-uris1
-        (map 'list #'uri (item-identifiers topic1)))
-       (ii-uris2
-        (map 'list #'uri (item-identifiers topic2)))
-       (locators1
-        (map 'list #'uri (locators topic1)))
-       (locators2
-        (map 'list #'uri (locators topic2))))
-    (let
-        ((all-uris1
-          (union psi-uris1 (union ii-uris1 locators1) :test #'string=))
-         (all-uris2
-          (union psi-uris2 (union ii-uris2 locators2) :test #'string=)))
-      ;;TODO: consider what we should do about this. If the topic at a
-      ;;given revision doesn't exist yet, it correctly has no uris
-      ;;(for that version)
-      ;; (when (= 0 (length all-uris1))
-;;         (error (make-condition 'no-identifier-error :message "Topic1 has no identifier" :internal-id (internal-id topic1))))
-;;       (when (= 0 (length all-uris2))
-;;         (error (make-condition 'no-identifier-error :message "Topic2 has no identifier" :internal-id (internal-id topic2))))
-      (intersection
-       all-uris1 all-uris2
-       :test #'string=))))
-    
-(defmethod get-all-identifiers-of-construct ((top TopicC))
-  (append (psis top)
-          (locators top)
-          (item-identifiers top)))
-
-  
-(defmethod topicid ((top TopicC) &optional (xtm-id nil))
-  "Return the primary id of this item (= essentially the OID). If
-xtm-id is explicitly given, return one of the topicids in that
-TM (which must then exist)"
-  (if xtm-id
-      (let 
-          ((possible-identifications
-            (remove-if-not
-             (lambda (top-id)
-               (string= (xtm-id top-id) xtm-id))
-             (elephant:get-instances-by-value 
-              'TopicIdentificationC
-              'identified-construct
-              top))))
-        (unless possible-identifications
-          (error (make-condition 
-                  'object-not-found-error
-                  :message 
-                  (format nil "Could not find an object ~a in xtm-id ~a" top xtm-id))))
-        (uri (first possible-identifications)))
-      (format nil "t~a"
-              (internal-id top))))
-  
-
-(defgeneric psis-p (top)
-  (:documentation "Test for the existence of PSIs")
-  (:method ((top TopicC)) (slot-predicate top 'psis)))
-
-(defgeneric list-instanceOf (topic &key tm)
- (:documentation "Generate a list of all topics that this topic is an
-  instance of, optionally filtered by a topic map"))
-
-(defmethod list-instanceOf ((topic TopicC)  &key (tm nil))
-  (remove-if 
-   #'null
-   (map 'list #'(lambda(x)
-                  (when (loop for psi in (psis (instance-of x))
-                           when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance")
-                           return t)
-                    (loop for role in (roles (parent x))
-                       when (not (eq role x))
-                       return (player role))))
-        (if tm
-            (remove-if-not 
-             (lambda (role)
-               ;(format t "player: ~a" (player role))
-               ;(format t "parent: ~a" (parent role))
-               ;(format t "topic: ~a~&" topic)
-               (in-topicmap tm (parent role)))
-             (player-in-roles topic))
-            (player-in-roles topic)))))
-
-
-(defgeneric list-super-types (topic &key tm)
- (:documentation "Generate a list of all topics that this topic is an
-  subclass of, optionally filtered by a topic map"))
-
-
-(defmethod list-super-types ((topic TopicC)  &key (tm nil))
-  (remove-if 
-   #'null
-   (map 'list #'(lambda(x)
-                  (when (loop for psi in (psis (instance-of x))
-                           when (string= (uri psi) *subtype-psi*)
-                           return t)
-                    (loop for role in (roles (parent x))
-                       when (not (eq role x))
-                       return (player role))))
-        (if tm
-            (remove-if-not 
-             (lambda (role)
-               (format t "player: ~a" (player role))
-               (format t "parent: ~a" (parent role))
-               (format t "topic: ~a~&" topic)
-               (in-topicmap tm (parent role)))
-             (player-in-roles topic))
-            (player-in-roles topic)))))
-
-
-(defun string-starts-with (str prefix)
-  "Checks if string str starts with a given prefix"
-  (declare (string str prefix))
-  (string= str prefix :start1 0 :end1
-           (min (length prefix)
-                (length str))))
-
-
-(defun get-item-by-item-identifier (uri &key revision)
-  "get a construct by its item identifier. Returns nil if the item does not exist in a
-particular revision"
-  (declare (string uri))
-  (declare (integer revision))
-  (let
-      ((ii-obj 
-        (elephant:get-instance-by-value 'ItemIdentifierC
-                                        'uri uri)))
-    (when ii-obj
-      (find-item-by-revision 
-       (identified-construct ii-obj) revision))))
-
-
-(defun get-item-by-psi (psi &key (revision 0))
-  "get a topic by its PSI. Returns nil if the item does not exist in a
-particular revision"
-  (declare (string psi))
-  (declare (integer revision))
-  (let
-      ((psi-obj 
-        (elephant:get-instance-by-value 'PersistentIdC
-                                        'uri psi)))
-    (when psi-obj
-      (find-item-by-revision 
-       (identified-construct psi-obj) revision))))
-
-(defun get-item-by-id (topicid &key (xtm-id *current-xtm*) (revision 0) (error-if-nil nil))
-  "get a topic by its id, assuming a xtm-id. If xtm-id is empty, the current TM
-is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
-applicable in the correct revision. If revison is provided, then the code checks
-if the topic already existed in this revision and returns nil otherwise.
-If no item meeting the constraints was found, then the return value is either
-NIL or an error is thrown, depending on error-if-nil."
-  (declare (integer revision))
-  (let
-      ((result 
-        (if xtm-id
-            (let
-                ((possible-items
-                  (delete-if-not
-                   (lambda (top-id)
-                     (and
-                      (string= (xtm-id top-id) xtm-id)
-                      (string= (uri top-id) topicid))) ;fixes a bug in
-                                                       ;get-instances-by-value
-                                                       ;that does a
-                                                       ;case-insensitive
-                                                       ;comparision
-                   (elephant:get-instances-by-value 
-                    'TopicIdentificationC
-                    'uri
-                    topicid))))
-              (when (and possible-items
-                         (identified-construct-p (first possible-items)))
-                (unless (= (length possible-items) 1)
-                  (error (make-condition 'duplicate-identifier-error 
-                                         :message 
-                                         (format nil "(length possible-items ~a) for id ~a und xtm-id ~a > 1" possible-items topicid xtm-id)
-                                         :uri topicid)))
-                (let
-                    ((found-topic 
-                      (identified-construct (first possible-items))))
-                  (if (= revision 0)
-                      found-topic 
-                      (find-item-by-revision found-topic revision)))))
-            (make-instance 'TopicC :from-oid (subseq topicid 1)))))
-    (if (and error-if-nil (not result))
-        (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision))
-        result)))
-
-      
-;;;;;;;;;;;;;;;;;;
-;;
-;; RoleC
-
-(elephant:defpclass RoleC (ReifiableConstructC TypableC)
-  ((parent :accessor parent
-           :initarg :parent
-           :associate AssociationC
-           :documentation "Association that this role belongs to")
-   (player :accessor player
-           :initarg :player
-           :associate TopicC
-           :documentation "references the topic that is the player in this role"))
-  (:documentation "The role that this topic plays in an association (formerly member)"))
-
-
-
-(defgeneric RoleC-p (object)
-  (:documentation "test if object is a of type RoleC")
-  (:method ((object t)) nil)
-  (:method ((object RoleC)) object))
-
-
-(defgeneric parent-p (vi)
-  (:documentation "t if this construct has a parent construct")
-  (:method ((constr RoleC)) (slot-predicate constr 'parent)))
-
-
-(defmethod delete-construct :before ((construct RoleC))
-                                        ;the way we use roles, we cannot just delete the parent association
-                                        ;(at least the second role won't have one left then and will
-                                        ;complain)
-  (delete-1-n-association construct 'parent)
-  (delete-1-n-association construct 'player))
-
-(defmethod find-all-equivalent ((construct RoleC))
-  (let
-      ((parent (and (slot-boundp construct 'parent)
-                    (parent construct))))
-    (when parent
-      (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand))
-                     (slot-value parent 'roles)))))
-
-
-(defmethod equivalent-constructs ((role1 RoleC) (role2 RoleC))
-  "Association role items are equal if the values of their [type], [player], and [parent] properties are equal (TMDM 5.8)"
-                                        ;for the purposes for which we use this method (namely the
-                                        ;construction of associations), roles will initially always be
-                                        ;unequal regarding their parent properties
-  (and
-   (= (internal-id (instance-of role1)) (internal-id (instance-of role2)))
-   (= (internal-id (player role1)) (internal-id (player role2)))))
-
-
-;;;;;;;;;;;;;;;;;;
-;;
-;; AssociationC
-
-(elephant:defpclass AssociationC (ReifiableConstructC ScopableC TypableC)
-  ((roles :accessor roles
-          :associate (RoleC parent)
-          :documentation "(non-empty) list of this association's roles")
-   (in-topicmaps
-    :associate (TopicMapC associations)
-    :many-to-many t
-    :documentation "list of all topic maps this association is part of"))
-  (:documentation "Association in a Topic Map")
-  (:index t))
-
-
-(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
-  (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
-
-
-(defgeneric AssociationC-p (object)
-  (:documentation "test if object is a of type AssociationC")
-  (:method ((object t)) nil)
-  (:method ((object AssociationC)) object))
-
-
-(defmethod initialize-instance :around ((instance AssociationC) 
-                                        &key 
-                                        (roles nil))
-  "implements the pseudo-initarg :roles"
-  (declare (list roles))
-  (let
-      ((association (call-next-method)))  
-    (dolist (role-data roles)
-      (make-instance 
-       'RoleC 
-       :instance-of (getf role-data :instance-of)
-       :player (getf role-data :player)
-       :item-identifiers (getf role-data :item-identifiers)
-       :reifier (getf role-data :reifier)
-       :parent association))))
-
-(defmethod make-construct :around ((class-symbol (eql 'AssociationC))
-                                   &key 
-                                   start-revision 
-                                   &allow-other-keys)
-  (declare (ignorable start-revision))
-  (let
-      ((association
-        (call-next-method)))
-    (declare (AssociationC association))
-    (dolist (role (slot-value association 'roles))
-      (unless (versions role)
-        (add-to-version-history role
-                                :start-revision start-revision)))
-    association))
-
-(defmethod copy-item-identifiers :around
-    ((from-construct AssociationC)
-     (to-construct AssociationC))
-  "Internal method to copy over item idenfiers from one association
-with its roles to another one. Role identifiers are also
-copied. Returns nil if neither association nor role identifiers had to be copied"
-  (let
-      ((item-identifiers-copied-p nil)) ;rather brutal solution. find a better one
-    (when (call-next-method)
-      (setf item-identifiers-copied-p t))
-    (do ((from-roles (roles from-construct) (rest from-roles))
-         (to-roles (roles to-construct) (rest to-roles)))
-        ((null from-roles) 'finished)
-      (let
-          ((from-role (first from-roles))
-           (to-role (first to-roles)))
-        (when
-            (mapc
-             (lambda (identifier)
-               (setf (identified-construct identifier) 
-                     to-role))
-             (set-difference (item-identifiers from-role)
-                             (item-identifiers to-role)
-                             :key #'uri :test #'string=))
-          (setf item-identifiers-copied-p t))))
-  item-identifiers-copied-p))
-
-(defmethod delete-construct :before ((construct AssociationC))
-  (dolist (role (roles construct))
-    (delete-construct role))
-  (dolist (tm (in-topicmaps construct))
-    (elephant:remove-association construct 'in-topicmaps tm)))
-
-(defmethod find-all-equivalent ((construct AssociationC))
-  (let
-      ((some-player (player (or
-                             (second (roles construct))
-                             (first (roles construct)))))) ;; dirty, dirty... but brings a tenfold speedup!
-    (delete-if-not  
-     #'(lambda (cand) 
-         (unless (eq construct cand)
-           (equivalent-constructs construct cand)))
-                                        ;here we need to use the "internal" API and access the players
-                                        ;with slot-value (otherwise we won't be able to merge with
-                                        ;'deleted' associations)
-     (mapcar #'parent (slot-value some-player 'player-in-roles)))))
-
-
-(defmethod equivalent-constructs ((assoc1 AssociationC) (assoc2 AssociationC))
-  "Association items are equal if the values of their [scope], [type], and [roles] properties are equal (TMDM 5.7)"
-  (and
-   (= (internal-id (instance-of assoc1)) (internal-id (instance-of assoc2)))
-   (not (set-exclusive-or (themes assoc1) (themes assoc2) 
-                          :key #'internal-id))
-   (not (set-exclusive-or
-         (roles assoc1)
-         (roles assoc2)
-         :test  #'equivalent-constructs))))
-
-
-(elephant:defpclass TopicMapC (ReifiableConstructC)
-  ((topics :accessor topics
-          :associate (TopicC in-topicmaps)
-          :documentation "list of topics that explicitly belong to this TM")
-   (associations :accessor associations
-                 :associate (AssociationC in-topicmaps)
-                 :documentation "list of associations that belong to this TM"))
-  (:documentation "Topic Map"))
-
-(defmethod equivalent-constructs ((tm1 TopicMapC) (tm2 TopicMapC))
-  "Topic Map items are equal if one of their identifiers is equal"
-  ;Note: TMDM does not make any statement to this effect, but it's the
-  ;one logical assumption
-  (intersection
-   (item-identifiers tm1)
-   (item-identifiers tm2)
-   :test  #'equivalent-constructs))
-
-(defmethod find-all-equivalent ((construct TopicMapC))
-  (let 
-      ((tms (elephant:get-instances-by-class 'd:TopicMapC)))
-    (delete-if-not 
-     (lambda(tm)
-         (strictly-equivalent-constructs construct tm))
-     tms)))
-
-(defgeneric add-to-topicmap (tm top)
-  (:documentation "add a topic or an association to a topic
-  map. Return the added construct"))
-
-(defmethod add-to-topicmap ((tm TopicMapC) (top TopicC))
-  ;TODO: add logic not to add pure topic stubs unless they don't exist yet in the store
-;  (elephant:add-association tm 'topics top) ;by adding the elephant association in this order, there will be missing one site of this association
-  (elephant:add-association top 'in-topicmaps tm)
-  top)
-
-(defmethod add-to-topicmap ((tm TopicMapC) (ass AssociationC))
-   ;(elephant:add-association tm 'associations ass)
-  (elephant:add-association ass 'in-topicmaps tm)
-  ass)
-
-(defgeneric in-topicmap (tm constr &key revision)
-  (:documentation "Is a given construct (topic or assiciation) in this topic map?"))
-
-(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0))
-  (when (find-item-by-revision top revision)
-    (find (d:internal-id top) (d:topics tm) :test #'= :key #'d:internal-id)))
-
-
-(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
-  (when (find-item-by-revision ass revision)
-    (find (d:internal-id ass) (d:associations tm)  :test #'= :key #'d:internal-id)))
-
-;;;;;;;;;;;;;;;;;
-;; reification
-
-(defgeneric add-reifier (construct reifier-topic)
-  (:method ((construct ReifiableConstructC) reifier-topic)
-    (let ((err "From add-reifier(): "))
-      (declare (TopicC reifier-topic))
-      (cond
-	((and (not (reifier construct))
-	      (not (reified reifier-topic)))
-	 (setf (reifier construct) reifier-topic)
-	 (setf (reified reifier-topic) construct))
-	((and (not (reified reifier-topic))
-	      (reifier construct))
-	 (merge-reifier-topics (reifier construct) reifier-topic))
-	((and (not (reifier construct))
-	      (reified reifier-topic))
-	 (error "~a~a ~a reifies already another object ~a"
-		err (psis reifier-topic) (item-identifiers reifier-topic)
-		(reified reifier-topic)))
-	(t
-	 (when (not (eql (reified reifier-topic) construct))
-	   (error "~a~a ~a reifies already another object ~a"
-		  err (psis reifier-topic) (item-identifiers reifier-topic)
-		  (reified reifier-topic)))
-	 (merge-reifier-topics (reifier construct) reifier-topic)))
-      construct)))
-
-
-(defgeneric remove-reifier (construct)
-  (:method ((construct ReifiableConstructC))
-    (let ((reifier-topic (reifier construct)))
-      (when reifier-topic
-	(elephant:remove-association construct 'reifier reifier-topic)
-	(elephant:remove-association reifier-topic 'reified construct)))))
-
-
-(defgeneric merge-reifier-topics (old-topic new-topic)
-  ;;the reifier topics are not only merged but also bound to the reified-construct
-  (:method ((old-topic TopicC) (new-topic TopicC))
-    (unless (eql old-topic new-topic)
-      ;merges all identifiers
-      (move-identifiers old-topic new-topic)
-      (move-identifiers old-topic new-topic :what 'locators)
-      (move-identifiers old-topic new-topic :what 'psis)
-      (move-identifiers old-topic new-topic :what 'topic-identifiers)
-      ;merges all typed-object-associations
-      (dolist (typed-construct (used-as-type new-topic))
-	(remove-association typed-construct 'instance-of new-topic)
-	(add-association typed-construct 'instance-of old-topic))
-      ;merges all scope-object-associations
-      (dolist (scoped-construct (used-as-theme new-topic))
-	(remove-association scoped-construct 'themes new-topic)
-	(add-association scoped-construct 'themes old-topic))
-      ;merges all topic-maps
-      (dolist (tm (in-topicmaps new-topic))
-	(add-association tm 'topics old-topic)) ;the new-topic is removed from this tm by deleting it
-      ;merges all role-players
-      (dolist (a-role (player-in-roles new-topic))
-	(remove-association a-role 'player new-topic)
-	(add-association a-role 'player old-topic))
-      ;merges all names
-      (dolist (name (names new-topic))
-	(remove-association name 'topic new-topic)
-	(add-association name 'topic old-topic))
-      ;merges all occurrences
-      (dolist (occurrence (occurrences new-topic))
-	(remove-association occurrence 'topic new-topic)
-	(add-association occurrence 'topic old-topic))
-      ;merges all version-infos
-      (let ((versions-to-move
-	     (loop for vrs in (versions new-topic)
-		when (not (find-if #'(lambda(x)
-				       (and (= (start-revision x) (start-revision vrs))
-					    (= (end-revision x) (end-revision vrs))))
-				   (versions old-topic)))
-		collect vrs)))
-	(dolist (vrs versions-to-move)
-	  (remove-association vrs 'versioned-construct new-topic)
-	  (add-association vrs 'versioned-construct old-topic)))
-      (delete-construct new-topic))
-    ;TODO: order/repair all version-infos of the topic itself and add all new
-    ;      versions to the original existing objects of the topic
-    old-topic))
\ No newline at end of file
+;;           ;; functions and slot accessors
+;;           :in-topicmaps
+;;           :add-to-topicmap
+;;           :add-source-locator
+;;           :associations
+;;           :changed-p
+;;           :charvalue
+;;           :check-for-duplicate-identifiers
+;;           :datatype
+;;           :equivalent-constructs
+;;           :find-item-by-revision
+;;           :find-most-recent-revision
+;;           :get-all-revisions
+;;           :get-all-revisions-for-tm
+;;           :get-fragment
+;;           :get-fragments
+;;           :get-revision
+;;           :get-item-by-content
+;;           :get-item-by-id
+;;           :get-item-by-item-identifier
+;;           :get-item-by-psi
+;;           :identified-construct
+;;           :identified-construct-p
+;;           :in-topicmap
+;;           :internal-id
+;;           :instance-of
+;;           :instance-of-p
+;;           :item-identifiers
+;;           :item-identifiers-p
+;;           :list-instanceOf
+;;	   :list-super-types
+;;           :locators
+;;           :locators-p
+;;           :make-construct
+;;           :mark-as-deleted
+;;           :names
+;;           :namevalue
+;;           :occurrences
+;;	   :name
+;;           :parent
+;;           :player
+;;           :player-in-roles
+;;           :players
+;;           :psis
+;;           :psis-p
+;;           :referenced-topics
+;;           :revision
+;;           :RoleC-p
+;;           :roleid
+;;           :roles
+;;           :themes
+;;           :xtm-id
+;;           :xtm-id-p
+;;           :topic
+;;           :topicid
+;;           :topic-identifiers
+;;           :topics
+;;           :unique-id
+;;	   :uri 
+;;	   :uri-p
+;;	   :used-as-type
+;;	   :used-as-theme
+;;	   :variants
+;;	   :xor
+;;           :create-latest-fragment-of-topic
+;;	   :reified
+;;	   :reifier
+;;	   :add-reifier
+;;	   :remove-reifier
+;;
+;;           :*current-xtm* ;; special variables
+;;           :*TM-REVISION*
+;;
+;;           :with-revision ;;macros
+;;
+;;	   :string-starts-with ;;helpers
+;;           ))
+;;
+;;(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))
+;;(in-package :datamodel)
+;;
+;;(defparameter *current-xtm* nil "Represents the currently active TM")
+;;
+;;(defmacro find-max-elem (candidate-list &key (relop #'> relop-p) (key #'identity key-p))
+;;  "Given a non-empty list, return the maximum element in the list.
+;;   If provided, then relop must be a relational operator that determines the ordering;
+;;   else #'> is used. The keyword parameter key may name a function that is used to extract
+;;   the sort key; otherwise the elements themselves are the sort keys."
+;;  (let
+;;      ((candidate-list-value-name (gensym))
+;;       (relop-value-name (gensym))
+;;       (key-value-name (gensym))
+;;       (best-seen-cand-name (gensym))
+;;       (max-key-name (gensym))
+;;       (inspected-cand-name (gensym))
+;;       (inspected-key-name (gensym)))
+;;    (let
+;;        ((max-key-init (if key-p
+;;                           `(funcall ,key-value-name ,best-seen-cand-name)
+;;                           best-seen-cand-name))
+;;         (inspected-key-init (if key-p
+;;                                 `(funcall ,key-value-name ,inspected-cand-name)
+;;                                 inspected-cand-name))
+;;         (relexp (if relop-p
+;;                     `(funcall ,relop-value-name ,inspected-key-name ,max-key-name)
+;;                     `(> ,inspected-key-name ,max-key-name))))
+;;      (let
+;;          ((initializers `((,candidate-list-value-name ,candidate-list)
+;;                           (,best-seen-cand-name (first ,candidate-list-value-name))
+;;                           (,max-key-name ,max-key-init))))
+;;        (when relop-p
+;;          (push `(,relop-value-name ,relop) initializers))
+;;        (when key-p
+;;          (push `(,key-value-name ,key) initializers))
+;;        `(let*
+;;          ,initializers
+;;          (dolist (,inspected-cand-name (rest ,candidate-list-value-name))
+;;            (let
+;;                ((,inspected-key-name ,inspected-key-init))
+;;              (when ,relexp
+;;                (setf ,best-seen-cand-name ,inspected-cand-name)
+;;                (setf ,max-key-name ,inspected-key-name))))
+;;          ,best-seen-cand-name)))))
+;;
+;;(defvar *TM-REVISION* 0)
+;;
+;;(defmacro with-revision (revision &rest body)
+;;  `(let
+;;    ((*TM-REVISION* ,revision))
+;;                                        ;(format t "*TM-REVISION* is ~a~&" *TM-REVISION*)
+;;    , at body))
+;;    
+;;
+;;(defmacro slot-predicate (instance slot)
+;;  (let
+;;      ((inst-name (gensym))
+;;       (slot-name (gensym)))
+;;    `(let
+;;      ((,inst-name ,instance)
+;;       (,slot-name ,slot))
+;;      (and (slot-boundp ,inst-name ,slot-name)
+;;       (slot-value ,inst-name ,slot-name)))))
+;;
+;;(defmacro delete-1-n-association (instance slot)
+;;  (let
+;;      ((inst-name (gensym))
+;;       (slot-name (gensym)))
+;;    `(let
+;;      ((,inst-name ,instance)
+;;       (,slot-name ,slot))
+;;      (when (slot-predicate ,inst-name ,slot-name)
+;;        (elephant:remove-association ,inst-name ,slot-name (slot-value ,inst-name ,slot-name))))))
+;;
+;;(defun xor (a1 a2)
+;;  (and (or a1 a2) (not (and a1 a2)))
+;;  )
+;;
+;;(defun remove-nil-values (plist)
+;;  (let
+;;      ((result nil))
+;;    (do* ((rest plist (cddr rest))
+;;          (key (first rest) (first rest))
+;;          (val (second rest) (second rest)))
+;;         ((null rest))
+;;      (when val
+;;        (pushnew val result)
+;;        (pushnew key result)))
+;;    result))
+;;
+;;(defun get-revision ()
+;;  "TODO: replace by something that does not suffer from a 1 second resolution."
+;;  (get-universal-time))
+;;
+;;(defgeneric delete-construct (construct)
+;;  (:documentation "drops recursively construct and all its dependent objects from the elephant store"))
+;;
+;;(defmethod delete-construct ((construct elephant:persistent))
+;;  nil)
+;;
+;;(defmethod delete-construct :after ((construct elephant:persistent))
+;;  (elephant:drop-instance construct))
+;;
+;;(defgeneric find-all-equivalent (construct)
+;;  (:method ((construct t)) nil)
+;;  (:documentation "searches an existing object that is equivalent (but not identical) to construct"))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; VersionInfoC
+;;
+;;
+;;(elephant:defpclass VersionInfoC ()
+;;  ((start-revision :accessor start-revision
+;;                   :initarg :start-revision
+;;                   :type integer
+;;                   :initform 0          ;TODO: for now
+;;                   :documentation "The first revison this AssociationC instance is associated with.")
+;;   (end-revision :accessor end-revision
+;;                 :initarg :end-revision
+;;                 :type integer
+;;                 :initform 0            ;TODO: for now
+;;                 :documentation "The first revison this AssociationC instance is no longer associated with.")
+;;   (versioned-construct :associate TopicMapConstructC
+;;                        :accessor versioned-construct
+;;                        :initarg :versioned-construct
+;;                        :documentation "reifiable construct that is described by this info"))
+;;  (:documentation "Version Info for individual revisions"))
+;;
+;;(defgeneric versioned-construct-p (vi)
+;;  (:documentation "t if this version info is already bound to a TM construct")
+;;  (:method ((vi VersionInfoC)) (slot-predicate vi 'versioned-construct)))
+;;
+;;(defmethod delete-construct :before ((vi VersionInfoC))
+;;  (delete-1-n-association vi 'versioned-construct))
+;;
+;;(defgeneric get-most-recent-version-info (construct))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; ItemIdentifierC
+;;
+;;(elephant:defpclass ItemIdentifierC (IdentifierC) 
+;;  ()
+;;  (:index t)
+;;  (:documentation "Represents an item identifier"))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; SubjectLocator
+;;
+;;(elephant:defpclass SubjectLocatorC (IdentifierC)
+;;  ((identified-construct :accessor identified-construct
+;;                         :initarg :identified-construct
+;;                         :associate TopicC))
+;;  (:index t)
+;;  (:documentation "Represents a subject locator"))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; IdentifierC
+;;
+;;(elephant:defpclass IdentifierC (PointerC)
+;;  ()
+;;  (:documentation "Abstract base class for ItemIdentifierC and
+;;  PersistentIdC, primarily in view of the equality rules"))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; PointerC
+;;
+;;(elephant:defpclass PointerC (TopicMapConstructC)
+;;  ((uri :accessor uri
+;;        :initarg :uri
+;;        :type string
+;;        :initform (error "The uri must be set for a pointer")
+;;        :index t)
+;;   (identified-construct :accessor identified-construct
+;;                         :initarg :identified-construct
+;;                         :associate ReifiableConstructC))
+;;  (:documentation "Abstract base class for all types of pointers and identifiers"))
+;;
+;;(defmethod delete-construct :before ((construct PointerC))
+;;  (delete-1-n-association construct 'identified-construct))
+;;
+;;(defmethod find-all-equivalent ((construct PointerC))
+;;  (delete construct
+;;          (elephant:get-instances-by-value (class-of construct)
+;;                                           'uri
+;;                                           (uri construct))
+;;          :key #'internal-id))
+;;(defgeneric uri-p (construct)
+;;  (:documentation "Check if the slot uri is bound in an identifier and not nil")
+;;  (:method ((identifier PointerC)) (slot-predicate identifier 'uri)))
+;;
+;;(defgeneric identified-construct-p (construct)
+;;  (:documentation "Check if the slot identified-construct is bound in an identifier and not nil")
+;;  (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct)))
+;;
+;;(defmethod print-object ((identifier PointerC) stream)
+;;  (format stream 
+;;          "~a(href: ~a; Construct: ~a)"
+;;          (class-name (class-of identifier))
+;;          (if (uri-p identifier)
+;;              (uri identifier)
+;;              "URI UNDEFINED")
+;;          (if (identified-construct-p identifier)
+;;              (identified-construct identifier) 
+;;              "SLOT UNBOUND")))
+;;
+;;(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC))
+;;  (string= (uri identifier1) (uri identifier2)))
+;;
+;;(defmethod initialize-instance :around ((identifier PointerC) &key
+;;                                        (start-revision (error "Start revision must be present") )
+;;                                        (end-revision 0))
+;;  (call-next-method)
+;;  (add-to-version-history identifier
+;;                          :start-revision start-revision
+;;                          :end-revision end-revision)
+;;  identifier)
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; TopicMapConstrucC
+;;
+;;
+;;(elephant:defpclass TopicMapConstructC ()
+;;  ((versions :associate (VersionInfoC versioned-construct)
+;;             :accessor versions
+;;             :initarg :versions
+;;             :documentation "version infos for former versions of this reifiable construct")))
+;;
+;;                                        ;TODO: if, one day, we allow merges of already existing constructs, we'll need
+;;                                        ;a tree of predecessors rather then just a list of versions. A case in point
+;;                                        ;may be if a newly imported topic carries the PSIs of two existing topics,
+;;                                        ;thereby forcing a merge post factum"
+;;
+;;(defmethod delete-construct :before ((construct TopicMapConstructC))
+;;  (dolist (versioninfo (versions construct))
+;;    (delete-construct versioninfo)))
+;;
+;;
+;;(defgeneric add-to-version-history (construct &key start-revision end-revision)
+;;  (:documentation "Add version history to a topic map construct"))
+;;
+;;(defmethod add-to-version-history ((construct TopicMapConstructC) 
+;;                                   &key 
+;;                                   (start-revision (error "Start revision must be present") )
+;;                                   (end-revision 0))
+;;  "Adds relevant information to a construct's version info"
+;;  (let
+;;      ((current-version-info
+;;        (get-most-recent-version-info construct)))
+;;    (cond
+;;      ((and current-version-info 
+;;           (= (end-revision current-version-info) start-revision)) ;the item was just marked as deleted
+;;       (setf (end-revision current-version-info) 0) ;just revitalize it, do not create a new version
+;;       current-version-info)  ;TODO: this is not quite correct, the topic
+;;                              ;might be recreated with new item
+;;                              ;identifiers. Consider adding a new parameter
+;;                              ;"revitalize"
+;;      ((and 
+;;        current-version-info 
+;;        (= (end-revision current-version-info) 0))
+;;       (setf (end-revision current-version-info) start-revision)
+;;       (make-instance 
+;;        'VersionInfoC 
+;;        :start-revision start-revision
+;;        :end-revision end-revision
+;;        :versioned-construct construct))
+;;      (t
+;;       (make-instance 
+;;        'VersionInfoC 
+;;        :start-revision start-revision
+;;        :end-revision end-revision
+;;        :versioned-construct construct)))))
+;;
+;;(defgeneric revision (constr)
+;;  (:documentation "Essentially a convenience method for start-revision"))
+;;
+;;(defmethod revision ((constr TopicMapConstructC))
+;;  (start-revision constr))
+;;
+;;(defmethod (setf revision) ((constr TopicMapConstructC) (revision integer))
+;;  (setf (start-revision constr) revision))
+;;
+;;
+;;(defgeneric find-item-by-revision (constr revision)
+;;  (:documentation "Get a given version of a construct (if any, nil if none can be found)"))
+;;
+;;(defmethod find-item-by-revision ((constr TopicMapConstructC) (revision integer))
+;;  (cond
+;;    ((= revision 0)
+;;     (find-most-recent-revision constr))
+;;    (t
+;;     (when (find-if
+;;            (lambda(version) 
+;;              (and (>= revision (start-revision version))
+;;                   (or
+;;		    (< revision (end-revision version))
+;;		    (= 0 (end-revision version)))))
+;;            (versions constr))
+;;       constr))))
+;;
+;;(defgeneric find-most-recent-revision (construct)
+;;  (:documentation "Get the most recent version of a construct (nil if
+;;the construct doesn't have versions yet or not anymore)"))
+;;
+;;(defmethod find-most-recent-revision ((construct TopicMapConstructC))
+;;  (when (find 0 (versions construct) :key #'end-revision)
+;;    construct))
+;;
+;;(defmethod delete-construct :before ((construct TopicMapConstructC))
+;;  (dolist (versionInfo (versions construct))
+;;    (delete-construct versionInfo)))
+;;
+;;
+;;(defgeneric check-for-duplicate-identifiers (top)
+;;  (:documentation "Check for possibly duplicate identifiers and signal an
+;;  duplicate-identifier-error is such duplicates are found"))
+;;
+;;(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC))
+;;  (declare (ignore construct))
+;;                                        ;do nothing
+;;  )
+;;
+;;(defgeneric filter-slot-value-by-revision (construct slot-name &key start-revision)
+;;  (:documentation "filter slot values by a given revision that is
+;;  either provided directly through the keyword argument start-revision
+;;  or through a bound variable named '*TM-REVISION*'"))
+;;
+;;(defmethod filter-slot-value-by-revision ((construct TopicMapConstructC) (slot-name symbol) &key (start-revision 0 start-revision-provided-p))
+;;  (let
+;;      ((revision            ;avoids warnings about undefined variables
+;;        (cond
+;;          (start-revision-provided-p
+;;           start-revision)
+;;          ((boundp '*TM-REVISION*)
+;;           (symbol-value '*TM-REVISION*))
+;;          (t 0)))
+;;       (properties (slot-value construct slot-name)))
+;;       ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision)
+;;    (cond
+;;      ((not properties) 
+;;       nil)   ;if we don't have any properties, we don't have to worry
+;;              ;about revisions
+;;      ((= 0 revision)
+;;       (remove 
+;;        nil
+;;        (map 'list #'find-most-recent-revision
+;;             properties)))
+;;      (t
+;;       (remove nil
+;;               (map 'list 
+;;                    (lambda (constr)
+;;                      (find-item-by-revision constr revision))
+;;                    properties))))))
+;;
+;;(defgeneric make-construct (classsymbol &key start-revision &allow-other-keys)
+;;  (:documentation "create a new topic map construct if necessary or
+;;retrieve an equivalent one if available and update the revision
+;;history accordingly. Return the object in question. Methods use
+;;specific keyword arguments for their purpose"))
+;;
+;;(defmethod make-construct ((classsymbol symbol) &rest args
+;;                           &key start-revision)
+;;  (let*
+;;      ((cleaned-args (remove-nil-values args))
+;;       (new-construct (apply #'make-instance classsymbol cleaned-args))
+;;       (existing-construct (first (find-all-equivalent new-construct))))
+;;    (if existing-construct
+;;        (progn
+;;                                        ;change over new item identifiers to the old construct
+;;          (when  (copy-item-identifiers
+;;                  new-construct existing-construct)
+;;                 ;an existing construct other than a topic (which is handled
+;;                 ;separatedly below) has changed only if it has received a new
+;;                 ;item identifier
+;;            (add-to-version-history existing-construct :start-revision start-revision))
+;;          (delete-construct new-construct)
+;;          existing-construct)
+;;        (progn
+;;          (add-to-version-history new-construct :start-revision start-revision)
+;;          (check-for-duplicate-identifiers new-construct)
+;;          new-construct))))
+;;    
+;;(defmethod get-most-recent-version-info ((construct TopicMapConstructC))
+;;  (let ((result (find 0 (versions construct) :key #'end-revision)))
+;;    (if result
+;;	result ;current version-info -> end-revision = 0
+;;	(let ((sorted-list (sort (versions construct)
+;;				 #'(lambda(x y)
+;;				     (> (end-revision x) (end-revision y))))))
+;;	  (when sorted-list
+;;	    (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
+;;
+;;(defgeneric equivalent-constructs (construct1 construct2)
+;;  (:documentation "checks if two topic map constructs are equal according to the TMDM equality rules"))
+;;
+;;(defgeneric strictly-equivalent-constructs (construct1 construct2)
+;;  (:documentation "checks if two topic map constructs are not identical but equal according to the TMDM equality rules")
+;;  (:method ((construct1 TopicMapConstructC) (construct2 TopicMapConstructC))
+;;    (and (equivalent-constructs construct1 construct2)
+;;         (not (eq construct1 construct2)))))
+;;
+;;(defgeneric internal-id (construct)
+;;  (:documentation "returns the internal id that uniquely identifies a
+;;  construct (currently simply its OID)"))
+;;
+;;(defmethod internal-id ((construct TopicMapConstructC))
+;;  (slot-value construct (find-symbol "OID" 'elephant)))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; TopicIdentificationC
+;;
+;;(elephant:defpclass TopicIdentificationC (PointerC) 
+;;  ((xtm-id 
+;;    :accessor xtm-id
+;;    :type string
+;;    :initarg :xtm-id
+;;    :index t
+;;    :documentation "ID of the TM this identification came from"))
+;;  (:documentation "Identify topic items through generalized
+;;  topicids. A topic may have many original topicids, the class
+;;  representing one of them") )
+;;
+;;(defmethod find-all-equivalent ((construct TopicIdentificationC))
+;;  (delete (xtm-id construct) (call-next-method) :key #'xtm-id :test #'string=))
+;;
+;;(defun init-topic-identification (top id xtm-id &key (revision *TM-REVISION*))
+;;  "create a TopicIdentification object (if necessary) and initialize it with the
+;;  combination of the current topicid and the ID of the current XTM id"
+;;                                        ;(declare (TopicC top))
+;;  (declare (string id))
+;;
+;;  (flet    ;prevent unnecessary copies of TopicIdentificationC objects
+;;      ((has-topic-identifier (top uri xtm-id)
+;;         (remove-if-not
+;;          (lambda (ident)
+;;            (and (string= (uri ident) uri)
+;;                 (string= (xtm-id ident) xtm-id)))
+;;          (topic-identifiers top))))
+;;    (unless (has-topic-identifier top id xtm-id)
+;;      (let
+;;          ((ti
+;;            (make-instance 
+;;             'TopicIdentificationC
+;;             :uri id
+;;             :xtm-id xtm-id
+;;             :identified-construct top
+;;             :start-revision revision)))
+;;           ;(add-to-version-history ti :start-revision revision)
+;;           ti))))
+;;
+;;(defun xtm-id-p (xtm-id)
+;;  "checks if a xtm-id has been used before"
+;;  (elephant:get-instance-by-value 'TopicIdentificationC
+;;                                  'xtm-id xtm-id))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; PSI
+;;
+;;(elephant:defpclass PersistentIdC (IdentifierC) 
+;;  ((identified-construct :accessor identified-construct
+;;                         :initarg :identified-construct
+;;                         :associate TopicC))
+;;  (:index t)
+;;  (:documentation "Represents a PSI"))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; ReifiableConstructC
+;;
+;;(elephant:defpclass ReifiableConstructC (TopicMapConstructC)
+;;  ((item-identifiers 
+;;    :associate (ItemIdentifierC identified-construct)
+;;    :inherit t
+;;    :documentation "Slot that realizes a 1 to N
+;;                     relation between reifiable constructs and their
+;;                     identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")
+;;   (reifier
+;;    :associate TopicC
+;;    :inherit t
+;;    :documentation "Represents a reifier association to a topic, i.e.
+;;                   it stands for a 1:1 association between this class and TopicC"))
+;;  (:documentation "Reifiable constructs as per TMDM"))
+;;
+;;
+;;(defgeneric reifier (construct &key revision)
+;;  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+;;    (when (slot-boundp construct 'reifier)
+;;      (slot-value construct 'reifier))))
+;;
+;;(defgeneric (setf reifier) (topic TopicC)
+;;  (:method (topic (construct ReifiableConstructC))
+;;    (setf (slot-value construct 'reifier) topic)))
+;;;    (setf (reified topic) construct)))
+;;
+;;(defgeneric item-identifiers (construct &key revision)
+;;  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))
+;;
+;;(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil))
+;;  "adds associations to these ids after the instance was initialized."
+;;  (declare (list item-identifiers))
+;;  (call-next-method)
+;;  (dolist (id item-identifiers)
+;;    (declare (ItemIdentifierC id))
+;;    (setf (identified-construct id) instance))
+;;  (when reifier
+;;    (add-reifier instance reifier))
+;;    ;(setf (reifier instance) reifier))
+;;  instance)
+;;
+;;(defmethod delete-construct :before ((construct ReifiableConstructC))
+;;  (dolist (id (item-identifiers construct))
+;;    (delete-construct id))
+;;  (when (reifier construct)
+;;    (let ((reifier-topic (reifier construct)))
+;;      (remove-reifier construct)
+;;      (delete-construct reifier-topic))))
+;;
+;;(defgeneric item-identifiers-p (constr)
+;;  (:documentation "Test for the existence of item identifiers")
+;;  (:method ((construct ReifiableConstructC)) (slot-predicate construct 'item-identifiers)))
+;;
+;;(defgeneric topicid (construct &optional xtm-id)
+;;  (:documentation "Return the ID of a construct"))
+;;
+;;(defmethod revision ((constr ReifiableConstructC))
+;;  (start-revision constr))
+;;
+;;(defgeneric (setf revision) (revision construct)
+;;  (:documentation "The corresponding setter method"))
+;;
+;;(defmethod (setf revision) ((revision integer) (constr ReifiableConstructC))
+;;  (setf (start-revision constr) revision))
+;;
+;;(defgeneric get-all-identifiers-of-construct (construct)
+;;  (:documentation "Get all identifiers that a given construct has"))
+;;
+;;(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC))
+;;  (item-identifiers construct))
+;;
+;;(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC))
+;;  (dolist (id (get-all-identifiers-of-construct construct))
+;;    (when (> (length 
+;;              (union 
+;;               (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id))
+;;               (union 
+;;                (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
+;;                (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
+;;             1)
+;;      (error 
+;;       (make-condition 'duplicate-identifier-error 
+;;                       :message (format nil "Duplicate Identifier ~a has been found" (uri id))
+;;                       :uri (uri id))))))
+;;
+;;(defmethod copy-item-identifiers ((from-construct ReifiableConstructC)
+;;                                  (to-construct ReifiableConstructC))
+;;  "Internal method to copy over item idenfiers from a construct to
+;;another on. Returns the set of new identifiers"
+;;  (mapc
+;;   (lambda (identifier)
+;;     (setf (identified-construct identifier) 
+;;           to-construct))
+;;   (set-difference (item-identifiers from-construct)
+;;                   (item-identifiers to-construct)
+;;                   :key #'uri :test #'string=)))
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; ScopableC
+;;
+;;(elephant:defpclass ScopableC ()
+;;  ((themes :accessor themes
+;;           :associate (TopicC used-as-theme)
+;;           :inherit t
+;;           :many-to-many t
+;;           :documentation "list of this scope's themes; pseudo-initarg is :themes")))
+;;
+;;(defmethod initialize-instance :around ((instance ScopableC) &key (themes nil))
+;;  (declare (list themes))
+;;  (call-next-method)
+;;  (dolist (theme themes)
+;;    (elephant:add-association instance 'themes theme))
+;;  instance)
+;;
+;;(defmethod delete-construct :before ((construct ScopableC))
+;;  (dolist (theme (themes construct))
+;;    (elephant:remove-association construct 'themes theme)))
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; TypableC
+;;
+;;(elephant:defpclass TypableC ()
+;;  ((instance-of :accessor instance-of
+;;                :initarg :instance-of
+;;                :associate TopicC
+;;                :inherit t
+;;                :documentation "topic that this construct is an instance of")))
+;;
+;;(defmethod delete-construct :before ((construct TypableC))
+;;  (when (instance-of-p construct)
+;;    (elephant:remove-association construct 'instance-of (instance-of construct))))
+;;
+;;(defgeneric instance-of-p (construct)
+;;  (:documentation "is the instance-of slot bound and not nil")
+;;  (:method ((construct TypableC)) (slot-predicate construct 'instance-of)))
+;;
+;;
+;;;; (defmethod equivalent-constructs ((scope1 ScopeC) (scope2 ScopeC))
+;;;;   "scopes are equal if their themes are equal"
+;;;;   (let
+;;;;       ((themes1 
+;;;;  (map 'list #'internal-id (themes scope1)))
+;;;;        (themes2
+;;;;  (map 'list #'internal-id (themes scope2))))
+;;;;     (not (set-exclusive-or themes1 themes2 :key #'internal-id))))
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; CharacteristicC
+;;       
+;;
+;;(elephant:defpclass CharacteristicC (ReifiableConstructC ScopableC TypableC)
+;;  ((topic :accessor topic
+;;          :initarg :topic
+;;          :associate TopicC
+;;          :documentation "The topic that this characteristic belongs to")
+;;   (charvalue :accessor charvalue
+;;              :type string
+;;              :initarg :charvalue
+;;              :index t
+;;              :documentation "the value of the characteristic in the given scope"))
+;;  (:documentation "Scoped characteristic of a topic (meant to be used
+;;  as an abstract class)"))
+;;
+;;(defgeneric CharacteristicC-p (object)
+;;  (:documentation "test if object is a of type CharacteristicC")
+;;  (:method ((object t)) nil)
+;;  (:method ((object CharacteristicC)) object))
+;;
+;;(defmethod delete-construct :before ((construct CharacteristicC))
+;;  (delete-1-n-association construct 'topic))
+;;
+;;(defun get-item-by-content (content &key (revision *TM-REVISION*))
+;;  "Find characteristis by their (atomic) content"
+;;  (flet
+;;      ((get-existing-instances (classname)
+;;         (delete-if-not #'(lambda (constr)
+;;                            (find-item-by-revision constr revision))
+;;                        (elephant:get-instances-by-value classname 'charvalue content))))
+;;    (nconc (get-existing-instances 'OccurenceC)
+;;           (get-existing-instances 'NameC))))
+;;
+;;
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; VariantC
+;;
+;;(elephant:defpclass VariantC (CharacteristicC)
+;;  ((datatype :accessor datatype
+;;             :initarg :datatype
+;;             :initform nil
+;;             :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")
+;;   (name :accessor name
+;;	  :initarg :name
+;;	  :associate NameC
+;;	  :documentation "references the NameC instance which is the owner of this element")))
+;;
+;;
+;;(defgeneric VariantC-p (object)
+;;  (:documentation "test if object is a of type VariantC")
+;;  (:method ((object t)) nil)
+;;  (:method ((object VariantC)) object))
+;;
+;;
+;;(defmethod delete-construct :before ((construct VariantC))
+;;  (delete-1-n-association construct 'name))
+;;
+;;
+;;(defmethod find-all-equivalent ((construct VariantC))
+;;  (let ((parent (and (slot-boundp construct 'name)
+;;                     (name construct))))
+;;    (when parent
+;;      (delete-if-not #'(lambda(x)(strictly-equivalent-constructs construct x))
+;;                     (slot-value parent 'variants)))))
+;;
+;;
+;;(defmethod equivalent-constructs ((variant1 VariantC) (variant2 VariantC))
+;;  "variant items are (TMDM(5.5)-)equal if the values of their
+;;   [value], [datatype], [scope], and [parent] properties are equal"
+;;  (and (string= (charvalue variant1) (charvalue variant2))
+;;       (or (and (not (slot-boundp variant1 'datatype)) (not (slot-boundp variant2 'datatype)))
+;;           (and (slot-boundp variant1 'datatype) (slot-boundp variant2 'datatype)
+;;                (string= (datatype variant1) (datatype variant2))))
+;;       (not (set-exclusive-or (themes variant1) (themes variant2) :key #'internal-id))))
+;;
+;;                        
+;;
+;;         
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; NameC
+;;
+;;(elephant:defpclass NameC (CharacteristicC)
+;;  ((variants ;:accessor variants
+;;	     :associate (VariantC name)))
+;;  (:documentation "Scoped name of a topic"))
+;;
+;;
+;;(defgeneric variants (name &key revision)
+;;  (:method ((name NameC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision name 'variants :start-revision revision)))
+;;
+;;
+;;(defgeneric NameC-p (object)
+;;  (:documentation "test if object is a of type NameC")
+;;  (:method ((object t)) nil)
+;;  (:method ((object NameC)) object))
+;;
+;;
+;;(defmethod find-all-equivalent ((construct NameC))
+;;  (let
+;;      ((parent (and (slot-boundp construct 'topic)
+;;                    (topic construct))))
+;;    (when parent
+;;      (delete-if-not 
+;;       #'(lambda (cand) (strictly-equivalent-constructs construct cand))
+;;       (slot-value parent 'names)))))
+;;
+;;
+;;(defmethod delete-construct :before ((construct NameC))
+;;  (dolist (variant (variants construct))
+;;    (delete-construct variant)))
+;;
+;;
+;;(defmethod equivalent-constructs ((name1 NameC) (name2 NameC))
+;;  "check for the equlity of two names by the TMDM's equality
+;;rules (5.4)"
+;;  (and
+;;   (string= (charvalue name1) (charvalue name2))
+;;   (or (and (instance-of-p name1)
+;;            (instance-of-p name2)
+;;            (= (internal-id (instance-of name1)) 
+;;               (internal-id (instance-of name2))))
+;;       (and (not (instance-of-p name1)) (not (instance-of-p name2))))
+;;   (not (set-exclusive-or (themes name1) (themes name2) :key #'internal-id))))
+;;           
+;;
+;;
+;;
+;;;;;;;;;;;;;;;;
+;;;;
+;;;; OccurrenceC
+;;
+;;(elephant:defpclass OccurrenceC (CharacteristicC)
+;;  ((datatype :accessor datatype
+;;             :initarg :datatype
+;;             :initform nil
+;;             :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")))
+;;
+;;
+;;(defgeneric OccurrenceC-p (object)
+;;  (:documentation "test if object is a of type OccurrenceC")
+;;  (:method ((object t)) nil)
+;;  (:method ((object OccurrenceC)) object))
+;;
+;;(defmethod find-all-equivalent ((construct OccurrenceC))
+;;  (let
+;;      ((parent (and (slot-boundp construct 'topic)
+;;                    (topic construct))))
+;;    (when parent
+;;      (delete-if-not  #'(lambda (cand) (strictly-equivalent-constructs construct cand))
+;;                      (slot-value parent 'occurrences)))))
+;;
+;;(defmethod equivalent-constructs ((occ1 OccurrenceC) (occ2 OccurrenceC))
+;;  "Occurrence items are equal if the values of their [value], [datatype], [scope], [type], and [parent] properties are equal (TMDM 5.6)"
+;;  (and
+;;   (string= (charvalue occ1) (charvalue occ2))
+;;   (not (set-exclusive-or (themes occ1) (themes occ2) :key #'internal-id))
+;;   (= (internal-id (topic occ1)) (internal-id (topic occ2)))
+;;   (or 
+;;    (and (instance-of-p occ1) (instance-of-p occ2)
+;;         (= 
+;;          (internal-id (instance-of occ1))
+;;          (internal-id (instance-of occ2))))
+;;    (and (not (instance-of-p occ1)) (not (instance-of-p occ2))))))
+;;
+;;
+;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; TopicC
+;;
+;;(elephant:defpclass TopicC (ReifiableConstructC)
+;;  ((topic-identifiers
+;;    :accessor topic-identifiers
+;;    :associate (TopicIdentificationC identified-construct))
+;;   (psis                                ;accessor written below
+;;    :associate (PersistentIdC identified-construct)
+;;    :documentation "list of PSI objects associated with this
+;;         topic")
+;;   (locators
+;;                                        ;accessor written below
+;;    :associate (SubjectLocatorC identified-construct)
+;;    :documentation "an optional URL that (if given) means that this topic is a subject locator")
+;;   (names                               ;accessor written below
+;;    :associate (NameC topic)
+;;    :documentation "list of topic names (as TopicC objects)") 
+;;   (occurrences         ;accessor occurrences explicitly written below
+;;    :associate (OccurrenceC topic)
+;;    :documentation "list of occurrences (as OccurrenceC objects)")
+;;   (player-in-roles            ;accessor player-in-roles written below
+;;    :associate (RoleC player)
+;;    :documentation "the list of all role instances where this topic is a player in")
+;;   (used-as-type                  ;accessor used-as-type written below
+;;    :associate (TypableC instance-of)
+;;    :documentation "list of all constructs that have this topic as their type")
+;;   (used-as-theme                ;accessor used-as-theme written below
+;;    :associate (ScopableC themes)
+;;    :many-to-many t
+;;    :documentation "list of all scopable objects this topic is a theme in")
+;;   (in-topicmaps
+;;    :associate (TopicMapC topics)
+;;    :many-to-many t
+;;    :documentation "list of all topic maps this topic is part of")
+;;   (reified
+;;    :associate ReifiableConstructC
+;;    :documentation "contains a reified object, represented as 1:1 association"))
+;;  (:documentation "Topic in a Topic Map"))
+;;
+;;
+;;(defgeneric reified (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (when (slot-boundp topic 'reified)
+;;      (slot-value topic 'reified))))
+;;
+;;(defgeneric (setf reified) (reifiable ReifiableConstructC)
+;;  (:method (reifiable (topic TopicC))
+;;    (setf (slot-value topic 'reified) reifiable)))
+;;;    (setf (reifier reifiable) topic)))
+;;
+;;(defgeneric occurrences (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision topic 'occurrences :start-revision revision)))
+;;
+;;(defgeneric names (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision topic 'names :start-revision revision)))
+;;
+;;(defgeneric psis (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision 
+;;     topic 'psis :start-revision revision)))
+;;
+;;(defgeneric locators (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision 
+;;     topic 'locators :start-revision revision)))
+;;
+;;(defgeneric player-in-roles (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision 
+;;     topic 'player-in-roles :start-revision revision)))
+;;
+;;(defgeneric used-as-type (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision topic 'used-as-type :start-revision revision)))
+;;
+;;(defgeneric used-as-theme (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision)))
+;;
+;;(defgeneric in-topicmaps (topic &key revision)
+;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
+;;    (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)))
+;;
+;;(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers))
+;;  "Moves all identifiers from the source-topic to the destination topic."
+;;  (declare (TopicC destination-topic source-topic))
+;;  (let ((all-source-identifiers
+;;	 (cond
+;;	   ((eql what 'item-identifiers)
+;;	    (item-identifiers source-topic))
+;;	   ((eql what 'locators)
+;;	    (locators source-topic))
+;;	   (t
+;;	    (psis source-topic))))
+;;	(all-destination-identifiers
+;;	 (cond
+;;	   ((eql what 'item-identifiers)
+;;	    (item-identifiers destination-topic))
+;;	   ((eql what 'locators)
+;;	    (locators destination-topic))
+;;	   ((eql what 'psis)
+;;	    (psis destination-topic))
+;;	   ((eql what 'topic-identifiers)
+;;	    (topic-identifiers destination-topic)))))
+;;    (let ((identifiers-to-move
+;;	   (loop for id in all-source-identifiers
+;;	      when (not (find-if #'(lambda(x)
+;;				     (if (eql what 'topic-identifiers)
+;;					 (string= (xtm-id x) (xtm-id id))
+;;					 (string= (uri x) (uri id))))
+;;				 all-destination-identifiers))
+;;	      collect id)))
+;;      (dolist (item identifiers-to-move)
+;;	(remove-association source-topic what item)
+;;	(add-association destination-topic what item)))))
+;;
+;;(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil))
+;;  "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators"
+;;  (declare (list psis))
+;;  (declare (list locators))
+;;  (call-next-method)
+;;  ;item-identifiers are handled in the around-method for ReifiableConstructs,
+;;  ;TopicIdentificationCs are handled in make-construct of TopicC
+;;  (dolist (persistent-id psis)
+;;    (declare (PersistentIdC persistent-id))
+;;    (setf (identified-construct persistent-id) instance))
+;;  (dolist (subject-locator locators)
+;;    (declare (SubjectLocatorC subject-locator))
+;;    (setf (identified-construct subject-locator) instance))
+;;  (when reified
+;;    (setf (reified instance) reified)))
+;;
+;;
+;;(defmethod delete-construct :before ((construct TopicC))
+;;  (dolist (dependent (append (topic-identifiers construct)
+;;                             (psis construct)
+;;                             (locators construct)
+;;                             (names construct)
+;;                             (occurrences construct)
+;;                             (player-in-roles construct)
+;;                             (used-as-type construct)))
+;;    (delete-construct dependent))
+;;  (dolist (theme (used-as-theme construct))
+;;    (elephant:remove-association construct 'used-as-theme theme))
+;;  (dolist (tm (in-topicmaps construct))
+;;    (elephant:remove-association construct 'in-topicmaps tm))
+;;  (when (reified construct)
+;;    (slot-makunbound (reified construct) 'reifier)))
+;;  
+;;(defun get-all-constructs-by-uri (uri)
+;;  (delete 
+;;   nil
+;;   (mapcar 
+;;    (lambda (identifier)
+;;      (and
+;;       (slot-boundp identifier 'identified-construct)
+;;       (identified-construct identifier)))
+;;    (union
+;;     (union
+;;      (elephant:get-instances-by-value 'ItemIdentifierC 'uri uri)
+;;      (elephant:get-instances-by-value 'PersistentIdC 'uri uri))
+;;     (elephant:get-instances-by-value 'SubjectLocatorC 'uri uri)))))
+;;
+;;
+;;(defun find-existing-topic (item-identifiers locators psis)
+;;  (let
+;;      ((uris 
+;;        (mapcar #'uri 
+;;               (union (union item-identifiers locators) psis)))
+;;       (existing-topics nil))
+;;    (dolist (uri uris)
+;;      (setf existing-topics
+;;            (nunion existing-topics
+;;                    (get-all-constructs-by-uri uri)
+;;                    :key #'internal-id)))
+;;    (assert (<= (length existing-topics) 1))
+;;    (first existing-topics)))
+;;
+;;
+;;(defmethod make-construct ((class-symbol (eql 'TopicC)) &rest args
+;;                           &key start-revision item-identifiers locators psis topicid xtm-id)
+;;  (let
+;;      ((existing-topic 
+;;        (find-existing-topic item-identifiers locators psis)))
+;;    (if existing-topic
+;;        (progn
+;;          ;our problem with topics is that we know only after the
+;;          ;addition of all the identifiers and characteristics if
+;;          ;anything has changed. We can't decide that here, so we must
+;;          ;add all revisions (real or imaginary) to version history
+;;          ;and decide the rest in changed-p. Maybe somebody can think
+;;          ;of a better way?
+;;          (add-to-version-history existing-topic
+;;                                  :start-revision start-revision)
+;;          (init-topic-identification existing-topic topicid xtm-id
+;;                                     :revision start-revision)
+;;          (let*                 ;add new identifiers to existing topics
+;;              ((all-new-identifiers 
+;;                (union (union item-identifiers locators) psis))
+;;               (all-existing-identifiers 
+;;                (get-all-identifiers-of-construct existing-topic)))
+;;            (mapc
+;;             (lambda (identifier)
+;;               (setf (identified-construct identifier) existing-topic))
+;;             (set-difference all-new-identifiers all-existing-identifiers
+;;                             :key #'uri :test #'string=))
+;;            (mapc #'delete-construct 
+;;                  (delete-if
+;;                   (lambda (identifier) 
+;;                     (slot-boundp identifier 'identified-construct))
+;;                   all-new-identifiers)))
+;;          (check-for-duplicate-identifiers existing-topic)
+;;          existing-topic)
+;;        (progn
+;;          (let*
+;;              ((cleaned-args (remove-nil-values args))
+;;               (new-topic 
+;;                (apply #'make-instance 'TopicC cleaned-args)))
+;;            
+;;            (init-topic-identification new-topic topicid xtm-id 
+;;                                       :revision start-revision)
+;;            (check-for-duplicate-identifiers new-topic)
+;;            (add-to-version-history new-topic
+;;                                    :start-revision start-revision)
+;;            new-topic)))))
+;;
+;;(defmethod make-construct :around ((class-symbol (eql 'TopicC))
+;;                                   &key start-revision &allow-other-keys)
+;;  (declare (ignorable start-revision))
+;;  (call-next-method))
+;;
+;;    
+;;(defmethod equivalent-constructs ((topic1 TopicC) (topic2 TopicC))
+;;  "TMDM, 5.3.5: Equality rule: Two topic items are equal if they have:
+;;
+;;* at least one equal string in their [subject identifiers] properties,
+;;
+;;* at least one equal string in their [item identifiers] properties,
+;;
+;;* at least one equal string in their [subject locators] properties,
+;;
+;;* an equal string in the [subject identifiers] property of the one
+;;topic item and the [item identifiers] property of the other, or the
+;;same information item in their [reified] properties (TODO: this rule
+;;is currently ignored)" 
+;;  ;(declare (optimize (debug 3)))
+;;  (let
+;;      ((psi-uris1
+;;        (map 'list #'uri (psis topic1)))
+;;       (psi-uris2
+;;        (map 'list #'uri (psis topic2)))
+;;       (ii-uris1
+;;        (map 'list #'uri (item-identifiers topic1)))
+;;       (ii-uris2
+;;        (map 'list #'uri (item-identifiers topic2)))
+;;       (locators1
+;;        (map 'list #'uri (locators topic1)))
+;;       (locators2
+;;        (map 'list #'uri (locators topic2))))
+;;    (let
+;;        ((all-uris1
+;;          (union psi-uris1 (union ii-uris1 locators1) :test #'string=))
+;;         (all-uris2
+;;          (union psi-uris2 (union ii-uris2 locators2) :test #'string=)))
+;;      ;;TODO: consider what we should do about this. If the topic at a
+;;      ;;given revision doesn't exist yet, it correctly has no uris
+;;      ;;(for that version)
+;;      ;; (when (= 0 (length all-uris1))
+;;;;         (error (make-condition 'no-identifier-error :message "Topic1 has no identifier" :internal-id (internal-id topic1))))
+;;;;       (when (= 0 (length all-uris2))
+;;;;         (error (make-condition 'no-identifier-error :message "Topic2 has no identifier" :internal-id (internal-id topic2))))
+;;      (intersection
+;;       all-uris1 all-uris2
+;;       :test #'string=))))
+;;    
+;;(defmethod get-all-identifiers-of-construct ((top TopicC))
+;;  (append (psis top)
+;;          (locators top)
+;;          (item-identifiers top)))
+;;
+;;  
+;;(defmethod topicid ((top TopicC) &optional (xtm-id nil))
+;;  "Return the primary id of this item (= essentially the OID). If
+;;xtm-id is explicitly given, return one of the topicids in that
+;;TM (which must then exist)"
+;;  (if xtm-id
+;;      (let 
+;;          ((possible-identifications
+;;            (remove-if-not
+;;             (lambda (top-id)
+;;               (string= (xtm-id top-id) xtm-id))
+;;             (elephant:get-instances-by-value 
+;;              'TopicIdentificationC
+;;              'identified-construct
+;;              top))))
+;;        (unless possible-identifications
+;;          (error (make-condition 
+;;                  'object-not-found-error
+;;                  :message 
+;;                  (format nil "Could not find an object ~a in xtm-id ~a" top xtm-id))))
+;;        (uri (first possible-identifications)))
+;;      (format nil "t~a"
+;;              (internal-id top))))
+;;  
+;;
+;;(defgeneric psis-p (top)
+;;  (:documentation "Test for the existence of PSIs")
+;;  (:method ((top TopicC)) (slot-predicate top 'psis)))
+;;
+;;(defgeneric list-instanceOf (topic &key tm)
+;; (:documentation "Generate a list of all topics that this topic is an
+;;  instance of, optionally filtered by a topic map"))
+;;
+;;(defmethod list-instanceOf ((topic TopicC)  &key (tm nil))
+;;  (remove-if 
+;;   #'null
+;;   (map 'list #'(lambda(x)
+;;                  (when (loop for psi in (psis (instance-of x))
+;;                           when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance")
+;;                           return t)
+;;                    (loop for role in (roles (parent x))
+;;                       when (not (eq role x))
+;;                       return (player role))))
+;;        (if tm
+;;            (remove-if-not 
+;;             (lambda (role)
+;;               ;(format t "player: ~a" (player role))
+;;               ;(format t "parent: ~a" (parent role))
+;;               ;(format t "topic: ~a~&" topic)
+;;               (in-topicmap tm (parent role)))
+;;             (player-in-roles topic))
+;;            (player-in-roles topic)))))
+;;
+;;
+;;(defgeneric list-super-types (topic &key tm)
+;; (:documentation "Generate a list of all topics that this topic is an
+;;  subclass of, optionally filtered by a topic map"))
+;;
+;;
+;;(defmethod list-super-types ((topic TopicC)  &key (tm nil))
+;;  (remove-if 
+;;   #'null
+;;   (map 'list #'(lambda(x)
+;;                  (when (loop for psi in (psis (instance-of x))
+;;                           when (string= (uri psi) *subtype-psi*)
+;;                           return t)
+;;                    (loop for role in (roles (parent x))
+;;                       when (not (eq role x))
+;;                       return (player role))))
+;;        (if tm
+;;            (remove-if-not 
+;;             (lambda (role)
+;;               (format t "player: ~a" (player role))
+;;               (format t "parent: ~a" (parent role))
+;;               (format t "topic: ~a~&" topic)
+;;               (in-topicmap tm (parent role)))
+;;             (player-in-roles topic))
+;;            (player-in-roles topic)))))
+;;
+;;
+;;(defun string-starts-with (str prefix)
+;;  "Checks if string str starts with a given prefix"
+;;  (declare (string str prefix))
+;;  (string= str prefix :start1 0 :end1
+;;           (min (length prefix)
+;;                (length str))))
+;;
+;;
+;;(defun get-item-by-item-identifier (uri &key revision)
+;;  "get a construct by its item identifier. Returns nil if the item does not exist in a
+;;particular revision"
+;;  (declare (string uri))
+;;  (declare (integer revision))
+;;  (let
+;;      ((ii-obj 
+;;        (elephant:get-instance-by-value 'ItemIdentifierC
+;;                                        'uri uri)))
+;;    (when ii-obj
+;;      (find-item-by-revision 
+;;       (identified-construct ii-obj) revision))))
+;;
+;;
+;;(defun get-item-by-psi (psi &key (revision 0))
+;;  "get a topic by its PSI. Returns nil if the item does not exist in a
+;;particular revision"
+;;  (declare (string psi))
+;;  (declare (integer revision))
+;;  (let
+;;      ((psi-obj 
+;;        (elephant:get-instance-by-value 'PersistentIdC
+;;                                        'uri psi)))
+;;    (when psi-obj
+;;      (find-item-by-revision 
+;;       (identified-construct psi-obj) revision))))
+;;
+;;(defun get-item-by-id (topicid &key (xtm-id *current-xtm*) (revision 0) (error-if-nil nil))
+;;  "get a topic by its id, assuming a xtm-id. If xtm-id is empty, the current TM
+;;is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
+;;applicable in the correct revision. If revison is provided, then the code checks
+;;if the topic already existed in this revision and returns nil otherwise.
+;;If no item meeting the constraints was found, then the return value is either
+;;NIL or an error is thrown, depending on error-if-nil."
+;;  (declare (integer revision))
+;;  (let
+;;      ((result 
+;;        (if xtm-id
+;;            (let
+;;                ((possible-items
+;;                  (delete-if-not
+;;                   (lambda (top-id)
+;;                     (and
+;;                      (string= (xtm-id top-id) xtm-id)
+;;                      (string= (uri top-id) topicid))) ;fixes a bug in
+;;                                                       ;get-instances-by-value
+;;                                                       ;that does a
+;;                                                       ;case-insensitive
+;;                                                       ;comparision
+;;                   (elephant:get-instances-by-value 
+;;                    'TopicIdentificationC
+;;                    'uri
+;;                    topicid))))
+;;              (when (and possible-items
+;;                         (identified-construct-p (first possible-items)))
+;;                (unless (= (length possible-items) 1)
+;;                  (error (make-condition 'duplicate-identifier-error 
+;;                                         :message 
+;;                                         (format nil "(length possible-items ~a) for id ~a und xtm-id ~a > 1" possible-items topicid xtm-id)
+;;                                         :uri topicid)))
+;;                (let
+;;                    ((found-topic 
+;;                      (identified-construct (first possible-items))))
+;;                  (if (= revision 0)
+;;                      found-topic 
+;;                      (find-item-by-revision found-topic revision)))))
+;;            (make-instance 'TopicC :from-oid (subseq topicid 1)))))
+;;    (if (and error-if-nil (not result))
+;;        (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision))
+;;        result)))
+;;
+;;      
+;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; RoleC
+;;
+;;(elephant:defpclass RoleC (ReifiableConstructC TypableC)
+;;  ((parent :accessor parent
+;;           :initarg :parent
+;;           :associate AssociationC
+;;           :documentation "Association that this role belongs to")
+;;   (player :accessor player
+;;           :initarg :player
+;;           :associate TopicC
+;;           :documentation "references the topic that is the player in this role"))
+;;  (:documentation "The role that this topic plays in an association (formerly member)"))
+;;
+;;
+;;
+;;(defgeneric RoleC-p (object)
+;;  (:documentation "test if object is a of type RoleC")
+;;  (:method ((object t)) nil)
+;;  (:method ((object RoleC)) object))
+;;
+;;
+;;(defgeneric parent-p (vi)
+;;  (:documentation "t if this construct has a parent construct")
+;;  (:method ((constr RoleC)) (slot-predicate constr 'parent)))
+;;
+;;
+;;(defmethod delete-construct :before ((construct RoleC))
+;;                                        ;the way we use roles, we cannot just delete the parent association
+;;                                        ;(at least the second role won't have one left then and will
+;;                                        ;complain)
+;;  (delete-1-n-association construct 'parent)
+;;  (delete-1-n-association construct 'player))
+;;
+;;(defmethod find-all-equivalent ((construct RoleC))
+;;  (let
+;;      ((parent (and (slot-boundp construct 'parent)
+;;                    (parent construct))))
+;;    (when parent
+;;      (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand))
+;;                     (slot-value parent 'roles)))))
+;;
+;;
+;;(defmethod equivalent-constructs ((role1 RoleC) (role2 RoleC))
+;;  "Association role items are equal if the values of their [type], [player], and [parent] properties are equal (TMDM 5.8)"
+;;                                        ;for the purposes for which we use this method (namely the
+;;                                        ;construction of associations), roles will initially always be
+;;                                        ;unequal regarding their parent properties
+;;  (and
+;;   (= (internal-id (instance-of role1)) (internal-id (instance-of role2)))
+;;   (= (internal-id (player role1)) (internal-id (player role2)))))
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; AssociationC
+;;
+;;(elephant:defpclass AssociationC (ReifiableConstructC ScopableC TypableC)
+;;  ((roles :accessor roles
+;;          :associate (RoleC parent)
+;;          :documentation "(non-empty) list of this association's roles")
+;;   (in-topicmaps
+;;    :associate (TopicMapC associations)
+;;    :many-to-many t
+;;    :documentation "list of all topic maps this association is part of"))
+;;  (:documentation "Association in a Topic Map")
+;;  (:index t))
+;;
+;;
+;;(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
+;;  (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
+;;
+;;
+;;(defgeneric AssociationC-p (object)
+;;  (:documentation "test if object is a of type AssociationC")
+;;  (:method ((object t)) nil)
+;;  (:method ((object AssociationC)) object))
+;;
+;;
+;;(defmethod initialize-instance :around ((instance AssociationC) 
+;;                                        &key 
+;;                                        (roles nil))
+;;  "implements the pseudo-initarg :roles"
+;;  (declare (list roles))
+;;  (let
+;;      ((association (call-next-method)))  
+;;    (dolist (role-data roles)
+;;      (make-instance 
+;;       'RoleC 
+;;       :instance-of (getf role-data :instance-of)
+;;       :player (getf role-data :player)
+;;       :item-identifiers (getf role-data :item-identifiers)
+;;       :reifier (getf role-data :reifier)
+;;       :parent association))))
+;;
+;;(defmethod make-construct :around ((class-symbol (eql 'AssociationC))
+;;                                   &key 
+;;                                   start-revision 
+;;                                   &allow-other-keys)
+;;  (declare (ignorable start-revision))
+;;  (let
+;;      ((association
+;;        (call-next-method)))
+;;    (declare (AssociationC association))
+;;    (dolist (role (slot-value association 'roles))
+;;      (unless (versions role)
+;;        (add-to-version-history role
+;;                                :start-revision start-revision)))
+;;    association))
+;;
+;;(defmethod copy-item-identifiers :around
+;;    ((from-construct AssociationC)
+;;     (to-construct AssociationC))
+;;  "Internal method to copy over item idenfiers from one association
+;;with its roles to another one. Role identifiers are also
+;;copied. Returns nil if neither association nor role identifiers had to be copied"
+;;  (let
+;;      ((item-identifiers-copied-p nil)) ;rather brutal solution. find a better one
+;;    (when (call-next-method)
+;;      (setf item-identifiers-copied-p t))
+;;    (do ((from-roles (roles from-construct) (rest from-roles))
+;;         (to-roles (roles to-construct) (rest to-roles)))
+;;        ((null from-roles) 'finished)
+;;      (let
+;;          ((from-role (first from-roles))
+;;           (to-role (first to-roles)))
+;;        (when
+;;            (mapc
+;;             (lambda (identifier)
+;;               (setf (identified-construct identifier) 
+;;                     to-role))
+;;             (set-difference (item-identifiers from-role)
+;;                             (item-identifiers to-role)
+;;                             :key #'uri :test #'string=))
+;;          (setf item-identifiers-copied-p t))))
+;;  item-identifiers-copied-p))
+;;
+;;(defmethod delete-construct :before ((construct AssociationC))
+;;  (dolist (role (roles construct))
+;;    (delete-construct role))
+;;  (dolist (tm (in-topicmaps construct))
+;;    (elephant:remove-association construct 'in-topicmaps tm)))
+;;
+;;(defmethod find-all-equivalent ((construct AssociationC))
+;;  (let
+;;      ((some-player (player (or
+;;                             (second (roles construct))
+;;                             (first (roles construct)))))) ;; dirty, dirty... but brings a tenfold speedup!
+;;    (delete-if-not  
+;;     #'(lambda (cand) 
+;;         (unless (eq construct cand)
+;;           (equivalent-constructs construct cand)))
+;;                                        ;here we need to use the "internal" API and access the players
+;;                                        ;with slot-value (otherwise we won't be able to merge with
+;;                                        ;'deleted' associations)
+;;     (mapcar #'parent (slot-value some-player 'player-in-roles)))))
+;;
+;;
+;;(defmethod equivalent-constructs ((assoc1 AssociationC) (assoc2 AssociationC))
+;;  "Association items are equal if the values of their [scope], [type], and [roles] properties are equal (TMDM 5.7)"
+;;  (and
+;;   (= (internal-id (instance-of assoc1)) (internal-id (instance-of assoc2)))
+;;   (not (set-exclusive-or (themes assoc1) (themes assoc2) 
+;;                          :key #'internal-id))
+;;   (not (set-exclusive-or
+;;         (roles assoc1)
+;;         (roles assoc2)
+;;         :test  #'equivalent-constructs))))
+;;
+;;
+;;(elephant:defpclass TopicMapC (ReifiableConstructC)
+;;  ((topics :accessor topics
+;;          :associate (TopicC in-topicmaps)
+;;          :documentation "list of topics that explicitly belong to this TM")
+;;   (associations :accessor associations
+;;                 :associate (AssociationC in-topicmaps)
+;;                 :documentation "list of associations that belong to this TM"))
+;;  (:documentation "Topic Map"))
+;;
+;;(defmethod equivalent-constructs ((tm1 TopicMapC) (tm2 TopicMapC))
+;;  "Topic Map items are equal if one of their identifiers is equal"
+;;  ;Note: TMDM does not make any statement to this effect, but it's the
+;;  ;one logical assumption
+;;  (intersection
+;;   (item-identifiers tm1)
+;;   (item-identifiers tm2)
+;;   :test  #'equivalent-constructs))
+;;
+;;(defmethod find-all-equivalent ((construct TopicMapC))
+;;  (let 
+;;      ((tms (elephant:get-instances-by-class 'd:TopicMapC)))
+;;    (delete-if-not 
+;;     (lambda(tm)
+;;         (strictly-equivalent-constructs construct tm))
+;;     tms)))
+;;
+;;(defgeneric add-to-topicmap (tm top)
+;;  (:documentation "add a topic or an association to a topic
+;;  map. Return the added construct"))
+;;
+;;(defmethod add-to-topicmap ((tm TopicMapC) (top TopicC))
+;;  ;TODO: add logic not to add pure topic stubs unless they don't exist yet in the store
+;;;  (elephant:add-association tm 'topics top) ;by adding the elephant association in this order, there will be missing one site of this association
+;;  (elephant:add-association top 'in-topicmaps tm)
+;;  top)
+;;
+;;(defmethod add-to-topicmap ((tm TopicMapC) (ass AssociationC))
+;;   ;(elephant:add-association tm 'associations ass)
+;;  (elephant:add-association ass 'in-topicmaps tm)
+;;  ass)
+;;
+;;(defgeneric in-topicmap (tm constr &key revision)
+;;  (:documentation "Is a given construct (topic or assiciation) in this topic map?"))
+;;
+;;(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0))
+;;  (when (find-item-by-revision top revision)
+;;    (find (d:internal-id top) (d:topics tm) :test #'= :key #'d:internal-id)))
+;;
+;;
+;;(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
+;;  (when (find-item-by-revision ass revision)
+;;    (find (d:internal-id ass) (d:associations tm)  :test #'= :key #'d:internal-id)))
+;;
+;;;;;;;;;;;;;;;;;;;
+;;;; reification
+;;
+;;(defgeneric add-reifier (construct reifier-topic)
+;;  (:method ((construct ReifiableConstructC) reifier-topic)
+;;    (let ((err "From add-reifier(): "))
+;;      (declare (TopicC reifier-topic))
+;;      (cond
+;;	((and (not (reifier construct))
+;;	      (not (reified reifier-topic)))
+;;	 (setf (reifier construct) reifier-topic)
+;;	 (setf (reified reifier-topic) construct))
+;;	((and (not (reified reifier-topic))
+;;	      (reifier construct))
+;;	 (merge-reifier-topics (reifier construct) reifier-topic))
+;;	((and (not (reifier construct))
+;;	      (reified reifier-topic))
+;;	 (error "~a~a ~a reifies already another object ~a"
+;;		err (psis reifier-topic) (item-identifiers reifier-topic)
+;;		(reified reifier-topic)))
+;;	(t
+;;	 (when (not (eql (reified reifier-topic) construct))
+;;	   (error "~a~a ~a reifies already another object ~a"
+;;		  err (psis reifier-topic) (item-identifiers reifier-topic)
+;;		  (reified reifier-topic)))
+;;	 (merge-reifier-topics (reifier construct) reifier-topic)))
+;;      construct)))
+;;
+;;
+;;(defgeneric remove-reifier (construct)
+;;  (:method ((construct ReifiableConstructC))
+;;    (let ((reifier-topic (reifier construct)))
+;;      (when reifier-topic
+;;	(elephant:remove-association construct 'reifier reifier-topic)
+;;	(elephant:remove-association reifier-topic 'reified construct)))))
+;;
+;;
+;;(defgeneric merge-reifier-topics (old-topic new-topic)
+;;  ;;the reifier topics are not only merged but also bound to the reified-construct
+;;  (:method ((old-topic TopicC) (new-topic TopicC))
+;;    (unless (eql old-topic new-topic)
+;;      ;merges all identifiers
+;;      (move-identifiers old-topic new-topic)
+;;      (move-identifiers old-topic new-topic :what 'locators)
+;;      (move-identifiers old-topic new-topic :what 'psis)
+;;      (move-identifiers old-topic new-topic :what 'topic-identifiers)
+;;      ;merges all typed-object-associations
+;;      (dolist (typed-construct (used-as-type new-topic))
+;;	(remove-association typed-construct 'instance-of new-topic)
+;;	(add-association typed-construct 'instance-of old-topic))
+;;      ;merges all scope-object-associations
+;;      (dolist (scoped-construct (used-as-theme new-topic))
+;;	(remove-association scoped-construct 'themes new-topic)
+;;	(add-association scoped-construct 'themes old-topic))
+;;      ;merges all topic-maps
+;;      (dolist (tm (in-topicmaps new-topic))
+;;	(add-association tm 'topics old-topic)) ;the new-topic is removed from this tm by deleting it
+;;      ;merges all role-players
+;;      (dolist (a-role (player-in-roles new-topic))
+;;	(remove-association a-role 'player new-topic)
+;;	(add-association a-role 'player old-topic))
+;;      ;merges all names
+;;      (dolist (name (names new-topic))
+;;	(remove-association name 'topic new-topic)
+;;	(add-association name 'topic old-topic))
+;;      ;merges all occurrences
+;;      (dolist (occurrence (occurrences new-topic))
+;;	(remove-association occurrence 'topic new-topic)
+;;	(add-association occurrence 'topic old-topic))
+;;      ;merges all version-infos
+;;      (let ((versions-to-move
+;;	     (loop for vrs in (versions new-topic)
+;;		when (not (find-if #'(lambda(x)
+;;				       (and (= (start-revision x) (start-revision vrs))
+;;					    (= (end-revision x) (end-revision vrs))))
+;;				   (versions old-topic)))
+;;		collect vrs)))
+;;	(dolist (vrs versions-to-move)
+;;	  (remove-association vrs 'versioned-construct new-topic)
+;;	  (add-association vrs 'versioned-construct old-topic)))
+;;      (delete-construct new-topic))
+;;    ;TODO: order/repair all version-infos of the topic itself and add all new
+;;    ;      versions to the original existing objects of the topic
+;;    old-topic))
\ No newline at end of file

Added: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp	Thu Feb 11 14:21:40 2010
@@ -0,0 +1,101 @@
+;;+-----------------------------------------------------------------------------
+;;+  Isidorus
+;;+  (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
+;;+
+;;+  Isidorus is freely distributable under the LGPL license.
+;;+  You can find a detailed description in trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+
+(defpackage :datamodel-test
+  (:use 
+   :common-lisp
+   :datamodel
+   :it.bese.FiveAM
+   :fixtures
+   :unittests-constants)
+  (:export :run-datamodel-tests
+	   :test-VersionInfoC
+	   :test-VersionedConstructC))
+
+
+(declaim (optimize (debug 3)))
+
+(in-package :datamodel-test)
+
+(def-suite datamodel-test
+    :description "tests  various key functions of the datamodel")
+
+(in-suite datamodel-test)
+
+(defvar *db-dir* "data_base")
+
+(test test-VersionInfoC ()
+  "Tests various functions of the VersionInfoC class."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((vi-1 (make-instance 'd::VersionInfoC
+			       :start-revision 100
+			       :end-revision 300))
+	  (vi-2 (make-instance 'd::VersionInfoC
+			       :start-revision 300))
+	  (vc (make-instance 'd::VersionedConstructC)))
+      (is (= (d::start-revision vi-1) 100))
+      (is (= (d::end-revision vi-1) 300))
+      (is (= (d::start-revision vi-2) 300))
+      (is (= (d::end-revision vi-2) 0))
+      (is-false (d::versioned-construct-p vi-1))
+      (setf (d::versioned-construct vi-1) vc)
+      (is-true (d::versioned-construct-p vi-1)))))
+
+
+(test test-VersionedConstructC ()
+  "Tests various functions of the VersionedCoinstructC class."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((vc (make-instance 'd::VersionedConstructC)))
+      (is-false (d::versions vc))
+      (d::add-to-version-history vc
+				 :start-revision 100
+				 :end-revision 300)
+      (is (= (length (d::versions vc)) 1))
+      (is (= (d::end-revision (first (d::versions vc))) 300))
+      (is (= (d::start-revision (first (d::versions vc))) 100))
+      (d::add-to-version-history vc :start-revision 300)
+      (is (= (length (d::versions vc)) 1))
+      (is (= (d::end-revision (first (d::versions vc))) 0))
+      (is (= (d::start-revision (first (d::versions vc))) 100))
+      (d::add-to-version-history vc :start-revision 500)
+      (is (= (length (d::versions vc)) 2))
+      (let* ((vi-1 (first (d::versions vc)))
+	     (vi-2 (second (d::versions vc)))
+	     (sr-1 (d::start-revision vi-1))
+	     (er-1 (d::end-revision vi-1))
+	     (sr-2 (d::start-revision vi-2))
+	     (er-2 (d::end-revision vi-2)))
+	(is-true (or (and (= sr-1 100) (= er-1 500)
+			  (= sr-2 500) (= er-2 0))
+		     (and (= sr-1 500) (= er-1 0)
+			  (= sr-2 100) (= er-2 500)))))
+      (d::add-to-version-history vc :start-revision 600)
+      (is (= (length (d::versions vc)) 3))
+      (map 'list #'(lambda(vi)
+		     (is-true (d::versioned-construct-p vi)))
+	   (d::versions vc))
+      (d::add-to-version-history vc
+				 :start-revision 100
+				 :end-revision 500)
+      (is (= (length (d::versions vc)) 3))
+      (is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 3))
+      (is (= (length
+	      (elephant:get-instances-by-class 'd::VersionedConstructC)) 1))
+      (d::delete-construct vc)
+      (is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 0))
+      (is (= (length
+	      (elephant:get-instances-by-class 'd::VersionedConstructC)) 0)))))
+      
+      
+
+
+(defun run-datamodel-tests()
+  (it.bese.fiveam:run! 'test-VersionInfoC)
+  (it.bese.fiveam:run! 'test-VersionedConstructC)
+)
\ No newline at end of file

Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/fixtures.lisp	(original)
+++ branches/new-datamodel/src/unit_tests/fixtures.lisp	Thu Feb 11 14:21:40 2010
@@ -37,7 +37,8 @@
            :*XTM-MERGE1-TM*
            :*XTM-MERGE2-TM*
 	   :rdf-init-db
-	   :rdf-test-db))
+	   :rdf-test-db
+	   :with-empty-db))
 
 (in-package :fixtures)
 
@@ -210,4 +211,11 @@
     (&body)
     (handler-case (delete-file exported-file-path)
       (error () )) ;do nothing
-    (tear-down-test-db)))
\ No newline at end of file
+    (tear-down-test-db)))
+
+
+(def-fixture with-empty-db (dir)
+  (clean-out-db dir)
+  (elephant:open-store (xml-importer:get-store-spec dir))
+  (&body)
+  (tear-down-test-db))
\ No newline at end of file



From lgiessmann at common-lisp.net  Fri Feb 12 21:11:55 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 12 Feb 2010 16:11:55 -0500
Subject: [isidorus-cvs] r184 - branches/new-datamodel/src/model
Message-ID: <E1Ng2nr-00009z-43@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 12 16:11:54 2010
New Revision: 184

Log:
new-datamodel: added all PointerC-classes and all PointerAssociationC-classes

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	Fri Feb 12 16:11:54 2010
@@ -13,12 +13,17 @@
 
 (in-package :datamodel)
 
+;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar *TM-REVISION* 0)
+
 
 ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun slot-p (instance slot-symbol)
   "Returns t if the slot depending on slot-symbol is bound and not nil."
-  (and (slot-boundp instance slot-symbol)
-       (slot-value instance slot-symbol)))
+  (when (slot-boundp instance slot-symbol)
+    (let ((value (slot-value instance slot-symbol)))
+      (when value
+	value))))
 
 
 (defun delete-1-n-association(instance slot-symbol)
@@ -144,57 +149,110 @@
 			    :versioned-construct construct)))))))
 
 
+(defgeneric marked-as-deleted-p (construct)
+  (:documentation "Returns t if the construct was marked-as-deleted.")
+  (:method ((construct VersionedConstructC))
+    (if (find-if #'(lambda(vi)
+		     (= (end-revision vi) 0))
+		 (versions construct))
+	nil
+	t)))
+
+
 ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ReifierAssociationC
 ;;; SubjectLocatorAssociationC
 ;;; PersistentIdAssociationC
 ;;; TopicIdAssociationC
 ;;; ItemIdAssociationC
 ;;; PointerAssociationC
 ;;; VersionedAssociationC
+(defpclass ReifierAssociationC(VersionedAssociationC)
+  ((reifiable-construct :initarg :reifiable-construct
+			:accessor reifiable-construct
+			:associate ReifiableConstructC
+			:documentation "The actual construct which is reified
+                                      by a topic.")
+   (reifier-topic :initarg :reifier-topic
+		  :accessor reifier-topic
+		  :associate TopicC
+		  :documentation "The reifier-topic that reifies the
+                                  reifiable-construct."))
+  (:index t)
+  (:documentation "A versioned-association that relates a reifiable-construct
+                   with a topic."))
+
+
+(defmethod delete-construct :before ((construct ReifierAssociationC))
+  "Deletes the association-construct and the reifier-topic when it
+   is not used as a reifier of another construct."
+  (delete-1-n-association construct 'reifiable-construct)
+  (let ((reifier-top (slot-p construct 'reifier-topic)))
+    (delete-1-n-association construct 'reifier-topic)
+    (when (= (length (all-reified-constructs reifier-top)) 0)
+      (delete-construct reifier-top))))
+
+
 (defpclass SubjectLocatorAssociationC(PointerAssociationC)
-  ((identified-construct :initarg :identified-construct
-			 :accessor identified-construct
-			 :associate TopicC
-			 :documentation "The actual topic which is associated
-                                         with the subject-locator."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :associate TopicC
+		     :documentation "The actual topic which is associated
+                                     with the subject-locator."))
   (:index t)
   (:documentation "A pointer that associates subject-locators, versions
                    and topics."))
 
 
+(defmethod delete-construct :before ((construct SubjectLocatorAssociationC))
+  (delete-1-n-association construct 'parent-construct))
+
+
 (defpclass PersistentIdAssociationC(PointerAssociationC)
-  ((identified-construct :initarg :identified-construct
-			 :accessor identified-construct
-			 :associate TopicC
-			 :documentation "The actual topic which is associated
-                                         with the subject-identifier/psi."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :associate TopicC
+		     :documentation "The actual topic which is associated
+                                     with the subject-identifier/psi."))
   (:index t)
   (:documentation "A pointer that associates subject-identifiers, versions
                    and topics."))
 
 
+(defmethod delete-construct :before ((construct PersistentIdAssociationC))
+  (delete-1-n-association construct 'parent-construct))
+
+
 (defpclass TopicIdAssociationC(PointerAssociationC)
-  ((identified-construct :initarg :identified-construct
-			 :accessor identified-construct
-			 :associate TopicC
-			 :documentation "The actual topic which is associated
-                                         with the topic-identifier."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :associate TopicC
+		     :documentation "The actual topic which is associated
+                                     with the topic-identifier."))
   (:index t)
   (:documentation "A pointer that associates topic-identifiers, versions
                    and topics."))
 
 
+(defmethod delete-construct :before ((construct TopicIdAssociationC))
+  (delete-1-n-association construct 'parent-construct))
+
+
 (defpclass ItemIdAssociationC(PointerAssociationC)
-  ((identified-construct :initarg :identified-construct
-			 :accessor identified-construct
-			 :associate ReifiableConstructC
-			 :documentation "The actual parent which is associated
-                                         with the item-identifier."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :associate ReifiableConstructC
+		     :documentation "The actual parent which is associated
+                                     with the item-identifier."))
   (:index t)
   (:documentation "A pointer that associates item-identifiers, versions
                    and reifiable-constructs."))
 
 
+(defmethod delete-construct :before ((construct ItemIdAssociationC))
+  (delete-1-n-association construct 'parent-construct))
+
+
 (defpclass PointerAssociationC (VersionedAssociationC)
   ((identifier :initarg :identifier
 	       :accessor identifier
@@ -205,6 +263,15 @@
                    pointer-associations."))
 
 
+(defmethod delete-construct :before ((construct PointerAssociationC))
+  "Deletes the association-construct and the pointer if it is not used
+   as an idengtiffier of any other object."
+  (let ((id (slot-p construct 'identifier)))
+    (delete-1-n-association construct 'identifier)
+    (when (= (length (all-identified-constructs id)) 0)
+      (delete-construct id))))
+
+
 (defpclass VersionedAssociationC()
   ()
   (:documentation "An abstract base class for all versioned associations."))
@@ -267,11 +334,34 @@
 	:index t
 	:documentation "The actual value of a pointer, i.e. uri or ID.")
    (identified-construct :initarg :identified-construct
-			 :accessor identified-construct
 			 :associate (PointerAssociationC identifier)))
   (:documentation "An abstract base class for all pointers."))
 
 
+(defgeneric identified-construct (construct &key revision)
+  (:documentation "Returns the identified-construct -> ReifiableConstructC or
+                   TopicC that corresponds with the passed revision.")
+  (:method ((construct PointerC) &key (revision *TM-REVISION*))
+    (let ((results
+	   (map 'list #'parent-construct
+		(filter-slot-value-by-revision construct 'identified-construct
+					       :start-revision revision))))
+      (when results ;result must be nil or a list with one item
+	(first results)))))
+
+
+(defgeneric all-identified-constructs (construct &key with-deleted)
+  (:documentation "Returns all constructs which are associated with this
+                   pointer.")
+  (:method ((construct PointerC) &key (with-deleted t))
+    (let ((all-values (slot-p construct 'identified-construct)))
+      (let ((filtered-values
+	     (if with-deleted 
+		 all-values
+		 (remove-if #'marked-as-deleted-p all-values))))
+	(map 'list #'parent-construct filtered-values)))))
+
+
 ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass ReifiableConstructC(TopicMapConstructC)
   ((item-identifiers :initarg :item-identifiers
@@ -284,9 +374,63 @@
   (:documentation "Reifiable constructs as per TMDM."))
 
 
-;;TODO: implement reader for item-identifiers and reifier (version)
-;;TODO: implement add-item-identifier and add-reifier (version)
+(defgeneric item-identifiers (construct &key revision)
+  (:documentation "Returns the ItemIdentifierC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'item-identifiers :start-revision revision)))
+      (map 'list #'identifier assocs))))
+
+
+(defgeneric reifier (construct &key revision)
+  (:documentation "Returns the reifier-topic that corresponds
+                   with the passed construct and the passed version.")
+  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'item-identifiers :start-revision revision)))
+      (when assocs ;assocs must be nil or a list with exactly one item
+	(reifier (first assocs))))))
+
+
+(defmethod delete-construct :before ((construct ReifiableConstructC))
+  "Deletes the passed construct its item-identifiers and its
+   reifiers. An item-identifier and a reifeir is only deleted
+   when these constructs are not referenced by other parent-objects."
+  (dolist (item-identifier (slot-p construct 'item-identifiers))
+    (delete-construct item-identifier))
+  (dolist (reifier-top (slot-p construct 'reifier))
+    (delete-construct reifier-top)))
+
+
+(defgeneric add-item-identifier (construct item-identifier &key revision)
+  (:documentation "Adds the passed item-identifier to the passed construct.
+                   If the item-identifier is already related with the passed
+                   construct a new revision is added.")
+  (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
+	    &key (revision *TM-REVISION*))
+    (let ((all-constructs
+	   (all-identified-constructs item-identifier
+				      :with-deleted nil)))
+      (cond ((find construct all-constructs)
+	     (let ((ii-assoc
+		    (loop for ii-assoc in (slot-p construct 'item-identifiers)
+			 when (eql (identifier ii-assoc) item-identifier)
+			 return ii-assoc)))
+	       (add-to-version-history ii-assoc :start-revision revision)))
+	    (all-constructs
+	     (merge-constructs (first all-constructs) (second all-constructs)))
+	    (t
+	     (make-construct 'ItemIdAssociationC
+			     :start-revision revision
+			     :parent-construct construct
+			     :identifier item-identifier))))
+    item-identifier))
+
 
+;;TODO: implement add-reifier (version)
+;;TODO: implement make-construct (symbol)
+;;TODO: implement merge-construct
 
 ;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass TopicMapConstructC()



From lgiessmann at common-lisp.net  Sat Feb 13 13:07:20 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 13 Feb 2010 08:07:20 -0500
Subject: [isidorus-cvs] r185 - branches/new-datamodel/src/model
Message-ID: <E1NgHiS-0008NC-8l@common-lisp.net>

Author: lgiessmann
Date: Sat Feb 13 08:07:13 2010
New Revision: 185

Log:
new-datamodel: added some functionality to the new existing classes -> identifiers, indetifier-associations, reifiable-construct

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	Sat Feb 13 08:07:13 2010
@@ -9,10 +9,75 @@
 
 (defpackage :datamodel
   (:use :cl :elephant :constants)
-  (:nicknames :d))
+  (:nicknames :d)
+  (:export ;;classes
+           :PersistenIdC
+	   :ItemIdentifierC
+	   :SubjectLocatorC
+	   :TopicIdentificationC
+	   :TopicC
+
+	   ;;methods and functions
+	   :xtm-id
+	   :uri
+	   :identifieid-construct
+	   :all-identified-constructs
+	   :item-identifiers
+	   :reifier
+	   :add-item-identifier
+	   :add-reifier
+	   :find-item-by-revision
+
+	   ;;globals
+	   :*TM-REVISION*))
 
 (in-package :datamodel)
 
+
+
+;;TODO: implement all-reified-constructs (:with-deleted t) -> TopicC
+;;      the method should return all reifed-constructs of the given topic
+;;TODO: implement make-construct -> symbol
+;;      replace the latest make-construct-method
+;;TODO: implement merge-construct -> ReifiableConstructC -> ...
+;;      the method should merge two constructs that are inherited from
+;;      ReifiableConstructC
+;;TODO: implement find-item-by-revision for all classes that don't have their
+;;      one revision-infos
+
+
+;;; hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;;;;;;;
+(defpclass TopicC (TopicMapConstructC)
+  ()
+  (:documentation "A temporary emtpy class to avoid compiler-errors."))
+
+(defgeneric merge-constructs(construc-1 construct-2 &key revision)
+  (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+	    &key (revision *TM-REVISION*))
+    (or construct-1 construct-2 revision)))
+
+
+(defgeneric all-reified-constructs(topic &key with-deleted)
+  (:method ((topic TopicC) &key (with-deleted t))
+    (or topic with-deleted)))
+
+
+(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
+  (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*))
+    (or class-symbol start-revision)))
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+
+
+
+
+
+
+
+
 ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defvar *TM-REVISION* 0)
 
@@ -45,6 +110,29 @@
   (drop-instance construct))
 
 
+(defun filter-slot-value-by-revision (construct slot-symbol
+				      &key (start-revision
+					    0 start-revision-provided-p))
+  (declare (symbol slot-symbol) (integer start-revision))
+  (let ((revision
+	 (cond (start-revision-provided-p
+		start-revision)
+	       ((boundp '*TM-REVISION*)
+		*TM-REVISION*)
+	       (t 0)))
+	(properties (slot-p construct slot-symbol)))
+    (cond ((not properties)
+	   nil) ;no properties were found -> nil
+	  ((= 0 revision)
+	   (remove-if #'null
+		      (map 'list #'find-most-recent-revision properties)))
+	  (t
+	   (remove-if #'null
+		      (map 'list #'(lambda(prop)
+				     (find-item-by-revision prop revision))
+			   properties))))))
+
+
 ;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass VersionInfoC()
   ((start-revision :initarg :start-revision
@@ -75,13 +163,6 @@
   (delete-1-n-association version-info 'versioned-construct))
 
 
-(defgeneric versioned-construct-p (version-info)
-  (:documentation "Returns t if the passed object is already bound to a
-                   VersionedObjectC.")
-  (:method ((version-info VersionInfoC))
-    (slot-p version-info 'versioned-construct)))
-
-
 ;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass VersionedConstructC()
   ((versions :initarg :versions
@@ -114,6 +195,30 @@
 	    (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
 
 
+(defgeneric find-most-recent-revision (construct)
+  (:documentation "Returns the latest version-info-object of the passed
+                   construct.")
+  (:method ((construct VersionedConstructC))
+    (when (find 0 (versions construct) :key #'end-revision)
+      construct)))
+
+
+(defgeneric find-item-by-revision (construct revision)
+  (:documentation "Returns the given object if it exists in the passed
+                   version otherwise nil.")
+  (:method ((construct VersionedConstructC) (revision integer))
+    (cond ((= revision 0)
+	   (find-most-recent-revision construct))
+	  (t
+	   (when (find-if
+		  #'(lambda(vi)
+		      (and (>= revision (start-revision vi))
+			   (or (< revision (end-revision vi))
+			       (= 0 (end-revision vi)))))
+		  (versions construct))
+	     construct)))))
+
+
 (defgeneric add-to-version-history (construct &key start-revision end-revision)
   (:documentation "Adds version history to a versioned construct"))
 
@@ -170,11 +275,13 @@
 (defpclass ReifierAssociationC(VersionedAssociationC)
   ((reifiable-construct :initarg :reifiable-construct
 			:accessor reifiable-construct
+			:initform (error "From ReifierAssociation(): reifiable-construct must be set")
 			: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")
 		  :associate TopicC
 		  :documentation "The reifier-topic that reifies the
                                   reifiable-construct."))
@@ -196,6 +303,7 @@
 (defpclass SubjectLocatorAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
+		     :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the subject-locator."))
@@ -211,6 +319,7 @@
 (defpclass PersistentIdAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
+		     :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the subject-identifier/psi."))
@@ -226,6 +335,7 @@
 (defpclass TopicIdAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
+		     :initform (error "From TopicIdAssociationC(): parent-construct must be set")
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the topic-identifier."))
@@ -241,6 +351,7 @@
 (defpclass ItemIdAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
+		     :initform (error "From ItemIDAssociationC(): parent-construct must be set")
 		     :associate ReifiableConstructC
 		     :documentation "The actual parent which is associated
                                      with the item-identifier."))
@@ -256,6 +367,7 @@
 (defpclass PointerAssociationC (VersionedAssociationC)
   ((identifier :initarg :identifier
 	       :accessor identifier
+	       :initform (error "From VersionedAssociationC(): identifier must be set")
 	       :associate PointerC
 	       :documentation "The actual data that is associated with
                                the pointer-association's parent."))
@@ -342,12 +454,12 @@
   (:documentation "Returns the identified-construct -> ReifiableConstructC or
                    TopicC that corresponds with the passed revision.")
   (:method ((construct PointerC) &key (revision *TM-REVISION*))
-    (let ((results
+    (let ((assocs
 	   (map 'list #'parent-construct
 		(filter-slot-value-by-revision construct 'identified-construct
 					       :start-revision revision))))
-      (when results ;result must be nil or a list with one item
-	(first results)))))
+      (when assocs ;result must be nil or a list with one item
+	(first assocs)))))
 
 
 (defgeneric all-identified-constructs (construct &key with-deleted)
@@ -406,7 +518,9 @@
 (defgeneric add-item-identifier (construct item-identifier &key revision)
   (:documentation "Adds the passed item-identifier to the passed construct.
                    If the item-identifier is already related with the passed
-                   construct a new revision is added.")
+                   construct a new revision is added.
+                   If the passed identifer already identifies another object
+                   the identified-constructs are merged.")
   (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
 	    &key (revision *TM-REVISION*))
     (let ((all-constructs
@@ -417,1696 +531,52 @@
 		    (loop for ii-assoc in (slot-p construct 'item-identifiers)
 			 when (eql (identifier ii-assoc) item-identifier)
 			 return ii-assoc)))
-	       (add-to-version-history ii-assoc :start-revision revision)))
+	       (add-to-version-history ii-assoc :start-revision revision)
+	       construct))
 	    (all-constructs
-	     (merge-constructs (first all-constructs) (second all-constructs)))
+	     (merge-constructs (first all-constructs) construct))
 	    (t
 	     (make-construct 'ItemIdAssociationC
 			     :start-revision revision
 			     :parent-construct construct
-			     :identifier item-identifier))))
-    item-identifier))
+			     :identifier item-identifier)
+	     construct)))))
+
 
+(defgeneric add-reifier (construct reifier-topic &key revision)
+  (:documentation "Adds the passed reifier-topic as reifier of the construct.
+                   If the construct is already reified by the given topic
+                   there only is added a new version-info.
+                   If the reifier-topic reifies already another construct
+                   the reified-constructs are merged.")
+  (:method ((construct ReifiableConstructC) (reifier-topic TopicC)
+	    &key (revision *TM-REVISION*))
+    (let ((merged-reifier-topic
+	   (when (reifier construct)
+	     (merge-constructs (reifier construct) reifier-topic))))
+      (let ((all-constructs
+	     (all-reified-constructs merged-reifier-topic :with-deleted nil)))
+	(cond ((find construct all-constructs)
+	       (let ((reifier-assoc
+		      (loop for reifier-assoc in
+			   (slot-p merged-reifier-topic 'reified-construct)
+			 when (eql (reifiable-construct reifier-assoc)
+				   construct)
+			 return reifier-assoc)))
+		 (add-to-version-history reifier-assoc :start-revision revision)
+		 construct))
+	      (all-constructs
+	       (merge-constructs (first all-constructs) construct))
+	      (t
+	       (make-construct 'ReifierAssociationC
+			       :start-revision revision
+			       :reifiable-construct construct
+			       :reifier-topic merged-reifier-topic)
+	       construct))))))
 
-;;TODO: implement add-reifier (version)
-;;TODO: implement make-construct (symbol)
-;;TODO: implement merge-construct
 
 ;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass TopicMapConstructC()
   ()
   (:documentation "An abstract base class for all classes that describes
                    Topic Maps data."))
-
-
-
-
-
-
-
-
-
-
-;;  (:import-from :exceptions
-;;                missing-reference-error
-;;                no-identifier-error
-;;                duplicate-identifier-error
-;;                object-not-found-error)
-;;  (:export :AssociationC ;; types
-;;           :CharacteristicC
-;;           :FragmentC
-;;           :IdentifierC
-;;           :IdentityC 
-;;           :ItemIdentifierC
-;;           :NameC
-;;           :OccurrenceC
-;;           :PersistentIdC
-;;           :ReifiableConstructC
-;;           :RoleC
-;;           :ScopableC
-;;           :SubjectLocatorC
-;;           :TopicC
-;;           :TopicIdentificationC
-;;           :TopicMapC
-;;	   :TopicMapConstructC 
-;;	   :TypableC
-;;	   :VariantC
-;;
-;;           ;; functions and slot accessors
-;;           :in-topicmaps
-;;           :add-to-topicmap
-;;           :add-source-locator
-;;           :associations
-;;           :changed-p
-;;           :charvalue
-;;           :check-for-duplicate-identifiers
-;;           :datatype
-;;           :equivalent-constructs
-;;           :find-item-by-revision
-;;           :find-most-recent-revision
-;;           :get-all-revisions
-;;           :get-all-revisions-for-tm
-;;           :get-fragment
-;;           :get-fragments
-;;           :get-revision
-;;           :get-item-by-content
-;;           :get-item-by-id
-;;           :get-item-by-item-identifier
-;;           :get-item-by-psi
-;;           :identified-construct
-;;           :identified-construct-p
-;;           :in-topicmap
-;;           :internal-id
-;;           :instance-of
-;;           :instance-of-p
-;;           :item-identifiers
-;;           :item-identifiers-p
-;;           :list-instanceOf
-;;	   :list-super-types
-;;           :locators
-;;           :locators-p
-;;           :make-construct
-;;           :mark-as-deleted
-;;           :names
-;;           :namevalue
-;;           :occurrences
-;;	   :name
-;;           :parent
-;;           :player
-;;           :player-in-roles
-;;           :players
-;;           :psis
-;;           :psis-p
-;;           :referenced-topics
-;;           :revision
-;;           :RoleC-p
-;;           :roleid
-;;           :roles
-;;           :themes
-;;           :xtm-id
-;;           :xtm-id-p
-;;           :topic
-;;           :topicid
-;;           :topic-identifiers
-;;           :topics
-;;           :unique-id
-;;	   :uri 
-;;	   :uri-p
-;;	   :used-as-type
-;;	   :used-as-theme
-;;	   :variants
-;;	   :xor
-;;           :create-latest-fragment-of-topic
-;;	   :reified
-;;	   :reifier
-;;	   :add-reifier
-;;	   :remove-reifier
-;;
-;;           :*current-xtm* ;; special variables
-;;           :*TM-REVISION*
-;;
-;;           :with-revision ;;macros
-;;
-;;	   :string-starts-with ;;helpers
-;;           ))
-;;
-;;(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))
-;;(in-package :datamodel)
-;;
-;;(defparameter *current-xtm* nil "Represents the currently active TM")
-;;
-;;(defmacro find-max-elem (candidate-list &key (relop #'> relop-p) (key #'identity key-p))
-;;  "Given a non-empty list, return the maximum element in the list.
-;;   If provided, then relop must be a relational operator that determines the ordering;
-;;   else #'> is used. The keyword parameter key may name a function that is used to extract
-;;   the sort key; otherwise the elements themselves are the sort keys."
-;;  (let
-;;      ((candidate-list-value-name (gensym))
-;;       (relop-value-name (gensym))
-;;       (key-value-name (gensym))
-;;       (best-seen-cand-name (gensym))
-;;       (max-key-name (gensym))
-;;       (inspected-cand-name (gensym))
-;;       (inspected-key-name (gensym)))
-;;    (let
-;;        ((max-key-init (if key-p
-;;                           `(funcall ,key-value-name ,best-seen-cand-name)
-;;                           best-seen-cand-name))
-;;         (inspected-key-init (if key-p
-;;                                 `(funcall ,key-value-name ,inspected-cand-name)
-;;                                 inspected-cand-name))
-;;         (relexp (if relop-p
-;;                     `(funcall ,relop-value-name ,inspected-key-name ,max-key-name)
-;;                     `(> ,inspected-key-name ,max-key-name))))
-;;      (let
-;;          ((initializers `((,candidate-list-value-name ,candidate-list)
-;;                           (,best-seen-cand-name (first ,candidate-list-value-name))
-;;                           (,max-key-name ,max-key-init))))
-;;        (when relop-p
-;;          (push `(,relop-value-name ,relop) initializers))
-;;        (when key-p
-;;          (push `(,key-value-name ,key) initializers))
-;;        `(let*
-;;          ,initializers
-;;          (dolist (,inspected-cand-name (rest ,candidate-list-value-name))
-;;            (let
-;;                ((,inspected-key-name ,inspected-key-init))
-;;              (when ,relexp
-;;                (setf ,best-seen-cand-name ,inspected-cand-name)
-;;                (setf ,max-key-name ,inspected-key-name))))
-;;          ,best-seen-cand-name)))))
-;;
-;;(defvar *TM-REVISION* 0)
-;;
-;;(defmacro with-revision (revision &rest body)
-;;  `(let
-;;    ((*TM-REVISION* ,revision))
-;;                                        ;(format t "*TM-REVISION* is ~a~&" *TM-REVISION*)
-;;    , at body))
-;;    
-;;
-;;(defmacro slot-predicate (instance slot)
-;;  (let
-;;      ((inst-name (gensym))
-;;       (slot-name (gensym)))
-;;    `(let
-;;      ((,inst-name ,instance)
-;;       (,slot-name ,slot))
-;;      (and (slot-boundp ,inst-name ,slot-name)
-;;       (slot-value ,inst-name ,slot-name)))))
-;;
-;;(defmacro delete-1-n-association (instance slot)
-;;  (let
-;;      ((inst-name (gensym))
-;;       (slot-name (gensym)))
-;;    `(let
-;;      ((,inst-name ,instance)
-;;       (,slot-name ,slot))
-;;      (when (slot-predicate ,inst-name ,slot-name)
-;;        (elephant:remove-association ,inst-name ,slot-name (slot-value ,inst-name ,slot-name))))))
-;;
-;;(defun xor (a1 a2)
-;;  (and (or a1 a2) (not (and a1 a2)))
-;;  )
-;;
-;;(defun remove-nil-values (plist)
-;;  (let
-;;      ((result nil))
-;;    (do* ((rest plist (cddr rest))
-;;          (key (first rest) (first rest))
-;;          (val (second rest) (second rest)))
-;;         ((null rest))
-;;      (when val
-;;        (pushnew val result)
-;;        (pushnew key result)))
-;;    result))
-;;
-;;(defun get-revision ()
-;;  "TODO: replace by something that does not suffer from a 1 second resolution."
-;;  (get-universal-time))
-;;
-;;(defgeneric delete-construct (construct)
-;;  (:documentation "drops recursively construct and all its dependent objects from the elephant store"))
-;;
-;;(defmethod delete-construct ((construct elephant:persistent))
-;;  nil)
-;;
-;;(defmethod delete-construct :after ((construct elephant:persistent))
-;;  (elephant:drop-instance construct))
-;;
-;;(defgeneric find-all-equivalent (construct)
-;;  (:method ((construct t)) nil)
-;;  (:documentation "searches an existing object that is equivalent (but not identical) to construct"))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; VersionInfoC
-;;
-;;
-;;(elephant:defpclass VersionInfoC ()
-;;  ((start-revision :accessor start-revision
-;;                   :initarg :start-revision
-;;                   :type integer
-;;                   :initform 0          ;TODO: for now
-;;                   :documentation "The first revison this AssociationC instance is associated with.")
-;;   (end-revision :accessor end-revision
-;;                 :initarg :end-revision
-;;                 :type integer
-;;                 :initform 0            ;TODO: for now
-;;                 :documentation "The first revison this AssociationC instance is no longer associated with.")
-;;   (versioned-construct :associate TopicMapConstructC
-;;                        :accessor versioned-construct
-;;                        :initarg :versioned-construct
-;;                        :documentation "reifiable construct that is described by this info"))
-;;  (:documentation "Version Info for individual revisions"))
-;;
-;;(defgeneric versioned-construct-p (vi)
-;;  (:documentation "t if this version info is already bound to a TM construct")
-;;  (:method ((vi VersionInfoC)) (slot-predicate vi 'versioned-construct)))
-;;
-;;(defmethod delete-construct :before ((vi VersionInfoC))
-;;  (delete-1-n-association vi 'versioned-construct))
-;;
-;;(defgeneric get-most-recent-version-info (construct))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; ItemIdentifierC
-;;
-;;(elephant:defpclass ItemIdentifierC (IdentifierC) 
-;;  ()
-;;  (:index t)
-;;  (:documentation "Represents an item identifier"))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; SubjectLocator
-;;
-;;(elephant:defpclass SubjectLocatorC (IdentifierC)
-;;  ((identified-construct :accessor identified-construct
-;;                         :initarg :identified-construct
-;;                         :associate TopicC))
-;;  (:index t)
-;;  (:documentation "Represents a subject locator"))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; IdentifierC
-;;
-;;(elephant:defpclass IdentifierC (PointerC)
-;;  ()
-;;  (:documentation "Abstract base class for ItemIdentifierC and
-;;  PersistentIdC, primarily in view of the equality rules"))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; PointerC
-;;
-;;(elephant:defpclass PointerC (TopicMapConstructC)
-;;  ((uri :accessor uri
-;;        :initarg :uri
-;;        :type string
-;;        :initform (error "The uri must be set for a pointer")
-;;        :index t)
-;;   (identified-construct :accessor identified-construct
-;;                         :initarg :identified-construct
-;;                         :associate ReifiableConstructC))
-;;  (:documentation "Abstract base class for all types of pointers and identifiers"))
-;;
-;;(defmethod delete-construct :before ((construct PointerC))
-;;  (delete-1-n-association construct 'identified-construct))
-;;
-;;(defmethod find-all-equivalent ((construct PointerC))
-;;  (delete construct
-;;          (elephant:get-instances-by-value (class-of construct)
-;;                                           'uri
-;;                                           (uri construct))
-;;          :key #'internal-id))
-;;(defgeneric uri-p (construct)
-;;  (:documentation "Check if the slot uri is bound in an identifier and not nil")
-;;  (:method ((identifier PointerC)) (slot-predicate identifier 'uri)))
-;;
-;;(defgeneric identified-construct-p (construct)
-;;  (:documentation "Check if the slot identified-construct is bound in an identifier and not nil")
-;;  (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct)))
-;;
-;;(defmethod print-object ((identifier PointerC) stream)
-;;  (format stream 
-;;          "~a(href: ~a; Construct: ~a)"
-;;          (class-name (class-of identifier))
-;;          (if (uri-p identifier)
-;;              (uri identifier)
-;;              "URI UNDEFINED")
-;;          (if (identified-construct-p identifier)
-;;              (identified-construct identifier) 
-;;              "SLOT UNBOUND")))
-;;
-;;(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC))
-;;  (string= (uri identifier1) (uri identifier2)))
-;;
-;;(defmethod initialize-instance :around ((identifier PointerC) &key
-;;                                        (start-revision (error "Start revision must be present") )
-;;                                        (end-revision 0))
-;;  (call-next-method)
-;;  (add-to-version-history identifier
-;;                          :start-revision start-revision
-;;                          :end-revision end-revision)
-;;  identifier)
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; TopicMapConstrucC
-;;
-;;
-;;(elephant:defpclass TopicMapConstructC ()
-;;  ((versions :associate (VersionInfoC versioned-construct)
-;;             :accessor versions
-;;             :initarg :versions
-;;             :documentation "version infos for former versions of this reifiable construct")))
-;;
-;;                                        ;TODO: if, one day, we allow merges of already existing constructs, we'll need
-;;                                        ;a tree of predecessors rather then just a list of versions. A case in point
-;;                                        ;may be if a newly imported topic carries the PSIs of two existing topics,
-;;                                        ;thereby forcing a merge post factum"
-;;
-;;(defmethod delete-construct :before ((construct TopicMapConstructC))
-;;  (dolist (versioninfo (versions construct))
-;;    (delete-construct versioninfo)))
-;;
-;;
-;;(defgeneric add-to-version-history (construct &key start-revision end-revision)
-;;  (:documentation "Add version history to a topic map construct"))
-;;
-;;(defmethod add-to-version-history ((construct TopicMapConstructC) 
-;;                                   &key 
-;;                                   (start-revision (error "Start revision must be present") )
-;;                                   (end-revision 0))
-;;  "Adds relevant information to a construct's version info"
-;;  (let
-;;      ((current-version-info
-;;        (get-most-recent-version-info construct)))
-;;    (cond
-;;      ((and current-version-info 
-;;           (= (end-revision current-version-info) start-revision)) ;the item was just marked as deleted
-;;       (setf (end-revision current-version-info) 0) ;just revitalize it, do not create a new version
-;;       current-version-info)  ;TODO: this is not quite correct, the topic
-;;                              ;might be recreated with new item
-;;                              ;identifiers. Consider adding a new parameter
-;;                              ;"revitalize"
-;;      ((and 
-;;        current-version-info 
-;;        (= (end-revision current-version-info) 0))
-;;       (setf (end-revision current-version-info) start-revision)
-;;       (make-instance 
-;;        'VersionInfoC 
-;;        :start-revision start-revision
-;;        :end-revision end-revision
-;;        :versioned-construct construct))
-;;      (t
-;;       (make-instance 
-;;        'VersionInfoC 
-;;        :start-revision start-revision
-;;        :end-revision end-revision
-;;        :versioned-construct construct)))))
-;;
-;;(defgeneric revision (constr)
-;;  (:documentation "Essentially a convenience method for start-revision"))
-;;
-;;(defmethod revision ((constr TopicMapConstructC))
-;;  (start-revision constr))
-;;
-;;(defmethod (setf revision) ((constr TopicMapConstructC) (revision integer))
-;;  (setf (start-revision constr) revision))
-;;
-;;
-;;(defgeneric find-item-by-revision (constr revision)
-;;  (:documentation "Get a given version of a construct (if any, nil if none can be found)"))
-;;
-;;(defmethod find-item-by-revision ((constr TopicMapConstructC) (revision integer))
-;;  (cond
-;;    ((= revision 0)
-;;     (find-most-recent-revision constr))
-;;    (t
-;;     (when (find-if
-;;            (lambda(version) 
-;;              (and (>= revision (start-revision version))
-;;                   (or
-;;		    (< revision (end-revision version))
-;;		    (= 0 (end-revision version)))))
-;;            (versions constr))
-;;       constr))))
-;;
-;;(defgeneric find-most-recent-revision (construct)
-;;  (:documentation "Get the most recent version of a construct (nil if
-;;the construct doesn't have versions yet or not anymore)"))
-;;
-;;(defmethod find-most-recent-revision ((construct TopicMapConstructC))
-;;  (when (find 0 (versions construct) :key #'end-revision)
-;;    construct))
-;;
-;;(defmethod delete-construct :before ((construct TopicMapConstructC))
-;;  (dolist (versionInfo (versions construct))
-;;    (delete-construct versionInfo)))
-;;
-;;
-;;(defgeneric check-for-duplicate-identifiers (top)
-;;  (:documentation "Check for possibly duplicate identifiers and signal an
-;;  duplicate-identifier-error is such duplicates are found"))
-;;
-;;(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC))
-;;  (declare (ignore construct))
-;;                                        ;do nothing
-;;  )
-;;
-;;(defgeneric filter-slot-value-by-revision (construct slot-name &key start-revision)
-;;  (:documentation "filter slot values by a given revision that is
-;;  either provided directly through the keyword argument start-revision
-;;  or through a bound variable named '*TM-REVISION*'"))
-;;
-;;(defmethod filter-slot-value-by-revision ((construct TopicMapConstructC) (slot-name symbol) &key (start-revision 0 start-revision-provided-p))
-;;  (let
-;;      ((revision            ;avoids warnings about undefined variables
-;;        (cond
-;;          (start-revision-provided-p
-;;           start-revision)
-;;          ((boundp '*TM-REVISION*)
-;;           (symbol-value '*TM-REVISION*))
-;;          (t 0)))
-;;       (properties (slot-value construct slot-name)))
-;;       ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision)
-;;    (cond
-;;      ((not properties) 
-;;       nil)   ;if we don't have any properties, we don't have to worry
-;;              ;about revisions
-;;      ((= 0 revision)
-;;       (remove 
-;;        nil
-;;        (map 'list #'find-most-recent-revision
-;;             properties)))
-;;      (t
-;;       (remove nil
-;;               (map 'list 
-;;                    (lambda (constr)
-;;                      (find-item-by-revision constr revision))
-;;                    properties))))))
-;;
-;;(defgeneric make-construct (classsymbol &key start-revision &allow-other-keys)
-;;  (:documentation "create a new topic map construct if necessary or
-;;retrieve an equivalent one if available and update the revision
-;;history accordingly. Return the object in question. Methods use
-;;specific keyword arguments for their purpose"))
-;;
-;;(defmethod make-construct ((classsymbol symbol) &rest args
-;;                           &key start-revision)
-;;  (let*
-;;      ((cleaned-args (remove-nil-values args))
-;;       (new-construct (apply #'make-instance classsymbol cleaned-args))
-;;       (existing-construct (first (find-all-equivalent new-construct))))
-;;    (if existing-construct
-;;        (progn
-;;                                        ;change over new item identifiers to the old construct
-;;          (when  (copy-item-identifiers
-;;                  new-construct existing-construct)
-;;                 ;an existing construct other than a topic (which is handled
-;;                 ;separatedly below) has changed only if it has received a new
-;;                 ;item identifier
-;;            (add-to-version-history existing-construct :start-revision start-revision))
-;;          (delete-construct new-construct)
-;;          existing-construct)
-;;        (progn
-;;          (add-to-version-history new-construct :start-revision start-revision)
-;;          (check-for-duplicate-identifiers new-construct)
-;;          new-construct))))
-;;    
-;;(defmethod get-most-recent-version-info ((construct TopicMapConstructC))
-;;  (let ((result (find 0 (versions construct) :key #'end-revision)))
-;;    (if result
-;;	result ;current version-info -> end-revision = 0
-;;	(let ((sorted-list (sort (versions construct)
-;;				 #'(lambda(x y)
-;;				     (> (end-revision x) (end-revision y))))))
-;;	  (when sorted-list
-;;	    (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
-;;
-;;(defgeneric equivalent-constructs (construct1 construct2)
-;;  (:documentation "checks if two topic map constructs are equal according to the TMDM equality rules"))
-;;
-;;(defgeneric strictly-equivalent-constructs (construct1 construct2)
-;;  (:documentation "checks if two topic map constructs are not identical but equal according to the TMDM equality rules")
-;;  (:method ((construct1 TopicMapConstructC) (construct2 TopicMapConstructC))
-;;    (and (equivalent-constructs construct1 construct2)
-;;         (not (eq construct1 construct2)))))
-;;
-;;(defgeneric internal-id (construct)
-;;  (:documentation "returns the internal id that uniquely identifies a
-;;  construct (currently simply its OID)"))
-;;
-;;(defmethod internal-id ((construct TopicMapConstructC))
-;;  (slot-value construct (find-symbol "OID" 'elephant)))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; TopicIdentificationC
-;;
-;;(elephant:defpclass TopicIdentificationC (PointerC) 
-;;  ((xtm-id 
-;;    :accessor xtm-id
-;;    :type string
-;;    :initarg :xtm-id
-;;    :index t
-;;    :documentation "ID of the TM this identification came from"))
-;;  (:documentation "Identify topic items through generalized
-;;  topicids. A topic may have many original topicids, the class
-;;  representing one of them") )
-;;
-;;(defmethod find-all-equivalent ((construct TopicIdentificationC))
-;;  (delete (xtm-id construct) (call-next-method) :key #'xtm-id :test #'string=))
-;;
-;;(defun init-topic-identification (top id xtm-id &key (revision *TM-REVISION*))
-;;  "create a TopicIdentification object (if necessary) and initialize it with the
-;;  combination of the current topicid and the ID of the current XTM id"
-;;                                        ;(declare (TopicC top))
-;;  (declare (string id))
-;;
-;;  (flet    ;prevent unnecessary copies of TopicIdentificationC objects
-;;      ((has-topic-identifier (top uri xtm-id)
-;;         (remove-if-not
-;;          (lambda (ident)
-;;            (and (string= (uri ident) uri)
-;;                 (string= (xtm-id ident) xtm-id)))
-;;          (topic-identifiers top))))
-;;    (unless (has-topic-identifier top id xtm-id)
-;;      (let
-;;          ((ti
-;;            (make-instance 
-;;             'TopicIdentificationC
-;;             :uri id
-;;             :xtm-id xtm-id
-;;             :identified-construct top
-;;             :start-revision revision)))
-;;           ;(add-to-version-history ti :start-revision revision)
-;;           ti))))
-;;
-;;(defun xtm-id-p (xtm-id)
-;;  "checks if a xtm-id has been used before"
-;;  (elephant:get-instance-by-value 'TopicIdentificationC
-;;                                  'xtm-id xtm-id))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; PSI
-;;
-;;(elephant:defpclass PersistentIdC (IdentifierC) 
-;;  ((identified-construct :accessor identified-construct
-;;                         :initarg :identified-construct
-;;                         :associate TopicC))
-;;  (:index t)
-;;  (:documentation "Represents a PSI"))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; ReifiableConstructC
-;;
-;;(elephant:defpclass ReifiableConstructC (TopicMapConstructC)
-;;  ((item-identifiers 
-;;    :associate (ItemIdentifierC identified-construct)
-;;    :inherit t
-;;    :documentation "Slot that realizes a 1 to N
-;;                     relation between reifiable constructs and their
-;;                     identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")
-;;   (reifier
-;;    :associate TopicC
-;;    :inherit t
-;;    :documentation "Represents a reifier association to a topic, i.e.
-;;                   it stands for a 1:1 association between this class and TopicC"))
-;;  (:documentation "Reifiable constructs as per TMDM"))
-;;
-;;
-;;(defgeneric reifier (construct &key revision)
-;;  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
-;;    (when (slot-boundp construct 'reifier)
-;;      (slot-value construct 'reifier))))
-;;
-;;(defgeneric (setf reifier) (topic TopicC)
-;;  (:method (topic (construct ReifiableConstructC))
-;;    (setf (slot-value construct 'reifier) topic)))
-;;;    (setf (reified topic) construct)))
-;;
-;;(defgeneric item-identifiers (construct &key revision)
-;;  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))
-;;
-;;(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil))
-;;  "adds associations to these ids after the instance was initialized."
-;;  (declare (list item-identifiers))
-;;  (call-next-method)
-;;  (dolist (id item-identifiers)
-;;    (declare (ItemIdentifierC id))
-;;    (setf (identified-construct id) instance))
-;;  (when reifier
-;;    (add-reifier instance reifier))
-;;    ;(setf (reifier instance) reifier))
-;;  instance)
-;;
-;;(defmethod delete-construct :before ((construct ReifiableConstructC))
-;;  (dolist (id (item-identifiers construct))
-;;    (delete-construct id))
-;;  (when (reifier construct)
-;;    (let ((reifier-topic (reifier construct)))
-;;      (remove-reifier construct)
-;;      (delete-construct reifier-topic))))
-;;
-;;(defgeneric item-identifiers-p (constr)
-;;  (:documentation "Test for the existence of item identifiers")
-;;  (:method ((construct ReifiableConstructC)) (slot-predicate construct 'item-identifiers)))
-;;
-;;(defgeneric topicid (construct &optional xtm-id)
-;;  (:documentation "Return the ID of a construct"))
-;;
-;;(defmethod revision ((constr ReifiableConstructC))
-;;  (start-revision constr))
-;;
-;;(defgeneric (setf revision) (revision construct)
-;;  (:documentation "The corresponding setter method"))
-;;
-;;(defmethod (setf revision) ((revision integer) (constr ReifiableConstructC))
-;;  (setf (start-revision constr) revision))
-;;
-;;(defgeneric get-all-identifiers-of-construct (construct)
-;;  (:documentation "Get all identifiers that a given construct has"))
-;;
-;;(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC))
-;;  (item-identifiers construct))
-;;
-;;(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC))
-;;  (dolist (id (get-all-identifiers-of-construct construct))
-;;    (when (> (length 
-;;              (union 
-;;               (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id))
-;;               (union 
-;;                (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
-;;                (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
-;;             1)
-;;      (error 
-;;       (make-condition 'duplicate-identifier-error 
-;;                       :message (format nil "Duplicate Identifier ~a has been found" (uri id))
-;;                       :uri (uri id))))))
-;;
-;;(defmethod copy-item-identifiers ((from-construct ReifiableConstructC)
-;;                                  (to-construct ReifiableConstructC))
-;;  "Internal method to copy over item idenfiers from a construct to
-;;another on. Returns the set of new identifiers"
-;;  (mapc
-;;   (lambda (identifier)
-;;     (setf (identified-construct identifier) 
-;;           to-construct))
-;;   (set-difference (item-identifiers from-construct)
-;;                   (item-identifiers to-construct)
-;;                   :key #'uri :test #'string=)))
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; ScopableC
-;;
-;;(elephant:defpclass ScopableC ()
-;;  ((themes :accessor themes
-;;           :associate (TopicC used-as-theme)
-;;           :inherit t
-;;           :many-to-many t
-;;           :documentation "list of this scope's themes; pseudo-initarg is :themes")))
-;;
-;;(defmethod initialize-instance :around ((instance ScopableC) &key (themes nil))
-;;  (declare (list themes))
-;;  (call-next-method)
-;;  (dolist (theme themes)
-;;    (elephant:add-association instance 'themes theme))
-;;  instance)
-;;
-;;(defmethod delete-construct :before ((construct ScopableC))
-;;  (dolist (theme (themes construct))
-;;    (elephant:remove-association construct 'themes theme)))
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; TypableC
-;;
-;;(elephant:defpclass TypableC ()
-;;  ((instance-of :accessor instance-of
-;;                :initarg :instance-of
-;;                :associate TopicC
-;;                :inherit t
-;;                :documentation "topic that this construct is an instance of")))
-;;
-;;(defmethod delete-construct :before ((construct TypableC))
-;;  (when (instance-of-p construct)
-;;    (elephant:remove-association construct 'instance-of (instance-of construct))))
-;;
-;;(defgeneric instance-of-p (construct)
-;;  (:documentation "is the instance-of slot bound and not nil")
-;;  (:method ((construct TypableC)) (slot-predicate construct 'instance-of)))
-;;
-;;
-;;;; (defmethod equivalent-constructs ((scope1 ScopeC) (scope2 ScopeC))
-;;;;   "scopes are equal if their themes are equal"
-;;;;   (let
-;;;;       ((themes1 
-;;;;  (map 'list #'internal-id (themes scope1)))
-;;;;        (themes2
-;;;;  (map 'list #'internal-id (themes scope2))))
-;;;;     (not (set-exclusive-or themes1 themes2 :key #'internal-id))))
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; CharacteristicC
-;;       
-;;
-;;(elephant:defpclass CharacteristicC (ReifiableConstructC ScopableC TypableC)
-;;  ((topic :accessor topic
-;;          :initarg :topic
-;;          :associate TopicC
-;;          :documentation "The topic that this characteristic belongs to")
-;;   (charvalue :accessor charvalue
-;;              :type string
-;;              :initarg :charvalue
-;;              :index t
-;;              :documentation "the value of the characteristic in the given scope"))
-;;  (:documentation "Scoped characteristic of a topic (meant to be used
-;;  as an abstract class)"))
-;;
-;;(defgeneric CharacteristicC-p (object)
-;;  (:documentation "test if object is a of type CharacteristicC")
-;;  (:method ((object t)) nil)
-;;  (:method ((object CharacteristicC)) object))
-;;
-;;(defmethod delete-construct :before ((construct CharacteristicC))
-;;  (delete-1-n-association construct 'topic))
-;;
-;;(defun get-item-by-content (content &key (revision *TM-REVISION*))
-;;  "Find characteristis by their (atomic) content"
-;;  (flet
-;;      ((get-existing-instances (classname)
-;;         (delete-if-not #'(lambda (constr)
-;;                            (find-item-by-revision constr revision))
-;;                        (elephant:get-instances-by-value classname 'charvalue content))))
-;;    (nconc (get-existing-instances 'OccurenceC)
-;;           (get-existing-instances 'NameC))))
-;;
-;;
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; VariantC
-;;
-;;(elephant:defpclass VariantC (CharacteristicC)
-;;  ((datatype :accessor datatype
-;;             :initarg :datatype
-;;             :initform nil
-;;             :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")
-;;   (name :accessor name
-;;	  :initarg :name
-;;	  :associate NameC
-;;	  :documentation "references the NameC instance which is the owner of this element")))
-;;
-;;
-;;(defgeneric VariantC-p (object)
-;;  (:documentation "test if object is a of type VariantC")
-;;  (:method ((object t)) nil)
-;;  (:method ((object VariantC)) object))
-;;
-;;
-;;(defmethod delete-construct :before ((construct VariantC))
-;;  (delete-1-n-association construct 'name))
-;;
-;;
-;;(defmethod find-all-equivalent ((construct VariantC))
-;;  (let ((parent (and (slot-boundp construct 'name)
-;;                     (name construct))))
-;;    (when parent
-;;      (delete-if-not #'(lambda(x)(strictly-equivalent-constructs construct x))
-;;                     (slot-value parent 'variants)))))
-;;
-;;
-;;(defmethod equivalent-constructs ((variant1 VariantC) (variant2 VariantC))
-;;  "variant items are (TMDM(5.5)-)equal if the values of their
-;;   [value], [datatype], [scope], and [parent] properties are equal"
-;;  (and (string= (charvalue variant1) (charvalue variant2))
-;;       (or (and (not (slot-boundp variant1 'datatype)) (not (slot-boundp variant2 'datatype)))
-;;           (and (slot-boundp variant1 'datatype) (slot-boundp variant2 'datatype)
-;;                (string= (datatype variant1) (datatype variant2))))
-;;       (not (set-exclusive-or (themes variant1) (themes variant2) :key #'internal-id))))
-;;
-;;                        
-;;
-;;         
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; NameC
-;;
-;;(elephant:defpclass NameC (CharacteristicC)
-;;  ((variants ;:accessor variants
-;;	     :associate (VariantC name)))
-;;  (:documentation "Scoped name of a topic"))
-;;
-;;
-;;(defgeneric variants (name &key revision)
-;;  (:method ((name NameC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision name 'variants :start-revision revision)))
-;;
-;;
-;;(defgeneric NameC-p (object)
-;;  (:documentation "test if object is a of type NameC")
-;;  (:method ((object t)) nil)
-;;  (:method ((object NameC)) object))
-;;
-;;
-;;(defmethod find-all-equivalent ((construct NameC))
-;;  (let
-;;      ((parent (and (slot-boundp construct 'topic)
-;;                    (topic construct))))
-;;    (when parent
-;;      (delete-if-not 
-;;       #'(lambda (cand) (strictly-equivalent-constructs construct cand))
-;;       (slot-value parent 'names)))))
-;;
-;;
-;;(defmethod delete-construct :before ((construct NameC))
-;;  (dolist (variant (variants construct))
-;;    (delete-construct variant)))
-;;
-;;
-;;(defmethod equivalent-constructs ((name1 NameC) (name2 NameC))
-;;  "check for the equlity of two names by the TMDM's equality
-;;rules (5.4)"
-;;  (and
-;;   (string= (charvalue name1) (charvalue name2))
-;;   (or (and (instance-of-p name1)
-;;            (instance-of-p name2)
-;;            (= (internal-id (instance-of name1)) 
-;;               (internal-id (instance-of name2))))
-;;       (and (not (instance-of-p name1)) (not (instance-of-p name2))))
-;;   (not (set-exclusive-or (themes name1) (themes name2) :key #'internal-id))))
-;;           
-;;
-;;
-;;
-;;;;;;;;;;;;;;;;
-;;;;
-;;;; OccurrenceC
-;;
-;;(elephant:defpclass OccurrenceC (CharacteristicC)
-;;  ((datatype :accessor datatype
-;;             :initarg :datatype
-;;             :initform nil
-;;             :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)")))
-;;
-;;
-;;(defgeneric OccurrenceC-p (object)
-;;  (:documentation "test if object is a of type OccurrenceC")
-;;  (:method ((object t)) nil)
-;;  (:method ((object OccurrenceC)) object))
-;;
-;;(defmethod find-all-equivalent ((construct OccurrenceC))
-;;  (let
-;;      ((parent (and (slot-boundp construct 'topic)
-;;                    (topic construct))))
-;;    (when parent
-;;      (delete-if-not  #'(lambda (cand) (strictly-equivalent-constructs construct cand))
-;;                      (slot-value parent 'occurrences)))))
-;;
-;;(defmethod equivalent-constructs ((occ1 OccurrenceC) (occ2 OccurrenceC))
-;;  "Occurrence items are equal if the values of their [value], [datatype], [scope], [type], and [parent] properties are equal (TMDM 5.6)"
-;;  (and
-;;   (string= (charvalue occ1) (charvalue occ2))
-;;   (not (set-exclusive-or (themes occ1) (themes occ2) :key #'internal-id))
-;;   (= (internal-id (topic occ1)) (internal-id (topic occ2)))
-;;   (or 
-;;    (and (instance-of-p occ1) (instance-of-p occ2)
-;;         (= 
-;;          (internal-id (instance-of occ1))
-;;          (internal-id (instance-of occ2))))
-;;    (and (not (instance-of-p occ1)) (not (instance-of-p occ2))))))
-;;
-;;
-;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; TopicC
-;;
-;;(elephant:defpclass TopicC (ReifiableConstructC)
-;;  ((topic-identifiers
-;;    :accessor topic-identifiers
-;;    :associate (TopicIdentificationC identified-construct))
-;;   (psis                                ;accessor written below
-;;    :associate (PersistentIdC identified-construct)
-;;    :documentation "list of PSI objects associated with this
-;;         topic")
-;;   (locators
-;;                                        ;accessor written below
-;;    :associate (SubjectLocatorC identified-construct)
-;;    :documentation "an optional URL that (if given) means that this topic is a subject locator")
-;;   (names                               ;accessor written below
-;;    :associate (NameC topic)
-;;    :documentation "list of topic names (as TopicC objects)") 
-;;   (occurrences         ;accessor occurrences explicitly written below
-;;    :associate (OccurrenceC topic)
-;;    :documentation "list of occurrences (as OccurrenceC objects)")
-;;   (player-in-roles            ;accessor player-in-roles written below
-;;    :associate (RoleC player)
-;;    :documentation "the list of all role instances where this topic is a player in")
-;;   (used-as-type                  ;accessor used-as-type written below
-;;    :associate (TypableC instance-of)
-;;    :documentation "list of all constructs that have this topic as their type")
-;;   (used-as-theme                ;accessor used-as-theme written below
-;;    :associate (ScopableC themes)
-;;    :many-to-many t
-;;    :documentation "list of all scopable objects this topic is a theme in")
-;;   (in-topicmaps
-;;    :associate (TopicMapC topics)
-;;    :many-to-many t
-;;    :documentation "list of all topic maps this topic is part of")
-;;   (reified
-;;    :associate ReifiableConstructC
-;;    :documentation "contains a reified object, represented as 1:1 association"))
-;;  (:documentation "Topic in a Topic Map"))
-;;
-;;
-;;(defgeneric reified (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (when (slot-boundp topic 'reified)
-;;      (slot-value topic 'reified))))
-;;
-;;(defgeneric (setf reified) (reifiable ReifiableConstructC)
-;;  (:method (reifiable (topic TopicC))
-;;    (setf (slot-value topic 'reified) reifiable)))
-;;;    (setf (reifier reifiable) topic)))
-;;
-;;(defgeneric occurrences (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision topic 'occurrences :start-revision revision)))
-;;
-;;(defgeneric names (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision topic 'names :start-revision revision)))
-;;
-;;(defgeneric psis (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision 
-;;     topic 'psis :start-revision revision)))
-;;
-;;(defgeneric locators (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision 
-;;     topic 'locators :start-revision revision)))
-;;
-;;(defgeneric player-in-roles (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision 
-;;     topic 'player-in-roles :start-revision revision)))
-;;
-;;(defgeneric used-as-type (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision topic 'used-as-type :start-revision revision)))
-;;
-;;(defgeneric used-as-theme (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision)))
-;;
-;;(defgeneric in-topicmaps (topic &key revision)
-;;  (:method ((topic TopicC) &key (revision *TM-REVISION*))
-;;    (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)))
-;;
-;;(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers))
-;;  "Moves all identifiers from the source-topic to the destination topic."
-;;  (declare (TopicC destination-topic source-topic))
-;;  (let ((all-source-identifiers
-;;	 (cond
-;;	   ((eql what 'item-identifiers)
-;;	    (item-identifiers source-topic))
-;;	   ((eql what 'locators)
-;;	    (locators source-topic))
-;;	   (t
-;;	    (psis source-topic))))
-;;	(all-destination-identifiers
-;;	 (cond
-;;	   ((eql what 'item-identifiers)
-;;	    (item-identifiers destination-topic))
-;;	   ((eql what 'locators)
-;;	    (locators destination-topic))
-;;	   ((eql what 'psis)
-;;	    (psis destination-topic))
-;;	   ((eql what 'topic-identifiers)
-;;	    (topic-identifiers destination-topic)))))
-;;    (let ((identifiers-to-move
-;;	   (loop for id in all-source-identifiers
-;;	      when (not (find-if #'(lambda(x)
-;;				     (if (eql what 'topic-identifiers)
-;;					 (string= (xtm-id x) (xtm-id id))
-;;					 (string= (uri x) (uri id))))
-;;				 all-destination-identifiers))
-;;	      collect id)))
-;;      (dolist (item identifiers-to-move)
-;;	(remove-association source-topic what item)
-;;	(add-association destination-topic what item)))))
-;;
-;;(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil))
-;;  "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators"
-;;  (declare (list psis))
-;;  (declare (list locators))
-;;  (call-next-method)
-;;  ;item-identifiers are handled in the around-method for ReifiableConstructs,
-;;  ;TopicIdentificationCs are handled in make-construct of TopicC
-;;  (dolist (persistent-id psis)
-;;    (declare (PersistentIdC persistent-id))
-;;    (setf (identified-construct persistent-id) instance))
-;;  (dolist (subject-locator locators)
-;;    (declare (SubjectLocatorC subject-locator))
-;;    (setf (identified-construct subject-locator) instance))
-;;  (when reified
-;;    (setf (reified instance) reified)))
-;;
-;;
-;;(defmethod delete-construct :before ((construct TopicC))
-;;  (dolist (dependent (append (topic-identifiers construct)
-;;                             (psis construct)
-;;                             (locators construct)
-;;                             (names construct)
-;;                             (occurrences construct)
-;;                             (player-in-roles construct)
-;;                             (used-as-type construct)))
-;;    (delete-construct dependent))
-;;  (dolist (theme (used-as-theme construct))
-;;    (elephant:remove-association construct 'used-as-theme theme))
-;;  (dolist (tm (in-topicmaps construct))
-;;    (elephant:remove-association construct 'in-topicmaps tm))
-;;  (when (reified construct)
-;;    (slot-makunbound (reified construct) 'reifier)))
-;;  
-;;(defun get-all-constructs-by-uri (uri)
-;;  (delete 
-;;   nil
-;;   (mapcar 
-;;    (lambda (identifier)
-;;      (and
-;;       (slot-boundp identifier 'identified-construct)
-;;       (identified-construct identifier)))
-;;    (union
-;;     (union
-;;      (elephant:get-instances-by-value 'ItemIdentifierC 'uri uri)
-;;      (elephant:get-instances-by-value 'PersistentIdC 'uri uri))
-;;     (elephant:get-instances-by-value 'SubjectLocatorC 'uri uri)))))
-;;
-;;
-;;(defun find-existing-topic (item-identifiers locators psis)
-;;  (let
-;;      ((uris 
-;;        (mapcar #'uri 
-;;               (union (union item-identifiers locators) psis)))
-;;       (existing-topics nil))
-;;    (dolist (uri uris)
-;;      (setf existing-topics
-;;            (nunion existing-topics
-;;                    (get-all-constructs-by-uri uri)
-;;                    :key #'internal-id)))
-;;    (assert (<= (length existing-topics) 1))
-;;    (first existing-topics)))
-;;
-;;
-;;(defmethod make-construct ((class-symbol (eql 'TopicC)) &rest args
-;;                           &key start-revision item-identifiers locators psis topicid xtm-id)
-;;  (let
-;;      ((existing-topic 
-;;        (find-existing-topic item-identifiers locators psis)))
-;;    (if existing-topic
-;;        (progn
-;;          ;our problem with topics is that we know only after the
-;;          ;addition of all the identifiers and characteristics if
-;;          ;anything has changed. We can't decide that here, so we must
-;;          ;add all revisions (real or imaginary) to version history
-;;          ;and decide the rest in changed-p. Maybe somebody can think
-;;          ;of a better way?
-;;          (add-to-version-history existing-topic
-;;                                  :start-revision start-revision)
-;;          (init-topic-identification existing-topic topicid xtm-id
-;;                                     :revision start-revision)
-;;          (let*                 ;add new identifiers to existing topics
-;;              ((all-new-identifiers 
-;;                (union (union item-identifiers locators) psis))
-;;               (all-existing-identifiers 
-;;                (get-all-identifiers-of-construct existing-topic)))
-;;            (mapc
-;;             (lambda (identifier)
-;;               (setf (identified-construct identifier) existing-topic))
-;;             (set-difference all-new-identifiers all-existing-identifiers
-;;                             :key #'uri :test #'string=))
-;;            (mapc #'delete-construct 
-;;                  (delete-if
-;;                   (lambda (identifier) 
-;;                     (slot-boundp identifier 'identified-construct))
-;;                   all-new-identifiers)))
-;;          (check-for-duplicate-identifiers existing-topic)
-;;          existing-topic)
-;;        (progn
-;;          (let*
-;;              ((cleaned-args (remove-nil-values args))
-;;               (new-topic 
-;;                (apply #'make-instance 'TopicC cleaned-args)))
-;;            
-;;            (init-topic-identification new-topic topicid xtm-id 
-;;                                       :revision start-revision)
-;;            (check-for-duplicate-identifiers new-topic)
-;;            (add-to-version-history new-topic
-;;                                    :start-revision start-revision)
-;;            new-topic)))))
-;;
-;;(defmethod make-construct :around ((class-symbol (eql 'TopicC))
-;;                                   &key start-revision &allow-other-keys)
-;;  (declare (ignorable start-revision))
-;;  (call-next-method))
-;;
-;;    
-;;(defmethod equivalent-constructs ((topic1 TopicC) (topic2 TopicC))
-;;  "TMDM, 5.3.5: Equality rule: Two topic items are equal if they have:
-;;
-;;* at least one equal string in their [subject identifiers] properties,
-;;
-;;* at least one equal string in their [item identifiers] properties,
-;;
-;;* at least one equal string in their [subject locators] properties,
-;;
-;;* an equal string in the [subject identifiers] property of the one
-;;topic item and the [item identifiers] property of the other, or the
-;;same information item in their [reified] properties (TODO: this rule
-;;is currently ignored)" 
-;;  ;(declare (optimize (debug 3)))
-;;  (let
-;;      ((psi-uris1
-;;        (map 'list #'uri (psis topic1)))
-;;       (psi-uris2
-;;        (map 'list #'uri (psis topic2)))
-;;       (ii-uris1
-;;        (map 'list #'uri (item-identifiers topic1)))
-;;       (ii-uris2
-;;        (map 'list #'uri (item-identifiers topic2)))
-;;       (locators1
-;;        (map 'list #'uri (locators topic1)))
-;;       (locators2
-;;        (map 'list #'uri (locators topic2))))
-;;    (let
-;;        ((all-uris1
-;;          (union psi-uris1 (union ii-uris1 locators1) :test #'string=))
-;;         (all-uris2
-;;          (union psi-uris2 (union ii-uris2 locators2) :test #'string=)))
-;;      ;;TODO: consider what we should do about this. If the topic at a
-;;      ;;given revision doesn't exist yet, it correctly has no uris
-;;      ;;(for that version)
-;;      ;; (when (= 0 (length all-uris1))
-;;;;         (error (make-condition 'no-identifier-error :message "Topic1 has no identifier" :internal-id (internal-id topic1))))
-;;;;       (when (= 0 (length all-uris2))
-;;;;         (error (make-condition 'no-identifier-error :message "Topic2 has no identifier" :internal-id (internal-id topic2))))
-;;      (intersection
-;;       all-uris1 all-uris2
-;;       :test #'string=))))
-;;    
-;;(defmethod get-all-identifiers-of-construct ((top TopicC))
-;;  (append (psis top)
-;;          (locators top)
-;;          (item-identifiers top)))
-;;
-;;  
-;;(defmethod topicid ((top TopicC) &optional (xtm-id nil))
-;;  "Return the primary id of this item (= essentially the OID). If
-;;xtm-id is explicitly given, return one of the topicids in that
-;;TM (which must then exist)"
-;;  (if xtm-id
-;;      (let 
-;;          ((possible-identifications
-;;            (remove-if-not
-;;             (lambda (top-id)
-;;               (string= (xtm-id top-id) xtm-id))
-;;             (elephant:get-instances-by-value 
-;;              'TopicIdentificationC
-;;              'identified-construct
-;;              top))))
-;;        (unless possible-identifications
-;;          (error (make-condition 
-;;                  'object-not-found-error
-;;                  :message 
-;;                  (format nil "Could not find an object ~a in xtm-id ~a" top xtm-id))))
-;;        (uri (first possible-identifications)))
-;;      (format nil "t~a"
-;;              (internal-id top))))
-;;  
-;;
-;;(defgeneric psis-p (top)
-;;  (:documentation "Test for the existence of PSIs")
-;;  (:method ((top TopicC)) (slot-predicate top 'psis)))
-;;
-;;(defgeneric list-instanceOf (topic &key tm)
-;; (:documentation "Generate a list of all topics that this topic is an
-;;  instance of, optionally filtered by a topic map"))
-;;
-;;(defmethod list-instanceOf ((topic TopicC)  &key (tm nil))
-;;  (remove-if 
-;;   #'null
-;;   (map 'list #'(lambda(x)
-;;                  (when (loop for psi in (psis (instance-of x))
-;;                           when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance")
-;;                           return t)
-;;                    (loop for role in (roles (parent x))
-;;                       when (not (eq role x))
-;;                       return (player role))))
-;;        (if tm
-;;            (remove-if-not 
-;;             (lambda (role)
-;;               ;(format t "player: ~a" (player role))
-;;               ;(format t "parent: ~a" (parent role))
-;;               ;(format t "topic: ~a~&" topic)
-;;               (in-topicmap tm (parent role)))
-;;             (player-in-roles topic))
-;;            (player-in-roles topic)))))
-;;
-;;
-;;(defgeneric list-super-types (topic &key tm)
-;; (:documentation "Generate a list of all topics that this topic is an
-;;  subclass of, optionally filtered by a topic map"))
-;;
-;;
-;;(defmethod list-super-types ((topic TopicC)  &key (tm nil))
-;;  (remove-if 
-;;   #'null
-;;   (map 'list #'(lambda(x)
-;;                  (when (loop for psi in (psis (instance-of x))
-;;                           when (string= (uri psi) *subtype-psi*)
-;;                           return t)
-;;                    (loop for role in (roles (parent x))
-;;                       when (not (eq role x))
-;;                       return (player role))))
-;;        (if tm
-;;            (remove-if-not 
-;;             (lambda (role)
-;;               (format t "player: ~a" (player role))
-;;               (format t "parent: ~a" (parent role))
-;;               (format t "topic: ~a~&" topic)
-;;               (in-topicmap tm (parent role)))
-;;             (player-in-roles topic))
-;;            (player-in-roles topic)))))
-;;
-;;
-;;(defun string-starts-with (str prefix)
-;;  "Checks if string str starts with a given prefix"
-;;  (declare (string str prefix))
-;;  (string= str prefix :start1 0 :end1
-;;           (min (length prefix)
-;;                (length str))))
-;;
-;;
-;;(defun get-item-by-item-identifier (uri &key revision)
-;;  "get a construct by its item identifier. Returns nil if the item does not exist in a
-;;particular revision"
-;;  (declare (string uri))
-;;  (declare (integer revision))
-;;  (let
-;;      ((ii-obj 
-;;        (elephant:get-instance-by-value 'ItemIdentifierC
-;;                                        'uri uri)))
-;;    (when ii-obj
-;;      (find-item-by-revision 
-;;       (identified-construct ii-obj) revision))))
-;;
-;;
-;;(defun get-item-by-psi (psi &key (revision 0))
-;;  "get a topic by its PSI. Returns nil if the item does not exist in a
-;;particular revision"
-;;  (declare (string psi))
-;;  (declare (integer revision))
-;;  (let
-;;      ((psi-obj 
-;;        (elephant:get-instance-by-value 'PersistentIdC
-;;                                        'uri psi)))
-;;    (when psi-obj
-;;      (find-item-by-revision 
-;;       (identified-construct psi-obj) revision))))
-;;
-;;(defun get-item-by-id (topicid &key (xtm-id *current-xtm*) (revision 0) (error-if-nil nil))
-;;  "get a topic by its id, assuming a xtm-id. If xtm-id is empty, the current TM
-;;is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
-;;applicable in the correct revision. If revison is provided, then the code checks
-;;if the topic already existed in this revision and returns nil otherwise.
-;;If no item meeting the constraints was found, then the return value is either
-;;NIL or an error is thrown, depending on error-if-nil."
-;;  (declare (integer revision))
-;;  (let
-;;      ((result 
-;;        (if xtm-id
-;;            (let
-;;                ((possible-items
-;;                  (delete-if-not
-;;                   (lambda (top-id)
-;;                     (and
-;;                      (string= (xtm-id top-id) xtm-id)
-;;                      (string= (uri top-id) topicid))) ;fixes a bug in
-;;                                                       ;get-instances-by-value
-;;                                                       ;that does a
-;;                                                       ;case-insensitive
-;;                                                       ;comparision
-;;                   (elephant:get-instances-by-value 
-;;                    'TopicIdentificationC
-;;                    'uri
-;;                    topicid))))
-;;              (when (and possible-items
-;;                         (identified-construct-p (first possible-items)))
-;;                (unless (= (length possible-items) 1)
-;;                  (error (make-condition 'duplicate-identifier-error 
-;;                                         :message 
-;;                                         (format nil "(length possible-items ~a) for id ~a und xtm-id ~a > 1" possible-items topicid xtm-id)
-;;                                         :uri topicid)))
-;;                (let
-;;                    ((found-topic 
-;;                      (identified-construct (first possible-items))))
-;;                  (if (= revision 0)
-;;                      found-topic 
-;;                      (find-item-by-revision found-topic revision)))))
-;;            (make-instance 'TopicC :from-oid (subseq topicid 1)))))
-;;    (if (and error-if-nil (not result))
-;;        (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision))
-;;        result)))
-;;
-;;      
-;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; RoleC
-;;
-;;(elephant:defpclass RoleC (ReifiableConstructC TypableC)
-;;  ((parent :accessor parent
-;;           :initarg :parent
-;;           :associate AssociationC
-;;           :documentation "Association that this role belongs to")
-;;   (player :accessor player
-;;           :initarg :player
-;;           :associate TopicC
-;;           :documentation "references the topic that is the player in this role"))
-;;  (:documentation "The role that this topic plays in an association (formerly member)"))
-;;
-;;
-;;
-;;(defgeneric RoleC-p (object)
-;;  (:documentation "test if object is a of type RoleC")
-;;  (:method ((object t)) nil)
-;;  (:method ((object RoleC)) object))
-;;
-;;
-;;(defgeneric parent-p (vi)
-;;  (:documentation "t if this construct has a parent construct")
-;;  (:method ((constr RoleC)) (slot-predicate constr 'parent)))
-;;
-;;
-;;(defmethod delete-construct :before ((construct RoleC))
-;;                                        ;the way we use roles, we cannot just delete the parent association
-;;                                        ;(at least the second role won't have one left then and will
-;;                                        ;complain)
-;;  (delete-1-n-association construct 'parent)
-;;  (delete-1-n-association construct 'player))
-;;
-;;(defmethod find-all-equivalent ((construct RoleC))
-;;  (let
-;;      ((parent (and (slot-boundp construct 'parent)
-;;                    (parent construct))))
-;;    (when parent
-;;      (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand))
-;;                     (slot-value parent 'roles)))))
-;;
-;;
-;;(defmethod equivalent-constructs ((role1 RoleC) (role2 RoleC))
-;;  "Association role items are equal if the values of their [type], [player], and [parent] properties are equal (TMDM 5.8)"
-;;                                        ;for the purposes for which we use this method (namely the
-;;                                        ;construction of associations), roles will initially always be
-;;                                        ;unequal regarding their parent properties
-;;  (and
-;;   (= (internal-id (instance-of role1)) (internal-id (instance-of role2)))
-;;   (= (internal-id (player role1)) (internal-id (player role2)))))
-;;
-;;
-;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; AssociationC
-;;
-;;(elephant:defpclass AssociationC (ReifiableConstructC ScopableC TypableC)
-;;  ((roles :accessor roles
-;;          :associate (RoleC parent)
-;;          :documentation "(non-empty) list of this association's roles")
-;;   (in-topicmaps
-;;    :associate (TopicMapC associations)
-;;    :many-to-many t
-;;    :documentation "list of all topic maps this association is part of"))
-;;  (:documentation "Association in a Topic Map")
-;;  (:index t))
-;;
-;;
-;;(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
-;;  (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
-;;
-;;
-;;(defgeneric AssociationC-p (object)
-;;  (:documentation "test if object is a of type AssociationC")
-;;  (:method ((object t)) nil)
-;;  (:method ((object AssociationC)) object))
-;;
-;;
-;;(defmethod initialize-instance :around ((instance AssociationC) 
-;;                                        &key 
-;;                                        (roles nil))
-;;  "implements the pseudo-initarg :roles"
-;;  (declare (list roles))
-;;  (let
-;;      ((association (call-next-method)))  
-;;    (dolist (role-data roles)
-;;      (make-instance 
-;;       'RoleC 
-;;       :instance-of (getf role-data :instance-of)
-;;       :player (getf role-data :player)
-;;       :item-identifiers (getf role-data :item-identifiers)
-;;       :reifier (getf role-data :reifier)
-;;       :parent association))))
-;;
-;;(defmethod make-construct :around ((class-symbol (eql 'AssociationC))
-;;                                   &key 
-;;                                   start-revision 
-;;                                   &allow-other-keys)
-;;  (declare (ignorable start-revision))
-;;  (let
-;;      ((association
-;;        (call-next-method)))
-;;    (declare (AssociationC association))
-;;    (dolist (role (slot-value association 'roles))
-;;      (unless (versions role)
-;;        (add-to-version-history role
-;;                                :start-revision start-revision)))
-;;    association))
-;;
-;;(defmethod copy-item-identifiers :around
-;;    ((from-construct AssociationC)
-;;     (to-construct AssociationC))
-;;  "Internal method to copy over item idenfiers from one association
-;;with its roles to another one. Role identifiers are also
-;;copied. Returns nil if neither association nor role identifiers had to be copied"
-;;  (let
-;;      ((item-identifiers-copied-p nil)) ;rather brutal solution. find a better one
-;;    (when (call-next-method)
-;;      (setf item-identifiers-copied-p t))
-;;    (do ((from-roles (roles from-construct) (rest from-roles))
-;;         (to-roles (roles to-construct) (rest to-roles)))
-;;        ((null from-roles) 'finished)
-;;      (let
-;;          ((from-role (first from-roles))
-;;           (to-role (first to-roles)))
-;;        (when
-;;            (mapc
-;;             (lambda (identifier)
-;;               (setf (identified-construct identifier) 
-;;                     to-role))
-;;             (set-difference (item-identifiers from-role)
-;;                             (item-identifiers to-role)
-;;                             :key #'uri :test #'string=))
-;;          (setf item-identifiers-copied-p t))))
-;;  item-identifiers-copied-p))
-;;
-;;(defmethod delete-construct :before ((construct AssociationC))
-;;  (dolist (role (roles construct))
-;;    (delete-construct role))
-;;  (dolist (tm (in-topicmaps construct))
-;;    (elephant:remove-association construct 'in-topicmaps tm)))
-;;
-;;(defmethod find-all-equivalent ((construct AssociationC))
-;;  (let
-;;      ((some-player (player (or
-;;                             (second (roles construct))
-;;                             (first (roles construct)))))) ;; dirty, dirty... but brings a tenfold speedup!
-;;    (delete-if-not  
-;;     #'(lambda (cand) 
-;;         (unless (eq construct cand)
-;;           (equivalent-constructs construct cand)))
-;;                                        ;here we need to use the "internal" API and access the players
-;;                                        ;with slot-value (otherwise we won't be able to merge with
-;;                                        ;'deleted' associations)
-;;     (mapcar #'parent (slot-value some-player 'player-in-roles)))))
-;;
-;;
-;;(defmethod equivalent-constructs ((assoc1 AssociationC) (assoc2 AssociationC))
-;;  "Association items are equal if the values of their [scope], [type], and [roles] properties are equal (TMDM 5.7)"
-;;  (and
-;;   (= (internal-id (instance-of assoc1)) (internal-id (instance-of assoc2)))
-;;   (not (set-exclusive-or (themes assoc1) (themes assoc2) 
-;;                          :key #'internal-id))
-;;   (not (set-exclusive-or
-;;         (roles assoc1)
-;;         (roles assoc2)
-;;         :test  #'equivalent-constructs))))
-;;
-;;
-;;(elephant:defpclass TopicMapC (ReifiableConstructC)
-;;  ((topics :accessor topics
-;;          :associate (TopicC in-topicmaps)
-;;          :documentation "list of topics that explicitly belong to this TM")
-;;   (associations :accessor associations
-;;                 :associate (AssociationC in-topicmaps)
-;;                 :documentation "list of associations that belong to this TM"))
-;;  (:documentation "Topic Map"))
-;;
-;;(defmethod equivalent-constructs ((tm1 TopicMapC) (tm2 TopicMapC))
-;;  "Topic Map items are equal if one of their identifiers is equal"
-;;  ;Note: TMDM does not make any statement to this effect, but it's the
-;;  ;one logical assumption
-;;  (intersection
-;;   (item-identifiers tm1)
-;;   (item-identifiers tm2)
-;;   :test  #'equivalent-constructs))
-;;
-;;(defmethod find-all-equivalent ((construct TopicMapC))
-;;  (let 
-;;      ((tms (elephant:get-instances-by-class 'd:TopicMapC)))
-;;    (delete-if-not 
-;;     (lambda(tm)
-;;         (strictly-equivalent-constructs construct tm))
-;;     tms)))
-;;
-;;(defgeneric add-to-topicmap (tm top)
-;;  (:documentation "add a topic or an association to a topic
-;;  map. Return the added construct"))
-;;
-;;(defmethod add-to-topicmap ((tm TopicMapC) (top TopicC))
-;;  ;TODO: add logic not to add pure topic stubs unless they don't exist yet in the store
-;;;  (elephant:add-association tm 'topics top) ;by adding the elephant association in this order, there will be missing one site of this association
-;;  (elephant:add-association top 'in-topicmaps tm)
-;;  top)
-;;
-;;(defmethod add-to-topicmap ((tm TopicMapC) (ass AssociationC))
-;;   ;(elephant:add-association tm 'associations ass)
-;;  (elephant:add-association ass 'in-topicmaps tm)
-;;  ass)
-;;
-;;(defgeneric in-topicmap (tm constr &key revision)
-;;  (:documentation "Is a given construct (topic or assiciation) in this topic map?"))
-;;
-;;(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0))
-;;  (when (find-item-by-revision top revision)
-;;    (find (d:internal-id top) (d:topics tm) :test #'= :key #'d:internal-id)))
-;;
-;;
-;;(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
-;;  (when (find-item-by-revision ass revision)
-;;    (find (d:internal-id ass) (d:associations tm)  :test #'= :key #'d:internal-id)))
-;;
-;;;;;;;;;;;;;;;;;;;
-;;;; reification
-;;
-;;(defgeneric add-reifier (construct reifier-topic)
-;;  (:method ((construct ReifiableConstructC) reifier-topic)
-;;    (let ((err "From add-reifier(): "))
-;;      (declare (TopicC reifier-topic))
-;;      (cond
-;;	((and (not (reifier construct))
-;;	      (not (reified reifier-topic)))
-;;	 (setf (reifier construct) reifier-topic)
-;;	 (setf (reified reifier-topic) construct))
-;;	((and (not (reified reifier-topic))
-;;	      (reifier construct))
-;;	 (merge-reifier-topics (reifier construct) reifier-topic))
-;;	((and (not (reifier construct))
-;;	      (reified reifier-topic))
-;;	 (error "~a~a ~a reifies already another object ~a"
-;;		err (psis reifier-topic) (item-identifiers reifier-topic)
-;;		(reified reifier-topic)))
-;;	(t
-;;	 (when (not (eql (reified reifier-topic) construct))
-;;	   (error "~a~a ~a reifies already another object ~a"
-;;		  err (psis reifier-topic) (item-identifiers reifier-topic)
-;;		  (reified reifier-topic)))
-;;	 (merge-reifier-topics (reifier construct) reifier-topic)))
-;;      construct)))
-;;
-;;
-;;(defgeneric remove-reifier (construct)
-;;  (:method ((construct ReifiableConstructC))
-;;    (let ((reifier-topic (reifier construct)))
-;;      (when reifier-topic
-;;	(elephant:remove-association construct 'reifier reifier-topic)
-;;	(elephant:remove-association reifier-topic 'reified construct)))))
-;;
-;;
-;;(defgeneric merge-reifier-topics (old-topic new-topic)
-;;  ;;the reifier topics are not only merged but also bound to the reified-construct
-;;  (:method ((old-topic TopicC) (new-topic TopicC))
-;;    (unless (eql old-topic new-topic)
-;;      ;merges all identifiers
-;;      (move-identifiers old-topic new-topic)
-;;      (move-identifiers old-topic new-topic :what 'locators)
-;;      (move-identifiers old-topic new-topic :what 'psis)
-;;      (move-identifiers old-topic new-topic :what 'topic-identifiers)
-;;      ;merges all typed-object-associations
-;;      (dolist (typed-construct (used-as-type new-topic))
-;;	(remove-association typed-construct 'instance-of new-topic)
-;;	(add-association typed-construct 'instance-of old-topic))
-;;      ;merges all scope-object-associations
-;;      (dolist (scoped-construct (used-as-theme new-topic))
-;;	(remove-association scoped-construct 'themes new-topic)
-;;	(add-association scoped-construct 'themes old-topic))
-;;      ;merges all topic-maps
-;;      (dolist (tm (in-topicmaps new-topic))
-;;	(add-association tm 'topics old-topic)) ;the new-topic is removed from this tm by deleting it
-;;      ;merges all role-players
-;;      (dolist (a-role (player-in-roles new-topic))
-;;	(remove-association a-role 'player new-topic)
-;;	(add-association a-role 'player old-topic))
-;;      ;merges all names
-;;      (dolist (name (names new-topic))
-;;	(remove-association name 'topic new-topic)
-;;	(add-association name 'topic old-topic))
-;;      ;merges all occurrences
-;;      (dolist (occurrence (occurrences new-topic))
-;;	(remove-association occurrence 'topic new-topic)
-;;	(add-association occurrence 'topic old-topic))
-;;      ;merges all version-infos
-;;      (let ((versions-to-move
-;;	     (loop for vrs in (versions new-topic)
-;;		when (not (find-if #'(lambda(x)
-;;				       (and (= (start-revision x) (start-revision vrs))
-;;					    (= (end-revision x) (end-revision vrs))))
-;;				   (versions old-topic)))
-;;		collect vrs)))
-;;	(dolist (vrs versions-to-move)
-;;	  (remove-association vrs 'versioned-construct new-topic)
-;;	  (add-association vrs 'versioned-construct old-topic)))
-;;      (delete-construct new-topic))
-;;    ;TODO: order/repair all version-infos of the topic itself and add all new
-;;    ;      versions to the original existing objects of the topic
-;;    old-topic))
\ No newline at end of file



From lgiessmann at common-lisp.net  Mon Feb 15 11:20:51 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 15 Feb 2010 06:20:51 -0500
Subject: [isidorus-cvs] r186 - in branches/new-datamodel: docs src/model
Message-ID: <E1Ngz0V-00022T-S1@common-lisp.net>

Author: lgiessmann
Date: Mon Feb 15 06:20:51 2010
New Revision: 186

Log:
new-datamodel: updated the uml schema

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Mon Feb 15 06:20:51 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Mon Feb 15 06:20:51 2010
@@ -46,7 +46,7 @@
 ;;      one revision-infos
 
 
-;;; hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;;;;;;;
+;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;
 (defpclass TopicC (TopicMapConstructC)
   ()
   (:documentation "A temporary emtpy class to avoid compiler-errors."))



From lgiessmann at common-lisp.net  Mon Feb 15 11:53:03 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 15 Feb 2010 06:53:03 -0500
Subject: [isidorus-cvs] r187 - branches/new-datamodel/src/model
Message-ID: <E1NgzVf-0003fY-2U@common-lisp.net>

Author: lgiessmann
Date: Mon Feb 15 06:53:02 2010
New Revision: 187

Log:
new-datamodel: fixed a bug when exporting PersistentIdC

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	Mon Feb 15 06:53:02 2010
@@ -11,7 +11,7 @@
   (:use :cl :elephant :constants)
   (:nicknames :d)
   (:export ;;classes
-           :PersistenIdC
+           :PersistentIdC
 	   :ItemIdentifierC
 	   :SubjectLocatorC
 	   :TopicIdentificationC
@@ -580,3 +580,10 @@
   ()
   (:documentation "An abstract base class for all classes that describes
                    Topic Maps data."))
+
+
+;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;TODO: implement a ScopeAssociationC-class -> extend the uml schema
+
+;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;TODO: implement a TypeAssociationC-class -> extend the uml schema
\ No newline at end of file



From lgiessmann at common-lisp.net  Tue Feb 16 10:55:20 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 16 Feb 2010 05:55:20 -0500
Subject: [isidorus-cvs] r188 - branches/new-datamodel/src/model
Message-ID: <E1NhL5M-0003zW-Ph@common-lisp.net>

Author: lgiessmann
Date: Tue Feb 16 05:55:20 2010
New Revision: 188

Log:
new-datamodel: implemented ScopableC, ScopeAssociationC and TypeAssociationC

Modified:
   branches/new-datamodel/src/model/changes.lisp
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/src/model/changes.lisp
==============================================================================
--- branches/new-datamodel/src/model/changes.lisp	(original)
+++ branches/new-datamodel/src/model/changes.lisp	Tue Feb 16 05:55:20 2010
@@ -1,4 +1,4 @@
-;;+-----------------------------------------------------------------------------
+#;;+-----------------------------------------------------------------------------
 ;;+  Isidorus
 ;;+  (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
 ;;+
@@ -208,49 +208,49 @@
                                   'unique-id
                                   unique-id))
 
-(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"))
-
-(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision)
-  "Mark a topic as deleted if it comes from the source indicated by
-source-locator"
-  (declare (ignorable source-locator))
-  (let
-      ((last-version ;the last active version
-        (find 0 (versions construct) :key #'end-revision)))
-    (when last-version
-      (setf (end-revision last-version) revision))))
-
-(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
-  "Mark an association and its roles as deleted"
-  (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator))
-        (roles ass))
-  (call-next-method))
-
-(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision)
-  "Mark a topic as deleted if it comes from the source indicated by
-source-locator"
-  ;;Part 1b, 1.4.3.3.1:
-  ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
-  ;; * Let SI be the value of TopicSI element in ATOM entry E
-  ;; * feed F contains E
-  ;; * entry E references topic fragment TF
-  ;; * Let LTM be the local topic map
-  ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
-  ;; * For all names, occurrences and associations in which T plays a role, TMC
-  ;;   * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC 
-  ;;   * Merge in the fragment TF using SP as the base all generated source locators. 
-
-  (when
-      (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top))
-    (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator))
-          (names top))
-    (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator))
-          (occurrences top))
-    (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator))
-          (find-associations-for-topic top))
-    (call-next-method)))
+;(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"))
+
+;(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision)
+;  "Mark a topic as deleted if it comes from the source indicated by
+;source-locator"
+;  (declare (ignorable source-locator))
+;  (let
+;      ((last-version ;the last active version
+;        (find 0 (versions construct) :key #'end-revision)))
+;    (when last-version
+;      (setf (end-revision last-version) revision))))
+;
+;(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
+;  "Mark an association and its roles as deleted"
+;  (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator))
+;        (roles ass))
+;  (call-next-method))
+;
+;(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision)
+;  "Mark a topic as deleted if it comes from the source indicated by
+;source-locator"
+;  ;;Part 1b, 1.4.3.3.1:
+;  ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
+;  ;; * Let SI be the value of TopicSI element in ATOM entry E
+;  ;; * feed F contains E
+;  ;; * entry E references topic fragment TF
+;  ;; * Let LTM be the local topic map
+;  ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
+;  ;; * For all names, occurrences and associations in which T plays a role, TMC
+;  ;;   * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC 
+;  ;;   * Merge in the fragment TF using SP as the base all generated source locators. 
+;
+;  (when
+;      (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top))
+;    (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator))
+;          (names top))
+;    (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator))
+;          (occurrences top))
+;    (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator))
+;          (find-associations-for-topic top))
+;    (call-next-method)))
 
 (defgeneric add-source-locator (construct &key source-locator revision)
   (:documentation "adds an item identifier to a given construct based on the source

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Tue Feb 16 05:55:20 2010
@@ -27,6 +27,9 @@
 	   :add-item-identifier
 	   :add-reifier
 	   :find-item-by-revision
+	   :themes
+	   :add-theme
+	   :mark-as-deleted
 
 	   ;;globals
 	   :*TM-REVISION*))
@@ -34,7 +37,8 @@
 (in-package :datamodel)
 
 
-
+;;TODO: extend the UML-schema -> ScopeAssociationC + TypeAssociationC
+;;      + PlayerAssociationC
 ;;TODO: implement all-reified-constructs (:with-deleted t) -> TopicC
 ;;      the method should return all reifed-constructs of the given topic
 ;;TODO: implement make-construct -> symbol
@@ -46,6 +50,7 @@
 ;;      one revision-infos
 
 
+
 ;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;
 (defpclass TopicC (TopicMapConstructC)
   ()
@@ -74,10 +79,6 @@
 
 
 
-
-
-
-
 ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defvar *TM-REVISION* 0)
 
@@ -264,7 +265,26 @@
 	t)))
 
 
+(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"))
+
+
+(defmethod mark-as-deleted ((construct VersionedConstructC)
+			    &key source-locator revision)
+  "Mark a topic as deleted if it comes from the source indicated by
+   source-locator"
+  (declare (ignorable source-locator))
+  (let
+      ((last-version ;the last active version
+        (find 0 (versions construct) :key #'end-revision)))
+    (when last-version
+      (setf (end-revision last-version) revision))))
+
+
 ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; TypeAssociationC
+;;; ScopeAssociationC
 ;;; ReifierAssociationC
 ;;; SubjectLocatorAssociationC
 ;;; PersistentIdAssociationC
@@ -272,6 +292,58 @@
 ;;; ItemIdAssociationC
 ;;; PointerAssociationC
 ;;; VersionedAssociationC
+(defpclass TypeAssociationC(VersionedAssociationC)
+  ((type-topic :initarg :type-topic
+	       :accessor type-topic
+	       :initform (error "From TypeAssociationC(): type-topic must be set")
+	       :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")
+		      :associate TypableC
+		      :documentation "Associates this object with the typable
+                                      construct that is typed by the
+                                      type-topic."))
+  (:index t)
+  (:documentation "This class associates topics that are used as type for
+                   typable constructcs. Additionally there are stored some
+                   version-infos."))
+
+
+(defmethod delete-construct :before ((construct TypeAssociationC))
+  "Deletes all elephant-associations of the given construct."
+  (delete-1-n-association construct 'type-topic)
+  (delete-1-n-association construct 'typable-construct))
+
+
+(defpclass ScopeAssociationC(VersionedAssociationC)
+  ((theme-topic :initarg :theme-topic
+		:accessor theme-topic
+		:initform (error "From ScopeAssociationC(): theme-topic must be set")
+		: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")
+		       :associate ScopableC
+		       :documentation "Associates this object with the socpable
+                                       construct that is scoped by the
+                                       scope-topic."))
+  (:index t)
+  (:documentation "This class associates topics that are used as scope with
+                   scopable construtcs. Additionally there are stored some
+                   version-infos"))
+
+
+(defmethod delete-construct :before ((construct ScopeAssociationC))
+  "Deletes all elephant-associations of this construct."
+  (delete-1-n-association construct 'theme-topic)
+  (delete-1-n-association construct 'scopable-topic))
+
+
 (defpclass ReifierAssociationC(VersionedAssociationC)
   ((reifiable-construct :initarg :reifiable-construct
 			:accessor reifiable-construct
@@ -583,7 +655,62 @@
 
 
 ;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;TODO: implement a ScopeAssociationC-class -> extend the uml schema
+(defpclass ScopableC()
+  ((themes :initarg :themes
+	   :associate (ScopeAssociationC scopable-construct)
+	   :inherit t
+	   :documentation "Contains all Association-objects that contain the
+                           actual scope-topics."))
+  (:documentation "An abstract base class for all constructs that are scoped."))
+
+
+(defmethod delete-construct :before ((construct ScopableC))
+  "Deletes all ScopeAssociationCs that are associated with the given object."
+  (dolist (theme (themes construct))
+    (delete-construct theme)))
+
+
+(defgeneric themes (construct)
+  (:documentation "Returns all topics that are not marked as deleted and are
+                   as a scope for the given topic.")
+  (:method ((construct ScopableC))
+    (let ((valid-associations
+	   (remove-if-not #'marked-as-deleted-p (slot-p construct 'themes))))
+      (map 'list #'theme-topic valid-associations))))
+
+
+(defgeneric add-theme (construct theme-topic &key revision)
+  (:documentation "Adds the given theme-topic to the passed
+                   scopable-construct.")
+  (:method ((construct ScopableC) (theme-topic TopicC)
+	    &key (revision *TM-REVISION*))
+    (let ((all-themes (themes construct)))
+      (if (find theme-topic all-themes)
+	  (let ((theme-assoc
+		 (loop for theme-assoc in (slot-p construct 'themes)
+		    when (eql (theme-topic theme-assoc) theme-topic)
+		    return theme-assoc)))
+	    (add-to-version-history theme-assoc  :start-revision revision))
+	  (make-instance 'ScopeAssociationC
+			 :start-revision revision
+			 :theme-topic theme-topic
+			 :scopable-construct construct)))
+    construct))
+
+
+(defgeneric delete-theme (construct theme-topic &key revision)
+  (: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")))
+    (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
+			      when (eql (theme-topic theme-assoc) theme-topic)
+			      return theme-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
+
 
 ;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;TODO: implement a TypeAssociationC-class -> extend the uml schema
\ No newline at end of file
+;;TODO: implement a TypeAssociationC-class -> extend the uml schema
+;;      --> error if there are more than one types on one revision
\ No newline at end of file



From lgiessmann at common-lisp.net  Tue Feb 16 11:54:17 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 16 Feb 2010 06:54:17 -0500
Subject: [isidorus-cvs] r189 - branches/new-datamodel/src/model
Message-ID: <E1NhM0P-0007sK-0t@common-lisp.net>

Author: lgiessmann
Date: Tue Feb 16 06:54:16 2010
New Revision: 189

Log:
new-datamodel: added the implementation of TypableC

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 Feb 16 06:54:16 2010
@@ -168,6 +168,7 @@
 (defpclass VersionedConstructC()
   ((versions :initarg :versions
 	     :accessor versions
+	     :inherit t
 	     :associate (VersionInfoC versioned-construct)
 	     :documentation "Version infos for former versions of this base
                              class.")))
@@ -439,6 +440,7 @@
 (defpclass PointerAssociationC (VersionedAssociationC)
   ((identifier :initarg :identifier
 	       :accessor identifier
+	       :inherit t
 	       :initform (error "From VersionedAssociationC(): identifier must be set")
 	       :associate PointerC
 	       :documentation "The actual data that is associated with
@@ -513,12 +515,14 @@
 (defpclass PointerC(TopicMapConstructC)
   ((uri :initarg :uri
 	:accessor uri
+	:inherit t
 	:type string
 	:initform (error "From PointerC(): uri must be set for a pointer")
 	:index t
 	:documentation "The actual value of a pointer, i.e. uri or ID.")
    (identified-construct :initarg :identified-construct
-			 :associate (PointerAssociationC identifier)))
+			 :associate (PointerAssociationC identifier)
+			 :inherit t))
   (:documentation "An abstract base class for all pointers."))
 
 
@@ -550,10 +554,12 @@
 (defpclass ReifiableConstructC(TopicMapConstructC)
   ((item-identifiers :initarg :item-identifiers
 		     :associate (ItemIdAssociationC identified-construct)
+		     :inherit t
 		     :documentation "A relation to all item-identifiers of
                                      this construct.")
    (reifier :initarg :reifier
 	    :associate (ReifierAssociationC reified-construct)
+	    :inherit t
 	    :documentation "A relation to a reifier-topic."))
   (:documentation "Reifiable constructs as per TMDM."))
 
@@ -656,26 +662,26 @@
 
 ;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass ScopableC()
-  ((themes :initarg :themes
-	   :associate (ScopeAssociationC scopable-construct)
+  ((themes :associate (ScopeAssociationC scopable-construct)
 	   :inherit t
-	   :documentation "Contains all Association-objects that contain the
+	   :documentation "Contains all association-objects that contain the
                            actual scope-topics."))
   (:documentation "An abstract base class for all constructs that are scoped."))
 
 
 (defmethod delete-construct :before ((construct ScopableC))
   "Deletes all ScopeAssociationCs that are associated with the given object."
-  (dolist (theme (themes construct))
+  (dolist (theme (slot-p construct 'themes))
     (delete-construct theme)))
 
 
-(defgeneric themes (construct)
+(defgeneric themes (construct &key revision)
   (:documentation "Returns all topics that are not marked as deleted and are
                    as a scope for the given topic.")
-  (:method ((construct ScopableC))
+  (:method ((construct ScopableC) &key (revision *TM-REVISION*))
     (let ((valid-associations
-	   (remove-if-not #'marked-as-deleted-p (slot-p construct 'themes))))
+	   (filter-slot-value-by-revision construct 'themes
+					  :start-revision revision)))
       (map 'list #'theme-topic valid-associations))))
 
 
@@ -712,5 +718,68 @@
 
 
 ;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;TODO: implement a TypeAssociationC-class -> extend the uml schema
-;;      --> error if there are more than one types on one revision
\ No newline at end of file
+(defpclass TypableC()
+  ((instance-of :associate (TypeAssociationC type-topic)
+		:inherit t
+		:documentation "Contains all association-objects that contain
+                                the actual type-topic."))
+  (:documentation "An abstract base class for all typed constructcs."))
+
+
+(defmethod delete-construct :before ((construct TypableC))
+  "Deletes all TypeAssociationCs that are associated with this object."
+  (dolist (type (slot-p construct 'instance-of))
+    (delete-construct type)))
+
+
+(defgeneric instance-of (construct &key revision)
+  (:documentation "Returns the type topic that is set on the passed
+                   revision.")
+  (:method ((construct TypableC) &key (revision *TM-REVISION*))
+    (let ((valid-associations
+	   (filter-slot-value-by-revision construct 'instance-of
+					  :start-revision revision)))
+      (when valid-associations
+	(type-topic (first valid-associations))))))
+
+
+(defgeneric add-type (construct type-topic &key revision)
+  (:documentation "Add the passed type-topic as type to the given
+                   typed construct if there is no other type-topic
+                   set at the same revision.")
+  (:method ((construct TypableC) (type-topic TopicC)
+	    &key (revision *TM-REVISION*))
+    (let ((already-set-type
+	   (map 'list #'type-topic
+		(filter-slot-value-by-revision construct 'instance-of
+					       :start-revision revision))))
+      (cond ((and already-set-type
+		  (eql (first already-set-type) type-topic))
+	     (let ((type-assoc
+		    (loop for type-assoc in (slot-p construct 'instance-of)
+		       when (eql type-topic (type-topic type-assoc))
+		       return type-assoc)))
+	       (add-to-version-history type-assoc :start-revision revision)))
+	    ((not already-set-type)
+	     (make-instance 'TypeAssociationC
+			    :start-revision revision
+			    :type-topic type-topic
+			    :typable-construct construct))
+	    (t
+	     (error "From add-type(): ~a can't by typed by ~a since it is already typed by the topic ~a"
+		    construct type-topic already-set-type)))
+      construct)))
+
+
+(defgeneric delete-type (construct type-topic &key revision)
+  (: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")))
+    (let ((assoc-to-delete
+	   (loop for type-assoc in (slot-p construct 'instance-of)
+	      when (eql (type-topic type-assoc) type-topic)
+	      return type-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
\ No newline at end of file



From lgiessmann at common-lisp.net  Tue Feb 16 14:16:33 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 16 Feb 2010 09:16:33 -0500
Subject: [isidorus-cvs] r190 - in branches/new-datamodel: docs src/model
Message-ID: <E1NhOE5-0003dm-5f@common-lisp.net>

Author: lgiessmann
Date: Tue Feb 16 09:16:32 2010
New Revision: 190

Log:
new-datamodel: updated the UML-Schema -> TypeAssoicationC, ScopeAssociationC, PlayerAssociationC

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Tue Feb 16 09:16:32 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Tue Feb 16 09:16:32 2010
@@ -37,8 +37,6 @@
 (in-package :datamodel)
 
 
-;;TODO: extend the UML-schema -> ScopeAssociationC + TypeAssociationC
-;;      + PlayerAssociationC
 ;;TODO: implement all-reified-constructs (:with-deleted t) -> TopicC
 ;;      the method should return all reifed-constructs of the given topic
 ;;TODO: implement make-construct -> symbol



From lgiessmann at common-lisp.net  Tue Feb 16 20:55:06 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 16 Feb 2010 15:55:06 -0500
Subject: [isidorus-cvs] r191 - in branches/new-datamodel: docs src/model
Message-ID: <E1NhURm-0004DW-8d@common-lisp.net>

Author: lgiessmann
Date: Tue Feb 16 15:55:05 2010
New Revision: 191

Log:
new-datamodel: fixed some name-problems with the UML-schema + implemented all CharacteristicCAssociationC-classes -> NameAssociationC, OccurrenceAssociationC, VariantAssociationC

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Tue Feb 16 15:55:05 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Tue Feb 16 15:55:05 2010
@@ -29,6 +29,8 @@
 	   :find-item-by-revision
 	   :themes
 	   :add-theme
+	   :instance-of
+	   :add-type
 	   :mark-as-deleted
 
 	   ;;globals
@@ -282,6 +284,10 @@
 
 
 ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; VariantAssociationC
+;;; NameAssociationC
+;;; OccurrenceAssociationC
+;;; CharacteristicAssociationC
 ;;; TypeAssociationC
 ;;; ScopeAssociationC
 ;;; ReifierAssociationC
@@ -291,6 +297,72 @@
 ;;; ItemIdAssociationC
 ;;; PointerAssociationC
 ;;; VersionedAssociationC
+(defpclass VariantAssociationC(CharateristicAssociationC)
+  ((name :initarg :name
+	 :accessor name
+	 :initform (error "From VariantAssociationC(): name must be set")
+	 :associate NameC
+	 :documentation "Associates this object with a name."))
+  (:index t)
+  (:documentation "Associates variant objects with name obejcts.
+                   Additionally version-infos are stored."))
+
+
+(defmethod delete-construct :before ((construct VariantAssociationC))
+  (delete-1-n-association construct 'name))
+
+
+(defpclass NameAssociationC(CharacteristicAssociationC)
+  ((topic :initarg :topic
+	  :accessor topic
+	  :initform (error "From NameAssociationC(): topic must be set")
+	  :associate TopicC
+	  :documentation "Associates this object with a topic."))
+  (:index t)
+  (:documentation "Associates name objects with their parent topics.
+                   Additionally version-infos are stored."))
+
+
+(defmethod delete-construct :before ((construct NameAssociationC))
+  (delete-1-n-association construct 'topic))
+
+
+(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
+  ((topic :initarg :topic
+	  :accessor topic
+	  :initform (error "From OccurrenceAssociationC(): topic must be set")
+	  :associate TopicC
+	  :documentation "Associates this object with a topic."))
+  (:index t)
+  (:documentation "Associates occurrence objects with their parent topics.
+                   Additionally version-infos are stored."))
+
+
+(defmethod delete-construct :before ((construct OccurrenceAssociationC))
+  (delete-1-n-association construct 'topic))
+
+
+(defpclass CharacteristicAssociationC(VersionedAssociationC)
+  ((characteristic :initarg :characteristic
+		   :accessor characteristic
+		   :inherit t
+		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+		   :associate CharactersiticC
+		   :documentation "Associates this object with the actual
+                                   characteristic object."))
+  (:documentation "An abstract base class for all association-objects that
+                   associates characteristics with topics."))
+
+
+(defmethod delete-construct :before ((construct CharacteristicAssociationC))
+  "Deletes all elephant-associations."
+  (let ((characteristic (characteristic construct)))
+    (delete-1-n-association construct 'characteristic)
+    (when (and characteristic
+	       (not (slot-p characteristic 'parent)))
+      (delete-construct characteristic))))
+
+
 (defpclass TypeAssociationC(VersionedAssociationC)
   ((type-topic :initarg :type-topic
 	       :accessor type-topic



From lgiessmann at common-lisp.net  Wed Feb 17 12:04:15 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 17 Feb 2010 07:04:15 -0500
Subject: [isidorus-cvs] r192 - branches/new-datamodel/src/model
Message-ID: <E1Nhidb-0004FR-V5@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 17 07:04:15 2010
New Revision: 192

Log:
new-datamodel: added the implementation of CharacteristiC

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	Wed Feb 17 07:04:15 2010
@@ -25,12 +25,18 @@
 	   :item-identifiers
 	   :reifier
 	   :add-item-identifier
+	   :delete-item-identifier
 	   :add-reifier
+	   :delete-reifier
 	   :find-item-by-revision
 	   :themes
 	   :add-theme
+	   :delete-theme
 	   :instance-of
 	   :add-type
+	   :delete-type
+	   :add-parent
+	   :delete-parent
 	   :mark-as-deleted
 
 	   ;;globals
@@ -39,6 +45,8 @@
 (in-package :datamodel)
 
 
+;;TODO: implement delete-item-identifier
+;;TODO: implement delete-reifier
 ;;TODO: implement all-reified-constructs (:with-deleted t) -> TopicC
 ;;      the method should return all reifed-constructs of the given topic
 ;;TODO: implement make-construct -> symbol
@@ -52,6 +60,15 @@
 
 
 ;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;
+(defpclass NameC (TopicMapConstructC)
+  ()
+  (:documentation "A temporary emtpy class to avoid compiler-errors."))
+
+(defpclass OccurrenceC (TopicMapConstructC)
+  ()
+  (:documentation "A temporary emtpy class to avoid compiler-errors."))
+
+
 (defpclass TopicC (TopicMapConstructC)
   ()
   (:documentation "A temporary emtpy class to avoid compiler-errors."))
@@ -283,6 +300,126 @@
       (setf (end-revision last-version) revision))))
 
 
+;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+  ((parent :associate (CharacteriticAssociationC characteristic)
+	   :inherit t
+	   :documentation "Assocates the characterist obejct with the
+                           parent-association.")
+   (charavalue :initarg :charvalue
+	       :accessor charvalue
+	       :type string
+	       :inherit t
+	       :initform ""
+	       :index t
+	       :documentation "Contains the actual data of this object."))
+  (:documentation "Scoped characteristic of a topic (meant to be used
+                   as an abstract class)."))
+
+
+(defmethod delete-construct :before ((construct CharacteristicC))
+  "Deletes all association-obejcts."
+  (dolist (parent-assoc (slot-p construct 'parent))
+    (delete-construct parent-assoc)))
+
+
+(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
+	(let ((valid-assoc (first valid-associations)))
+	  (if (typep valid-assoc 'VariantAssociationC)
+	      (name valid-assoc)
+	      (topic valid-assoc)))))))
+
+
+(defgeneric add-parent (construct parent-construct &key revision)
+  (:documentation "Adds the parent-construct (TopicC or NameC) in form of
+                   a corresponding association to the given object."))
+
+
+(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
+		       &key (revision *TM-REVISION*))
+  (let ((already-set-topic
+	   (map 'list #'topic
+		(filter-slot-value-by-revision construct 'parent
+					       :start-revision revision))))
+      (cond ((and already-set-topic
+		  (eql (first already-set-topic) parent-construct))
+	     (let ((parent-assoc
+		    (loop for parent-assoc in (slot-p construct 'parent)
+		       when (eql parent-construct (topic parent-assoc))
+		       return parent-assoc)))
+	       (add-to-version-history parent-assoc :start-revision revision)))
+	    ((not already-set-topic)
+	     (make-instance (if (typep construct 'OccurrenceC)
+				'OccurrenceAssociationC
+				'NameAssociationC)
+			    :start-revision revision
+			    :topic parent-construct
+			    :characteristic construct))
+	    (t
+	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+		    construct parent-construct already-set-topic)))
+      construct))
+
+
+(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
+		       &key (revision *TM-REVISION*))
+  (let ((already-set-name
+	   (map 'list #'name
+		(filter-slot-value-by-revision construct 'parent
+					       :start-revision revision))))
+      (cond ((and already-set-name
+		  (eql (first already-set-name) parent-construct))
+	     (let ((parent-assoc
+		    (loop for parent-assoc in (slot-p construct 'parent)
+		       when (eql parent-construct (name parent-assoc))
+		       return parent-assoc)))
+	       (add-to-version-history parent-assoc :start-revision revision)))
+	    ((not already-set-name)
+	     (make-instance 'VariantAssociationC
+			    :start-revision revision
+			    :name parent-construct
+			    :characteristic construct))
+	    (t
+	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+		    construct parent-construct already-set-name)))
+      construct))
+
+
+(defgeneric delete-parent (construct parent-construct &key revision)
+  (:documentation "Sets the assoication-object between the passed
+                   constructs as marded-as-deleted."))
+
+
+(defmethod delete-parent ((construct CharacteristicC) (parent-construct TopicC)
+			  &key (revision (error "From delete-parent(): revision must be set")))
+  (let ((assoc-to-delete
+	 (loop for parent-assoc in (slot-p construct 'parent)
+	    when (eql (topic parent-assoc) parent-construct)
+	    return parent-assoc)))
+    (when assoc-to-delete
+      (mark-as-deleted assoc-to-delete :revision revision))
+    construct))
+
+
+(defmethod delete-parent ((construct CharacteristicC) (parent-construct NameC)
+			  &key (revision (error "From delete-parent(): revision must be set")))
+  (let ((assoc-to-delete
+	 (loop for parent-assoc in (slot-p construct 'parent)
+	    when (eql (name parent-assoc) parent-construct)
+	    return parent-assoc)))
+    (when assoc-to-delete
+      (mark-as-deleted assoc-to-delete :revision revision))
+    construct))
+
+
 ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; VariantAssociationC
 ;;; NameAssociationC
@@ -691,6 +828,19 @@
 	     construct)))))
 
 
+(defgeneric delete-item-identifier (construct item-identifier &key revision)
+  (: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")))
+    (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))
+      construct)))
+
+
 (defgeneric add-reifier (construct reifier-topic &key revision)
   (:documentation "Adds the passed reifier-topic as reifier of the construct.
                    If the construct is already reified by the given topic
@@ -723,6 +873,19 @@
 	       construct))))))
 
 
+(defgeneric delete-reifier (construct reifier &key revision)
+  (: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")))
+    (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))
+      construct)))
+
+
 ;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass TopicMapConstructC()
   ()
@@ -836,7 +999,7 @@
 			    :type-topic type-topic
 			    :typable-construct construct))
 	    (t
-	     (error "From add-type(): ~a can't by typed by ~a since it is already typed by the topic ~a"
+	     (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a"
 		    construct type-topic already-set-type)))
       construct)))
 



From lgiessmann at common-lisp.net  Wed Feb 17 18:59:30 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 17 Feb 2010 13:59:30 -0500
Subject: [isidorus-cvs] r193 - in branches/new-datamodel: docs src/model
Message-ID: <E1Nhp7S-0002Q6-O4@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 17 13:59:30 2010
New Revision: 193

Log:
new-datamodel: fixed some problems; removed some unnecessary functions; implemented RoleC, PlayerAssociationC, RoleAssociationC; updated the UML-schema

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Wed Feb 17 13:59:30 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Wed Feb 17 13:59:30 2010
@@ -11,6 +11,10 @@
   (:use :cl :elephant :constants)
   (:nicknames :d)
   (:export ;;classes
+           :RoleC
+           :OccurrenceC
+	   :NameC
+	   :VariantC
            :PersistentIdC
 	   :ItemIdentifierC
 	   :SubjectLocatorC
@@ -21,7 +25,6 @@
 	   :xtm-id
 	   :uri
 	   :identifieid-construct
-	   :all-identified-constructs
 	   :item-identifiers
 	   :reifier
 	   :add-item-identifier
@@ -37,6 +40,15 @@
 	   :delete-type
 	   :add-parent
 	   :delete-parent
+	   :variants
+	   :add-variant
+	   :delete-variant
+	   :parent
+	   :add-parent
+	   :delete-parent
+	   :player
+	   :add-player
+	   :delete-player
 	   :mark-as-deleted
 
 	   ;;globals
@@ -44,11 +56,8 @@
 
 (in-package :datamodel)
 
-
-;;TODO: implement delete-item-identifier
-;;TODO: implement delete-reifier
-;;TODO: implement all-reified-constructs (:with-deleted t) -> TopicC
-;;      the method should return all reifed-constructs of the given topic
+;;TODO: use some exceptions --> more than one type,
+;;      identifier, not-mergeable merges, ...
 ;;TODO: implement make-construct -> symbol
 ;;      replace the latest make-construct-method
 ;;TODO: implement merge-construct -> ReifiableConstructC -> ...
@@ -60,30 +69,21 @@
 
 
 ;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;
-(defpclass NameC (TopicMapConstructC)
+(defpclass TopicC (TopicMapConstructC)
   ()
   (:documentation "A temporary emtpy class to avoid compiler-errors."))
 
-(defpclass OccurrenceC (TopicMapConstructC)
+(defpclass AssociationC (TopicMapConstructC)
   ()
   (:documentation "A temporary emtpy class to avoid compiler-errors."))
 
 
-(defpclass TopicC (TopicMapConstructC)
-  ()
-  (:documentation "A temporary emtpy class to avoid compiler-errors."))
-
 (defgeneric merge-constructs(construc-1 construct-2 &key revision)
   (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
 	    &key (revision *TM-REVISION*))
     (or construct-1 construct-2 revision)))
 
 
-(defgeneric all-reified-constructs(topic &key with-deleted)
-  (:method ((topic TopicC) &key (with-deleted t))
-    (or topic with-deleted)))
-
-
 (defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
   (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*))
     (or class-symbol start-revision)))
@@ -301,6 +301,74 @@
 
 
 ;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass OccurrenceC(CharacteristicC)
+  ((datatype :accessor datatype
+             :initarg :datatype
+             :initform nil
+             :documentation "The XML Schema datatype of the occurrencevalue
+                             (optional, always IRI for resourceRef).")))
+
+
+(defpclass NameC(CharacteristicC)
+  ((variants :associate (VaraitnAssociationC name)
+	     :documentation "Associates this obejct with varian-associations."))
+  (:documentation "Scoped name of a topic."))
+
+
+(defgeneric variants (construct &key revision)
+  (:documentation "Returns all variants that correspond with the given revision
+                   and that are associated with the passed construct.")
+  (:method ((construct NameC) &key (revision *TM-REVISION*))
+    (let ((valid-associations
+	   (filter-slot-value-by-revision construct 'variants
+					  :start-revision revision)))
+      (map 'list #'characteristic valid-associations))))
+
+
+(defgeneric add-variant (construct variant &key revision)
+  (:documentation "Adds the given theme-topic to the passed
+                   scopable-construct.")
+  (:method ((construct ScopableC) (variant VariantC)
+	    &key (revision *TM-REVISION*))
+    (let ((all-variants 
+	   (map 'list #'characteristic
+		(remove-if #'marked-as-deleted-p
+			   (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-instance 'VariantAssociationC
+			 :start-revision revision
+			 :characteristic variant
+			 :name construct)))
+    construct))
+
+
+(defgeneric delete-variant (construct variant &key revision)
+  (: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-theme(): revision must be set")))
+    (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
+							      'variants)
+			      when (eql (characteristic variant-assoc) variant)
+			      return variant-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
+
+
+(defpclass VariantC(CharacteristicC)
+  ((datatype :accessor datatype
+             :initarg :datatype
+             :initform nil
+             :documentation "The XML Schema datatype of the occurrencevalue
+                             (optional, always IRI for resourceRef).")))
+
+
 (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
   ((parent :associate (CharacteriticAssociationC characteristic)
 	   :inherit t
@@ -421,6 +489,8 @@
 
 
 ;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; PlayerAssociationC
+;;; RoleAssociationC
 ;;; VariantAssociationC
 ;;; NameAssociationC
 ;;; OccurrenceAssociationC
@@ -434,13 +504,59 @@
 ;;; ItemIdAssociationC
 ;;; PointerAssociationC
 ;;; VersionedAssociationC
+(defpclass PlayerAssociationC(VersionedAssociationC)
+  ((player-topic :initarg :player-topic
+		 :accessor player-topic
+		 :associate TopicC
+		 :initform (error "From PlayerAssociationC(): player-topic must be set")
+		 :documentation "Associates this object with a topic that is
+                                 a player.")
+   (role :initarg :role
+	 :accessor role
+	 :associate RoleC
+	 :initform (error "From PlayerAssociationC(): role must be set")
+	 :documentation "Associates this object with the parent-association."))
+  (:documentation "This class associates roles and their player in given
+                   revisions."))
+
+
+(defmethod delete-construct :before ((construct PlayerAssociationC))
+  "Deletes all elephant-associations."
+  (delete-1-n-association construct 'player-topic)
+  (delete-1-n-association construct 'role))
+
+
+(defpclass RoleAssociationC(VersionedAssociationC)
+  ((role :initarg :role
+	 :accessor role
+	 :associate RoleC
+	 :initform (error "From RoleAssociationC(): role must be set")
+	 :documentation "Associates this objetc with a role-object.")
+   (association :initarg :association
+		:accessor association
+		:associate AssociationC
+		:initform (error "From RoleAssociationC(): association  must be set")
+		:documentation "Assocates thius object with an association-object."))
+  (:documentation "Associates roles with assoications and adds some
+                   version-infos between these realtions."))
+
+
+(defmethod delete-construct :before ((construct RoleAssociationC))
+  "Deletes all elephant-associations and the entire role if it is not
+   associated with another AssociationC object."
+  (let ((role (role construct)))
+    (delete-1-n-association construct 'role)
+    (when (not (slot-p role 'parent))
+      (delete-construct role))
+    (delete-1-n-association construct 'association)))
+
+
 (defpclass VariantAssociationC(CharateristicAssociationC)
   ((name :initarg :name
 	 :accessor name
 	 :initform (error "From VariantAssociationC(): name must be set")
 	 :associate NameC
 	 :documentation "Associates this object with a name."))
-  (:index t)
   (:documentation "Associates variant objects with name obejcts.
                    Additionally version-infos are stored."))
 
@@ -455,7 +571,6 @@
 	  :initform (error "From NameAssociationC(): topic must be set")
 	  :associate TopicC
 	  :documentation "Associates this object with a topic."))
-  (:index t)
   (:documentation "Associates name objects with their parent topics.
                    Additionally version-infos are stored."))
 
@@ -470,7 +585,6 @@
 	  :initform (error "From OccurrenceAssociationC(): topic must be set")
 	  :associate TopicC
 	  :documentation "Associates this object with a topic."))
-  (:index t)
   (:documentation "Associates occurrence objects with their parent topics.
                    Additionally version-infos are stored."))
 
@@ -514,7 +628,6 @@
 		      :documentation "Associates this object with the typable
                                       construct that is typed by the
                                       type-topic."))
-  (:index t)
   (:documentation "This class associates topics that are used as type for
                    typable constructcs. Additionally there are stored some
                    version-infos."))
@@ -540,7 +653,6 @@
 		       :documentation "Associates this object with the socpable
                                        construct that is scoped by the
                                        scope-topic."))
-  (:index t)
   (:documentation "This class associates topics that are used as scope with
                    scopable construtcs. Additionally there are stored some
                    version-infos"))
@@ -565,7 +677,6 @@
 		  :associate TopicC
 		  :documentation "The reifier-topic that reifies the
                                   reifiable-construct."))
-  (:index t)
   (:documentation "A versioned-association that relates a reifiable-construct
                    with a topic."))
 
@@ -587,7 +698,6 @@
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the subject-locator."))
-  (:index t)
   (:documentation "A pointer that associates subject-locators, versions
                    and topics."))
 
@@ -603,7 +713,6 @@
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the subject-identifier/psi."))
-  (:index t)
   (:documentation "A pointer that associates subject-identifiers, versions
                    and topics."))
 
@@ -619,7 +728,6 @@
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the topic-identifier."))
-  (:index t)
   (:documentation "A pointer that associates topic-identifiers, versions
                    and topics."))
 
@@ -635,7 +743,6 @@
 		     :associate ReifiableConstructC
 		     :documentation "The actual parent which is associated
                                      with the item-identifier."))
-  (:index t)
   (:documentation "A pointer that associates item-identifiers, versions
                    and reifiable-constructs."))
 
@@ -661,7 +768,7 @@
    as an idengtiffier of any other object."
   (let ((id (slot-p construct 'identifier)))
     (delete-1-n-association construct 'identifier)
-    (when (= (length (all-identified-constructs id)) 0)
+    (when (= (length (slot-p id 'identified-construct)) 0)
       (delete-construct id))))
 
 
@@ -670,6 +777,119 @@
   (:documentation "An abstract base class for all versioned associations."))
 
 
+;;; RoleC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass RoleC(ReifiableConstructC TypableC)
+  ((parent :associate (RoleAssociationC role)
+	   :documentation "Associates this object with a role-association.")
+   (player :associate (PlayerAssociationC parent-role)
+	   :documentation "Associates this object with a player-association.")))
+
+
+(defmethod delete-construct :before ((construct RoleC))
+  "Deletes all association-objects."
+  (dolist (assoc (slot-p construct 'parent))
+    (delete-construct assoc))
+  (dolist (assoc (slot-p construct 'player))
+    (delete-construct assoc)))
+
+
+(defgeneric parent (construct &key revision)
+  (:documentation "Returns the construct's parent corresponding to
+                   the given revision.")
+  (:method ((construct RoleC) &key (revision *TM-REVISION*))
+    (let ((valid-associations
+	   (filter-slot-value-by-revision construct 'parent
+					  :start-revision revision)))
+      (when valid-associations
+	(association (first valid-associations))))))
+
+
+(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
+		       &key (revision *TM-REVISION*))
+  (let ((already-set-parent
+	   (map 'list #'association
+		(filter-slot-value-by-revision construct 'parent
+					       :start-revision revision))))
+      (cond ((and already-set-parent
+		  (eql (first already-set-parent) parent-construct))
+	     (let ((parent-assoc
+		    (loop for parent-assoc in (slot-p construct 'parent)
+		       when (eql parent-construct (association parent-assoc))
+		       return parent-assoc)))
+	       (add-to-version-history parent-assoc :start-revision revision)))
+	    ((not already-set-parent)
+	     (make-instance 'RoleAssociationC
+			    :start-revision revision
+			    :role construct
+			    :association parent-construct))
+	    (t
+	     (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a"
+		    parent-construct construct already-set-parent)))
+      construct))
+
+
+(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
+	    &key (revision (error "From delete-parent(): revision must be set")))
+  (let ((assoc-to-delete
+	 (loop for parent-assoc in (slot-p construct 'parent)
+	    when (eql (association parent-assoc) parent-construct)
+	    return parent-assoc)))
+    (when assoc-to-delete
+      (mark-as-deleted assoc-to-delete :revision revision))
+    construct))
+
+
+(defgeneric player (construct &key revision)
+  (:documentation "Returns the construct's player corresponding to
+                   the given revision.")
+  (:method ((construct RoleC) &key (revision *TM-REVISION*))
+    (let ((valid-associations
+	   (filter-slot-value-by-revision construct 'player
+					  :start-revision revision)))
+      (when valid-associations
+	(player-topic (first valid-associations))))))
+
+
+(defgeneric add-player (construct player-topic &key revision)
+  (:documentation "Adds a topic as a player to a role in the given revision.")
+  (:method ((construct RoleC) (player-topic TopicC)
+	    &key (revision *TM-REVISION*))
+    (let ((already-set-player
+	   (map 'list #'player-topic
+		(filter-slot-value-by-revision construct 'player
+					       :start-revision revision))))
+      (cond ((and already-set-player
+		  (eql (first already-set-player) player-topic))
+	     (let ((player-assoc
+		    (loop for player-assoc in (slot-p construct 'player)
+		       when (eql player-topic (player-topic player-assoc))
+		       return player-assoc)))
+	       (add-to-version-history player-assoc :start-revision revision)))
+	    ((not already-set-player)
+	     (make-instance 'PlayerAssociationC
+			    :start-revision revision
+			    :role construct
+			    :player-topic player-topic))
+	    (t
+	     (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a"
+		    player-topic construct already-set-player)))
+      construct)))
+
+
+(defgeneric delete-player (construct player-topic &key revision)
+  (: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")))
+    (let ((assoc-to-delete
+	   (loop for player-assoc in (slot-p construct 'player)
+	      when (eql (player-topic player-assoc) player-topic)
+	      return player-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
+
+
 ;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; SubjectLocatorC
 ;;; PersistentIdC
@@ -745,18 +965,6 @@
 	(first assocs)))))
 
 
-(defgeneric all-identified-constructs (construct &key with-deleted)
-  (:documentation "Returns all constructs which are associated with this
-                   pointer.")
-  (:method ((construct PointerC) &key (with-deleted t))
-    (let ((all-values (slot-p construct 'identified-construct)))
-      (let ((filtered-values
-	     (if with-deleted 
-		 all-values
-		 (remove-if #'marked-as-deleted-p all-values))))
-	(map 'list #'parent-construct filtered-values)))))
-
-
 ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass ReifiableConstructC(TopicMapConstructC)
   ((item-identifiers :initarg :item-identifiers
@@ -808,18 +1016,20 @@
                    the identified-constructs are merged.")
   (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
 	    &key (revision *TM-REVISION*))
-    (let ((all-constructs
-	   (all-identified-constructs item-identifier
-				      :with-deleted nil)))
-      (cond ((find construct all-constructs)
-	     (let ((ii-assoc
-		    (loop for ii-assoc in (slot-p construct 'item-identifiers)
-			 when (eql (identifier ii-assoc) item-identifier)
-			 return ii-assoc)))
-	       (add-to-version-history ii-assoc :start-revision revision)
-	       construct))
-	    (all-constructs
-	     (merge-constructs (first all-constructs) construct))
+    (let ((all-ids
+	   (map 'list #'identifier
+		(remove-if #'marked-as-deleted-p
+			   (slot-p construct 'item-identifiers)))))
+      (cond ((find item-identifier all-ids)
+	     (let ((ii-assoc (loop for ii-assoc in (slot-p construct
+							   'item-identifiers)
+				when (eql (identifier ii-assoc) item-identifier)
+				return ii-assoc)))
+	       (add-to-version-history ii-assoc :start-revision revision)))
+	    (all-ids
+	     (merge-constructs (identified-construct (first all-ids)
+						     :revision revision)
+			       construct))
 	    (t
 	     (make-construct 'ItemIdAssociationC
 			     :start-revision revision
@@ -909,7 +1119,7 @@
 
 
 (defgeneric themes (construct &key revision)
-  (:documentation "Returns all topics that are not marked as deleted and are
+  (:documentation "Returns all topics that correspond with the given revision
                    as a scope for the given topic.")
   (:method ((construct ScopableC) &key (revision *TM-REVISION*))
     (let ((valid-associations
@@ -923,7 +1133,9 @@
                    scopable-construct.")
   (:method ((construct ScopableC) (theme-topic TopicC)
 	    &key (revision *TM-REVISION*))
-    (let ((all-themes (themes construct)))
+    (let ((all-themes
+	   (map 'list #'theme-topic
+		(remove-if #'marked-as-deleted-p (slot-p construct 'themes)))))
       (if (find theme-topic all-themes)
 	  (let ((theme-assoc
 		 (loop for theme-assoc in (slot-p construct 'themes)



From lgiessmann at common-lisp.net  Wed Feb 17 19:55:30 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 17 Feb 2010 14:55:30 -0500
Subject: [isidorus-cvs] r194 - in branches/new-datamodel: docs src/model
Message-ID: <E1Nhpze-0006EI-0b@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 17 14:55:29 2010
New Revision: 194

Log:
new-datamodel: updated the uml-schema; implemented AssociationC

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Wed Feb 17 14:55:29 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Wed Feb 17 14:55:29 2010
@@ -11,6 +11,7 @@
   (:use :cl :elephant :constants)
   (:nicknames :d)
   (:export ;;classes
+           :AssociationC
            :RoleC
            :OccurrenceC
 	   :NameC
@@ -43,13 +44,17 @@
 	   :variants
 	   :add-variant
 	   :delete-variant
-	   :parent
-	   :add-parent
-	   :delete-parent
+	   :association
+	   :add-tm-association
+	   :delete-tm-association
 	   :player
 	   :add-player
 	   :delete-player
+	   :roles
+	   :add-role
+	   :delete-role
 	   :mark-as-deleted
+	   :in-topicmaps
 
 	   ;;globals
 	   :*TM-REVISION*))
@@ -57,7 +62,7 @@
 (in-package :datamodel)
 
 ;;TODO: use some exceptions --> more than one type,
-;;      identifier, not-mergeable merges, ...
+;;      identifier, not-mergable merges, ...
 ;;TODO: implement make-construct -> symbol
 ;;      replace the latest make-construct-method
 ;;TODO: implement merge-construct -> ReifiableConstructC -> ...
@@ -73,10 +78,6 @@
   ()
   (:documentation "A temporary emtpy class to avoid compiler-errors."))
 
-(defpclass AssociationC (TopicMapConstructC)
-  ()
-  (:documentation "A temporary emtpy class to avoid compiler-errors."))
-
 
 (defgeneric merge-constructs(construc-1 construct-2 &key revision)
   (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
@@ -310,11 +311,35 @@
 
 
 (defpclass NameC(CharacteristicC)
-  ((variants :associate (VaraitnAssociationC name)
+  ((variants :associate (VariantAssociationC name)
 	     :documentation "Associates this obejct with varian-associations."))
   (:documentation "Scoped name of a topic."))
 
 
+(defpclass VariantC(CharacteristicC)
+  ((datatype :accessor datatype
+             :initarg :datatype
+             :initform nil
+             :documentation "The XML Schema datatype of the occurrencevalue
+                             (optional, always IRI for resourceRef).")))
+
+
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+  ((parent :associate (CharacteriticAssociationC characteristic)
+	   :inherit t
+	   :documentation "Assocates the characterist obejct with the
+                           parent-association.")
+   (charavalue :initarg :charvalue
+	       :accessor charvalue
+	       :type string
+	       :inherit t
+	       :initform ""
+	       :index t
+	       :documentation "Contains the actual data of this object."))
+  (:documentation "Scoped characteristic of a topic (meant to be used
+                   as an abstract class)."))
+
+
 (defgeneric variants (construct &key revision)
   (:documentation "Returns all variants that correspond with the given revision
                    and that are associated with the passed construct.")
@@ -351,7 +376,7 @@
   (: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-theme(): revision must be set")))
+	    &key (revision (error "From delete-variant(): revision must be set")))
     (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
 							      'variants)
 			      when (eql (characteristic variant-assoc) variant)
@@ -361,30 +386,6 @@
       construct)))
 
 
-(defpclass VariantC(CharacteristicC)
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform nil
-             :documentation "The XML Schema datatype of the occurrencevalue
-                             (optional, always IRI for resourceRef).")))
-
-
-(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
-  ((parent :associate (CharacteriticAssociationC characteristic)
-	   :inherit t
-	   :documentation "Assocates the characterist obejct with the
-                           parent-association.")
-   (charavalue :initarg :charvalue
-	       :accessor charvalue
-	       :type string
-	       :inherit t
-	       :initform ""
-	       :index t
-	       :documentation "Contains the actual data of this object."))
-  (:documentation "Scoped characteristic of a topic (meant to be used
-                   as an abstract class)."))
-
-
 (defmethod delete-construct :before ((construct CharacteristicC))
   "Deletes all association-obejcts."
   (dolist (parent-assoc (slot-p construct 'parent))
@@ -532,11 +533,12 @@
 	 :associate RoleC
 	 :initform (error "From RoleAssociationC(): role must be set")
 	 :documentation "Associates this objetc with a role-object.")
-   (association :initarg :association
-		:accessor association
-		:associate AssociationC
-		:initform (error "From RoleAssociationC(): association  must be set")
-		:documentation "Assocates thius object with an association-object."))
+   (parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :associate AssociationC
+		     :initform (error "From RoleAssociationC(): association  must be set")
+		     :documentation "Assocates thius object with an
+                                     association-object."))
   (:documentation "Associates roles with assoications and adds some
                    version-infos between these realtions."))
 
@@ -548,7 +550,7 @@
     (delete-1-n-association construct 'role)
     (when (not (slot-p role 'parent))
       (delete-construct role))
-    (delete-1-n-association construct 'association)))
+    (delete-1-n-association construct 'parent-construct)))
 
 
 (defpclass VariantAssociationC(CharateristicAssociationC)
@@ -687,7 +689,7 @@
   (delete-1-n-association construct 'reifiable-construct)
   (let ((reifier-top (slot-p construct 'reifier-topic)))
     (delete-1-n-association construct 'reifier-topic)
-    (when (= (length (all-reified-constructs reifier-top)) 0)
+    (when (= (length (slot-p reifier-top 'reified-construct)) 0)
       (delete-construct reifier-top))))
 
 
@@ -777,43 +779,111 @@
   (:documentation "An abstract base class for all versioned associations."))
 
 
-;;; RoleC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; RoleC + AssociationC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
+  ((roles :associate (RoleAssociationC association)
+	  :documentation "Contains all association-objects of all roles this
+                          association contains.")
+   (in-topicmaps :associate (TopicMapC associations)
+		 :many-to-many t
+		 :documentation "List of all topic maps this association is
+                                 part of"))
+  (:index t)
+  (:documentation "Association in a Topic Map"))
+
+
 (defpclass RoleC(ReifiableConstructC TypableC)
-  ((parent :associate (RoleAssociationC role)
-	   :documentation "Associates this object with a role-association.")
+  ((assocation :associate (RoleAssociationC role)
+	       :documentation "Associates this object with a role-association.")
    (player :associate (PlayerAssociationC parent-role)
 	   :documentation "Associates this object with a player-association.")))
 
 
+(defmethod delete-construct :before ((construct AssociationC))
+  "Removes all elephant-associations and deleted all roles that are not
+   associated by another associations."
+  (dolist (assoc (slot-p construct 'roles))
+    (delete-construct assoc))
+  (dolist (tm (in-topicmaps construct))
+    (remove-association construct 'in-topicmaps tm)))
+
+
+(defgeneric roles (construct &key revision)
+  (:documentation "Returns all topics that correspond with the given revision
+                   as a scope for the given topic.")
+  (:method ((construct AssociationC) &key (revision *TM-REVISION*))
+    (let ((valid-associations
+	   (filter-slot-value-by-revision construct 'roles
+					  :start-revision revision)))
+      (map 'list #'role valid-associations))))
+
+
+(defgeneric add-role (construct role &key revision)
+  (: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
+		(remove-if #'marked-as-deleted-p (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-instance 'RoleAssociationC
+			 :start-revision revision
+			 :role role
+			 :association construct)))
+    construct))
+
+
+(defgeneric delete-role (construct role &key revision)
+  (: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")))
+    (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))
+      construct)))
+
+
+(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
+  (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
+
+
 (defmethod delete-construct :before ((construct RoleC))
   "Deletes all association-objects."
-  (dolist (assoc (slot-p construct 'parent))
+  (dolist (assoc (slot-p construct 'association))
     (delete-construct assoc))
   (dolist (assoc (slot-p construct 'player))
     (delete-construct assoc)))
 
 
-(defgeneric parent (construct &key revision)
+(defgeneric association (construct &key revision)
   (:documentation "Returns the construct's parent corresponding to
                    the given revision.")
   (:method ((construct RoleC) &key (revision *TM-REVISION*))
     (let ((valid-associations
-	   (filter-slot-value-by-revision construct 'parent
+	   (filter-slot-value-by-revision construct 'association
 					  :start-revision revision)))
       (when valid-associations
-	(association (first valid-associations))))))
+	(parent-construct (first valid-associations))))))
 
 
-(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
-		       &key (revision *TM-REVISION*))
+(defmethod add-tm-association ((construct RoleC) (parent-construct AssociationC)
+			    &key (revision *TM-REVISION*))
   (let ((already-set-parent
 	   (map 'list #'association
-		(filter-slot-value-by-revision construct 'parent
+		(filter-slot-value-by-revision construct 'association
 					       :start-revision revision))))
       (cond ((and already-set-parent
 		  (eql (first already-set-parent) parent-construct))
 	     (let ((parent-assoc
-		    (loop for parent-assoc in (slot-p construct 'parent)
+		    (loop for parent-assoc in (slot-p construct 'association)
 		       when (eql parent-construct (association parent-assoc))
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
@@ -821,17 +891,17 @@
 	     (make-instance 'RoleAssociationC
 			    :start-revision revision
 			    :role construct
-			    :association parent-construct))
+			    :parent-construct parent-construct))
 	    (t
 	     (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a"
 		    parent-construct construct already-set-parent)))
       construct))
 
 
-(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
+(defmethod delete-tm-association ((construct RoleC) (parent-construct AssociationC)
 	    &key (revision (error "From delete-parent(): revision must be set")))
   (let ((assoc-to-delete
-	 (loop for parent-assoc in (slot-p construct 'parent)
+	 (loop for parent-assoc in (slot-p construct 'assocaition)
 	    when (eql (association parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
@@ -1063,7 +1133,8 @@
 	   (when (reifier construct)
 	     (merge-constructs (reifier construct) reifier-topic))))
       (let ((all-constructs
-	     (all-reified-constructs merged-reifier-topic :with-deleted nil)))
+	     (remove-if #'marked-as-deleted-p
+			(slot-p reifier-topic 'reified-construct)))) 
 	(cond ((find construct all-constructs)
 	       (let ((reifier-assoc
 		      (loop for reifier-assoc in



From lgiessmann at common-lisp.net  Wed Feb 17 21:39:10 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 17 Feb 2010 16:39:10 -0500
Subject: [isidorus-cvs] r195 - in branches/new-datamodel: docs src/model
Message-ID: <E1Nhrby-0004LL-Lg@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 17 16:39:10 2010
New Revision: 195

Log:
new-datamodel: updated the uml-schema; started to implement TopiC; implemented TopicMapC

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Wed Feb 17 16:39:10 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Wed Feb 17 16:39:10 2010
@@ -11,6 +11,7 @@
   (:use :cl :elephant :constants)
   (:nicknames :d)
   (:export ;;classes
+           :TopicMapC
            :AssociationC
            :RoleC
            :OccurrenceC
@@ -53,6 +54,8 @@
 	   :roles
 	   :add-role
 	   :delete-role
+	   :associations
+	   :topics
 	   :mark-as-deleted
 	   :in-topicmaps
 
@@ -72,31 +75,6 @@
 ;;      one revision-infos
 
 
-
-;;; start hacks -> just some temporary hacks to avoid compiler-errors ;;;;;;;;;;
-(defpclass TopicC (TopicMapConstructC)
-  ()
-  (:documentation "A temporary emtpy class to avoid compiler-errors."))
-
-
-(defgeneric merge-constructs(construc-1 construct-2 &key revision)
-  (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
-	    &key (revision *TM-REVISION*))
-    (or construct-1 construct-2 revision)))
-
-
-(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
-  (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*))
-    (or class-symbol start-revision)))
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-
-
-
-
-
 ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defvar *TM-REVISION* 0)
 
@@ -301,7 +279,62 @@
       (setf (end-revision last-version) revision))))
 
 
-;;; Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(elephant:defpclass TopicMapC (ReifiableConstructC)
+  ((topics :accessor topics
+	   :associate (TopicC in-topicmaps)
+	   :documentation "List of topics that explicitly belong to this TM.")
+   (associations :accessor associations
+                 :associate (AssociationC in-topicmaps)
+                 :documentation "List of associations that belong to this TM."))
+  (:documentation "Represnets a topic map."))
+
+
+;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defpclass TopicC (ReifiableConstructC)
+  ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
+		      :documentation "Contains all association objects that
+                                      relate a topic with its actual
+                                      topic-identifiers.")
+   (psis :associate (PersistentIdAssociationC parent-construct)
+	 :documentation "Contains all association objects that relate a topic
+                         with its actual psis.")
+   (locators :associate (PersistentIdAssociationC parent-construct)
+	     :documentation "Contains all association objects that relate a
+                             topic with its actual subject-lcoators.")
+   (names :associate (NameAssociationC parent-construct)
+	  :documentation "Contains all association objects that relate a topic
+                          with its actual names.")
+   (occurrences :associate (OccurrenceAssociationC parent-construct)
+		:documentation "Contains all association objects that relate a
+                                topic with its actual occurrences.")
+   (player-in-roles :associate (PlayerAssociationC player-topic)
+		    :documentation "Contains all association objects that relate
+                                    a topic that is a player with its role.")
+   (used-as-type :associate (TypeAssociationC type-topic)
+		 :documentation "Contains all association objects that relate a
+                                 topic that is a type with its typable obejct.")
+   (used-as-theme :associate (ScopeAssociationC theme-topic)
+		  :documentation "Contains all association objects that relate a
+                                  topic that is a theme with its scoppable
+                                  object.")
+   (reified-construct :associate (ReifiedAssociationC reifier-topic)
+		      :documentation "Contains all association objects that
+                                      relate a topic that is a reifier with
+                                      its reified object.")
+   (in-topicmaps :associate (TopicMapC topics)
+		 :many-to-many t
+		 :documentation "List of all topic maps this topic is part of."))
+  (:index t)
+  (:documentation "Represents a TM topic."))
+
+
+;;TODO: delete-construct, topic-identifiers, add-topic-identifier,
+;;      delete-topic-identifier, psis, add-psi, delete-psi, locators,
+;;      add-locator, delete-locator, names, add-name, delete-name,
+;;      occurrences, add-occurrence, delete-occurrence, player-in-roles
+;;      used-as-type, used-as-theme, reified-construct, in-topicmaps
+
 (defpclass OccurrenceC(CharacteristicC)
   ((datatype :accessor datatype
              :initarg :datatype
@@ -311,7 +344,7 @@
 
 
 (defpclass NameC(CharacteristicC)
-  ((variants :associate (VariantAssociationC name)
+  ((variants :associate (VariantAssociationC parent-construct)
 	     :documentation "Associates this obejct with varian-associations."))
   (:documentation "Scoped name of a topic."))
 
@@ -329,13 +362,13 @@
 	   :inherit t
 	   :documentation "Assocates the characterist obejct with the
                            parent-association.")
-   (charavalue :initarg :charvalue
-	       :accessor charvalue
-	       :type string
-	       :inherit t
-	       :initform ""
-	       :index t
-	       :documentation "Contains the actual data of this object."))
+   (charvalue :initarg :charvalue
+	      :accessor charvalue
+	      :type string
+	      :inherit t
+	      :initform ""
+	      :index t
+	      :documentation "Contains the actual data of this object."))
   (:documentation "Scoped characteristic of a topic (meant to be used
                    as an abstract class)."))
 
@@ -368,7 +401,7 @@
 	  (make-instance 'VariantAssociationC
 			 :start-revision revision
 			 :characteristic variant
-			 :name construct)))
+			 :parent-construct construct)))
     construct))
 
 
@@ -430,7 +463,7 @@
 				'OccurrenceAssociationC
 				'NameAssociationC)
 			    :start-revision revision
-			    :topic parent-construct
+			    :parent-construct parent-construct
 			    :characteristic construct))
 	    (t
 	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
@@ -454,7 +487,7 @@
 	    ((not already-set-name)
 	     (make-instance 'VariantAssociationC
 			    :start-revision revision
-			    :name parent-construct
+			    :parent-construct parent-construct
 			    :characteristic construct))
 	    (t
 	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
@@ -512,11 +545,11 @@
 		 :initform (error "From PlayerAssociationC(): player-topic must be set")
 		 :documentation "Associates this object with a topic that is
                                  a player.")
-   (role :initarg :role
-	 :accessor role
-	 :associate RoleC
-	 :initform (error "From PlayerAssociationC(): role must be set")
-	 :documentation "Associates this object with the parent-association."))
+   (parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :associate RoleC
+		     :initform (error "From PlayerAssociationC(): parent-construct must be set")
+		     :documentation "Associates this object with the parent-association."))
   (:documentation "This class associates roles and their player in given
                    revisions."))
 
@@ -524,7 +557,7 @@
 (defmethod delete-construct :before ((construct PlayerAssociationC))
   "Deletes all elephant-associations."
   (delete-1-n-association construct 'player-topic)
-  (delete-1-n-association construct 'role))
+  (delete-1-n-association construct 'parent-construct))
 
 
 (defpclass RoleAssociationC(VersionedAssociationC)
@@ -536,7 +569,7 @@
    (parent-construct :initarg :parent-construct
 		     :accessor parent-construct
 		     :associate AssociationC
-		     :initform (error "From RoleAssociationC(): association  must be set")
+		     :initform (error "From RoleAssociationC(): parent-construct  must be set")
 		     :documentation "Assocates thius object with an
                                      association-object."))
   (:documentation "Associates roles with assoications and adds some
@@ -554,45 +587,45 @@
 
 
 (defpclass VariantAssociationC(CharateristicAssociationC)
-  ((name :initarg :name
-	 :accessor name
-	 :initform (error "From VariantAssociationC(): name must be set")
-	 :associate NameC
-	 :documentation "Associates this object with a name."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From VariantAssociationC(): parent-construct must be set")
+		     :associate NameC
+		     :documentation "Associates this object with a name."))
   (:documentation "Associates variant objects with name obejcts.
                    Additionally version-infos are stored."))
 
 
 (defmethod delete-construct :before ((construct VariantAssociationC))
-  (delete-1-n-association construct 'name))
+  (delete-1-n-association construct 'parent-construct))
 
 
 (defpclass NameAssociationC(CharacteristicAssociationC)
-  ((topic :initarg :topic
-	  :accessor topic
-	  :initform (error "From NameAssociationC(): topic must be set")
-	  :associate TopicC
-	  :documentation "Associates this object with a topic."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From NameAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "Associates this object with a topic."))
   (:documentation "Associates name objects with their parent topics.
                    Additionally version-infos are stored."))
 
 
 (defmethod delete-construct :before ((construct NameAssociationC))
-  (delete-1-n-association construct 'topic))
+  (delete-1-n-association construct 'parent-construct))
 
 
 (defpclass OccurrenceAssociationC(CharacteristicAssociationC)
-  ((topic :initarg :topic
-	  :accessor topic
-	  :initform (error "From OccurrenceAssociationC(): topic must be set")
-	  :associate TopicC
-	  :documentation "Associates this object with a topic."))
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "Associates this object with a topic."))
   (:documentation "Associates occurrence objects with their parent topics.
                    Additionally version-infos are stored."))
 
 
 (defmethod delete-construct :before ((construct OccurrenceAssociationC))
-  (delete-1-n-association construct 'topic))
+  (delete-1-n-association construct 'parent-construct))
 
 
 (defpclass CharacteristicAssociationC(VersionedAssociationC)
@@ -795,7 +828,7 @@
 (defpclass RoleC(ReifiableConstructC TypableC)
   ((assocation :associate (RoleAssociationC role)
 	       :documentation "Associates this object with a role-association.")
-   (player :associate (PlayerAssociationC parent-role)
+   (player :associate (PlayerAssociationC parent-construct)
 	   :documentation "Associates this object with a player-association.")))
 
 
@@ -938,7 +971,7 @@
 	    ((not already-set-player)
 	     (make-instance 'PlayerAssociationC
 			    :start-revision revision
-			    :role construct
+			    :parent-construct construct
 			    :player-topic player-topic))
 	    (t
 	     (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a"
@@ -1037,13 +1070,11 @@
 
 ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass ReifiableConstructC(TopicMapConstructC)
-  ((item-identifiers :initarg :item-identifiers
-		     :associate (ItemIdAssociationC identified-construct)
+  ((item-identifiers :associate (ItemIdAssociationC identified-construct)
 		     :inherit t
 		     :documentation "A relation to all item-identifiers of
                                      this construct.")
-   (reifier :initarg :reifier
-	    :associate (ReifierAssociationC reified-construct)
+   (reifier :associate (ReifierAssociationC reified-construct)
 	    :inherit t
 	    :documentation "A relation to a reifier-topic."))
   (:documentation "Reifiable constructs as per TMDM."))
@@ -1298,4 +1329,31 @@
 	      return type-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
-      construct)))
\ No newline at end of file
+      construct)))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric merge-constructs(construc-1 construct-2 &key revision)
+  (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
+	    &key (revision *TM-REVISION*))
+    (or construct-1 construct-2 revision)))
+
+
+(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
+  (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*))
+    (or class-symbol start-revision)))
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file



From lgiessmann at common-lisp.net  Thu Feb 18 20:36:40 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 18 Feb 2010 15:36:40 -0500
Subject: [isidorus-cvs] r196 - branches/new-datamodel/src/model
Message-ID: <E1NiD72-0004cx-Ic@common-lisp.net>

Author: lgiessmann
Date: Thu Feb 18 15:36:34 2010
New Revision: 196

Log:
new-datamodel: added some accessors and helpers to TopicC

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	Thu Feb 18 15:36:34 2010
@@ -56,6 +56,25 @@
 	   :delete-role
 	   :associations
 	   :topics
+	   :psis
+	   :add-psi
+	   :delete-psi
+	   :topic-identifiers
+	   :add-topic-identifier
+	   :delete-topic-identifier
+	   :locators
+	   :add-locator
+	   :delete-locator
+	   :names
+	   :add-name
+	   :delete-name
+	   :occurrences
+	   :add-occurrence
+	   :delete-occurrence
+	   :player-in-roles
+	   :used-as-type
+	   :ased-as-theme
+	   :reified-construct
 	   :mark-as-deleted
 	   :in-topicmaps
 
@@ -290,6 +309,81 @@
   (:documentation "Represnets a topic map."))
 
 
+;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; SubjectLocatorC
+;;; PersistentIdC
+;;; ItemIdentifierC
+;;; IdentifierC
+;;; TopicIdentificationC
+;;; PointerC
+(defpclass SubjectLocatorC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-locator that contains an uri-value and an
+                   association to SubjectLocatorAssociationC's which are in
+                   turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-identifier that contains an uri-value and an
+                   association to PersistentIdAssociationC's which are in
+                   turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "An item-identifier that contains an uri-value and an
+                   association to ItemIdAssociationC's which are in turn
+                   associated with RiefiableConstructC's."))
+
+
+(defpclass IdentifierC(PointerC)
+  ()
+  (:documentation "An abstract base class for all TM-Identifiers."))
+
+
+(defpclass TopicIdentificationC(PointerC)
+  ((xtm-id :initarg :xtm-id
+	   :accessor xtm-id
+	   :type string
+	   :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+	   :index t
+	   :documentation "ID of the TM this identification came from."))
+  (:index t)
+  (:documentation "Identify topic items through generalized topic-ids.
+                   A topic may have many original topicids, the class
+                   representing one of them."))
+
+
+(defpclass PointerC(TopicMapConstructC)
+  ((uri :initarg :uri
+	:accessor uri
+	:inherit t
+	:type string
+	:initform (error "From PointerC(): uri must be set for a pointer")
+	:index t
+	:documentation "The actual value of a pointer, i.e. uri or ID.")
+   (identified-construct :initarg :identified-construct
+			 :associate (PointerAssociationC identifier)
+			 :inherit t))
+  (:documentation "An abstract base class for all pointers."))
+
+
+(defgeneric identified-construct (construct &key revision)
+  (:documentation "Returns the identified-construct -> ReifiableConstructC or
+                   TopicC that corresponds with the passed revision.")
+  (:method ((construct PointerC) &key (revision *TM-REVISION*))
+    (let ((assocs
+	   (map 'list #'parent-construct
+		(filter-slot-value-by-revision construct 'identified-construct
+					       :start-revision revision))))
+      (when assocs ;result must be nil or a list with one item
+	(first assocs)))))
+
+
 ;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass TopicC (ReifiableConstructC)
   ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
@@ -329,12 +423,6 @@
   (:documentation "Represents a TM topic."))
 
 
-;;TODO: delete-construct, topic-identifiers, add-topic-identifier,
-;;      delete-topic-identifier, psis, add-psi, delete-psi, locators,
-;;      add-locator, delete-locator, names, add-name, delete-name,
-;;      occurrences, add-occurrence, delete-occurrence, player-in-roles
-;;      used-as-type, used-as-theme, reified-construct, in-topicmaps
-
 (defpclass OccurrenceC(CharacteristicC)
   ((datatype :accessor datatype
              :initarg :datatype
@@ -373,6 +461,319 @@
                    as an abstract class)."))
 
 
+(defmethod delete-construct :before ((construct TopicC))
+  "Deletes all association objects of the passed construct."
+  (dolist (assoc (append (slot-p construct 'topic-identifiers)
+			 (slot-p construct 'psis)
+			 (slot-p construct 'locators)
+			 (slot-p construct 'names)
+			 (slot-p construct 'occurrences)
+			 (slot-p construct 'player-in-roles)
+			 (slot-p construct 'used-as-type)
+			 (slot-p construct 'used-as-theme)
+			 (slot-p construct 'reified-construct)))
+    (delete-construct assoc))
+  (dolist (assoc (slot-p construct 'in-topicmaps))
+    (remove-association construct 'in-topicmaps assoc)))
+
+
+(defgeneric topic-identifiers (construct &key revision)
+  (:documentation "Returns the TopicIdentificationC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'topic-identifiers :start-revision revision)))
+      (map 'list #'identifier assocs))))
+
+
+(defgeneric add-topic-identifier (construct topic-identifier &key revision)
+  (:documentation "Adds the passed topic-identifier to the passed topic.
+                   If the topic-identifier is already related with the passed
+                   topic a new revision is added.
+                   If the passed identifer already identifies another object
+                   the identified-constructs are merged.")
+  (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
+	    &key (revision *TM-REVISION*))
+    (let ((all-ids
+	   (map 'list #'identifier
+		(remove-if #'marked-as-deleted-p
+			   (slot-p construct 'topic-identifiers)))))
+      (cond ((find topic-identifier all-ids)
+	     (let ((ti-assoc (loop for ti-assoc in (slot-p construct
+							   'topic-identifiers)
+				when (eql (identifier ti-assoc)
+					  topic-identifier)
+				return ti-assoc)))
+	       (add-to-version-history ti-assoc :start-revision revision)))
+	    (all-ids
+	     (merge-constructs (identified-construct (first all-ids)
+						     :revision revision)
+			       construct))
+	    (t
+	     (make-construct 'TopicIdAssociationC
+			     :start-revision revision
+			     :parent-construct construct
+			     :identifier topic-identifier)
+	     construct)))))
+
+
+(defgeneric delete-topic-identifier (construct topic-identifier &key revision)
+  (: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")))
+    (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))
+      construct)))
+
+
+(defgeneric psis (construct &key revision)
+  (:documentation "Returns the PersistentIdC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'psis :start-revision revision)))
+      (map 'list #'identifier assocs))))
+
+
+(defgeneric add-psi (construct psi &key revision)
+  (:documentation "Adds the passed psi to the passed topic.
+                   If the psi is already related with the passed
+                   topic a new revision is added.
+                   If the passed identifer already identifies another object
+                   the identified-constructs are merged.")
+  (:method ((construct TopicC) (psi PersistentIdC)
+	    &key (revision *TM-REVISION*))
+    (let ((all-ids
+	   (map 'list #'identifier
+		(remove-if #'marked-as-deleted-p
+			   (slot-p construct 'psis)))))
+      (cond ((find psi all-ids)
+	     (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
+				when (eql (identifier psi-assoc) psi)
+				return psi-assoc)))
+	       (add-to-version-history psi-assoc :start-revision revision)))
+	    (all-ids
+	     (merge-constructs (identified-construct (first all-ids)
+						     :revision revision)
+			       construct))
+	    (t
+	     (make-construct 'PersistentIdAssociationC
+			     :start-revision revision
+			     :parent-construct construct
+			     :identifier psi)
+	     construct)))))
+
+
+(defgeneric delete-psi (construct psi &key revision)
+  (: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")))
+    (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))
+      construct)))
+
+
+(defgeneric locators (construct &key revision)
+  (:documentation "Returns the SubjectLocatorC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'locators :start-revision revision)))
+      (map 'list #'identifier assocs))))
+
+
+(defgeneric add-locator (construct locator &key revision)
+  (:documentation "Adds the passed locator to the passed topic.
+                   If the locator is already related with the passed
+                   topic a new revision is added.
+                   If the passed identifer already identifies another object
+                   the identified-constructs are merged.")
+  (:method ((construct TopicC) (locator SubjectLocatorC)
+	    &key (revision *TM-REVISION*))
+    (let ((all-ids
+	   (map 'list #'identifier
+		(remove-if #'marked-as-deleted-p
+			   (slot-p construct 'locators)))))
+      (cond ((find locator all-ids)
+	     (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators)
+				when (eql (identifier loc-assoc) locator)
+				return loc-assoc)))
+	       (add-to-version-history loc-assoc :start-revision revision)))
+	    (all-ids
+	     (merge-constructs (identified-construct (first all-ids)
+						     :revision revision)
+			       construct))
+	    (t
+	     (make-construct 'SubjectLocatorAssociationC
+			     :start-revision revision
+			     :parent-construct construct
+			     :identifier locator)
+	     construct)))))
+
+
+(defgeneric delete-locator (construct locator &key revision)
+  (: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")))
+    (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))
+      construct)))
+
+
+(defgeneric names (construct &key revision)
+  (:documentation "Returns the NameC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'names :start-revision revision)))
+      (map 'list #'characteristic assocs))))
+
+
+(defgeneric add-name (construct name &key revision)
+  (:documentation "Adds the passed name to the passed topic.
+                   If the name is already related with the passed
+                   topic a new revision is added.
+                   If the passed name already owns another object
+                   an error is thrown.")
+  (:method ((construct TopicC) (name NameC)
+	    &key (revision *TM-REVISION*))
+    (when (not (eql (parent name) 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)))
+    (let ((all-names
+	   (map 'list #'characteristic
+		(remove-if #'marked-as-deleted-p
+			   (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) name)
+			       return name-assoc)))
+	    (add-to-version-history name-assoc :start-revision revision))
+	  (make-construct 'NameAssociationC
+			  :start-revision revision
+			  :parent-construct construct
+			  :characteristic name))
+      construct)))
+
+
+(defgeneric delete-name (construct name &key revision)
+  (: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")))
+    (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
+			      when (eql (parent-construct name-assoc) name)
+			      return name-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
+
+
+(defgeneric occurrences (construct &key revision)
+  (:documentation "Returns the OccurrenceC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'occurences :start-revision revision)))
+      (map 'list #'characteristic assocs))))
+
+
+(defgeneric add-occurrence (construct occurrence &key revision)
+  (:documentation "Adds the passed occurrence to the passed topic.
+                   If the occurrence is already related with the passed
+                   topic a new revision is added.
+                   If the passed occurrence already owns another object
+                   an error is thrown.")
+  (:method ((construct TopicC) (occurrence OccurrenceC)
+	    &key (revision *TM-REVISION*))
+    (when (not (eql (parent occurrence) 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)))
+    (let ((all-occurrences
+	   (map 'list #'characteristic
+		(remove-if #'marked-as-deleted-p
+			   (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) occurrence)
+			      return occ-assoc)))
+	    (add-to-version-history occ-assoc :start-revision revision))
+	  (make-construct 'OccurrenceAssociationC
+			  :start-revision revision
+			  :parent-construct construct
+			  :characteristic occurrence))
+      construct)))
+
+
+(defgeneric delete-occurrence (construct occurrence &key revision)
+  (: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")))
+    (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
+			      when (eql (parent-construct occ-assoc) occurrence)
+			      return occ-assoc)))
+      (when assoc-to-delete
+	(mark-as-deleted assoc-to-delete :revision revision))
+      construct)))
+
+
+(defgeneric player-in-roles (construct &key revision)
+  (:documentation "Returns the RoleC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'player-in-roles :start-revision revision)))
+      (map 'list #'parent-construct assocs))))
+
+
+(defgeneric used-as-type (construct &key revision)
+  (:documentation "Returns the TypableC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'used-as-type :start-revision revision)))
+      (map 'list #'typable-construct assocs))))
+
+
+(defgeneric used-as-theme (construct &key revision)
+  (:documentation "Returns the ScopableC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'used-as-theme :start-revision revision)))
+      (map 'list #'scopable-construct assocs))))
+
+
+(defgeneric reified-construct (construct &key revision)
+  (:documentation "Returns the ReifiableConstructC-objects that correspond
+                   with the passed construct and the passed version.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (let ((assocs (filter-slot-value-by-revision
+		   construct 'reified-construct :start-revision revision)))
+      (map 'list #'reifiable-construct assocs))))
+
+
+(defgeneric in-topicmaps (construct &key revision)
+  (:documentation "Returns all TopicMapS-obejcts where the constrict is
+                   contained in."))
+
+(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*))
+  (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
+
+
 (defgeneric variants (construct &key revision)
   (:documentation "Returns all variants that correspond with the given revision
                    and that are associated with the passed construct.")
@@ -388,6 +789,9 @@
                    scopable-construct.")
   (:method ((construct ScopableC) (variant VariantC)
 	    &key (revision *TM-REVISION*))
+    (when (not (eql (parent variant) 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)))
     (let ((all-variants 
 	   (map 'list #'characteristic
 		(remove-if #'marked-as-deleted-p
@@ -425,6 +829,12 @@
     (delete-construct parent-assoc)))
 
 
+(defmethod delete-construct :before ((construct NameC))
+  "Deletes all association-obejcts."
+  (dolist (variant-assoc (slot-p construct 'variants))
+    (delete-construct variant-assoc)))
+
+
 (defgeneric parent (construct &key revision)
   (:documentation "Returns the parent construct of the passed object that
                    corresponds with the given revision. The returned construct
@@ -434,10 +844,7 @@
 	   (filter-slot-value-by-revision construct 'parent
 					  :start-revision revision)))
       (when valid-associations
-	(let ((valid-assoc (first valid-associations)))
-	  (if (typep valid-assoc 'VariantAssociationC)
-	      (name valid-assoc)
-	      (topic valid-assoc)))))))
+	(parent-construct (first valid-associations))))))
 
 
 (defgeneric add-parent (construct parent-construct &key revision)
@@ -448,14 +855,15 @@
 (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
 		       &key (revision *TM-REVISION*))
   (let ((already-set-topic
-	   (map 'list #'topic
+	   (map 'list #'parent-construct
 		(filter-slot-value-by-revision construct 'parent
 					       :start-revision revision))))
       (cond ((and already-set-topic
 		  (eql (first already-set-topic) parent-construct))
 	     (let ((parent-assoc
 		    (loop for parent-assoc in (slot-p construct 'parent)
-		       when (eql parent-construct (topic parent-assoc))
+		       when (eql parent-construct (parent-construct
+						   parent-assoc))
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
 	    ((not already-set-topic)
@@ -474,14 +882,14 @@
 (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
 		       &key (revision *TM-REVISION*))
   (let ((already-set-name
-	   (map 'list #'name
+	   (map 'list #'characteristic
 		(filter-slot-value-by-revision construct 'parent
 					       :start-revision revision))))
       (cond ((and already-set-name
 		  (eql (first already-set-name) parent-construct))
 	     (let ((parent-assoc
 		    (loop for parent-assoc in (slot-p construct 'parent)
-		       when (eql parent-construct (name parent-assoc))
+		       when (eql parent-construct (characteristic parent-assoc))
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
 	    ((not already-set-name)
@@ -504,7 +912,7 @@
 			  &key (revision (error "From delete-parent(): revision must be set")))
   (let ((assoc-to-delete
 	 (loop for parent-assoc in (slot-p construct 'parent)
-	    when (eql (topic parent-assoc) parent-construct)
+	    when (eql (parent-construct parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
       (mark-as-deleted assoc-to-delete :revision revision))
@@ -515,7 +923,7 @@
 			  &key (revision (error "From delete-parent(): revision must be set")))
   (let ((assoc-to-delete
 	 (loop for parent-assoc in (slot-p construct 'parent)
-	    when (eql (name parent-assoc) parent-construct)
+	    when (eql (characteristic parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
       (mark-as-deleted assoc-to-delete :revision revision))
@@ -993,81 +1401,6 @@
       construct)))
 
 
-;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; SubjectLocatorC
-;;; PersistentIdC
-;;; ItemIdentifierC
-;;; IdentifierC
-;;; TopicIdentificationC
-;;; PointerC
-(defpclass SubjectLocatorC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "A subject-locator that contains an uri-value and an
-                   association to SubjectLocatorAssociationC's which are in
-                   turn associated with TopicC's."))
-
-
-(defpclass PersistentIdC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "A subject-identifier that contains an uri-value and an
-                   association to PersistentIdAssociationC's which are in
-                   turn associated with TopicC's."))
-
-
-(defpclass ItemIdentifierC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "An item-identifier that contains an uri-value and an
-                   association to ItemIdAssociationC's which are in turn
-                   associated with RiefiableConstructC's."))
-
-
-(defpclass IdentifierC(PointerC)
-  ()
-  (:documentation "An abstract base class for all TM-Identifiers."))
-
-
-(defpclass TopicIdentificationC(PointerC)
-  ((xtm-id :initarg :xtm-id
-	   :accessor xtm-id
-	   :type string
-	   :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
-	   :index t
-	   :documentation "ID of the TM this identification came from."))
-  (:index t)
-  (:documentation "Identify topic items through generalized topic-ids.
-                   A topic may have many original topicids, the class
-                   representing one of them."))
-
-
-(defpclass PointerC(TopicMapConstructC)
-  ((uri :initarg :uri
-	:accessor uri
-	:inherit t
-	:type string
-	:initform (error "From PointerC(): uri must be set for a pointer")
-	:index t
-	:documentation "The actual value of a pointer, i.e. uri or ID.")
-   (identified-construct :initarg :identified-construct
-			 :associate (PointerAssociationC identifier)
-			 :inherit t))
-  (:documentation "An abstract base class for all pointers."))
-
-
-(defgeneric identified-construct (construct &key revision)
-  (:documentation "Returns the identified-construct -> ReifiableConstructC or
-                   TopicC that corresponds with the passed revision.")
-  (:method ((construct PointerC) &key (revision *TM-REVISION*))
-    (let ((assocs
-	   (map 'list #'parent-construct
-		(filter-slot-value-by-revision construct 'identified-construct
-					       :start-revision revision))))
-      (when assocs ;result must be nil or a list with one item
-	(first assocs)))))
-
-
 ;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defpclass ReifiableConstructC(TopicMapConstructC)
   ((item-identifiers :associate (ItemIdAssociationC identified-construct)



From lgiessmann at common-lisp.net  Fri Feb 19 18:34:28 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 19 Feb 2010 13:34:28 -0500
Subject: [isidorus-cvs] r197 - in branches/new-datamodel: docs src/model
Message-ID: <E1NiXgK-0008Iv-Ph@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 19 13:34:28 2010
New Revision: 197

Log:
new-datamodel: added the class DatatypableC as abstract base class for variants and occurrences; fixed some problems; updates the uml-schema

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Fri Feb 19 13:34:28 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Fri Feb 19 13:34:28 2010
@@ -26,11 +26,11 @@
 	   ;;methods and functions
 	   :xtm-id
 	   :uri
-	   :identifieid-construct
+	   :identified-construct
 	   :item-identifiers
-	   :reifier
 	   :add-item-identifier
 	   :delete-item-identifier
+	   :reifier
 	   :add-reifier
 	   :delete-reifier
 	   :find-item-by-revision
@@ -40,14 +40,12 @@
 	   :instance-of
 	   :add-type
 	   :delete-type
+	   :parent
 	   :add-parent
 	   :delete-parent
 	   :variants
 	   :add-variant
 	   :delete-variant
-	   :association
-	   :add-tm-association
-	   :delete-tm-association
 	   :player
 	   :add-player
 	   :delete-player
@@ -73,16 +71,23 @@
 	   :delete-occurrence
 	   :player-in-roles
 	   :used-as-type
-	   :ased-as-theme
+	   :used-as-theme
+	   :datatype
 	   :reified-construct
 	   :mark-as-deleted
+	   :mark-as-deleted-p
 	   :in-topicmaps
+	   :delete-construct
 
 	   ;;globals
 	   :*TM-REVISION*))
 
 (in-package :datamodel)
 
+
+;;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, ...
 ;;TODO: implement make-construct -> symbol
@@ -423,12 +428,9 @@
   (:documentation "Represents a TM topic."))
 
 
-(defpclass OccurrenceC(CharacteristicC)
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform nil
-             :documentation "The XML Schema datatype of the occurrencevalue
-                             (optional, always IRI for resourceRef).")))
+(defpclass OccurrenceC(CharacteristicC DatatypableC)
+  ()
+  (:documentation "Represents a TM occurrence."))
 
 
 (defpclass NameC(CharacteristicC)
@@ -437,12 +439,9 @@
   (:documentation "Scoped name of a topic."))
 
 
-(defpclass VariantC(CharacteristicC)
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform nil
-             :documentation "The XML Schema datatype of the occurrencevalue
-                             (optional, always IRI for resourceRef).")))
+(defpclass VariantC(CharacteristicC DatatypableC)
+  ()
+  (:documentation "Represents a TM variant."))
 
 
 (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
@@ -1234,8 +1233,8 @@
 
 
 (defpclass RoleC(ReifiableConstructC TypableC)
-  ((assocation :associate (RoleAssociationC role)
-	       :documentation "Associates this object with a role-association.")
+  ((parent :associate (RoleAssociationC role)
+	   :documentation "Associates this object with a role-association.")
    (player :associate (PlayerAssociationC parent-construct)
 	   :documentation "Associates this object with a player-association.")))
 
@@ -1298,34 +1297,33 @@
 
 (defmethod delete-construct :before ((construct RoleC))
   "Deletes all association-objects."
-  (dolist (assoc (slot-p construct 'association))
+  (dolist (assoc (slot-p construct 'parent))
     (delete-construct assoc))
   (dolist (assoc (slot-p construct 'player))
     (delete-construct assoc)))
 
 
-(defgeneric association (construct &key revision)
-  (:documentation "Returns the construct's parent corresponding to
-                   the given revision.")
-  (:method ((construct RoleC) &key (revision *TM-REVISION*))
-    (let ((valid-associations
-	   (filter-slot-value-by-revision construct 'association
-					  :start-revision revision)))
-      (when valid-associations
-	(parent-construct (first valid-associations))))))
-
+(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*))
+  "Returns the construct's parent corresponding to the given revision."
+  (let ((valid-associations
+	 (filter-slot-value-by-revision construct 'parent
+					:start-revision revision)))
+    (when valid-associations
+      (parent-construct (first valid-associations)))))
+  
 
-(defmethod add-tm-association ((construct RoleC) (parent-construct AssociationC)
+(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
 			    &key (revision *TM-REVISION*))
   (let ((already-set-parent
-	   (map 'list #'association
-		(filter-slot-value-by-revision construct 'association
+	   (map 'list #'parent
+		(filter-slot-value-by-revision construct 'parent
 					       :start-revision revision))))
       (cond ((and already-set-parent
 		  (eql (first already-set-parent) parent-construct))
 	     (let ((parent-assoc
-		    (loop for parent-assoc in (slot-p construct 'association)
-		       when (eql parent-construct (association parent-assoc))
+		    (loop for parent-assoc in (slot-p construct 'parent)
+		       when (eql parent-construct
+				 (parent-construct parent-assoc))
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
 	    ((not already-set-parent)
@@ -1339,10 +1337,10 @@
       construct))
 
 
-(defmethod delete-tm-association ((construct RoleC) (parent-construct AssociationC)
+(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
 	    &key (revision (error "From delete-parent(): revision must be set")))
   (let ((assoc-to-delete
-	 (loop for parent-assoc in (slot-p construct 'assocaition)
+	 (loop for parent-assoc in (slot-p construct 'parent)
 	    when (eql (association parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
@@ -1665,7 +1663,16 @@
       construct)))
 
 
-
+;;; DatatypableC
+(defpclass DatatypableC()
+  ((datatype :accessor datatype
+             :initarg :datatype
+             :initform constants:*xml-string*
+             :documentation "The XML Schema datatype of the occurrencevalue
+                             (optional, always IRI for resourceRef)."))
+  (:index t)
+  (:documentation "An abstract base class for characteristics that own
+                   an xml-datatype."))
 
 
 



From lgiessmann at common-lisp.net  Sat Feb 20 14:49:31 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 20 Feb 2010 09:49:31 -0500
Subject: [isidorus-cvs] r198 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NiqeB-0000Rp-3H@common-lisp.net>

Author: lgiessmann
Date: Sat Feb 20 09:49:30 2010
New Revision: 198

Log:
new-datamodel: fixed some accessor/slot-names; restructured the file datamodel.lisp

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	Sat Feb 20 09:49:30 2010
@@ -78,9 +78,11 @@
 	   :mark-as-deleted-p
 	   :in-topicmaps
 	   :delete-construct
+	   :get-revision
 
 	   ;;globals
-	   :*TM-REVISION*))
+	   :*TM-REVISION*
+	   :*CURRENT-XTM*))
 
 (in-package :datamodel)
 
@@ -89,7 +91,7 @@
 ;;      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, ...
+;;      identifier, not-mergable merges, missing-init-args...
 ;;TODO: implement make-construct -> symbol
 ;;      replace the latest make-construct-method
 ;;TODO: implement merge-construct -> ReifiableConstructC -> ...
@@ -103,6 +105,447 @@
 (defvar *TM-REVISION* 0)
 
 
+(defparameter *CURRENT-XTM* nil "Represents the currently active TM.")
+
+
+;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; versioning
+(defpclass VersionInfoC()
+  ((start-revision :initarg :start-revision
+		   :accessor start-revision
+		   :type integer
+		   :initform 0
+		   :documentation "The start-revision of the version's
+                                   interval of a versioned object.")
+   (end-revision :initarg :end-revision
+		 :accessor end-revision
+		 :type integer
+		 :initform 0
+		 :documentation "The end-revision of the version's interval
+                                 of a versioned object.")
+   (versioned-construct :initarg :versioned-construct
+			:accessor versioned-construct
+			:associate VersionedConstructC
+			:documentation "The reference of the versioned
+                                        object that is described by this
+                                        VersionInfoC-object."))
+  (:documentation "A VersionInfoC-object describes the revision information
+                   of a versioned object in intervals starting by the value
+                   start-revision and ending by the value end-revision - 1.
+                   end-revision=0 means always the latest version."))
+
+
+(defpclass VersionedConstructC()
+  ((versions :initarg :versions
+	     :accessor versions
+	     :inherit t
+	     :associate (VersionInfoC versioned-construct)
+	     :documentation "Version infos for former versions of this base
+                             class.")))
+
+
+;;; pointers ...
+(defpclass SubjectLocatorC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-locator that contains an uri-value and an
+                   association to SubjectLocatorAssociationC's which are in
+                   turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-identifier that contains an uri-value and an
+                   association to PersistentIdAssociationC's which are in
+                   turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "An item-identifier that contains an uri-value and an
+                   association to ItemIdAssociationC's which are in turn
+                   associated with RiefiableConstructC's."))
+
+
+(defpclass IdentifierC(PointerC)
+  ()
+  (:documentation "An abstract base class for all TM-Identifiers."))
+
+
+(defpclass TopicIdentificationC(PointerC)
+  ((xtm-id :initarg :xtm-id
+	   :accessor xtm-id
+	   :type string
+	   :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+	   :index t
+	   :documentation "ID of the TM this identification came from."))
+  (:index t)
+  (:documentation "Identify topic items through generalized topic-ids.
+                   A topic may have many original topicids, the class
+                   representing one of them."))
+
+
+(defpclass PointerC(TopicMapConstructC)
+  ((uri :initarg :uri
+	:accessor uri
+	:inherit t
+	:type string
+	:initform (error "From PointerC(): uri must be set for a pointer")
+	:index t
+	:documentation "The actual value of a pointer, i.e. uri or ID.")
+   (identified-construct :associate (PointerAssociationC identifier)
+			 :inherit t
+			 :documentation "Associates a association-object that
+                                         additionally stores some
+                                         version-infos."))
+  (:documentation "An abstract base class for all pointers."))
+
+
+;;; reifiables ...
+(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
+  ((roles :associate (RoleAssociationC association)
+	  :documentation "Contains all association-objects of all roles this
+                          association contains.")
+   (in-topicmaps :associate (TopicMapC associations)
+		 :many-to-many t
+		 :documentation "List of all topic maps this association is
+                                 part of"))
+  (:index t)
+  (:documentation "Association in a Topic Map"))
+
+
+(defpclass RoleC(ReifiableConstructC TypableC)
+  ((parent :associate (RoleAssociationC role)
+	   :documentation "Associates this object with a role-association.")
+   (player :associate (PlayerAssociationC parent-construct)
+	   :documentation "Associates this object with a player-association.")))
+
+
+(defpclass ReifiableConstructC(TopicMapConstructC)
+  ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+		     :inherit t
+		     :documentation "A relation to all item-identifiers of
+                                     this construct.")
+   (reifier :associate (ReifierAssociationC reified-construct)
+	    :inherit t
+	    :documentation "A relation to a reifier-topic."))
+  (:documentation "Reifiable constructs as per TMDM."))
+
+
+(elephant:defpclass TopicMapC (ReifiableConstructC)
+  ((topics :accessor topics
+	   :associate (TopicC in-topicmaps)
+	   :documentation "List of topics that explicitly belong to this TM.")
+   (associations :accessor associations
+                 :associate (AssociationC in-topicmaps)
+                 :documentation "List of associations that belong to this TM."))
+  (:documentation "Represnets a topic map."))
+
+
+(defpclass TopicC (ReifiableConstructC)
+  ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
+		      :documentation "Contains all association objects that
+                                      relate a topic with its actual
+                                      topic-identifiers.")
+   (psis :associate (PersistentIdAssociationC parent-construct)
+	 :documentation "Contains all association objects that relate a topic
+                         with its actual psis.")
+   (locators :associate (PersistentIdAssociationC parent-construct)
+	     :documentation "Contains all association objects that relate a
+                             topic with its actual subject-lcoators.")
+   (names :associate (NameAssociationC parent-construct)
+	  :documentation "Contains all association objects that relate a topic
+                          with its actual names.")
+   (occurrences :associate (OccurrenceAssociationC parent-construct)
+		:documentation "Contains all association objects that relate a
+                                topic with its actual occurrences.")
+   (player-in-roles :associate (PlayerAssociationC player-topic)
+		    :documentation "Contains all association objects that relate
+                                    a topic that is a player with its role.")
+   (used-as-type :associate (TypeAssociationC type-topic)
+		 :documentation "Contains all association objects that relate a
+                                 topic that is a type with its typable obejct.")
+   (used-as-theme :associate (ScopeAssociationC theme-topic)
+		  :documentation "Contains all association objects that relate a
+                                  topic that is a theme with its scoppable
+                                  object.")
+   (reified-construct :associate (ReifiedAssociationC reifier-topic)
+		      :documentation "Contains all association objects that
+                                      relate a topic that is a reifier with
+                                      its reified object.")
+   (in-topicmaps :associate (TopicMapC topics)
+		 :many-to-many t
+		 :documentation "List of all topic maps this topic is part of."))
+  (:index t)
+  (:documentation "Represents a TM topic."))
+
+
+
+;;; characteristics ...
+(defpclass OccurrenceC(CharacteristicC DatatypableC)
+  ()
+  (:documentation "Represents a TM occurrence."))
+
+
+(defpclass NameC(CharacteristicC)
+  ((variants :associate (VariantAssociationC parent-construct)
+	     :documentation "Associates this obejct with varian-associations."))
+  (:documentation "Scoped name of a topic."))
+
+
+(defpclass VariantC(CharacteristicC DatatypableC)
+  ()
+  (:documentation "Represents a TM variant."))
+
+
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+  ((parent :associate (CharacteriticAssociationC characteristic)
+	   :inherit t
+	   :documentation "Assocates the characterist obejct with the
+                           parent-association.")
+   (charvalue :initarg :charvalue
+	      :accessor charvalue
+	      :type string
+	      :inherit t
+	      :initform ""
+	      :index t
+	      :documentation "Contains the actual data of this object."))
+  (:documentation "Scoped characteristic of a topic (meant to be used
+                   as an abstract class)."))
+
+
+;;; versioned associations ...
+(defpclass TypeAssociationC(VersionedAssociationC)
+  ((type-topic :initarg :type-topic
+	       :accessor type-topic
+	       :initform (error "From TypeAssociationC(): type-topic must be set")
+	       :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")
+		      :associate TypableC
+		      :documentation "Associates this object with the typable
+                                      construct that is typed by the
+                                      type-topic."))
+  (:documentation "This class associates topics that are used as type for
+                   typable constructcs. Additionally there are stored some
+                   version-infos."))
+
+
+(defpclass ScopeAssociationC(VersionedAssociationC)
+  ((theme-topic :initarg :theme-topic
+		:accessor theme-topic
+		:initform (error "From ScopeAssociationC(): theme-topic must be set")
+		: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")
+		       :associate ScopableC
+		       :documentation "Associates this object with the socpable
+                                       construct that is scoped by the
+                                       scope-topic."))
+  (:documentation "This class associates topics that are used as scope with
+                   scopable construtcs. Additionally there are stored some
+                   version-infos"))
+
+
+(defpclass ReifierAssociationC(VersionedAssociationC)
+  ((reifiable-construct :initarg :reifiable-construct
+			:accessor reifiable-construct
+			:initform (error "From ReifierAssociation(): reifiable-construct must be set")
+			: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")
+		  :associate TopicC
+		  :documentation "The reifier-topic that reifies the
+                                  reifiable-construct."))
+  (:documentation "A versioned-association that relates a reifiable-construct
+                   with a topic."))
+
+
+(defpclass VersionedAssociationC(VersionedConstructC)
+  ()
+  (:documentation "An abstract base class for all versioned associations."))
+
+
+
+;;; pointer associations ...
+(defpclass SubjectLocatorAssociationC(PointerAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "The actual topic which is associated
+                                     with the subject-locator."))
+  (:documentation "A pointer that associates subject-locators, versions
+                   and topics."))
+
+
+(defpclass PersistentIdAssociationC(PointerAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "The actual topic which is associated
+                                     with the subject-identifier/psi."))
+  (:documentation "A pointer that associates subject-identifiers, versions
+                   and topics."))
+
+
+(defpclass TopicIdAssociationC(PointerAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From TopicIdAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "The actual topic which is associated
+                                     with the topic-identifier."))
+  (:documentation "A pointer that associates topic-identifiers, versions
+                   and topics."))
+
+
+(defpclass ItemIdAssociationC(PointerAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+		     :associate ReifiableConstructC
+		     :documentation "The actual parent which is associated
+                                     with the item-identifier."))
+  (:documentation "A pointer that associates item-identifiers, versions
+                   and reifiable-constructs."))
+
+
+(defpclass PointerAssociationC (VersionedAssociationC)
+  ((identifier :initarg :identifier
+	       :accessor identifier
+	       :inherit t
+	       :initform (error "From PointerAssociationC(): identifier must be set")
+	       :associate PointerC
+	       :documentation "The actual data that is associated with
+                               the pointer-association's parent."))
+  (:documentation "An abstract base class for all versioned
+                   pointer-associations."))
+
+
+;;; characteristic associations ...
+(defpclass VariantAssociationC(CharateristicAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From VariantAssociationC(): parent-construct must be set")
+		     :associate NameC
+		     :documentation "Associates this object with a name."))
+  (:documentation "Associates variant objects with name obejcts.
+                   Additionally version-infos are stored."))
+
+
+(defpclass NameAssociationC(CharacteristicAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From NameAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "Associates this object with a topic."))
+  (:documentation "Associates name objects with their parent topics.
+                   Additionally version-infos are stored."))
+
+
+(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+		     :associate TopicC
+		     :documentation "Associates this object with a topic."))
+  (:documentation "Associates occurrence objects with their parent topics.
+                   Additionally version-infos are stored."))
+
+
+(defpclass CharacteristicAssociationC(VersionedAssociationC)
+  ((characteristic :initarg :characteristic
+		   :accessor characteristic
+		   :inherit t
+		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+		   :associate CharactersiticC
+		   :documentation "Associates this object with the actual
+                                   characteristic object."))
+  (:documentation "An abstract base class for all association-objects that
+                   associates characteristics with topics."))
+
+
+;;; roles/association associations ...
+(defpclass PlayerAssociationC(VersionedAssociationC)
+  ((player-topic :initarg :player-topic
+		 :accessor player-topic
+		 :associate TopicC
+		 :initform (error "From PlayerAssociationC(): player-topic must be set")
+		 :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")
+		     :documentation "Associates this object with the parent-association."))
+  (:documentation "This class associates roles and their player in given
+                   revisions."))
+
+
+(defpclass RoleAssociationC(VersionedAssociationC)
+  ((role :initarg :role
+	 :accessor role
+	 :associate RoleC
+	 :initform (error "From RoleAssociationC(): role must be set")
+	 :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")
+		     :documentation "Assocates thius object with an
+                                     association-object."))
+  (:documentation "Associates roles with assoications and adds some
+                   version-infos between these realtions."))
+
+
+;;; base classes ...
+(defpclass TopicMapConstructC()
+  ()
+  (:documentation "An abstract base class for all classes that describes
+                   Topic Maps data."))
+
+
+(defpclass ScopableC()
+  ((themes :associate (ScopeAssociationC scopable-construct)
+	   :inherit t
+	   :documentation "Contains all association-objects that contain the
+                           actual scope-topics."))
+  (:documentation "An abstract base class for all constructs that are scoped."))
+
+
+(defpclass TypableC()
+  ((instance-of :associate (TypeAssociationC type-topic)
+		:inherit t
+		:documentation "Contains all association-objects that contain
+                                the actual type-topic."))
+  (:documentation "An abstract base class for all typed constructcs."))
+
+
+(defpclass DatatypableC()
+  ((datatype :accessor datatype
+             :initarg :datatype
+             :initform constants:*xml-string*
+	     :type string
+             :documentation "The XML Schema datatype of the occurrencevalue
+                             (optional, always IRI for resourceRef)."))
+  (:index t)
+  (:documentation "An abstract base class for characteristics that own
+                   an xml-datatype."))
+
+
 ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun slot-p (instance slot-symbol)
   "Returns t if the slot depending on slot-symbol is bound and not nil."
@@ -154,46 +597,18 @@
 			   properties))))))
 
 
-;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass VersionInfoC()
-  ((start-revision :initarg :start-revision
-		   :accessor start-revision
-		   :type integer
-		   :initform 0
-		   :documentation "The start-revision of the version's
-                                   interval of a versioned object.")
-   (end-revision :initarg :end-revision
-		 :accessor end-revision
-		 :type integer
-		 :initform 0
-		 :documentation "The end-revision of the version's interval
-                                 of a versioned object.")
-   (versioned-construct :initarg :versioned-construct
-			:accessor versioned-construct
-			:associate VersionedConstructC
-			:documentation "The reference of the versioned
-                                        object that is described by this
-                                        VersionInfoC-object."))
-  (:documentation "A VersionInfoC-object describes the revision information
-                   of a versioned object in intervals starting by the value
-                   start-revision and ending by the value end-revision - 1.
-                   end-revision=0 means always the latest version."))
+(defun get-revision ()
+  "TODO: replace by something that does not suffer from a 1 second resolution."
+  (get-universal-time))
 
 
+;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; VersionInfocC
 (defmethod delete-construct :before ((version-info VersionInfoC))
   (delete-1-n-association version-info 'versioned-construct))
 
 
-;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass VersionedConstructC()
-  ((versions :initarg :versions
-	     :accessor versions
-	     :inherit t
-	     :associate (VersionInfoC versioned-construct)
-	     :documentation "Version infos for former versions of this base
-                             class.")))
-
-
+;;; VersionedConstructC
 (defmethod delete-construct :before ((construct VersionedConstructC))
   (dolist (version-info (versions construct))
     (delete-construct version-info)))
@@ -303,80 +718,7 @@
       (setf (end-revision last-version) revision))))
 
 
-;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(elephant:defpclass TopicMapC (ReifiableConstructC)
-  ((topics :accessor topics
-	   :associate (TopicC in-topicmaps)
-	   :documentation "List of topics that explicitly belong to this TM.")
-   (associations :accessor associations
-                 :associate (AssociationC in-topicmaps)
-                 :documentation "List of associations that belong to this TM."))
-  (:documentation "Represnets a topic map."))
-
-
-;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; SubjectLocatorC
-;;; PersistentIdC
-;;; ItemIdentifierC
-;;; IdentifierC
-;;; TopicIdentificationC
 ;;; PointerC
-(defpclass SubjectLocatorC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "A subject-locator that contains an uri-value and an
-                   association to SubjectLocatorAssociationC's which are in
-                   turn associated with TopicC's."))
-
-
-(defpclass PersistentIdC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "A subject-identifier that contains an uri-value and an
-                   association to PersistentIdAssociationC's which are in
-                   turn associated with TopicC's."))
-
-
-(defpclass ItemIdentifierC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "An item-identifier that contains an uri-value and an
-                   association to ItemIdAssociationC's which are in turn
-                   associated with RiefiableConstructC's."))
-
-
-(defpclass IdentifierC(PointerC)
-  ()
-  (:documentation "An abstract base class for all TM-Identifiers."))
-
-
-(defpclass TopicIdentificationC(PointerC)
-  ((xtm-id :initarg :xtm-id
-	   :accessor xtm-id
-	   :type string
-	   :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
-	   :index t
-	   :documentation "ID of the TM this identification came from."))
-  (:index t)
-  (:documentation "Identify topic items through generalized topic-ids.
-                   A topic may have many original topicids, the class
-                   representing one of them."))
-
-
-(defpclass PointerC(TopicMapConstructC)
-  ((uri :initarg :uri
-	:accessor uri
-	:inherit t
-	:type string
-	:initform (error "From PointerC(): uri must be set for a pointer")
-	:index t
-	:documentation "The actual value of a pointer, i.e. uri or ID.")
-   (identified-construct :initarg :identified-construct
-			 :associate (PointerAssociationC identifier)
-			 :inherit t))
-  (:documentation "An abstract base class for all pointers."))
-
-
 (defgeneric identified-construct (construct &key revision)
   (:documentation "Returns the identified-construct -> ReifiableConstructC or
                    TopicC that corresponds with the passed revision.")
@@ -389,77 +731,7 @@
 	(first assocs)))))
 
 
-;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass TopicC (ReifiableConstructC)
-  ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
-		      :documentation "Contains all association objects that
-                                      relate a topic with its actual
-                                      topic-identifiers.")
-   (psis :associate (PersistentIdAssociationC parent-construct)
-	 :documentation "Contains all association objects that relate a topic
-                         with its actual psis.")
-   (locators :associate (PersistentIdAssociationC parent-construct)
-	     :documentation "Contains all association objects that relate a
-                             topic with its actual subject-lcoators.")
-   (names :associate (NameAssociationC parent-construct)
-	  :documentation "Contains all association objects that relate a topic
-                          with its actual names.")
-   (occurrences :associate (OccurrenceAssociationC parent-construct)
-		:documentation "Contains all association objects that relate a
-                                topic with its actual occurrences.")
-   (player-in-roles :associate (PlayerAssociationC player-topic)
-		    :documentation "Contains all association objects that relate
-                                    a topic that is a player with its role.")
-   (used-as-type :associate (TypeAssociationC type-topic)
-		 :documentation "Contains all association objects that relate a
-                                 topic that is a type with its typable obejct.")
-   (used-as-theme :associate (ScopeAssociationC theme-topic)
-		  :documentation "Contains all association objects that relate a
-                                  topic that is a theme with its scoppable
-                                  object.")
-   (reified-construct :associate (ReifiedAssociationC reifier-topic)
-		      :documentation "Contains all association objects that
-                                      relate a topic that is a reifier with
-                                      its reified object.")
-   (in-topicmaps :associate (TopicMapC topics)
-		 :many-to-many t
-		 :documentation "List of all topic maps this topic is part of."))
-  (:index t)
-  (:documentation "Represents a TM topic."))
-
-
-(defpclass OccurrenceC(CharacteristicC DatatypableC)
-  ()
-  (:documentation "Represents a TM occurrence."))
-
-
-(defpclass NameC(CharacteristicC)
-  ((variants :associate (VariantAssociationC parent-construct)
-	     :documentation "Associates this obejct with varian-associations."))
-  (:documentation "Scoped name of a topic."))
-
-
-(defpclass VariantC(CharacteristicC DatatypableC)
-  ()
-  (:documentation "Represents a TM variant."))
-
-
-(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
-  ((parent :associate (CharacteriticAssociationC characteristic)
-	   :inherit t
-	   :documentation "Assocates the characterist obejct with the
-                           parent-association.")
-   (charvalue :initarg :charvalue
-	      :accessor charvalue
-	      :type string
-	      :inherit t
-	      :initform ""
-	      :index t
-	      :documentation "Contains the actual data of this object."))
-  (:documentation "Scoped characteristic of a topic (meant to be used
-                   as an abstract class)."))
-
-
+;;; TopicC
 (defmethod delete-construct :before ((construct TopicC))
   "Deletes all association objects of the passed construct."
   (dolist (assoc (append (slot-p construct 'topic-identifiers)
@@ -509,10 +781,10 @@
 						     :revision revision)
 			       construct))
 	    (t
-	     (make-construct 'TopicIdAssociationC
-			     :start-revision revision
-			     :parent-construct construct
-			     :identifier topic-identifier)
+	     (make-instance 'TopicIdAssociationC
+			    :start-revision revision
+			    :parent-construct construct
+			    :identifier topic-identifier)
 	     construct)))))
 
 
@@ -560,10 +832,10 @@
 						     :revision revision)
 			       construct))
 	    (t
-	     (make-construct 'PersistentIdAssociationC
-			     :start-revision revision
-			     :parent-construct construct
-			     :identifier psi)
+	     (make-instance 'PersistentIdAssociationC
+			    :start-revision revision
+			    :parent-construct construct
+			    :identifier psi)
 	     construct)))))
 
 
@@ -611,10 +883,10 @@
 						     :revision revision)
 			       construct))
 	    (t
-	     (make-construct 'SubjectLocatorAssociationC
-			     :start-revision revision
-			     :parent-construct construct
-			     :identifier locator)
+	     (make-instance 'SubjectLocatorAssociationC
+			    :start-revision revision
+			    :parent-construct construct
+			    :identifier locator)
 	     construct)))))
 
 
@@ -660,10 +932,10 @@
 			       when (eql (parent-construct name-assoc) name)
 			       return name-assoc)))
 	    (add-to-version-history name-assoc :start-revision revision))
-	  (make-construct 'NameAssociationC
-			  :start-revision revision
-			  :parent-construct construct
-			  :characteristic name))
+	  (make-instance 'NameAssociationC
+			 :start-revision revision
+			 :parent-construct construct
+			 :characteristic name))
       construct)))
 
 
@@ -709,10 +981,10 @@
 			      when (eql (parent-construct occ-assoc) occurrence)
 			      return occ-assoc)))
 	    (add-to-version-history occ-assoc :start-revision revision))
-	  (make-construct 'OccurrenceAssociationC
-			  :start-revision revision
-			  :parent-construct construct
-			  :characteristic occurrence))
+	  (make-instance 'OccurrenceAssociationC
+			 :start-revision revision
+			 :parent-construct construct
+			 :characteristic occurrence))
       construct)))
 
 
@@ -773,6 +1045,8 @@
   (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
 
 
+
+;;; NameC
 (defgeneric variants (construct &key revision)
   (:documentation "Returns all variants that correspond with the given revision
                    and that are associated with the passed construct.")
@@ -786,7 +1060,7 @@
 (defgeneric add-variant (construct variant &key revision)
   (:documentation "Adds the given theme-topic to the passed
                    scopable-construct.")
-  (:method ((construct ScopableC) (variant VariantC)
+  (:method ((construct NameC) (variant VariantC)
 	    &key (revision *TM-REVISION*))
     (when (not (eql (parent variant) construct))
       (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
@@ -822,6 +1096,7 @@
       construct)))
 
 
+;;; CharacteristicC
 (defmethod delete-construct :before ((construct CharacteristicC))
   "Deletes all association-obejcts."
   (dolist (parent-assoc (slot-p construct 'parent))
@@ -923,66 +1198,20 @@
   (let ((assoc-to-delete
 	 (loop for parent-assoc in (slot-p construct 'parent)
 	    when (eql (characteristic parent-assoc) parent-construct)
-	    return parent-assoc)))
-    (when assoc-to-delete
-      (mark-as-deleted assoc-to-delete :revision revision))
-    construct))
-
-
-;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; PlayerAssociationC
-;;; RoleAssociationC
-;;; VariantAssociationC
-;;; NameAssociationC
-;;; OccurrenceAssociationC
-;;; CharacteristicAssociationC
-;;; TypeAssociationC
-;;; ScopeAssociationC
-;;; ReifierAssociationC
-;;; SubjectLocatorAssociationC
-;;; PersistentIdAssociationC
-;;; TopicIdAssociationC
-;;; ItemIdAssociationC
-;;; PointerAssociationC
-;;; VersionedAssociationC
-(defpclass PlayerAssociationC(VersionedAssociationC)
-  ((player-topic :initarg :player-topic
-		 :accessor player-topic
-		 :associate TopicC
-		 :initform (error "From PlayerAssociationC(): player-topic must be set")
-		 :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")
-		     :documentation "Associates this object with the parent-association."))
-  (:documentation "This class associates roles and their player in given
-                   revisions."))
+	    return parent-assoc)))
+    (when assoc-to-delete
+      (mark-as-deleted assoc-to-delete :revision revision))
+    construct))
 
 
+;;; PlayerAssociationC
 (defmethod delete-construct :before ((construct PlayerAssociationC))
   "Deletes all elephant-associations."
   (delete-1-n-association construct 'player-topic)
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass RoleAssociationC(VersionedAssociationC)
-  ((role :initarg :role
-	 :accessor role
-	 :associate RoleC
-	 :initform (error "From RoleAssociationC(): role must be set")
-	 :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")
-		     :documentation "Assocates thius object with an
-                                     association-object."))
-  (:documentation "Associates roles with assoications and adds some
-                   version-infos between these realtions."))
-
-
+;;; RoleAssociationC
 (defmethod delete-construct :before ((construct RoleAssociationC))
   "Deletes all elephant-associations and the entire role if it is not
    associated with another AssociationC object."
@@ -993,60 +1222,22 @@
     (delete-1-n-association construct 'parent-construct)))
 
 
-(defpclass VariantAssociationC(CharateristicAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From VariantAssociationC(): parent-construct must be set")
-		     :associate NameC
-		     :documentation "Associates this object with a name."))
-  (:documentation "Associates variant objects with name obejcts.
-                   Additionally version-infos are stored."))
-
-
+;;; VariantAssociationC
 (defmethod delete-construct :before ((construct VariantAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass NameAssociationC(CharacteristicAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From NameAssociationC(): parent-construct must be set")
-		     :associate TopicC
-		     :documentation "Associates this object with a topic."))
-  (:documentation "Associates name objects with their parent topics.
-                   Additionally version-infos are stored."))
-
-
+;;; NameAssociationC
 (defmethod delete-construct :before ((construct NameAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
-		     :associate TopicC
-		     :documentation "Associates this object with a topic."))
-  (:documentation "Associates occurrence objects with their parent topics.
-                   Additionally version-infos are stored."))
-
-
+;;; OccurrenceAssociationC
 (defmethod delete-construct :before ((construct OccurrenceAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass CharacteristicAssociationC(VersionedAssociationC)
-  ((characteristic :initarg :characteristic
-		   :accessor characteristic
-		   :inherit t
-		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
-		   :associate CharactersiticC
-		   :documentation "Associates this object with the actual
-                                   characteristic object."))
-  (:documentation "An abstract base class for all association-objects that
-                   associates characteristics with topics."))
-
-
+;;; CharacteristicAssociationC
 (defmethod delete-construct :before ((construct CharacteristicAssociationC))
   "Deletes all elephant-associations."
   (let ((characteristic (characteristic construct)))
@@ -1056,73 +1247,21 @@
       (delete-construct characteristic))))
 
 
-(defpclass TypeAssociationC(VersionedAssociationC)
-  ((type-topic :initarg :type-topic
-	       :accessor type-topic
-	       :initform (error "From TypeAssociationC(): type-topic must be set")
-	       :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")
-		      :associate TypableC
-		      :documentation "Associates this object with the typable
-                                      construct that is typed by the
-                                      type-topic."))
-  (:documentation "This class associates topics that are used as type for
-                   typable constructcs. Additionally there are stored some
-                   version-infos."))
-
-
+;;; TypeAssociationC
 (defmethod delete-construct :before ((construct TypeAssociationC))
   "Deletes all elephant-associations of the given construct."
   (delete-1-n-association construct 'type-topic)
   (delete-1-n-association construct 'typable-construct))
 
 
-(defpclass ScopeAssociationC(VersionedAssociationC)
-  ((theme-topic :initarg :theme-topic
-		:accessor theme-topic
-		:initform (error "From ScopeAssociationC(): theme-topic must be set")
-		: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")
-		       :associate ScopableC
-		       :documentation "Associates this object with the socpable
-                                       construct that is scoped by the
-                                       scope-topic."))
-  (:documentation "This class associates topics that are used as scope with
-                   scopable construtcs. Additionally there are stored some
-                   version-infos"))
-
-
+;;; ScopeAssociationC
 (defmethod delete-construct :before ((construct ScopeAssociationC))
   "Deletes all elephant-associations of this construct."
   (delete-1-n-association construct 'theme-topic)
   (delete-1-n-association construct 'scopable-topic))
 
 
-(defpclass ReifierAssociationC(VersionedAssociationC)
-  ((reifiable-construct :initarg :reifiable-construct
-			:accessor reifiable-construct
-			:initform (error "From ReifierAssociation(): reifiable-construct must be set")
-			: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")
-		  :associate TopicC
-		  :documentation "The reifier-topic that reifies the
-                                  reifiable-construct."))
-  (:documentation "A versioned-association that relates a reifiable-construct
-                   with a topic."))
-
-
+;;; ReifierAssociationC
 (defmethod delete-construct :before ((construct ReifierAssociationC))
   "Deletes the association-construct and the reifier-topic when it
    is not used as a reifier of another construct."
@@ -1133,78 +1272,27 @@
       (delete-construct reifier-top))))
 
 
-(defpclass SubjectLocatorAssociationC(PointerAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
-		     :associate TopicC
-		     :documentation "The actual topic which is associated
-                                     with the subject-locator."))
-  (:documentation "A pointer that associates subject-locators, versions
-                   and topics."))
-
-
+;;; SubjectLocatorAssociationC
 (defmethod delete-construct :before ((construct SubjectLocatorAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass PersistentIdAssociationC(PointerAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
-		     :associate TopicC
-		     :documentation "The actual topic which is associated
-                                     with the subject-identifier/psi."))
-  (:documentation "A pointer that associates subject-identifiers, versions
-                   and topics."))
-
-
+;;; PersistentIdAssociationC
 (defmethod delete-construct :before ((construct PersistentIdAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass TopicIdAssociationC(PointerAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From TopicIdAssociationC(): parent-construct must be set")
-		     :associate TopicC
-		     :documentation "The actual topic which is associated
-                                     with the topic-identifier."))
-  (:documentation "A pointer that associates topic-identifiers, versions
-                   and topics."))
-
-
+;;; TopicIdAssociationC
 (defmethod delete-construct :before ((construct TopicIdAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass ItemIdAssociationC(PointerAssociationC)
-  ((parent-construct :initarg :parent-construct
-		     :accessor parent-construct
-		     :initform (error "From ItemIDAssociationC(): parent-construct must be set")
-		     :associate ReifiableConstructC
-		     :documentation "The actual parent which is associated
-                                     with the item-identifier."))
-  (:documentation "A pointer that associates item-identifiers, versions
-                   and reifiable-constructs."))
-
-
+;;; ItemIdAssociationC
 (defmethod delete-construct :before ((construct ItemIdAssociationC))
   (delete-1-n-association construct 'parent-construct))
 
 
-(defpclass PointerAssociationC (VersionedAssociationC)
-  ((identifier :initarg :identifier
-	       :accessor identifier
-	       :inherit t
-	       :initform (error "From VersionedAssociationC(): identifier must be set")
-	       :associate PointerC
-	       :documentation "The actual data that is associated with
-                               the pointer-association's parent."))
-  (:documentation "An abstract base class for all versioned
-                   pointer-associations."))
-
-
+;;; PointerAssociationC
 (defmethod delete-construct :before ((construct PointerAssociationC))
   "Deletes the association-construct and the pointer if it is not used
    as an idengtiffier of any other object."
@@ -1214,31 +1302,7 @@
       (delete-construct id))))
 
 
-(defpclass VersionedAssociationC()
-  ()
-  (:documentation "An abstract base class for all versioned associations."))
-
-
-;;; RoleC + AssociationC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
-  ((roles :associate (RoleAssociationC association)
-	  :documentation "Contains all association-objects of all roles this
-                          association contains.")
-   (in-topicmaps :associate (TopicMapC associations)
-		 :many-to-many t
-		 :documentation "List of all topic maps this association is
-                                 part of"))
-  (:index t)
-  (:documentation "Association in a Topic Map"))
-
-
-(defpclass RoleC(ReifiableConstructC TypableC)
-  ((parent :associate (RoleAssociationC role)
-	   :documentation "Associates this object with a role-association.")
-   (player :associate (PlayerAssociationC parent-construct)
-	   :documentation "Associates this object with a player-association.")))
-
-
+;;; AssociationC
 (defmethod delete-construct :before ((construct AssociationC))
   "Removes all elephant-associations and deleted all roles that are not
    associated by another associations."
@@ -1295,6 +1359,7 @@
   (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
 
 
+;;; RoleC
 (defmethod delete-construct :before ((construct RoleC))
   "Deletes all association-objects."
   (dolist (assoc (slot-p construct 'parent))
@@ -1341,7 +1406,7 @@
 	    &key (revision (error "From delete-parent(): revision must be set")))
   (let ((assoc-to-delete
 	 (loop for parent-assoc in (slot-p construct 'parent)
-	    when (eql (association parent-assoc) parent-construct)
+	    when (eql (parent-construct parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
       (mark-as-deleted assoc-to-delete :revision revision))
@@ -1399,18 +1464,7 @@
       construct)))
 
 
-;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass ReifiableConstructC(TopicMapConstructC)
-  ((item-identifiers :associate (ItemIdAssociationC identified-construct)
-		     :inherit t
-		     :documentation "A relation to all item-identifiers of
-                                     this construct.")
-   (reifier :associate (ReifierAssociationC reified-construct)
-	    :inherit t
-	    :documentation "A relation to a reifier-topic."))
-  (:documentation "Reifiable constructs as per TMDM."))
-
-
+;;; ReifiableConstructC
 (defgeneric item-identifiers (construct &key revision)
   (:documentation "Returns the ItemIdentifierC-objects that correspond
                    with the passed construct and the passed version.")
@@ -1463,11 +1517,11 @@
 						     :revision revision)
 			       construct))
 	    (t
-	     (make-construct 'ItemIdAssociationC
-			     :start-revision revision
-			     :parent-construct construct
-			     :identifier item-identifier)
-	     construct)))))
+	     (make-instance 'ItemIdAssociationC 
+			    :start-revision revision
+			    :parent-construct construct
+			    :identifier item-identifier)))
+      construct)))
 
 
 (defgeneric delete-item-identifier (construct item-identifier &key revision)
@@ -1509,10 +1563,10 @@
 	      (all-constructs
 	       (merge-constructs (first all-constructs) construct))
 	      (t
-	       (make-construct 'ReifierAssociationC
-			       :start-revision revision
-			       :reifiable-construct construct
-			       :reifier-topic merged-reifier-topic)
+	       (make-instance 'ReifierAssociationC
+			      :start-revision revision
+			      :reifiable-construct construct
+			      :reifier-topic merged-reifier-topic)
 	       construct))))))
 
 
@@ -1529,22 +1583,7 @@
       construct)))
 
 
-;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass TopicMapConstructC()
-  ()
-  (:documentation "An abstract base class for all classes that describes
-                   Topic Maps data."))
-
-
-;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass ScopableC()
-  ((themes :associate (ScopeAssociationC scopable-construct)
-	   :inherit t
-	   :documentation "Contains all association-objects that contain the
-                           actual scope-topics."))
-  (:documentation "An abstract base class for all constructs that are scoped."))
-
-
+;;; ScopableC
 (defmethod delete-construct :before ((construct ScopableC))
   "Deletes all ScopeAssociationCs that are associated with the given object."
   (dolist (theme (slot-p construct 'themes))
@@ -1595,15 +1634,7 @@
       construct)))
 
 
-;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defpclass TypableC()
-  ((instance-of :associate (TypeAssociationC type-topic)
-		:inherit t
-		:documentation "Contains all association-objects that contain
-                                the actual type-topic."))
-  (:documentation "An abstract base class for all typed constructcs."))
-
-
+;;; TypableC
 (defmethod delete-construct :before ((construct TypableC))
   "Deletes all TypeAssociationCs that are associated with this object."
   (dolist (type (slot-p construct 'instance-of))
@@ -1663,18 +1694,6 @@
       construct)))
 
 
-;;; DatatypableC
-(defpclass DatatypableC()
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform constants:*xml-string*
-             :documentation "The XML Schema datatype of the occurrencevalue
-                             (optional, always IRI for resourceRef)."))
-  (:index t)
-  (:documentation "An abstract base class for characteristics that own
-                   an xml-datatype."))
-
-
 
 
 

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	Sat Feb 20 09:49:30 2010
@@ -16,7 +16,8 @@
    :unittests-constants)
   (:export :run-datamodel-tests
 	   :test-VersionInfoC
-	   :test-VersionedConstructC))
+	   :test-VersionedConstructC
+	   :test-ItemIdentifierC))
 
 
 (declaim (optimize (debug 3)))
@@ -91,11 +92,28 @@
       (is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 0))
       (is (= (length
 	      (elephant:get-instances-by-class 'd::VersionedConstructC)) 0)))))
-      
-      
 
 
+(test test-ItemIdentifierC ()
+    "Tests various functions of the VersionedCoinstructC class."
+    (with-fixture with-empty-db (*db-dir*)
+      (setf d:*TM-REVISION* 100)
+      (let ((ii-1 (make-instance 'd:ItemIdentifierC
+				 :uri "ii-1"))
+	    (ii-2 (make-instance 'd:ItemIdentifierC
+				 :uri "ii-2"))
+	    (topic (make-instance 'd:TopicC)))
+	(is-false (d:identified-construct ii-1))
+	(signals error (make-instance 'd:ItemIdentifierC))
+	(is-false (item-identifiers topic))
+	(d:add-item-identifier topic ii-1)
+	(format t ">>> ~a~%" (d::parent-construct ii-1))
+	(is (= (length (d:item-identifiers topic)) 1))
+	)))
+	
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
+  (it.bese.fiveam:run! 'test-ItemIdentifierC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Sun Feb 21 20:34:02 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sun, 21 Feb 2010 15:34:02 -0500
Subject: [isidorus-cvs] r199 - in branches/new-datamodel: playground
	src/model
Message-ID: <E1NjIV8-0004Eo-3U@common-lisp.net>

Author: lgiessmann
Date: Sun Feb 21 15:34:01 2010
New Revision: 199

Log:
new-datamodel: added some example code files that analyses certain situations and elephant's behviour

Added:
   branches/new-datamodel/playground/
   branches/new-datamodel/playground/ii_versioned_association.lisp
   branches/new-datamodel/playground/system_crash.lisp
   branches/new-datamodel/playground/versioned-pointer.lisp
Modified:
   branches/new-datamodel/src/model/datamodel.lisp

Added: branches/new-datamodel/playground/ii_versioned_association.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/playground/ii_versioned_association.lisp	Sun Feb 21 15:34:01 2010
@@ -0,0 +1,117 @@
+(asdf:operate 'asdf:load-op 'elephant)
+(use-package :elephant)
+
+(defpclass VersionInfoC()
+  ((start-revision :initarg :start-revision
+		   :accessor start-revision
+		   :type integer
+		   :initform 0)
+   (end-revision :initarg :end-revision
+		 :accessor end-revision
+		 :type integer
+		 :initform 0)
+   (versioned-construct :initarg :versioned-construct
+			:accessor versioned-construct
+			:associate VersionedConstructC)))
+
+(defpclass VersionedConstructC()
+  ((versions :initarg :versions
+	     :accessor versions
+	     :inherit t
+	     :associate (VersionInfoC versioned-construct))))
+
+
+(defpclass VersionedAssociationC(VersionedConstructC)
+  ())
+
+
+(defpclass PointerAssociationC (VersionedAssociationC)
+  ((identifier :initarg :identifier
+	       :accessor identifier
+	       :inherit t
+	       :initform (error "From PointerAssociationC(): identifier must be set")
+	       :associate PointerC)))
+
+
+(defpclass ItemIdAssociationC(PointerAssociationC)
+  ((parent-construct :initarg :parent-construct
+		     :accessor parent-construct
+		     :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+		     :associate ReifiableConstructC)))
+
+
+(defpclass TopicMapConstructC()
+  ())
+
+
+(defpclass ReifiableConstructC(TopicMapConstructC)
+  ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+		     :inherit t)))
+
+
+(defpclass PointerC(TopicMapConstructC)
+  ((uri :initarg :uri
+	:accessor uri
+	:inherit t
+	:type string
+	:initform (error "From PointerC(): uri must be set for a pointer")
+	:index t)
+   (identified-construct :associate (PointerAssociationC identifier)
+			 :inherit t)))
+
+
+(defpclass IdentifierC(PointerC)
+  ())
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+  ()
+  (:index t))
+
+
+(open-store '(:BDB "data_base"))
+(defvar *p* (make-instance 'PointerC
+			   :uri "anyUri"))
+(defvar *pa* (make-instance 'PointerAssociationC
+			    :identifier *p*))
+
+(defvar *ii* (make-instance 'ItemIdentifierC
+			    :uri "anyUri"))
+
+(defvar *pa-ii* (make-instance 'PointerAssociationC
+			       :identifier *ii*))
+
+(defvar *ii-2* (make-instance 'ItemIdentifierC
+			      :uri "anyUri"))
+
+(defvar *rc* (make-instance 'ReifiableConstructC))
+
+
+(defvar *ia* (make-instance 'ItemIdAssociationC
+			    :identifier *ii-2*
+			    :parent-construct *rc*))
+
+
+(when (not (slot-value *p* 'identified-construct))
+  (error ">> 1"))
+
+(when (not (slot-value *pa* 'identifier))
+  (error ">> 2"))
+
+(when (not (slot-value *ii* 'identified-construct))
+  (error ">> 3"))
+
+(when (not (slot-value *pa-ii* 'identifier))
+  (error ">> 4"))
+
+(when (not (slot-value *ii-2* 'identified-construct))
+  (error ">> 5"))
+
+(when (not (slot-value *rc* 'item-identifiers))
+  (error ">> 6"))
+
+(when (not (slot-value *ia* 'parent-construct))
+  (error ">> 7"))
+
+(when (not (slot-value *ia* 'identifier))
+  (error ">> 8"))
\ No newline at end of file

Added: branches/new-datamodel/playground/system_crash.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/playground/system_crash.lisp	Sun Feb 21 15:34:01 2010
@@ -0,0 +1,3 @@
+(sb-mop:class-slots (find-class 'd:ItemIdentifierC))
+(sb-mop:class-finalized-p (find-class 'd:ItemIdentifierC))
+(sb-mop:finalize-inheritance (find-class 'd:ItemIdentifierC))

Added: branches/new-datamodel/playground/versioned-pointer.lisp
==============================================================================
--- (empty file)
+++ branches/new-datamodel/playground/versioned-pointer.lisp	Sun Feb 21 15:34:01 2010
@@ -0,0 +1,28 @@
+(asdf:operate 'asdf:load-op 'elephant)
+(elephant:open-store '(:BDB "data_base"))
+(defpclass Relation()
+	   ((to-a :associate NodeA
+		  :accessor to-a
+		  :initarg :to-a)
+	    (to-b :associate NodeB
+		  :accessor to-b
+		  :initarg :to-b)
+	    (version :initarg :version
+		     :accessor version
+		     :type integer
+		     :index t))
+	   (:index t))
+(defpclass NodeA()
+	   ((relation-to-b :associate (Relation to-a)
+			   :accessor relation-to-b
+			   :initarg :relation-to-b))
+	   (:index t))
+(defpclass NodeB()
+	   ((relation-to-a :associate (Relation to-b)
+			   :accessor relation-to-a
+			   :initarg :relation-to-a))
+	   (:index t))
+(defvar *rel* (make-instance 'Relation
+				      :to-a (make-instance 'NodeA)
+				      :to-b (make-instance 'NodeB)
+				      :version 1))

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Sun Feb 21 15:34:01 2010
@@ -190,7 +190,7 @@
 (defpclass PointerC(TopicMapConstructC)
   ((uri :initarg :uri
 	:accessor uri
-	:inherit t
+	;:inherit t
 	:type string
 	:initform (error "From PointerC(): uri must be set for a pointer")
 	:index t
@@ -308,7 +308,7 @@
    (charvalue :initarg :charvalue
 	      :accessor charvalue
 	      :type string
-	      :inherit t
+	      ;:inherit t
 	      :initform ""
 	      :index t
 	      :documentation "Contains the actual data of this object."))
@@ -426,7 +426,7 @@
 (defpclass PointerAssociationC (VersionedAssociationC)
   ((identifier :initarg :identifier
 	       :accessor identifier
-	       :inherit t
+	       ;:inherit t
 	       :initform (error "From PointerAssociationC(): identifier must be set")
 	       :associate PointerC
 	       :documentation "The actual data that is associated with
@@ -469,7 +469,7 @@
 (defpclass CharacteristicAssociationC(VersionedAssociationC)
   ((characteristic :initarg :characteristic
 		   :accessor characteristic
-		   :inherit t
+		   ;:inherit t
 		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
 		   :associate CharactersiticC
 		   :documentation "Associates this object with the actual



From lgiessmann at common-lisp.net  Mon Feb 22 19:05:08 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 22 Feb 2010 14:05:08 -0500
Subject: [isidorus-cvs] r200 - branches/new-datamodel/src/model
Message-ID: <E1Njdae-0005FV-3j@common-lisp.net>

Author: lgiessmann
Date: Mon Feb 22 14:05:06 2010
New Revision: 200

Log:
new-datamode: fixed a problem with elephant-associaitons in the PointerAssociationC-classes

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	Mon Feb 22 14:05:06 2010
@@ -144,29 +144,56 @@
                              class.")))
 
 
-;;; pointers ...
-(defpclass SubjectLocatorC(IdentifierC)
+;;; base classes ...
+(defpclass TopicMapConstructC()
   ()
-  (:index t)
-  (:documentation "A subject-locator that contains an uri-value and an
-                   association to SubjectLocatorAssociationC's which are in
-                   turn associated with TopicC's."))
+  (:documentation "An abstract base class for all classes that describes
+                   Topic Maps data."))
 
 
-(defpclass PersistentIdC(IdentifierC)
-  ()
-  (:index t)
-  (:documentation "A subject-identifier that contains an uri-value and an
-                   association to PersistentIdAssociationC's which are in
-                   turn associated with TopicC's."))
+(defpclass ScopableC()
+  ((themes :associate (ScopeAssociationC scopable-construct)
+	   :inherit t
+	   :documentation "Contains all association-objects that contain the
+                           actual scope-topics."))
+  (:documentation "An abstract base class for all constructs that are scoped."))
 
 
-(defpclass ItemIdentifierC(IdentifierC)
-  ()
+(defpclass TypableC()
+  ((instance-of :associate (TypeAssociationC type-topic)
+		:inherit t
+		:documentation "Contains all association-objects that contain
+                                the actual type-topic."))
+  (:documentation "An abstract base class for all typed constructcs."))
+
+
+(defpclass DatatypableC()
+  ((datatype :accessor datatype
+             :initarg :datatype
+             :initform constants:*xml-string*
+	     :type string
+             :documentation "The XML Schema datatype of the occurrencevalue
+                             (optional, always IRI for resourceRef)."))
   (:index t)
-  (:documentation "An item-identifier that contains an uri-value and an
-                   association to ItemIdAssociationC's which are in turn
-                   associated with RiefiableConstructC's."))
+  (:documentation "An abstract base class for characteristics that own
+                   an xml-datatype."))
+
+
+;;; pointers ...
+(defpclass PointerC(TopicMapConstructC)
+  ((uri :initarg :uri
+	:accessor uri
+	:inherit t
+	:type string
+	:initform (error "From PointerC(): uri must be set for a pointer")
+	:index t
+	:documentation "The actual value of a pointer, i.e. uri or ID.")
+   (identified-construct :associate (PointerAssociationC identifier)
+			 :inherit t
+			 :documentation "Associates a association-object that
+                                         additionally stores some
+                                         version-infos."))
+  (:documentation "An abstract base class for all pointers."))
 
 
 (defpclass IdentifierC(PointerC)
@@ -187,23 +214,42 @@
                    representing one of them."))
 
 
-(defpclass PointerC(TopicMapConstructC)
-  ((uri :initarg :uri
-	:accessor uri
-	;:inherit t
-	:type string
-	:initform (error "From PointerC(): uri must be set for a pointer")
-	:index t
-	:documentation "The actual value of a pointer, i.e. uri or ID.")
-   (identified-construct :associate (PointerAssociationC identifier)
-			 :inherit t
-			 :documentation "Associates a association-object that
-                                         additionally stores some
-                                         version-infos."))
-  (:documentation "An abstract base class for all pointers."))
+(defpclass SubjectLocatorC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-locator that contains an uri-value and an
+                   association to SubjectLocatorAssociationC's which are in
+                   turn associated with TopicC's."))
+
+
+(defpclass PersistentIdC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "A subject-identifier that contains an uri-value and an
+                   association to PersistentIdAssociationC's which are in
+                   turn associated with TopicC's."))
+
+
+(defpclass ItemIdentifierC(IdentifierC)
+  ()
+  (:index t)
+  (:documentation "An item-identifier that contains an uri-value and an
+                   association to ItemIdAssociationC's which are in turn
+                   associated with RiefiableConstructC's."))
 
 
 ;;; reifiables ...
+(defpclass ReifiableConstructC(TopicMapConstructC)
+  ((item-identifiers :associate (ItemIdAssociationC parent-construct)
+		     :inherit t
+		     :documentation "A relation to all item-identifiers of
+                                     this construct.")
+   (reifier :associate (ReifierAssociationC reified-construct)
+	    :inherit t
+	    :documentation "A relation to a reifier-topic."))
+  (:documentation "Reifiable constructs as per TMDM."))
+
+
 (defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
   ((roles :associate (RoleAssociationC association)
 	  :documentation "Contains all association-objects of all roles this
@@ -223,17 +269,6 @@
 	   :documentation "Associates this object with a player-association.")))
 
 
-(defpclass ReifiableConstructC(TopicMapConstructC)
-  ((item-identifiers :associate (ItemIdAssociationC parent-construct)
-		     :inherit t
-		     :documentation "A relation to all item-identifiers of
-                                     this construct.")
-   (reifier :associate (ReifierAssociationC reified-construct)
-	    :inherit t
-	    :documentation "A relation to a reifier-topic."))
-  (:documentation "Reifiable constructs as per TMDM."))
-
-
 (elephant:defpclass TopicMapC (ReifiableConstructC)
   ((topics :accessor topics
 	   :associate (TopicC in-topicmaps)
@@ -284,6 +319,22 @@
 
 
 ;;; characteristics ...
+(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
+  ((parent :associate (CharacteriticAssociationC characteristic)
+	   :inherit t
+	   :documentation "Assocates the characterist obejct with the
+                           parent-association.")
+   (charvalue :initarg :charvalue
+	      :accessor charvalue
+	      :type string
+	      :inherit t
+	      :initform ""
+	      :index t
+	      :documentation "Contains the actual data of this object."))
+  (:documentation "Scoped characteristic of a topic (meant to be used
+                   as an abstract class)."))
+
+
 (defpclass OccurrenceC(CharacteristicC DatatypableC)
   ()
   (:documentation "Represents a TM occurrence."))
@@ -300,23 +351,12 @@
   (:documentation "Represents a TM variant."))
 
 
-(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
-  ((parent :associate (CharacteriticAssociationC characteristic)
-	   :inherit t
-	   :documentation "Assocates the characterist obejct with the
-                           parent-association.")
-   (charvalue :initarg :charvalue
-	      :accessor charvalue
-	      :type string
-	      ;:inherit t
-	      :initform ""
-	      :index t
-	      :documentation "Contains the actual data of this object."))
-  (:documentation "Scoped characteristic of a topic (meant to be used
-                   as an abstract class)."))
+;;; versioned associations ...
+(defpclass VersionedAssociationC(VersionedConstructC)
+  ()
+  (:documentation "An abstract base class for all versioned associations."))
 
 
-;;; versioned associations ...
 (defpclass TypeAssociationC(VersionedAssociationC)
   ((type-topic :initarg :type-topic
 	       :accessor type-topic
@@ -372,13 +412,19 @@
                    with a topic."))
 
 
-(defpclass VersionedAssociationC(VersionedConstructC)
-  ()
-  (:documentation "An abstract base class for all versioned associations."))
-
+;;; pointer associations ...
+(defpclass PointerAssociationC (VersionedAssociationC)
+  ((identifier :initarg :identifier
+	       :accessor identifier
+	       :inherit t
+	       :initform (error "From PointerAssociationC(): identifier must be set")
+	       :associate PointerC
+	       :documentation "The actual data that is associated with
+                               the pointer-association's parent."))
+  (:documentation "An abstract base class for all versioned
+                   pointer-associations."))
 
 
-;;; pointer associations ...
 (defpclass SubjectLocatorAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
@@ -423,19 +469,19 @@
                    and reifiable-constructs."))
 
 
-(defpclass PointerAssociationC (VersionedAssociationC)
-  ((identifier :initarg :identifier
-	       :accessor identifier
-	       ;:inherit t
-	       :initform (error "From PointerAssociationC(): identifier must be set")
-	       :associate PointerC
-	       :documentation "The actual data that is associated with
-                               the pointer-association's parent."))
-  (:documentation "An abstract base class for all versioned
-                   pointer-associations."))
+;;; characteristic associations ...
+(defpclass CharacteristicAssociationC(VersionedAssociationC)
+  ((characteristic :initarg :characteristic
+		   :accessor characteristic
+		   :inherit t
+		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+		   :associate CharactersiticC
+		   :documentation "Associates this object with the actual
+                                   characteristic object."))
+  (:documentation "An abstract base class for all association-objects that
+                   associates characteristics with topics."))
 
 
-;;; characteristic associations ...
 (defpclass VariantAssociationC(CharateristicAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
@@ -466,18 +512,6 @@
                    Additionally version-infos are stored."))
 
 
-(defpclass CharacteristicAssociationC(VersionedAssociationC)
-  ((characteristic :initarg :characteristic
-		   :accessor characteristic
-		   ;:inherit t
-		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
-		   :associate CharactersiticC
-		   :documentation "Associates this object with the actual
-                                   characteristic object."))
-  (:documentation "An abstract base class for all association-objects that
-                   associates characteristics with topics."))
-
-
 ;;; roles/association associations ...
 (defpclass PlayerAssociationC(VersionedAssociationC)
   ((player-topic :initarg :player-topic
@@ -511,48 +545,19 @@
                    version-infos between these realtions."))
 
 
-;;; base classes ...
-(defpclass TopicMapConstructC()
-  ()
-  (:documentation "An abstract base class for all classes that describes
-                   Topic Maps data."))
-
-
-(defpclass ScopableC()
-  ((themes :associate (ScopeAssociationC scopable-construct)
-	   :inherit t
-	   :documentation "Contains all association-objects that contain the
-                           actual scope-topics."))
-  (:documentation "An abstract base class for all constructs that are scoped."))
-
-
-(defpclass TypableC()
-  ((instance-of :associate (TypeAssociationC type-topic)
-		:inherit t
-		:documentation "Contains all association-objects that contain
-                                the actual type-topic."))
-  (:documentation "An abstract base class for all typed constructcs."))
-
-
-(defpclass DatatypableC()
-  ((datatype :accessor datatype
-             :initarg :datatype
-             :initform constants:*xml-string*
-	     :type string
-             :documentation "The XML Schema datatype of the occurrencevalue
-                             (optional, always IRI for resourceRef)."))
-  (:index t)
-  (:documentation "An abstract base class for characteristics that own
-                   an xml-datatype."))
-
-
 ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun slot-p (instance slot-symbol)
   "Returns t if the slot depending on slot-symbol is bound and not nil."
-  (when (slot-boundp instance slot-symbol)
-    (let ((value (slot-value instance slot-symbol)))
-      (when value
-	value))))
+  (if (slot-boundp instance slot-symbol)
+      (let ((value (slot-value instance slot-symbol)))
+	(when value
+	  value))
+      ;elephant-relations are handled separately, since slot-boundp does not
+      ;here
+      (handler-case (let ((value (slot-value instance slot-symbol)))
+		      (when value
+			value))
+	(error () nil))))
 
 
 (defun delete-1-n-association(instance slot-symbol)
@@ -1517,10 +1522,11 @@
 						     :revision revision)
 			       construct))
 	    (t
-	     (make-instance 'ItemIdAssociationC 
-			    :start-revision revision
-			    :parent-construct construct
-			    :identifier item-identifier)))
+	     (let ((assoc
+		    (make-instance 'ItemIdAssociationC
+				   :parent-construct construct
+				   :identifier item-identifier)))
+	       (add-to-version-history assoc :start-revision revision))))
       construct)))
 
 



From lgiessmann at common-lisp.net  Mon Feb 22 19:55:41 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 22 Feb 2010 14:55:41 -0500
Subject: [isidorus-cvs] r201 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NjeNY-0008PI-Vk@common-lisp.net>

Author: lgiessmann
Date: Mon Feb 22 14:55:40 2010
New Revision: 201

Log:
new-datamodel: fixed some bugs in item-identifiers, add-item-identifier and delete-item-identifier; added a unit-test for item-identifiers

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	Mon Feb 22 14:55:40 2010
@@ -1508,17 +1508,19 @@
   (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
 	    &key (revision *TM-REVISION*))
     (let ((all-ids
-	   (map 'list #'identifier
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct 'item-identifiers)))))
+	   (map 'list #'identifier (slot-p construct 'item-identifiers)))
+	  (construct-to-be-merged
+	   (let ((id-owner (identified-construct item-identifier)))
+	     (when (not (eql id-owner construct))
+	       id-owner))))
       (cond ((find item-identifier all-ids)
 	     (let ((ii-assoc (loop for ii-assoc in (slot-p construct
 							   'item-identifiers)
 				when (eql (identifier ii-assoc) item-identifier)
 				return ii-assoc)))
 	       (add-to-version-history ii-assoc :start-revision revision)))
-	    (all-ids
-	     (merge-constructs (identified-construct (first all-ids)
+	    (construct-to-be-merged
+	     (merge-constructs (identified-construct construct-to-be-merged
 						     :revision revision)
 			       construct))
 	    (t

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	Mon Feb 22 14:55:40 2010
@@ -97,19 +97,52 @@
 (test test-ItemIdentifierC ()
     "Tests various functions of the VersionedCoinstructC class."
     (with-fixture with-empty-db (*db-dir*)
-      (setf d:*TM-REVISION* 100)
       (let ((ii-1 (make-instance 'd:ItemIdentifierC
 				 :uri "ii-1"))
 	    (ii-2 (make-instance 'd:ItemIdentifierC
 				 :uri "ii-2"))
-	    (topic (make-instance 'd:TopicC)))
+	    (topic-1 (make-instance 'd:TopicC))
+	    (revision-0 0)
+	    (revision-1 100)
+	    (revision-2 200)
+	    (revision-3 300)
+	    (revision-3-5 350)
+	    (revision-4 400))
+	(setf d:*TM-REVISION* revision-1)
 	(is-false (d:identified-construct ii-1))
 	(signals error (make-instance 'd:ItemIdentifierC))
-	(is-false (item-identifiers topic))
-	(d:add-item-identifier topic ii-1)
-	(format t ">>> ~a~%" (d::parent-construct ii-1))
-	(is (= (length (d:item-identifiers topic)) 1))
-	)))
+	(is-false (item-identifiers topic-1))
+	(d:add-item-identifier topic-1 ii-1)
+	(is (= (length (item-identifiers topic-1)) 1))
+	(is (eql (first (item-identifiers topic-1)) ii-1))
+	(is (eql (identified-construct ii-1) topic-1))
+	(d:add-item-identifier topic-1 ii-2 :revision revision-2)
+	(is (= (length (item-identifiers topic-1 :revision revision-0)) 2))
+	(is (= (length (item-identifiers topic-1 :revision revision-1)) 1))
+	(is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1))
+	(is (= (length (union (list ii-1 ii-2)
+			      (item-identifiers topic-1 :revision revision-2)))
+	       2))
+	(is (= (length (union (list ii-1 ii-2)
+			      (item-identifiers topic-1 :revision revision-0)))
+	       2))
+	(delete-item-identifier topic-1 ii-1 :revision revision-3)
+	(is (= (length (union (list ii-2)
+			      (d:item-identifiers topic-1
+						  :revision revision-0)))
+	       1))
+	(is (= (length (union (list ii-1 ii-2)
+			      (d:item-identifiers topic-1
+						  :revision revision-2)))
+	       2))
+	(delete-item-identifier topic-1 ii-2 :revision revision-3)
+	(is-false (item-identifiers topic-1 :revision revision-3))
+	(add-item-identifier topic-1 ii-1 :revision revision-4)
+	(is (= (length (union (list ii-1)
+			      (item-identifiers topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2))
+	(is-false (item-identifiers topic-1 :revision revision-3-5)))))
 	
 
 (defun run-datamodel-tests()



From lgiessmann at common-lisp.net  Tue Feb 23 19:35:33 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 23 Feb 2010 14:35:33 -0500
Subject: [isidorus-cvs] r202 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1Nk0Xc-0001Rb-38@common-lisp.net>

Author: lgiessmann
Date: Tue Feb 23 14:35:31 2010
New Revision: 202

Log:
new-datamode: added some unit-tests for PersistentIdC and SubjectLocatorC; fixed some bugs related to PersistentIdC, SubjectLocatorC and TopicC

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 Feb 23 14:35:31 2010
@@ -87,6 +87,8 @@
 (in-package :datamodel)
 
 
+;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
+;;      initarg in make-construct
 ;;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
@@ -287,7 +289,7 @@
    (psis :associate (PersistentIdAssociationC parent-construct)
 	 :documentation "Contains all association objects that relate a topic
                          with its actual psis.")
-   (locators :associate (PersistentIdAssociationC parent-construct)
+   (locators :associate (SubjectLocatorAssociationC parent-construct)
 	     :documentation "Contains all association objects that relate a
                              topic with its actual subject-lcoators.")
    (names :associate (NameAssociationC parent-construct)
@@ -824,24 +826,27 @@
   (:method ((construct TopicC) (psi PersistentIdC)
 	    &key (revision *TM-REVISION*))
     (let ((all-ids
-	   (map 'list #'identifier
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct 'psis)))))
-      (cond ((find psi all-ids)
+	   (map 'list #'identifier (slot-p construct 'psis)))
+	  (construct-to-be-merged
+	   (let ((id-owner (identified-construct psi)))
+	     (when (not (eql id-owner construct))
+	       id-owner))))
+      (cond (construct-to-be-merged
+	     (merge-constructs (identified-construct construct-to-be-merged
+						     :revision revision)
+			       construct))
+	    ((find psi all-ids)
 	     (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
 				when (eql (identifier psi-assoc) psi)
 				return psi-assoc)))
 	       (add-to-version-history psi-assoc :start-revision revision)))
-	    (all-ids
-	     (merge-constructs (identified-construct (first all-ids)
-						     :revision revision)
-			       construct))
 	    (t
-	     (make-instance 'PersistentIdAssociationC
-			    :start-revision revision
-			    :parent-construct construct
-			    :identifier psi)
-	     construct)))))
+	     (let ((assoc
+		    (make-instance 'PersistentIdAssociationC
+				   :parent-construct construct
+				   :identifier psi)))
+	       (add-to-version-history assoc :start-revision revision))))
+      construct)))
 
 
 (defgeneric delete-psi (construct psi &key revision)
@@ -875,24 +880,27 @@
   (:method ((construct TopicC) (locator SubjectLocatorC)
 	    &key (revision *TM-REVISION*))
     (let ((all-ids
-	   (map 'list #'identifier
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct 'locators)))))
-      (cond ((find locator all-ids)
+	   (map 'list #'identifier (slot-p construct 'locators)))
+	  (construct-to-be-merged
+	   (let ((id-owner (identified-construct locator)))
+	     (when (not (eql id-owner construct))
+	       id-owner))))
+      (cond (construct-to-be-merged
+	     (merge-constructs (identified-construct construct-to-be-merged
+						     :revision revision)
+			       construct))
+	    ((find locator all-ids)
 	     (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators)
 				when (eql (identifier loc-assoc) locator)
 				return loc-assoc)))
 	       (add-to-version-history loc-assoc :start-revision revision)))
-	    (all-ids
-	     (merge-constructs (identified-construct (first all-ids)
-						     :revision revision)
-			       construct))
 	    (t
-	     (make-instance 'SubjectLocatorAssociationC
-			    :start-revision revision
-			    :parent-construct construct
-			    :identifier locator)
-	     construct)))))
+	     (let ((assoc
+		    (make-instance 'SubjectLocatorAssociationC
+				   :parent-construct construct
+				   :identifier locator)))
+	       (add-to-version-history assoc :start-revision revision))))
+      construct)))
 
 
 (defgeneric delete-locator (construct locator &key revision)
@@ -1513,16 +1521,16 @@
 	   (let ((id-owner (identified-construct item-identifier)))
 	     (when (not (eql id-owner construct))
 	       id-owner))))
-      (cond ((find item-identifier all-ids)
+      (cond (construct-to-be-merged
+	     (merge-constructs (identified-construct construct-to-be-merged
+						     :revision revision)
+			       construct))
+	    ((find item-identifier all-ids)
 	     (let ((ii-assoc (loop for ii-assoc in (slot-p construct
 							   'item-identifiers)
 				when (eql (identifier ii-assoc) item-identifier)
 				return ii-assoc)))
 	       (add-to-version-history ii-assoc :start-revision revision)))
-	    (construct-to-be-merged
-	     (merge-constructs (identified-construct construct-to-be-merged
-						     :revision revision)
-			       construct))
 	    (t
 	     (let ((assoc
 		    (make-instance 'ItemIdAssociationC

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 Feb 23 14:35:31 2010
@@ -17,7 +17,15 @@
   (:export :run-datamodel-tests
 	   :test-VersionInfoC
 	   :test-VersionedConstructC
-	   :test-ItemIdentifierC))
+	   :test-ItemIdentifierC
+	   :test-PersistentIdC
+	   :test-SubjectLocatorC))
+
+
+;;TODO: test merges-constructs when merging was caused by an item-dentifier
+;;TODO: test merges-constructs when merging was caused by an psi
+;;TODO: test merges-constructs when merging was caused by an subject-locator
+
 
 
 (declaim (optimize (debug 3)))
@@ -44,9 +52,7 @@
       (is (= (d::end-revision vi-1) 300))
       (is (= (d::start-revision vi-2) 300))
       (is (= (d::end-revision vi-2) 0))
-      (is-false (d::versioned-construct-p vi-1))
-      (setf (d::versioned-construct vi-1) vc)
-      (is-true (d::versioned-construct-p vi-1)))))
+      (setf (d::versioned-construct vi-1) vc))))
 
 
 (test test-VersionedConstructC ()
@@ -78,9 +84,6 @@
 			  (= sr-2 100) (= er-2 500)))))
       (d::add-to-version-history vc :start-revision 600)
       (is (= (length (d::versions vc)) 3))
-      (map 'list #'(lambda(vi)
-		     (is-true (d::versioned-construct-p vi)))
-	   (d::versions vc))
       (d::add-to-version-history vc
 				 :start-revision 100
 				 :end-revision 500)
@@ -95,13 +98,13 @@
 
 
 (test test-ItemIdentifierC ()
-    "Tests various functions of the VersionedCoinstructC class."
+    "Tests various functions of the ItemIdentifierC class."
     (with-fixture with-empty-db (*db-dir*)
-      (let ((ii-1 (make-instance 'd:ItemIdentifierC
+      (let ((ii-1 (make-instance 'ItemIdentifierC
 				 :uri "ii-1"))
-	    (ii-2 (make-instance 'd:ItemIdentifierC
+	    (ii-2 (make-instance 'ItemIdentifierC
 				 :uri "ii-2"))
-	    (topic-1 (make-instance 'd:TopicC))
+	    (topic-1 (make-instance 'TopicC))
 	    (revision-0 0)
 	    (revision-1 100)
 	    (revision-2 200)
@@ -109,14 +112,14 @@
 	    (revision-3-5 350)
 	    (revision-4 400))
 	(setf d:*TM-REVISION* revision-1)
-	(is-false (d:identified-construct ii-1))
-	(signals error (make-instance 'd:ItemIdentifierC))
+	(is-false (identified-construct ii-1))
+	(signals error (make-instance 'ItemIdentifierC))
 	(is-false (item-identifiers topic-1))
-	(d:add-item-identifier topic-1 ii-1)
+	(add-item-identifier topic-1 ii-1)
 	(is (= (length (item-identifiers topic-1)) 1))
 	(is (eql (first (item-identifiers topic-1)) ii-1))
 	(is (eql (identified-construct ii-1) topic-1))
-	(d:add-item-identifier topic-1 ii-2 :revision revision-2)
+	(add-item-identifier topic-1 ii-2 :revision revision-2)
 	(is (= (length (item-identifiers topic-1 :revision revision-0)) 2))
 	(is (= (length (item-identifiers topic-1 :revision revision-1)) 1))
 	(is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1))
@@ -128,11 +131,11 @@
 	       2))
 	(delete-item-identifier topic-1 ii-1 :revision revision-3)
 	(is (= (length (union (list ii-2)
-			      (d:item-identifiers topic-1
+			      (item-identifiers topic-1
 						  :revision revision-0)))
 	       1))
 	(is (= (length (union (list ii-1 ii-2)
-			      (d:item-identifiers topic-1
+			      (item-identifiers topic-1
 						  :revision revision-2)))
 	       2))
 	(delete-item-identifier topic-1 ii-2 :revision revision-3)
@@ -143,10 +146,110 @@
 	       1))
 	(is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2))
 	(is-false (item-identifiers topic-1 :revision revision-3-5)))))
-	
+
+
+(test test-PersistentIdC ()
+    "Tests various functions of the PersistentIdC class."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((psi-1 (make-instance 'PersistentIdC
+				  :uri "psi-1"))
+	    (psi-2 (make-instance 'PersistentIdC
+				  :uri "psi-2"))
+	    (topic-1 (make-instance 'TopicC))
+	    (revision-0 0)
+	    (revision-1 100)
+	    (revision-2 200)
+	    (revision-3 300)
+	    (revision-3-5 350)
+	    (revision-4 400))
+	(setf d:*TM-REVISION* revision-1)
+	(is-false (identified-construct psi-1))
+	(signals error (make-instance 'PersistentIdC))
+	(is-false (psis topic-1))
+	(add-psi topic-1 psi-1)
+	(is (= (length (psis topic-1)) 1))
+	(is (eql (first (psis topic-1)) psi-1))
+	(is (eql (identified-construct psi-1) topic-1))
+	(add-psi topic-1 psi-2 :revision revision-2)
+	(is (= (length (psis topic-1 :revision revision-0)) 2))
+	(is (= (length (psis topic-1 :revision revision-1)) 1))
+	(is (eql (first (psis topic-1 :revision revision-1)) psi-1))
+	(is (= (length (union (list psi-1 psi-2)
+			      (psis topic-1 :revision revision-2)))
+	       2))
+	(is (= (length (union (list psi-1 psi-2)
+			      (psis topic-1 :revision revision-0)))
+	       2))
+	(delete-psi topic-1 psi-1 :revision revision-3)
+	(is (= (length (union (list psi-2)
+			      (psis topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (union (list psi-1 psi-2)
+			      (psis topic-1 :revision revision-2)))
+	       2))
+	(delete-psi topic-1 psi-2 :revision revision-3)
+	(is-false (psis topic-1 :revision revision-3))
+	(add-psi topic-1 psi-1 :revision revision-4)
+	(is (= (length (union (list psi-1)
+			      (psis topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (d::slot-p topic-1 'd::psis)) 2))
+	(is-false (psis topic-1 :revision revision-3-5)))))
+
+
+(test test-SubjectLocatorC ()
+    "Tests various functions of the SubjectLocatorC class."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((sl-1 (make-instance 'SubjectLocatorC
+				 :uri "sl-1"))
+	    (sl-2 (make-instance 'SubjectLocatorC
+				 :uri "sl-2"))
+	    (topic-1 (make-instance 'TopicC))
+	    (revision-0 0)
+	    (revision-1 100)
+	    (revision-2 200)
+	    (revision-3 300)
+	    (revision-3-5 350)
+	    (revision-4 400))
+	(setf d:*TM-REVISION* revision-1)
+	(is-false (identified-construct sl-1))
+	(signals error (make-instance 'SubjectLocatorC))
+	(is-false (locators topic-1))
+	(add-locator topic-1 sl-1)
+	(is (= (length (locators topic-1)) 1))
+	(is (eql (first (locators topic-1)) sl-1))
+	(is (eql (identified-construct sl-1) topic-1))
+	(add-locator topic-1 sl-2 :revision revision-2)
+	(is (= (length (locators topic-1 :revision revision-0)) 2))
+	(is (= (length (locators topic-1 :revision revision-1)) 1))
+	(is (eql (first (locators topic-1 :revision revision-1)) sl-1))
+	(is (= (length (union (list sl-1 sl-2)
+			      (locators topic-1 :revision revision-2)))
+	       2))
+	(is (= (length (union (list sl-1 sl-2)
+			      (locators topic-1 :revision revision-0)))
+	       2))
+	(delete-locator topic-1 sl-1 :revision revision-3)
+	(is (= (length (union (list sl-2)
+			      (locators topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (union (list sl-1 sl-2)
+			      (locators topic-1 :revision revision-2)))
+	       2))
+	(delete-locator topic-1 sl-2 :revision revision-3)
+	(is-false (locators topic-1 :revision revision-3))
+	(add-locator topic-1 sl-1 :revision revision-4)
+	(is (= (length (union (list sl-1)
+			      (locators topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (d::slot-p topic-1 'd::locators)) 2))
+	(is-false (locators topic-1 :revision revision-3-5)))))
+
 
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
   (it.bese.fiveam:run! 'test-ItemIdentifierC)
+  (it.bese.fiveam:run! 'test-PersistentIdC)
+  (it.bese.fiveam:run! 'test-SubjectLocatorC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Tue Feb 23 19:49:02 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 23 Feb 2010 14:49:02 -0500
Subject: [isidorus-cvs] r203 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1Nk0kf-00032x-VG@common-lisp.net>

Author: lgiessmann
Date: Tue Feb 23 14:49:01 2010
New Revision: 203

Log:
new-datamode: added some unit-tests for TopicIdentificationC; fixed some bugs related to TopicIdentifiecationC

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 Feb 23 14:49:01 2010
@@ -773,26 +773,29 @@
   (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
 	    &key (revision *TM-REVISION*))
     (let ((all-ids
-	   (map 'list #'identifier
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct 'topic-identifiers)))))
-      (cond ((find topic-identifier all-ids)
+	   (map 'list #'identifier (slot-p construct 'topic-identifiers)))
+	  (construct-to-be-merged
+	   (let ((id-owner (identified-construct topic-identifier)))
+	     (when (not (eql id-owner construct))
+	       id-owner))))
+      (cond (construct-to-be-merged
+	     (merge-constructs (identified-construct construct-to-be-merged
+						     :revision revision)
+			       construct))
+	    ((find topic-identifier all-ids)
 	     (let ((ti-assoc (loop for ti-assoc in (slot-p construct
 							   'topic-identifiers)
 				when (eql (identifier ti-assoc)
 					  topic-identifier)
 				return ti-assoc)))
 	       (add-to-version-history ti-assoc :start-revision revision)))
-	    (all-ids
-	     (merge-constructs (identified-construct (first all-ids)
-						     :revision revision)
-			       construct))
 	    (t
-	     (make-instance 'TopicIdAssociationC
-			    :start-revision revision
-			    :parent-construct construct
-			    :identifier topic-identifier)
-	     construct)))))
+	     (let ((assoc
+		    (make-instance 'TopicIdAssociationC
+				   :parent-construct construct
+				   :identifier topic-identifier)))
+	       (add-to-version-history assoc :start-revision revision))))
+      construct)))
 
 
 (defgeneric delete-topic-identifier (construct topic-identifier &key revision)

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 Feb 23 14:49:01 2010
@@ -19,12 +19,14 @@
 	   :test-VersionedConstructC
 	   :test-ItemIdentifierC
 	   :test-PersistentIdC
-	   :test-SubjectLocatorC))
+	   :test-SubjectLocatorC
+	   :test-TopicIdentificationC))
 
 
 ;;TODO: test merges-constructs when merging was caused by an item-dentifier
 ;;TODO: test merges-constructs when merging was caused by an psi
 ;;TODO: test merges-constructs when merging was caused by an subject-locator
+;;TODO: test merges-constructs when merging was caused by a topic-id
 
 
 
@@ -246,10 +248,65 @@
 	(is-false (locators topic-1 :revision revision-3-5)))))
 
 
+(test test-TopicIdentificationC ()
+    "Tests various functions of the TopicIdentificationC class."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((ti-1 (make-instance 'TopicIdentificationC
+				 :uri "ti-1"
+				 :xtm-id "xtm-id-1"))
+	    (ti-2 (make-instance 'TopicIdentificationC
+				 :uri "ti-2"
+				 :xtm-id "xtm-id-2"))
+	    (topic-1 (make-instance 'TopicC))
+	    (revision-0 0)
+	    (revision-1 100)
+	    (revision-2 200)
+	    (revision-3 300)
+	    (revision-3-5 350)
+	    (revision-4 400))
+	(setf d:*TM-REVISION* revision-1)
+	(is-false (identified-construct ti-1))
+	(signals error (make-instance 'TopicIdentificationC
+				      :uri "ti-1"))
+	(signals error (make-instance 'TopicIdentificationC
+				      :xtm-id "xtm-id-1"))
+	(is-false (topic-identifiers topic-1))
+	(add-topic-identifier topic-1 ti-1)
+	(is (= (length (topic-identifiers topic-1)) 1))
+	(is (eql (first (topic-identifiers topic-1)) ti-1))
+	(is (eql (identified-construct ti-1) topic-1))
+	(add-topic-identifier topic-1 ti-2 :revision revision-2)
+	(is (= (length (topic-identifiers topic-1 :revision revision-0)) 2))
+	(is (= (length (topic-identifiers topic-1 :revision revision-1)) 1))
+	(is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1))
+	(is (= (length (union (list ti-1 ti-2)
+			      (topic-identifiers topic-1 :revision revision-2)))
+	       2))
+	(is (= (length (union (list ti-1 ti-2)
+			      (topic-identifiers topic-1 :revision revision-0)))
+	       2))
+	(delete-topic-identifier topic-1 ti-1 :revision revision-3)
+	(is (= (length (union (list ti-2)
+			      (topic-identifiers topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (union (list ti-1 ti-2)
+			      (topic-identifiers topic-1 :revision revision-2)))
+	       2))
+	(delete-topic-identifier topic-1 ti-2 :revision revision-3)
+	(is-false (topic-identifiers topic-1 :revision revision-3))
+	(add-topic-identifier topic-1 ti-1 :revision revision-4)
+	(is (= (length (union (list ti-1)
+			      (topic-identifiers topic-1 :revision revision-0)))
+	       1))
+	(is (= (length (d::slot-p topic-1 'd::topic-identifiers)) 2))
+	(is-false (topic-identifiers topic-1 :revision revision-3-5)))))
+
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
   (it.bese.fiveam:run! 'test-ItemIdentifierC)
   (it.bese.fiveam:run! 'test-PersistentIdC)
   (it.bese.fiveam:run! 'test-SubjectLocatorC)
+  (it.bese.fiveam:run! 'test-TopicIdentificationC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Wed Feb 24 16:04:47 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 24 Feb 2010 11:04:47 -0500
Subject: [isidorus-cvs] r204 - branches/new-datamodel/src/model
	trunk/src/model
Message-ID: <E1NkJjD-0004ng-Ef@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 24 11:04:46 2010
New Revision: 204

Log:
new-datamodel: added the functions get-item-by-item-identifier, get-item-by-psi, get-item-by-locator; fixed a bug in the function get-item-by-id -> ticket #65

Modified:
   branches/new-datamodel/src/model/datamodel.lisp
   trunk/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	Wed Feb 24 11:04:46 2010
@@ -10,6 +10,8 @@
 (defpackage :datamodel
   (:use :cl :elephant :constants)
   (:nicknames :d)
+  (:import-from :exceptions
+		duplicate-identifier-error)
   (:export ;;classes
            :TopicMapC
            :AssociationC
@@ -79,6 +81,11 @@
 	   :in-topicmaps
 	   :delete-construct
 	   :get-revision
+	   :get-item-by-id
+	   :get-item-by-psi
+	   :get-item-by-item-identnfier
+	   :get-item-by-locator
+	   :string-integer-p
 
 	   ;;globals
 	   :*TM-REVISION*
@@ -87,6 +94,12 @@
 (in-package :datamodel)
 
 
+;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1)))))
+;;      in get-item-by-id
+;;TODO: implement get-item-by-id(TopicC) + unit-tests
+;;TODO: implement get-item-by-psi(TopicC) + unit-tests
+;;TODO: implement get-item-by-locator(TopicC) + unit-tests
+;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
 ;;TODO: implement a macro "with-merge-construct" that merges constructs
@@ -609,6 +622,13 @@
   (get-universal-time))
 
 
+(defun string-integer-p (integer-as-string)
+  "Returns t if the passed string can be parsed to an integer."
+  (handler-case (when (parse-integer integer-as-string)
+		  t)
+    (condition () nil)))
+
+
 ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; VersionInfocC
 (defmethod delete-construct :before ((version-info VersionInfoC))
@@ -1061,6 +1081,96 @@
   (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
 
 
+(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) (revision 0) (error-if-nil nil))
+  "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM
+   is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
+   applicable in the correct revision. If revison is provided, then the code checks
+   if the topic already existed in this revision and returns nil otherwise.
+   If no item meeting the constraints was found, then the return value is either
+   NIL or an error is thrown, depending on error-if-nil."
+  (declare (string topic-id) (integer revision) (string xtm-id))
+  (let ((result
+	 (if xtm-id
+	     (let ((possible-top-ids
+		    (delete-if-not
+		     #'(lambda(top-id)
+			 (and (string= (xtm-id top-id) xtm-id)
+			      (string= (uri top-id) topic-id)))
+		     ;fixes a bug in get-instances-by-value that does a
+		     ;case-insensitive comparision
+		     (elephant:get-instances-by-value
+		      'TopicIdentificationC
+		      'uri
+		      topic-id))))
+	       (when (and possible-top-ids
+			  (identified-construct (first possible-top-ids) :revision revision))
+		 (unless (= (length possible-top-ids) 1)
+		   (error (make-condition 'duplicate-identifier-error
+					  :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
+							   possible-top-ids topic-id xtm-id)
+					  :uri topic-id)))
+		 (identified-construct (first possible-top-ids)
+				       :revision revision)
+ 	 	 ;no revision need not to be chaecked, since the revision
+                 ;is implicitely checked by the function identified-construct
+		 ))
+	     (when (and (> (length topic-id) 0)
+			(eql (elt 0 topic-id) #\t)
+			(string-integer-p (subseq topic-id 1)))
+	       (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1))))))
+    (if (and error-if-nil (not result))
+        (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)
+        result)))
+
+
+(defun get-item-by-identifier (uri &key (revision 0)
+			       (identifier-type-symbol 'PersistentIdC)
+			       (error-if-nil nil))
+  "Returns the construct that is bound to the given identifier-uri."
+  (declare (string uri) (integer revision) (symbol identifier-type-symbol))
+  (let ((result
+	 (let ((possible-ids
+		(delete-if-not
+		 #'(lambda(id)
+		     (string= (uri id) uri))
+		 (get-instances-by-class identifier-type-symbol))))
+	   (when (and possible-ids
+			  (identified-construct (first possible-ids) :revision revision))
+	     (unless (= (length possible-ids) 1)
+	       (error (make-condition 'duplicate-identifier-error
+				      :message (format nil "(length possible-items ~a) for id ~a"
+						       possible-ids uri)
+				      :uri uri)))
+	     (identified-construct (first possible-ids)
+				   :revision revision)))))
+	     ;no revision need not 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.")))))
+
+
+(defun get-item-by-item-identifier (uri &key (revision 0) (error-if-nil nil))
+  "Returns a ReifiableConstructC that is bound to the identifier-uri."
+  (get-item-by-identifier uri :revision revision
+			  :identifier-type-symbol 'ItemIdentifierC
+			  :error-if-nil error-if-nil))
+
+
+(defun get-item-by-psi (uri &key (revision 0) (error-if-nil nil))
+  "Returns a TopicC that is bound to the identifier-uri."
+  (get-item-by-identifier uri :revision revision
+			  :identifier-type-symbol 'PersistentIdC
+			  :error-if-nil error-if-nil))
+
+
+(defun get-item-by-locator (uri &key (revision 0) (error-if-nil nil))
+  "Returns a TopicC that is bound to the identifier-uri."
+  (get-item-by-identifier uri :revision revision
+			  :identifier-type-symbol 'SubjectLocatorC
+			  :error-if-nil error-if-nil))
+
 
 ;;; NameC
 (defgeneric variants (construct &key revision)

Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp	(original)
+++ trunk/src/model/datamodel.lisp	Wed Feb 24 11:04:46 2010
@@ -1360,7 +1360,7 @@
                   (if (= revision 0)
                       found-topic 
                       (find-item-by-revision found-topic revision)))))
-            (make-instance 'TopicC :from-oid (subseq topicid 1)))))
+            (elephant::controller-recreate-instance elephant:*store-controller* (subseq topicid 1)))))
     (if (and error-if-nil (not result))
         (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision))
         result)))



From lgiessmann at common-lisp.net  Wed Feb 24 19:28:29 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 24 Feb 2010 14:28:29 -0500
Subject: [isidorus-cvs] r205 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NkMuL-0003FH-0f@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 24 14:28:28 2010
New Revision: 205

Log:
new-datamodel: fixed some problems with get-item-by-id and added some unit-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	Wed Feb 24 14:28:28 2010
@@ -94,8 +94,7 @@
 (in-package :datamodel)
 
 
-;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1)))))
-;;      in get-item-by-id
+
 ;;TODO: implement get-item-by-id(TopicC) + unit-tests
 ;;TODO: implement get-item-by-psi(TopicC) + unit-tests
 ;;TODO: implement get-item-by-locator(TopicC) + unit-tests
@@ -265,7 +264,8 @@
   (:documentation "Reifiable constructs as per TMDM."))
 
 
-(defpclass AssociationC(ReifiableConstructC ScopableC TypableC)
+(defpclass AssociationC(ReifiableConstructC ScopableC TypableC
+					    VersionedConstructC)
   ((roles :associate (RoleAssociationC association)
 	  :documentation "Contains all association-objects of all roles this
                           association contains.")
@@ -284,7 +284,7 @@
 	   :documentation "Associates this object with a player-association.")))
 
 
-(elephant:defpclass TopicMapC (ReifiableConstructC)
+(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
   ((topics :accessor topics
 	   :associate (TopicC in-topicmaps)
 	   :documentation "List of topics that explicitly belong to this TM.")
@@ -294,7 +294,7 @@
   (:documentation "Represnets a topic map."))
 
 
-(defpclass TopicC (ReifiableConstructC)
+(defpclass TopicC (ReifiableConstructC VersionedConstructC)
   ((topic-identifiers :associate (TopicIdAssociationC parent-construct)
 		      :documentation "Contains all association objects that
                                       relate a topic with its actual
@@ -749,7 +749,7 @@
 (defgeneric identified-construct (construct &key revision)
   (:documentation "Returns the identified-construct -> ReifiableConstructC or
                    TopicC that corresponds with the passed revision.")
-  (:method ((construct PointerC) &key (revision *TM-REVISION*))
+  (:method ((construct PointerC) &key (revision 0))
     (let ((assocs
 	   (map 'list #'parent-construct
 		(filter-slot-value-by-revision construct 'identified-construct
@@ -778,7 +778,7 @@
 (defgeneric topic-identifiers (construct &key revision)
   (:documentation "Returns the TopicIdentificationC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'topic-identifiers :start-revision revision)))
       (map 'list #'identifier assocs))))
@@ -791,7 +791,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'topic-identifiers)))
 	  (construct-to-be-merged
@@ -799,9 +799,7 @@
 	     (when (not (eql id-owner construct))
 	       id-owner))))
       (cond (construct-to-be-merged
-	     (merge-constructs (identified-construct construct-to-be-merged
-						     :revision revision)
-			       construct))
+	     (merge-constructs construct construct-to-be-merged :revision revision))
 	    ((find topic-identifier all-ids)
 	     (let ((ti-assoc (loop for ti-assoc in (slot-p construct
 							   'topic-identifiers)
@@ -834,7 +832,7 @@
 (defgeneric psis (construct &key revision)
   (:documentation "Returns the PersistentIdC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'psis :start-revision revision)))
       (map 'list #'identifier assocs))))
@@ -847,7 +845,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct TopicC) (psi PersistentIdC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'psis)))
 	  (construct-to-be-merged
@@ -855,9 +853,8 @@
 	     (when (not (eql id-owner construct))
 	       id-owner))))
       (cond (construct-to-be-merged
-	     (merge-constructs (identified-construct construct-to-be-merged
-						     :revision revision)
-			       construct))
+	     (merge-constructs construct construct-to-be-merged
+			       :revision revision))
 	    ((find psi all-ids)
 	     (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
 				when (eql (identifier psi-assoc) psi)
@@ -888,7 +885,7 @@
 (defgeneric locators (construct &key revision)
   (:documentation "Returns the SubjectLocatorC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'locators :start-revision revision)))
       (map 'list #'identifier assocs))))
@@ -901,7 +898,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct TopicC) (locator SubjectLocatorC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'locators)))
 	  (construct-to-be-merged
@@ -909,9 +906,8 @@
 	     (when (not (eql id-owner construct))
 	       id-owner))))
       (cond (construct-to-be-merged
-	     (merge-constructs (identified-construct construct-to-be-merged
-						     :revision revision)
-			       construct))
+	     (merge-constructs construct construct-to-be-merged
+			       :revision revision))
 	    ((find locator all-ids)
 	     (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators)
 				when (eql (identifier loc-assoc) locator)
@@ -942,7 +938,7 @@
 (defgeneric names (construct &key revision)
   (:documentation "Returns the NameC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'names :start-revision revision)))
       (map 'list #'characteristic assocs))))
@@ -955,7 +951,7 @@
                    If the passed name already owns another object
                    an error is thrown.")
   (:method ((construct TopicC) (name NameC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (when (not (eql (parent name) 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)))
@@ -991,7 +987,7 @@
 (defgeneric occurrences (construct &key revision)
   (:documentation "Returns the OccurrenceC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'occurences :start-revision revision)))
       (map 'list #'characteristic assocs))))
@@ -1004,7 +1000,7 @@
                    If the passed occurrence already owns another object
                    an error is thrown.")
   (:method ((construct TopicC) (occurrence OccurrenceC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (when (not (eql (parent occurrence) 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)))
@@ -1040,7 +1036,7 @@
 (defgeneric player-in-roles (construct &key revision)
   (:documentation "Returns the RoleC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'player-in-roles :start-revision revision)))
       (map 'list #'parent-construct assocs))))
@@ -1049,7 +1045,7 @@
 (defgeneric used-as-type (construct &key revision)
   (:documentation "Returns the TypableC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'used-as-type :start-revision revision)))
       (map 'list #'typable-construct assocs))))
@@ -1058,7 +1054,7 @@
 (defgeneric used-as-theme (construct &key revision)
   (:documentation "Returns the ScopableC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'used-as-theme :start-revision revision)))
       (map 'list #'scopable-construct assocs))))
@@ -1067,7 +1063,7 @@
 (defgeneric reified-construct (construct &key revision)
   (:documentation "Returns the ReifiableConstructC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+  (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'reified-construct :start-revision revision)))
       (map 'list #'reifiable-construct assocs))))
@@ -1077,7 +1073,7 @@
   (:documentation "Returns all TopicMapS-obejcts where the constrict is
                    contained in."))
 
-(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*))
+(defmethod in-topicmaps ((topic TopicC) &key (revision 0))
   (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
 
 
@@ -1088,7 +1084,7 @@
    if the topic already existed in this revision and returns nil otherwise.
    If no item meeting the constraints was found, then the return value is either
    NIL or an error is thrown, depending on error-if-nil."
-  (declare (string topic-id) (integer revision) (string xtm-id))
+  (declare (string topic-id) (integer revision))
   (let ((result
 	 (if xtm-id
 	     (let ((possible-top-ids
@@ -1105,19 +1101,25 @@
 	       (when (and possible-top-ids
 			  (identified-construct (first possible-top-ids) :revision revision))
 		 (unless (= (length possible-top-ids) 1)
-		   (error (make-condition 'duplicate-identifier-error
-					  :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
-							   possible-top-ids topic-id xtm-id)
-					  :uri topic-id)))
+		   (error
+		    (make-condition 'duplicate-identifier-error
+				    :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
+						     possible-top-ids topic-id xtm-id)
+				    :uri topic-id)))
 		 (identified-construct (first possible-top-ids)
 				       :revision revision)
  	 	 ;no revision need not to be chaecked, since the revision
                  ;is implicitely checked by the function identified-construct
 		 ))
 	     (when (and (> (length topic-id) 0)
-			(eql (elt 0 topic-id) #\t)
+			(eql (elt topic-id 0) #\t)
 			(string-integer-p (subseq topic-id 1)))
-	       (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1))))))
+	       (let ((top-from-oid
+		      (elephant::controller-recreate-instance
+		       elephant::*store-controller*
+		       (parse-integer (subseq topic-id 1)))))
+		 (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)
         result)))
@@ -1176,7 +1178,7 @@
 (defgeneric variants (construct &key revision)
   (:documentation "Returns all variants that correspond with the given revision
                    and that are associated with the passed construct.")
-  (:method ((construct NameC) &key (revision *TM-REVISION*))
+  (:method ((construct NameC) &key (revision 0))
     (let ((valid-associations
 	   (filter-slot-value-by-revision construct 'variants
 					  :start-revision revision)))
@@ -1187,7 +1189,7 @@
   (:documentation "Adds the given theme-topic to the passed
                    scopable-construct.")
   (:method ((construct NameC) (variant VariantC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (when (not (eql (parent variant) 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)))
@@ -1239,7 +1241,7 @@
   (: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*))
+  (:method ((construct CharacteristicC) &key (revision 0))
     (let ((valid-associations
 	   (filter-slot-value-by-revision construct 'parent
 					  :start-revision revision)))
@@ -1253,7 +1255,7 @@
 
 
 (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
-		       &key (revision *TM-REVISION*))
+		       &key (revision 0))
   (let ((already-set-topic
 	   (map 'list #'parent-construct
 		(filter-slot-value-by-revision construct 'parent
@@ -1280,7 +1282,7 @@
 
 
 (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
-		       &key (revision *TM-REVISION*))
+		       &key (revision 0))
   (let ((already-set-name
 	   (map 'list #'characteristic
 		(filter-slot-value-by-revision construct 'parent
@@ -1441,7 +1443,7 @@
 (defgeneric roles (construct &key revision)
   (:documentation "Returns all topics that correspond with the given revision
                    as a scope for the given topic.")
-  (:method ((construct AssociationC) &key (revision *TM-REVISION*))
+  (:method ((construct AssociationC) &key (revision 0))
     (let ((valid-associations
 	   (filter-slot-value-by-revision construct 'roles
 					  :start-revision revision)))
@@ -1451,7 +1453,7 @@
 (defgeneric add-role (construct role &key revision)
   (:documentation "Adds the given role to the passed association-construct.")
   (:method ((construct AssociationC) (role RoleC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((all-roles
 	   (map 'list #'role
 		(remove-if #'marked-as-deleted-p (slot-p construct 'roles)))))
@@ -1481,7 +1483,7 @@
       construct)))
 
 
-(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
+(defmethod in-topicmaps ((association AssociationC) &key (revision 0))
   (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
 
 
@@ -1494,7 +1496,7 @@
     (delete-construct assoc)))
 
 
-(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*))
+(defmethod parent ((construct RoleC) &key (revision 0))
   "Returns the construct's parent corresponding to the given revision."
   (let ((valid-associations
 	 (filter-slot-value-by-revision construct 'parent
@@ -1504,7 +1506,7 @@
   
 
 (defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
-			    &key (revision *TM-REVISION*))
+			    &key (revision 0))
   (let ((already-set-parent
 	   (map 'list #'parent
 		(filter-slot-value-by-revision construct 'parent
@@ -1542,7 +1544,7 @@
 (defgeneric player (construct &key revision)
   (:documentation "Returns the construct's player corresponding to
                    the given revision.")
-  (:method ((construct RoleC) &key (revision *TM-REVISION*))
+  (:method ((construct RoleC) &key (revision 0))
     (let ((valid-associations
 	   (filter-slot-value-by-revision construct 'player
 					  :start-revision revision)))
@@ -1553,7 +1555,7 @@
 (defgeneric add-player (construct player-topic &key revision)
   (:documentation "Adds a topic as a player to a role in the given revision.")
   (:method ((construct RoleC) (player-topic TopicC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((already-set-player
 	   (map 'list #'player-topic
 		(filter-slot-value-by-revision construct 'player
@@ -1594,7 +1596,7 @@
 (defgeneric item-identifiers (construct &key revision)
   (:documentation "Returns the ItemIdentifierC-objects that correspond
                    with the passed construct and the passed version.")
-  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+  (:method ((construct ReifiableConstructC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'item-identifiers :start-revision revision)))
       (map 'list #'identifier assocs))))
@@ -1603,7 +1605,7 @@
 (defgeneric reifier (construct &key revision)
   (:documentation "Returns the reifier-topic that corresponds
                    with the passed construct and the passed version.")
-  (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
+  (:method ((construct ReifiableConstructC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'item-identifiers :start-revision revision)))
       (when assocs ;assocs must be nil or a list with exactly one item
@@ -1627,7 +1629,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'item-identifiers)))
 	  (construct-to-be-merged
@@ -1635,9 +1637,8 @@
 	     (when (not (eql id-owner construct))
 	       id-owner))))
       (cond (construct-to-be-merged
-	     (merge-constructs (identified-construct construct-to-be-merged
-						     :revision revision)
-			       construct))
+	     (merge-constructs construct construct-to-be-merged
+			       :revision revision))
 	    ((find item-identifier all-ids)
 	     (let ((ii-assoc (loop for ii-assoc in (slot-p construct
 							   'item-identifiers)
@@ -1673,7 +1674,7 @@
                    If the reifier-topic reifies already another construct
                    the reified-constructs are merged.")
   (:method ((construct ReifiableConstructC) (reifier-topic TopicC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((merged-reifier-topic
 	   (when (reifier construct)
 	     (merge-constructs (reifier construct) reifier-topic))))
@@ -1722,7 +1723,7 @@
 (defgeneric themes (construct &key revision)
   (:documentation "Returns all topics that correspond with the given revision
                    as a scope for the given topic.")
-  (:method ((construct ScopableC) &key (revision *TM-REVISION*))
+  (:method ((construct ScopableC) &key (revision 0))
     (let ((valid-associations
 	   (filter-slot-value-by-revision construct 'themes
 					  :start-revision revision)))
@@ -1733,7 +1734,7 @@
   (:documentation "Adds the given theme-topic to the passed
                    scopable-construct.")
   (:method ((construct ScopableC) (theme-topic TopicC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((all-themes
 	   (map 'list #'theme-topic
 		(remove-if #'marked-as-deleted-p (slot-p construct 'themes)))))
@@ -1773,7 +1774,7 @@
 (defgeneric instance-of (construct &key revision)
   (:documentation "Returns the type topic that is set on the passed
                    revision.")
-  (:method ((construct TypableC) &key (revision *TM-REVISION*))
+  (:method ((construct TypableC) &key (revision 0))
     (let ((valid-associations
 	   (filter-slot-value-by-revision construct 'instance-of
 					  :start-revision revision)))
@@ -1786,7 +1787,7 @@
                    typed construct if there is no other type-topic
                    set at the same revision.")
   (:method ((construct TypableC) (type-topic TopicC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (let ((already-set-type
 	   (map 'list #'type-topic
 		(filter-slot-value-by-revision construct 'instance-of
@@ -1837,7 +1838,7 @@
 ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defgeneric merge-constructs(construc-1 construct-2 &key revision)
   (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
-	    &key (revision *TM-REVISION*))
+	    &key (revision 0))
     (or construct-1 construct-2 revision)))
 
 

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	Wed Feb 24 14:28:28 2010
@@ -14,13 +14,16 @@
    :it.bese.FiveAM
    :fixtures
    :unittests-constants)
+  (:import-from :exceptions
+		duplicate-identifier-error)
   (:export :run-datamodel-tests
 	   :test-VersionInfoC
 	   :test-VersionedConstructC
 	   :test-ItemIdentifierC
 	   :test-PersistentIdC
 	   :test-SubjectLocatorC
-	   :test-TopicIdentificationC))
+	   :test-TopicIdentificationC
+	   :test-get-item-by-id))
 
 
 ;;TODO: test merges-constructs when merging was caused by an item-dentifier
@@ -302,6 +305,64 @@
 	(is-false (topic-identifiers topic-1 :revision revision-3-5)))))
 
 
+(test test-get-item-by-id ()
+    "Tests the function test-get-item-by-id."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((top-id-1 (make-instance 'TopicIdentificationC
+				     :uri "topid-1"
+				     :xtm-id "xtm-id-1"))
+	    (top-id-2 (make-instance 'TopicIdentificationC
+				     :uri "topid-2"
+				     :xtm-id "xtm-id-2"))
+	    (top-id-3-1 (make-instance 'TopicIdentificationC
+				       :uri "topid-3"
+				       :xtm-id "xtm-id-3"))
+	    (top-id-3-2 (make-instance 'TopicIdentificationC
+				       :uri "topid-3"
+				       :xtm-id "xtm-id-3"))
+	    (top-1 (make-instance 'TopicC))
+	    (top-2 (make-instance 'TopicC))
+	    (top-3 (make-instance 'TopicC))
+	    (revision 100)
+	    (revision-2 200))
+	(setf d:*TM-REVISION* revision)
+	(is-false (get-item-by-id "any-top-id"))
+	(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)))
+	(is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id"))
+	(add-topic-identifier top-1 top-id-3-1 :revision revision)
+	(add-topic-identifier top-1 top-id-3-2 :revision revision)
+	(signals duplicate-identifier-error
+	  (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision revision))
+	(add-topic-identifier top-2 top-id-1)
+	(add-topic-identifier top-2 top-id-2 :revision revision-2)
+	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1")))
+	(is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2")))
+	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
+				       :revision 500)))
+	(is-false (get-item-by-id "topid-2" :xtm-id "xtm-id-2"
+				  :revision revision))
+	(delete-topic-identifier top-2 top-id-1 :revision revision-2)
+	(is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1"))
+	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
+				       :revision revision)))
+	(add-topic-identifier top-3 top-id-1 :revision revision-2)
+	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
+				       :revision revision)))
+	(d::add-to-version-history top-3 :start-revision revision-2)
+	(is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1")))
+	(is (eql top-3
+		 (get-item-by-id
+		  (concatenate 'string "t" (write-to-string
+					    (elephant::oid top-3))))))
+	(is-false (get-item-by-id
+		   (concatenate 'string "t" (write-to-string
+					     (elephant::oid top-3)))
+		   :revision revision)))))
+
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
@@ -309,4 +370,5 @@
   (it.bese.fiveam:run! 'test-PersistentIdC)
   (it.bese.fiveam:run! 'test-SubjectLocatorC)
   (it.bese.fiveam:run! 'test-TopicIdentificationC)
+  (it.bese.fiveam:run! 'test-get-item-by-id)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Wed Feb 24 19:59:59 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 24 Feb 2010 14:59:59 -0500
Subject: [isidorus-cvs] r206 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NkNOp-0004uW-9S@common-lisp.net>

Author: lgiessmann
Date: Wed Feb 24 14:59:58 2010
New Revision: 206

Log:
new-datamodel: added unit-tests for: get-item-by-item-identifier, get-item-by-psi and get-item-by-locator; optimized the function get item-by-identifier

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	Wed Feb 24 14:59:58 2010
@@ -83,7 +83,7 @@
 	   :get-revision
 	   :get-item-by-id
 	   :get-item-by-psi
-	   :get-item-by-item-identnfier
+	   :get-item-by-item-identifier
 	   :get-item-by-locator
 	   :string-integer-p
 
@@ -94,11 +94,6 @@
 (in-package :datamodel)
 
 
-
-;;TODO: implement get-item-by-id(TopicC) + unit-tests
-;;TODO: implement get-item-by-psi(TopicC) + unit-tests
-;;TODO: implement get-item-by-locator(TopicC) + unit-tests
-;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
 ;;TODO: implement a macro "with-merge-construct" that merges constructs
@@ -1135,7 +1130,7 @@
 		(delete-if-not
 		 #'(lambda(id)
 		     (string= (uri id) uri))
-		 (get-instances-by-class identifier-type-symbol))))
+		 (get-instances-by-value identifier-type-symbol 'uri uri))))
 	   (when (and possible-ids
 			  (identified-construct (first possible-ids) :revision revision))
 	     (unless (= (length possible-ids) 1)

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	Wed Feb 24 14:59:58 2010
@@ -23,7 +23,10 @@
 	   :test-PersistentIdC
 	   :test-SubjectLocatorC
 	   :test-TopicIdentificationC
-	   :test-get-item-by-id))
+	   :test-get-item-by-id
+	   :test-get-item-by-item-identifier
+	   :test-get-item-by-locator
+	   :test-get-item-by-psi))
 
 
 ;;TODO: test merges-constructs when merging was caused by an item-dentifier
@@ -363,6 +366,132 @@
 		   :revision revision)))))
 
 
+(test test-get-item-by-item-identifier ()
+    "Tests the function test-get-item-by-id."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((ii-1 (make-instance 'ItemIdentifierC
+				 :uri "ii-1"))
+	    (ii-2 (make-instance 'ItemIdentifierC
+				 :uri "ii-2"))
+	    (ii-3-1 (make-instance 'ItemIdentifierC
+				   :uri "ii-3"))
+	    (ii-3-2 (make-instance 'ItemIdentifierC
+				   :uri "ii-3"))
+	    (top-1 (make-instance 'TopicC))
+	    (top-2 (make-instance 'TopicC))
+	    (top-3 (make-instance 'TopicC))
+	    (revision 100)
+	    (revision-2 200))
+	(setf d:*TM-REVISION* revision)
+	(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)))
+	(signals error (is-false (get-item-by-item-identifier
+				  "any-ii-id" :error-if-nil t)))
+	(is-false (get-item-by-item-identifier "any-ii-id"))
+	(add-item-identifier top-1 ii-3-1 :revision revision)
+	(add-item-identifier top-1 ii-3-2 :revision revision)
+	(signals duplicate-identifier-error
+	  (get-item-by-item-identifier "ii-3" :revision revision))
+	(add-item-identifier top-2 ii-1)
+	(add-item-identifier top-2 ii-2 :revision revision-2)
+	(is (eql top-2 (get-item-by-item-identifier "ii-1")))
+	(is (eql top-2 (get-item-by-item-identifier "ii-2")))
+	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision 500)))
+	(is-false (get-item-by-item-identifier "ii-2" :revision revision))
+	(delete-item-identifier top-2 ii-1 :revision revision-2)
+	(is-false (get-item-by-item-identifier "ii-1"))
+	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision)))
+	(add-item-identifier top-3 ii-1 :revision revision-2)
+	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision)))
+	(d::add-to-version-history top-3 :start-revision revision-2)
+	(is (eql top-3 (get-item-by-item-identifier "ii-1"))))))
+
+
+(test test-get-item-by-locator ()
+    "Tests the function test-get-item-by-id."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((sl-1 (make-instance 'SubjectLocatorC
+				 :uri "sl-1"))
+	    (sl-2 (make-instance 'SubjectLocatorC
+				 :uri "sl-2"))
+	    (sl-3-1 (make-instance 'SubjectLocatorC
+				   :uri "sl-3"))
+	    (sl-3-2 (make-instance 'SubjectLocatorC
+				   :uri "sl-3"))
+	    (top-1 (make-instance 'TopicC))
+	    (top-2 (make-instance 'TopicC))
+	    (top-3 (make-instance 'TopicC))
+	    (revision 100)
+	    (revision-2 200))
+	(setf d:*TM-REVISION* revision)
+	(is-false (get-item-by-id "any-sl-id"))
+	(signals error (is-false (get-item-by-locator
+				  "any-sl-id" :error-if-nil t)))
+	(signals error (is-false (get-item-by-locator
+				  "any-sl-id" :error-if-nil t)))
+	(is-false (get-item-by-locator "any-sl-id"))
+	(add-locator top-1 sl-3-1 :revision revision)
+	(add-locator top-1 sl-3-2 :revision revision)
+	(signals duplicate-identifier-error
+	  (get-item-by-locator "sl-3" :revision revision))
+	(add-locator top-2 sl-1)
+	(add-locator top-2 sl-2 :revision revision-2)
+	(is (eql top-2 (get-item-by-locator "sl-1")))
+	(is (eql top-2 (get-item-by-locator "sl-2")))
+	(is (eql top-2 (get-item-by-locator "sl-1" :revision 500)))
+	(is-false (get-item-by-locator "sl-2" :revision revision))
+	(delete-locator top-2 sl-1 :revision revision-2)
+	(is-false (get-item-by-locator "sl-1"))
+	(is (eql top-2 (get-item-by-locator "sl-1" :revision revision)))
+	(add-locator top-3 sl-1 :revision revision-2)
+	(is (eql top-2 (get-item-by-locator "sl-1" :revision revision)))
+	(d::add-to-version-history top-3 :start-revision revision-2)
+	(is (eql top-3 (get-item-by-locator "sl-1"))))))
+
+
+(test test-get-item-by-psi ()
+    "Tests the function test-get-item-by-id."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((psi-1 (make-instance 'PersistentIdC
+				  :uri "psi-1"))
+	    (psi-2 (make-instance 'PersistentIdC
+				  :uri "psi-2"))
+	    (psi-3-1 (make-instance 'PersistentIdC
+				    :uri "psi-3"))
+	    (psi-3-2 (make-instance 'PersistentIdC
+				    :uri "psi-3"))
+	    (top-1 (make-instance 'TopicC))
+	    (top-2 (make-instance 'TopicC))
+	    (top-3 (make-instance 'TopicC))
+	    (revision 100)
+	    (revision-2 200))
+	(setf d:*TM-REVISION* revision)
+	(is-false (get-item-by-id "any-psi-id"))
+	(signals error (is-false (get-item-by-locator
+				  "any-psi-id" :error-if-nil t)))
+	(signals error (is-false (get-item-by-locator
+				  "any-psi-id" :error-if-nil t)))
+	(is-false (get-item-by-locator "any-psi-id"))
+	(add-psi top-1 psi-3-1 :revision revision)
+	(add-psi top-1 psi-3-2 :revision revision)
+	(signals duplicate-identifier-error
+	  (get-item-by-locator "psi-3" :revision revision))
+	(add-psi top-2 psi-1)
+	(add-psi top-2 psi-2 :revision revision-2)
+	(is (eql top-2 (get-item-by-locator "psi-1")))
+	(is (eql top-2 (get-item-by-locator "psi-2")))
+	(is (eql top-2 (get-item-by-locator "psi-1" :revision 500)))
+	(is-false (get-item-by-locator "psi-2" :revision revision))
+	(delete-psi top-2 psi-1 :revision revision-2)
+	(is-false (get-item-by-locator "psi-1"))
+	(is (eql top-2 (get-item-by-locator "psi-1" :revision revision)))
+	(add-psi top-3 psi-1 :revision revision-2)
+	(is (eql top-2 (get-item-by-locator "psi-1" :revision revision)))
+	(d::add-to-version-history top-3 :start-revision revision-2)
+	(is (eql top-3 (get-item-by-locator "psi-1"))))))
+
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
@@ -371,4 +500,7 @@
   (it.bese.fiveam:run! 'test-SubjectLocatorC)
   (it.bese.fiveam:run! 'test-TopicIdentificationC)
   (it.bese.fiveam:run! 'test-get-item-by-id)
+  (it.bese.fiveam:run! 'test-get-item-by-item-identifier)
+  (it.bese.fiveam:run! 'test-get-item-by-locator)
+  (it.bese.fiveam:run! 'test-get-item-by-psi)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Thu Feb 25 19:20:52 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 25 Feb 2010 14:20:52 -0500
Subject: [isidorus-cvs] r207 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NkjGW-0001iy-5X@common-lisp.net>

Author: lgiessmann
Date: Thu Feb 25 14:20:51 2010
New Revision: 207

Log:
new-datamodel: added some unit-tests for add-reifier, reifier and delete-reifier; fixed alos msome problems in these functions; changed some key-parameters --> (reivision 0) was changed to (revision *TM-REVISION*) in all adder-functions, e.g. add-psi

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 Feb 25 14:20:51 2010
@@ -94,6 +94,7 @@
 (in-package :datamodel)
 
 
+;;TODO: finalize add-reifier
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
 ;;TODO: implement a macro "with-merge-construct" that merges constructs
@@ -253,7 +254,7 @@
 		     :inherit t
 		     :documentation "A relation to all item-identifiers of
                                      this construct.")
-   (reifier :associate (ReifierAssociationC reified-construct)
+   (reifier :associate (ReifierAssociationC reifiable-construct)
 	    :inherit t
 	    :documentation "A relation to a reifier-topic."))
   (:documentation "Reifiable constructs as per TMDM."))
@@ -316,7 +317,7 @@
 		  :documentation "Contains all association objects that relate a
                                   topic that is a theme with its scoppable
                                   object.")
-   (reified-construct :associate (ReifiedAssociationC reifier-topic)
+   (reified-construct :associate (ReifierAssociationC reifier-topic)
 		      :documentation "Contains all association objects that
                                       relate a topic that is a reifier with
                                       its reified object.")
@@ -411,7 +412,7 @@
 			:initform (error "From ReifierAssociation(): reifiable-construct must be set")
 			:associate ReifiableConstructC
 			:documentation "The actual construct which is reified
-                                      by a topic.")
+                                        by a topic.")
    (reifier-topic :initarg :reifier-topic
 		  :accessor reifier-topic
 		  :initform (error "From ReifierAssociationC(): reifier-topic must be set")
@@ -786,7 +787,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'topic-identifiers)))
 	  (construct-to-be-merged
@@ -840,7 +841,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct TopicC) (psi PersistentIdC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'psis)))
 	  (construct-to-be-merged
@@ -893,7 +894,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct TopicC) (locator SubjectLocatorC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'locators)))
 	  (construct-to-be-merged
@@ -946,7 +947,7 @@
                    If the passed name already owns another object
                    an error is thrown.")
   (:method ((construct TopicC) (name NameC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (when (not (eql (parent name) 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)))
@@ -959,11 +960,12 @@
 			       when (eql (parent-construct name-assoc) name)
 			       return name-assoc)))
 	    (add-to-version-history name-assoc :start-revision revision))
-	  (make-instance 'NameAssociationC
-			 :start-revision revision
-			 :parent-construct construct
-			 :characteristic name))
-      construct)))
+	  (let ((assoc
+		 (make-instance 'NameAssociationC
+				:parent-construct construct
+				:characteristic name)))
+	    (add-to-version-history assoc :start-revision revision))))
+    construct))
 
 
 (defgeneric delete-name (construct name &key revision)
@@ -995,7 +997,7 @@
                    If the passed occurrence already owns another object
                    an error is thrown.")
   (:method ((construct TopicC) (occurrence OccurrenceC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (when (not (eql (parent occurrence) 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)))
@@ -1008,11 +1010,12 @@
 			      when (eql (parent-construct occ-assoc) occurrence)
 			      return occ-assoc)))
 	    (add-to-version-history occ-assoc :start-revision revision))
-	  (make-instance 'OccurrenceAssociationC
-			 :start-revision revision
-			 :parent-construct construct
-			 :characteristic occurrence))
-      construct)))
+	  (let ((assoc
+		 (make-instance 'OccurrenceAssociationC
+				:parent-construct construct
+				:characteristic occurrence)))
+	    (add-to-version-history assoc :start-revision revision))))
+    construct))
 
 
 (defgeneric delete-occurrence (construct occurrence &key revision)
@@ -1061,7 +1064,8 @@
   (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
 		   construct 'reified-construct :start-revision revision)))
-      (map 'list #'reifiable-construct assocs))))
+      (when assocs
+	(reifiable-construct (first assocs))))))
 
 
 (defgeneric in-topicmaps (construct &key revision)
@@ -1184,7 +1188,7 @@
   (:documentation "Adds the given theme-topic to the passed
                    scopable-construct.")
   (:method ((construct NameC) (variant VariantC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (when (not (eql (parent variant) 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)))
@@ -1198,10 +1202,11 @@
 		    when (eql (characteristic variant-assoc) variant)
 		    return variant-assoc)))
 	    (add-to-version-history variant-assoc :start-revision revision))
-	  (make-instance 'VariantAssociationC
-			 :start-revision revision
-			 :characteristic variant
-			 :parent-construct construct)))
+	  (let ((assoc
+		 (make-instance 'VariantAssociationC
+				:characteristic variant
+				:parent-construct construct)))
+	    (add-to-version-history assoc :start-revision revision))))
     construct))
 
 
@@ -1250,7 +1255,7 @@
 
 
 (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
-		       &key (revision 0))
+		       &key (revision *TM-REVISION*))
   (let ((already-set-topic
 	   (map 'list #'parent-construct
 		(filter-slot-value-by-revision construct 'parent
@@ -1264,12 +1269,13 @@
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
 	    ((not already-set-topic)
-	     (make-instance (if (typep construct 'OccurrenceC)
-				'OccurrenceAssociationC
-				'NameAssociationC)
-			    :start-revision revision
-			    :parent-construct parent-construct
-			    :characteristic construct))
+	     (let ((assoc
+		    (make-instance (if (typep construct 'OccurrenceC)
+				       'OccurrenceAssociationC
+				       'NameAssociationC)
+				   :parent-construct parent-construct
+				   :characteristic construct)))
+	       (add-to-version-history assoc :start-revision revision)))
 	    (t
 	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
 		    construct parent-construct already-set-topic)))
@@ -1277,7 +1283,7 @@
 
 
 (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
-		       &key (revision 0))
+		       &key (revision *TM-REVISION*))
   (let ((already-set-name
 	   (map 'list #'characteristic
 		(filter-slot-value-by-revision construct 'parent
@@ -1290,10 +1296,11 @@
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
 	    ((not already-set-name)
-	     (make-instance 'VariantAssociationC
-			    :start-revision revision
-			    :parent-construct parent-construct
-			    :characteristic construct))
+	     (let ((assoc
+		    (make-instance 'VariantAssociationC
+				   :parent-construct parent-construct
+				   :characteristic construct)))
+	       (add-to-version-history assoc :start-revision revision)))
 	    (t
 	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
 		    construct parent-construct already-set-name)))
@@ -1448,7 +1455,7 @@
 (defgeneric add-role (construct role &key revision)
   (:documentation "Adds the given role to the passed association-construct.")
   (:method ((construct AssociationC) (role RoleC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((all-roles
 	   (map 'list #'role
 		(remove-if #'marked-as-deleted-p (slot-p construct 'roles)))))
@@ -1458,10 +1465,11 @@
 		    when (eql (role role-assoc) role)
 		    return role-assoc)))
 	    (add-to-version-history role-assoc  :start-revision revision))
-	  (make-instance 'RoleAssociationC
-			 :start-revision revision
-			 :role role
-			 :association construct)))
+	  (let ((assoc
+		 (make-instance 'RoleAssociationC
+				:role role
+				:association construct)))
+	    (add-to-version-history assoc :start-revision revision))))
     construct))
 
 
@@ -1501,7 +1509,7 @@
   
 
 (defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
-			    &key (revision 0))
+			    &key (revision *TM-REVISION*))
   (let ((already-set-parent
 	   (map 'list #'parent
 		(filter-slot-value-by-revision construct 'parent
@@ -1515,10 +1523,10 @@
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
 	    ((not already-set-parent)
-	     (make-instance 'RoleAssociationC
-			    :start-revision revision
-			    :role construct
-			    :parent-construct parent-construct))
+	     (let ((assoc (make-instance 'RoleAssociationC
+					 :role construct
+					 :parent-construct parent-construct)))
+	       (add-to-version-history assoc :start-revision revision)))
 	    (t
 	     (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a"
 		    parent-construct construct already-set-parent)))
@@ -1550,7 +1558,7 @@
 (defgeneric add-player (construct player-topic &key revision)
   (:documentation "Adds a topic as a player to a role in the given revision.")
   (:method ((construct RoleC) (player-topic TopicC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((already-set-player
 	   (map 'list #'player-topic
 		(filter-slot-value-by-revision construct 'player
@@ -1563,10 +1571,10 @@
 		       return player-assoc)))
 	       (add-to-version-history player-assoc :start-revision revision)))
 	    ((not already-set-player)
-	     (make-instance 'PlayerAssociationC
-			    :start-revision revision
-			    :parent-construct construct
-			    :player-topic player-topic))
+	     (let ((assoc (make-instance 'PlayerAssociationC
+					 :parent-construct construct
+					 :player-topic player-topic)))
+	       (add-to-version-history assoc :start-revision revision)))
 	    (t
 	     (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a"
 		    player-topic construct already-set-player)))
@@ -1602,9 +1610,9 @@
                    with the passed construct and the passed version.")
   (:method ((construct ReifiableConstructC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
-		   construct 'item-identifiers :start-revision revision)))
+		   construct 'reifier :start-revision revision)))
       (when assocs ;assocs must be nil or a list with exactly one item
-	(reifier (first assocs))))))
+	(reifier-topic (first assocs))))))
 
 
 (defmethod delete-construct :before ((construct ReifiableConstructC))
@@ -1624,7 +1632,7 @@
                    If the passed identifer already identifies another object
                    the identified-constructs are merged.")
   (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((all-ids
 	   (map 'list #'identifier (slot-p construct 'item-identifiers)))
 	  (construct-to-be-merged
@@ -1669,13 +1677,16 @@
                    If the reifier-topic reifies already another construct
                    the reified-constructs are merged.")
   (:method ((construct ReifiableConstructC) (reifier-topic TopicC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((merged-reifier-topic
-	   (when (reifier construct)
-	     (merge-constructs (reifier construct) reifier-topic))))
+	   (if (reifier construct)
+	       (merge-constructs (reifier construct) reifier-topic)
+	       reifier-topic)))
       (let ((all-constructs
-	     (remove-if #'marked-as-deleted-p
-			(slot-p reifier-topic 'reified-construct)))) 
+	     (let ((inner-construct (reified-construct merged-reifier-topic
+						       :revision revision)))
+	       (when inner-construct
+		 (list inner-construct)))))
 	(cond ((find construct all-constructs)
 	       (let ((reifier-assoc
 		      (loop for reifier-assoc in
@@ -1688,11 +1699,12 @@
 	      (all-constructs
 	       (merge-constructs (first all-constructs) construct))
 	      (t
-	       (make-instance 'ReifierAssociationC
-			      :start-revision revision
-			      :reifiable-construct construct
-			      :reifier-topic merged-reifier-topic)
-	       construct))))))
+	       (let ((assoc
+		      (make-instance 'ReifierAssociationC
+				     :reifiable-construct construct
+				     :reifier-topic merged-reifier-topic)))
+		 (add-to-version-history assoc :start-revision revision))))
+	construct))))
 
 
 (defgeneric delete-reifier (construct reifier &key revision)
@@ -1729,7 +1741,7 @@
   (:documentation "Adds the given theme-topic to the passed
                    scopable-construct.")
   (:method ((construct ScopableC) (theme-topic TopicC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((all-themes
 	   (map 'list #'theme-topic
 		(remove-if #'marked-as-deleted-p (slot-p construct 'themes)))))
@@ -1739,10 +1751,11 @@
 		    when (eql (theme-topic theme-assoc) theme-topic)
 		    return theme-assoc)))
 	    (add-to-version-history theme-assoc  :start-revision revision))
-	  (make-instance 'ScopeAssociationC
-			 :start-revision revision
-			 :theme-topic theme-topic
-			 :scopable-construct construct)))
+	  (let ((assoc
+		 (make-instance 'ScopeAssociationCn
+				:theme-topic theme-topic
+				:scopable-construct construct)))
+	    (add-to-version-history assoc :start-revision revision))))
     construct))
 
 
@@ -1782,7 +1795,7 @@
                    typed construct if there is no other type-topic
                    set at the same revision.")
   (:method ((construct TypableC) (type-topic TopicC)
-	    &key (revision 0))
+	    &key (revision *TM-REVISION*))
     (let ((already-set-type
 	   (map 'list #'type-topic
 		(filter-slot-value-by-revision construct 'instance-of
@@ -1795,10 +1808,11 @@
 		       return type-assoc)))
 	       (add-to-version-history type-assoc :start-revision revision)))
 	    ((not already-set-type)
-	     (make-instance 'TypeAssociationC
-			    :start-revision revision
-			    :type-topic type-topic
-			    :typable-construct construct))
+	     (let ((assoc
+		    (make-instance 'TypeAssociationC
+				   :type-topic type-topic
+				   :typable-construct construct)))
+	       (add-to-version-history assoc :start-revision revision)))
 	    (t
 	     (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a"
 		    construct type-topic already-set-type)))
@@ -1831,10 +1845,11 @@
 
 
 ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric merge-constructs(construc-1 construct-2 &key revision)
+(defgeneric merge-constructs(construct-1 construct-2 &key revision)
   (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
-	    &key (revision 0))
-    (or construct-1 construct-2 revision)))
+	    &key (revision *TM-REVISION*))
+    (or revision)
+    (if construct-1 construct-1 construct-2)))
 
 
 (defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)

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 Feb 25 14:20:51 2010
@@ -26,13 +26,18 @@
 	   :test-get-item-by-id
 	   :test-get-item-by-item-identifier
 	   :test-get-item-by-locator
-	   :test-get-item-by-psi))
+	   :test-get-item-by-psi
+	   :test-ReifiableConstructC))
 
 
-;;TODO: test merges-constructs when merging was caused by an item-dentifier
-;;TODO: test merges-constructs when merging was caused by an psi
-;;TODO: test merges-constructs when merging was caused by an subject-locator
-;;TODO: test merges-constructs when merging was caused by a topic-id
+;;TODO: test delete-construct
+;;TODO: test merge-constructs when merging was caused by an item-dentifier
+;;TODO: test merge-constructs when merging was caused by an psi
+;;TODO: test merge-constructs when merging was caused by an subject-locator
+;;TODO: test merge-constructs when merging was caused by a topic-id
+;;TODO: test merge-constructs when merging was caused by reifiers
+;;      (occurrences, names, variants, associations, roles)
+;;TODO: test ReifiableConstructC --> reifier has to be merged
 
 
 
@@ -367,7 +372,7 @@
 
 
 (test test-get-item-by-item-identifier ()
-    "Tests the function test-get-item-by-id."
+    "Tests the function test-get-item-by-item-identifier."
     (with-fixture with-empty-db (*db-dir*)
       (let ((ii-1 (make-instance 'ItemIdentifierC
 				 :uri "ii-1"))
@@ -409,7 +414,7 @@
 
 
 (test test-get-item-by-locator ()
-    "Tests the function test-get-item-by-id."
+    "Tests the function test-get-item-by-locator."
     (with-fixture with-empty-db (*db-dir*)
       (let ((sl-1 (make-instance 'SubjectLocatorC
 				 :uri "sl-1"))
@@ -451,7 +456,7 @@
 
 
 (test test-get-item-by-psi ()
-    "Tests the function test-get-item-by-id."
+    "Tests the function test-get-item-by-psi."
     (with-fixture with-empty-db (*db-dir*)
       (let ((psi-1 (make-instance 'PersistentIdC
 				  :uri "psi-1"))
@@ -492,6 +497,22 @@
 	(is (eql top-3 (get-item-by-locator "psi-1"))))))
 
 
+(test test-ReifiableConstructC ()
+    "Tests variuas functions of the ReifialeConstructC."
+    (with-fixture with-empty-db (*db-dir*)
+      (let ((reifier-top (make-instance 'TopicC))
+	    (reified-rc (make-instance 'd::ReifiableConstructC)))
+	(is-false (reifier reified-rc))
+	(is-false (reified-construct reifier-top))
+	(add-reifier reified-rc reifier-top :revision 100)
+	(is (eql reifier-top (reifier reified-rc)))
+	(is (eql reified-rc (reified-construct reifier-top)))
+	(is (eql reifier-top (reifier reified-rc :revision 200)))
+	(is (eql reified-rc (reified-construct reifier-top :revision 200)))
+	(is-false (reifier reified-rc :revision 50))
+	(is-false (reified-construct reifier-top :revision 50)))))
+
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
@@ -503,4 +524,5 @@
   (it.bese.fiveam:run! 'test-get-item-by-item-identifier)
   (it.bese.fiveam:run! 'test-get-item-by-locator)
   (it.bese.fiveam:run! 'test-get-item-by-psi)
+  (it.bese.fiveam:run! 'test-ReifiableConstructC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Thu Feb 25 20:45:40 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 25 Feb 2010 15:45:40 -0500
Subject: [isidorus-cvs] r208 - branches/new-datamodel/src/rest_interface
	trunk/src/rest_interface
Message-ID: <E1Nkkaa-0006MU-4D@common-lisp.net>

Author: lgiessmann
Date: Thu Feb 25 15:45:39 2010
New Revision: 208

Log:
rest-interface: fixed a bug in the restful-handler return-overview that caused a memory-leak

Modified:
   branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp
   trunk/src/rest_interface/set-up-json-interface.lisp

Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp	(original)
+++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp	Thu Feb 25 15:45:39 2010
@@ -331,15 +331,15 @@
 (defun return-overview (&optional param)
   "Returns a json-object representing a topic map overview as a tree(s)"
   (declare (ignorable param))
-  (handler-case (let ((json-string
-		       (with-reader-lock
-			 (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))))
-		  (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
-		  json-string)
-    (Condition (err) (progn
-		       (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
-		       (setf (hunchentoot:content-type*) "text")
-		       (format nil "Condition: \"~a\"" err)))))
+  (with-reader-lock
+      (handler-case (let ((json-string
+			   (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))
+		      (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+		      json-string)
+	(Condition (err) (progn
+			   (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+			   (setf (hunchentoot:content-type*) "text")
+			   (format nil "Condition: \"~a\"" err))))))
 
 
 ;; =============================================================================
@@ -385,4 +385,4 @@
 		   (setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx))))
 		   (incf idx)))
 	     (unless (< idx (length str))
-	       (return ret-str)))))))
\ No newline at end of file
+	       (return ret-str)))))))

Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp	(original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp	Thu Feb 25 15:45:39 2010
@@ -331,15 +331,15 @@
 (defun return-overview (&optional param)
   "Returns a json-object representing a topic map overview as a tree(s)"
   (declare (ignorable param))
-  (handler-case (let ((json-string
-		       (with-reader-lock
-			 (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))))
-		  (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
-		  json-string)
-    (Condition (err) (progn
-		       (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
-		       (setf (hunchentoot:content-type*) "text")
-		       (format nil "Condition: \"~a\"" err)))))
+  (with-reader-lock
+    (handler-case (let ((json-string
+			 (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))
+		    (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+		    json-string)
+      (Condition (err) (progn
+			 (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+			 (setf (hunchentoot:content-type*) "text")
+			 (format nil "Condition: \"~a\"" err))))))
 
 
 ;; =============================================================================



From lgiessmann at common-lisp.net  Thu Feb 25 21:36:11 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 25 Feb 2010 16:36:11 -0500
Subject: [isidorus-cvs] r209 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NklNT-00016X-B6@common-lisp.net>

Author: lgiessmann
Date: Thu Feb 25 16:36:10 2010
New Revision: 209

Log:
new-datamodel: added some unit-tests for add-occurrence, delete-occurrence, occurrences; fixed some bugs in these funtions

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 Feb 25 16:36:10 2010
@@ -486,7 +486,7 @@
 		   :accessor characteristic
 		   :inherit t
 		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
-		   :associate CharactersiticC
+		   :associate CharacteristicC
 		   :documentation "Associates this object with the actual
                                    characteristic object."))
   (:documentation "An abstract base class for all association-objects that
@@ -986,7 +986,7 @@
                    with the passed construct and the passed version.")
   (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
-		   construct 'occurences :start-revision revision)))
+		   construct 'occurrences :start-revision revision)))
       (map 'list #'characteristic assocs))))
 
 
@@ -998,7 +998,8 @@
                    an error is thrown.")
   (:method ((construct TopicC) (occurrence OccurrenceC)
 	    &key (revision *TM-REVISION*))
-    (when (not (eql (parent occurrence) construct))
+    (when (and (parent occurrence)
+	       (not (eql (parent occurrence) 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)))
     (let ((all-occurrences
@@ -1007,7 +1008,7 @@
 			   (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) occurrence)
+			      when (eql (parent-construct occ-assoc) construct)
 			      return occ-assoc)))
 	    (add-to-version-history occ-assoc :start-revision revision))
 	  (let ((assoc
@@ -1024,7 +1025,7 @@
   (:method ((construct TopicC) (occurrence OccurrenceC)
 	    &key (revision (error "From delete-occurrence(): revision must be set")))
     (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
-			      when (eql (parent-construct occ-assoc) occurrence)
+			      when (eql (parent-construct occ-assoc) construct)
 			      return occ-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))

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 Feb 25 16:36:10 2010
@@ -27,14 +27,13 @@
 	   :test-get-item-by-item-identifier
 	   :test-get-item-by-locator
 	   :test-get-item-by-psi
-	   :test-ReifiableConstructC))
+	   :test-ReifiableConstructC
+	   :test-OccurrenceC))
 
 
 ;;TODO: test delete-construct
-;;TODO: test merge-constructs when merging was caused by an item-dentifier
-;;TODO: test merge-constructs when merging was caused by an psi
-;;TODO: test merge-constructs when merging was caused by an subject-locator
-;;TODO: test merge-constructs when merging was caused by a topic-id
+;;TODO: test merge-constructs when merging was caused by an item-dentifier,
+;;      a psi, a subject-locator, a topic-id
 ;;TODO: test merge-constructs when merging was caused by reifiers
 ;;      (occurrences, names, variants, associations, roles)
 ;;TODO: test ReifiableConstructC --> reifier has to be merged
@@ -513,6 +512,41 @@
 	(is-false (reified-construct reifier-top :revision 50)))))
 
 
+(test test-OccurrenceC ()
+  "Tests various functions of OccurrenceC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((occ-1 (make-instance 'OccurrenceC))
+	  (occ-2 (make-instance 'OccurrenceC))
+	  (top (make-instance 'TopicC))
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300)
+	  (revision-4 400))
+      (setf *TM-REVISION* revision-1)
+      (is-false (parent occ-1))
+      (is-false (occurrences top))
+      (add-occurrence top occ-1 :revision revision-1)
+      (is (= (length (union (list occ-1)
+			    (occurrences top))) 1))
+      (add-occurrence top occ-2 :revision revision-2)
+      (is (= (length (union (list occ-1 occ-2)
+			    (occurrences top))) 2))
+      (is (= (length (union (list occ-1)
+			    (occurrences top :revision revision-1))) 1))
+      (add-occurrence top occ-2 :revision revision-3)
+      (is (= (length (d::slot-p top 'd::occurrences)) 2))
+      (delete-occurrence top occ-1 :revision revision-4)
+      (is (= (length (union (list occ-2)
+			    (occurrences top :revision revision-4))) 1))
+      (is (= (length (union (list occ-2)
+			    (occurrences top))) 1))
+      (is (= (length (union (list occ-1 occ-2)
+			    (occurrences top :revision revision-2))) 2))
+      (add-occurrence top occ-1 :revision revision-4)
+      (is (= (length (union (list occ-2 occ-1)
+			    (occurrences top))) 2)))))
+
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
@@ -525,4 +559,5 @@
   (it.bese.fiveam:run! 'test-get-item-by-locator)
   (it.bese.fiveam:run! 'test-get-item-by-psi)
   (it.bese.fiveam:run! 'test-ReifiableConstructC)
+  (it.bese.fiveam:run! 'test-OccurrenceC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Fri Feb 26 07:14:12 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 26 Feb 2010 02:14:12 -0500
Subject: [isidorus-cvs] r210 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NkuOq-0005yp-Hu@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 26 02:14:11 2010
New Revision: 210

Log:
new-datamodel: merged the generic functions add-parent, so there is only one for the parents TopicC and NameC; added some unit-tests for add-parent, delete-parent and parent

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 Feb 26 02:14:11 2010
@@ -331,7 +331,7 @@
 
 ;;; characteristics ...
 (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
-  ((parent :associate (CharacteriticAssociationC characteristic)
+  ((parent :associate (CharacteristicAssociationC characteristic)
 	   :inherit t
 	   :documentation "Assocates the characterist obejct with the
                            parent-association.")
@@ -948,13 +948,12 @@
                    an error is thrown.")
   (:method ((construct TopicC) (name NameC)
 	    &key (revision *TM-REVISION*))
-    (when (not (eql (parent name) construct))
+    (when (and (parent name)
+	       (not (eql (parent name) 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)))
     (let ((all-names
-	   (map 'list #'characteristic
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct '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) name)
@@ -998,14 +997,12 @@
                    an error is thrown.")
   (:method ((construct TopicC) (occurrence OccurrenceC)
 	    &key (revision *TM-REVISION*))
-    (when (and (parent occurrence)
+    (when (and (parent occurrence :revision revision)
 	       (not (eql (parent occurrence) 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)))
     (let ((all-occurrences
-	   (map 'list #'characteristic
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct '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)
@@ -1190,13 +1187,12 @@
                    scopable-construct.")
   (:method ((construct NameC) (variant VariantC)
 	    &key (revision *TM-REVISION*))
-    (when (not (eql (parent variant) construct))
+    (when (and (parent variant)
+	       (not (eql (parent variant) 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)))
     (let ((all-variants 
-	   (map 'list #'characteristic
-		(remove-if #'marked-as-deleted-p
-			   (slot-p construct '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)
@@ -1252,60 +1248,39 @@
 
 (defgeneric add-parent (construct parent-construct &key revision)
   (:documentation "Adds the parent-construct (TopicC or NameC) in form of
-                   a corresponding association to the given object."))
-
-
-(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
-		       &key (revision *TM-REVISION*))
-  (let ((already-set-topic
-	   (map 'list #'parent-construct
-		(filter-slot-value-by-revision construct 'parent
-					       :start-revision revision))))
-      (cond ((and already-set-topic
-		  (eql (first already-set-topic) parent-construct))
-	     (let ((parent-assoc
-		    (loop for parent-assoc in (slot-p construct 'parent)
-		       when (eql parent-construct (parent-construct
-						   parent-assoc))
-		       return parent-assoc)))
-	       (add-to-version-history parent-assoc :start-revision revision)))
-	    ((not already-set-topic)
-	     (let ((assoc
-		    (make-instance (if (typep construct 'OccurrenceC)
-				       'OccurrenceAssociationC
-				       'NameAssociationC)
-				   :parent-construct parent-construct
-				   :characteristic construct)))
-	       (add-to-version-history assoc :start-revision revision)))
-	    (t
-	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
-		    construct parent-construct already-set-topic)))
-      construct))
-
-
-(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
-		       &key (revision *TM-REVISION*))
-  (let ((already-set-name
-	   (map 'list #'characteristic
-		(filter-slot-value-by-revision construct 'parent
-					       :start-revision revision))))
-      (cond ((and already-set-name
-		  (eql (first already-set-name) parent-construct))
+                   a corresponding association to the given object.")
+  (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC)
+	    &key (revision *TM-REVISION*))
+    (let ((already-set-parent (parent construct :revision revision))
+	  (same-parent-assoc ;should contain a object that was marked as deleted
+	   (loop for parent-assoc in (slot-p construct 'parent)
+	      when (eql parent-construct (parent-construct parent-assoc))
+	      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))
+      (cond (already-set-parent
 	     (let ((parent-assoc
 		    (loop for parent-assoc in (slot-p construct 'parent)
-		       when (eql parent-construct (characteristic parent-assoc))
+		       when (eql parent-construct
+				 (parent-construct parent-assoc))
 		       return parent-assoc)))
 	       (add-to-version-history parent-assoc :start-revision revision)))
-	    ((not already-set-name)
-	     (let ((assoc
-		    (make-instance 'VariantAssociationC
-				   :parent-construct parent-construct
-				   :characteristic construct)))
-	       (add-to-version-history assoc :start-revision revision)))
+	    (same-parent-assoc
+	     (add-to-version-history same-parent-assoc :start-revision revision))
 	    (t
-	     (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
-		    construct parent-construct already-set-name)))
-      construct))
+	     (let ((association-type (cond ((typep construct 'OccurrenceC)
+					    'OccurrenceAssociationC)
+					   ((typep construct 'NameC)
+					    'NameAssociationC)
+					   (t
+					    'VariantAssociationC))))
+	       (let ((assoc (make-instance association-type
+					   :characteristic construct
+					   :parent-construct parent-construct)))
+		 (add-to-version-history assoc :start-revision revision))))))
+    construct))
 
 
 (defgeneric delete-parent (construct parent-construct &key revision)

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 Feb 26 02:14:11 2010
@@ -28,7 +28,8 @@
 	   :test-get-item-by-locator
 	   :test-get-item-by-psi
 	   :test-ReifiableConstructC
-	   :test-OccurrenceC))
+	   :test-OccurrenceC
+	   :test-VariantC))
 
 
 ;;TODO: test delete-construct
@@ -518,10 +519,15 @@
     (let ((occ-1 (make-instance 'OccurrenceC))
 	  (occ-2 (make-instance 'OccurrenceC))
 	  (top (make-instance 'TopicC))
+	  (top-2 (make-instance 'TopicC))
 	  (revision-1 100)
 	  (revision-2 200)
 	  (revision-3 300)
-	  (revision-4 400))
+	  (revision-4 400)
+	  (revision-5 500)
+	  (revision-6 600)
+	  (revision-7 700)
+	  (revision-8 800))
       (setf *TM-REVISION* revision-1)
       (is-false (parent occ-1))
       (is-false (occurrences top))
@@ -544,7 +550,42 @@
 			    (occurrences top :revision revision-2))) 2))
       (add-occurrence top occ-1 :revision revision-4)
       (is (= (length (union (list occ-2 occ-1)
-			    (occurrences top))) 2)))))
+			    (occurrences top))) 2))
+      (signals error (add-occurrence top-2 occ-1 :revision revision-4))
+      (delete-occurrence top occ-1 :revision revision-5)
+      (is (= (length (union (list occ-2)
+			    (occurrences top :revision revision-5))) 1))
+      (add-occurrence top-2 occ-1 :revision revision-5)
+      (is (eql (parent occ-1) top-2))
+      (is (eql (parent occ-1 :revision revision-2) top))
+      (delete-parent occ-2 top :revision revision-4)
+      (is-false (parent occ-2 :revision revision-4))
+      (is (eql top (parent occ-2 :revision revision-3)))
+      (add-parent occ-2 top :revision revision-5)
+      (is-false (parent occ-2 :revision revision-4))
+      (is (eql top (parent occ-2)))
+      (delete-parent occ-2 top :revision revision-6)
+      (add-parent occ-2 top-2 :revision revision-7)
+      (delete-parent occ-2 top-2 :revision revision-8)
+      (is-false (parent occ-2))
+      (add-parent occ-2 top :revision revision-8)
+      (is (eql top (parent occ-2))))))
+
+
+(test test-VariantC ()
+"Tests various functions of VariantC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((v-1 (make-instance 'VariantC))
+	  (v-2 (make-instance 'VariantC))
+	  (name (make-instance 'NameC))
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300)
+	  (revision-4 400))
+      (setf *TM-REVISION* revision-1)
+      
+      )))
+      
 
 
 (defun run-datamodel-tests()
@@ -560,4 +601,5 @@
   (it.bese.fiveam:run! 'test-get-item-by-psi)
   (it.bese.fiveam:run! 'test-ReifiableConstructC)
   (it.bese.fiveam:run! 'test-OccurrenceC)
+  (it.bese.fiveam:run! 'test-VariantC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Fri Feb 26 07:58:58 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 26 Feb 2010 02:58:58 -0500
Subject: [isidorus-cvs] r211 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1Nkv6A-0008O0-4Z@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 26 02:58:57 2010
New Revision: 211

Log:
new-datamodel: merged the generic functions delete-parent, so there is only one generic function with the signature ((construct CharacteristicC) (parent-construct ReifiableConstructC)
    &key (revision (error "From delete-parent(): revision must be set"))); added some unit-tests for the class VariantC

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 Feb 26 02:58:57 2010
@@ -493,7 +493,7 @@
                    associates characteristics with topics."))
 
 
-(defpclass VariantAssociationC(CharateristicAssociationC)
+(defpclass VariantAssociationC(CharacteristicAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
 		     :initform (error "From VariantAssociationC(): parent-construct must be set")
@@ -1187,8 +1187,8 @@
                    scopable-construct.")
   (:method ((construct NameC) (variant VariantC)
 	    &key (revision *TM-REVISION*))
-    (when (and (parent variant)
-	       (not (eql (parent variant) construct)))
+    (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)))
     (let ((all-variants 
@@ -1285,29 +1285,16 @@
 
 (defgeneric delete-parent (construct parent-construct &key revision)
   (:documentation "Sets the assoication-object between the passed
-                   constructs as marded-as-deleted."))
-
-
-(defmethod delete-parent ((construct CharacteristicC) (parent-construct TopicC)
-			  &key (revision (error "From delete-parent(): revision must be set")))
-  (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))
-    construct))
-
-
-(defmethod delete-parent ((construct CharacteristicC) (parent-construct NameC)
-			  &key (revision (error "From delete-parent(): revision must be set")))
-  (let ((assoc-to-delete
-	 (loop for parent-assoc in (slot-p construct 'parent)
-	    when (eql (characteristic parent-assoc) parent-construct)
-	    return parent-assoc)))
-    (when assoc-to-delete
-      (mark-as-deleted assoc-to-delete :revision revision))
-    construct))
+                   constructs as marded-as-deleted.")
+  (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC)
+	    &key (revision (error "From delete-parent(): revision must be set")))
+    (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))
+      construct)))
 
 
 ;;; PlayerAssociationC

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 Feb 26 02:58:57 2010
@@ -518,7 +518,7 @@
   (with-fixture with-empty-db (*db-dir*)
     (let ((occ-1 (make-instance 'OccurrenceC))
 	  (occ-2 (make-instance 'OccurrenceC))
-	  (top (make-instance 'TopicC))
+	  (top-1 (make-instance 'TopicC))
 	  (top-2 (make-instance 'TopicC))
 	  (revision-1 100)
 	  (revision-2 200)
@@ -530,46 +530,46 @@
 	  (revision-8 800))
       (setf *TM-REVISION* revision-1)
       (is-false (parent occ-1))
-      (is-false (occurrences top))
-      (add-occurrence top occ-1 :revision revision-1)
+      (is-false (occurrences top-1))
+      (add-occurrence top-1 occ-1 :revision revision-1)
       (is (= (length (union (list occ-1)
-			    (occurrences top))) 1))
-      (add-occurrence top occ-2 :revision revision-2)
+			    (occurrences top-1))) 1))
+      (add-occurrence top-1 occ-2 :revision revision-2)
       (is (= (length (union (list occ-1 occ-2)
-			    (occurrences top))) 2))
+			    (occurrences top-1))) 2))
       (is (= (length (union (list occ-1)
-			    (occurrences top :revision revision-1))) 1))
-      (add-occurrence top occ-2 :revision revision-3)
-      (is (= (length (d::slot-p top 'd::occurrences)) 2))
-      (delete-occurrence top occ-1 :revision revision-4)
+			    (occurrences top-1 :revision revision-1))) 1))
+      (add-occurrence top-1 occ-2 :revision revision-3)
+      (is (= (length (d::slot-p top-1 'd::occurrences)) 2))
+      (delete-occurrence top-1 occ-1 :revision revision-4)
       (is (= (length (union (list occ-2)
-			    (occurrences top :revision revision-4))) 1))
+			    (occurrences top-1 :revision revision-4))) 1))
       (is (= (length (union (list occ-2)
-			    (occurrences top))) 1))
+			    (occurrences top-1))) 1))
       (is (= (length (union (list occ-1 occ-2)
-			    (occurrences top :revision revision-2))) 2))
-      (add-occurrence top occ-1 :revision revision-4)
+			    (occurrences top-1 :revision revision-2))) 2))
+      (add-occurrence top-1 occ-1 :revision revision-4)
       (is (= (length (union (list occ-2 occ-1)
-			    (occurrences top))) 2))
+			    (occurrences top-1))) 2))
       (signals error (add-occurrence top-2 occ-1 :revision revision-4))
-      (delete-occurrence top occ-1 :revision revision-5)
+      (delete-occurrence top-1 occ-1 :revision revision-5)
       (is (= (length (union (list occ-2)
-			    (occurrences top :revision revision-5))) 1))
+			    (occurrences top-1 :revision revision-5))) 1))
       (add-occurrence top-2 occ-1 :revision revision-5)
       (is (eql (parent occ-1) top-2))
-      (is (eql (parent occ-1 :revision revision-2) top))
-      (delete-parent occ-2 top :revision revision-4)
+      (is (eql (parent occ-1 :revision revision-2) top-1))
+      (delete-parent occ-2 top-1 :revision revision-4)
       (is-false (parent occ-2 :revision revision-4))
-      (is (eql top (parent occ-2 :revision revision-3)))
-      (add-parent occ-2 top :revision revision-5)
+      (is (eql top-1 (parent occ-2 :revision revision-3)))
+      (add-parent occ-2 top-1 :revision revision-5)
       (is-false (parent occ-2 :revision revision-4))
-      (is (eql top (parent occ-2)))
-      (delete-parent occ-2 top :revision revision-6)
+      (is (eql top-1 (parent occ-2)))
+      (delete-parent occ-2 top-1 :revision revision-6)
       (add-parent occ-2 top-2 :revision revision-7)
       (delete-parent occ-2 top-2 :revision revision-8)
       (is-false (parent occ-2))
-      (add-parent occ-2 top :revision revision-8)
-      (is (eql top (parent occ-2))))))
+      (add-parent occ-2 top-1 :revision revision-8)
+      (is (eql top-1 (parent occ-2))))))
 
 
 (test test-VariantC ()
@@ -577,14 +577,59 @@
   (with-fixture with-empty-db (*db-dir*)
     (let ((v-1 (make-instance 'VariantC))
 	  (v-2 (make-instance 'VariantC))
-	  (name (make-instance 'NameC))
+	  (name-1 (make-instance 'NameC))
+	  (name-2 (make-instance 'NameC))
 	  (revision-1 100)
 	  (revision-2 200)
 	  (revision-3 300)
-	  (revision-4 400))
+	  (revision-4 400)
+	  (revision-5 500)
+	  (revision-6 600)
+	  (revision-7 700)
+	  (revision-8 800))
       (setf *TM-REVISION* revision-1)
-      
-      )))
+      (is-false (parent v-1))
+      (is-false (variants name-1))
+      (add-variant name-1 v-1 :revision revision-1)
+      (is (= (length (union (list v-1)
+			    (variants name-1))) 1))
+      (add-variant name-1 v-2 :revision revision-2)
+      (is (= (length (union (list v-1 v-2)
+			    (variants name-1))) 2))
+      (is (= (length (union (list v-1)
+			    (variants name-1 :revision revision-1))) 1))
+      (add-variant name-1 v-2 :revision revision-3)
+      (is (= (length (d::slot-p name-1 'd::variants)) 2))
+      (delete-variant name-1 v-1 :revision revision-4)
+      (is (= (length (union (list v-2)
+			    (variants name-1 :revision revision-4))) 1))
+      (is (= (length (union (list v-2)
+			    (variants name-1))) 1))
+      (is (= (length (union (list v-1 v-2)
+			    (variants name-1 :revision revision-2))) 2))
+      (add-variant name-1 v-1 :revision revision-4)
+      (is (= (length (union (list v-2 v-1)
+			    (variants name-1))) 2))
+      (signals error (add-variant name-2 v-1 :revision revision-4))
+      (delete-variant name-1 v-1 :revision revision-5)
+      (is (= (length (union (list v-2)
+			    (variants name-1 :revision revision-5))) 1))
+      (add-variant name-2 v-1 :revision revision-5)
+      (is (eql (parent v-1) name-2))
+      (is (eql (parent v-1 :revision revision-2) name-1))
+      (delete-parent v-2 name-1 :revision revision-4)
+      (format t "-->")
+      (is-false (parent v-2 :revision revision-4))
+      (is (eql name-1 (parent v-2 :revision revision-3)))
+      (add-parent v-2 name-1 :revision revision-5)
+      (is-false (parent v-2 :revision revision-4))
+      (is (eql name-1 (parent v-2)))
+      (delete-parent v-2 name-1 :revision revision-6)
+      (add-parent v-2 name-2 :revision revision-7)
+      (delete-parent v-2 name-2 :revision revision-8)
+      (is-false (parent v-2))
+      (add-parent v-2 name-1 :revision revision-8)
+      (is (eql name-1 (parent v-2))))))
       
 
 



From lgiessmann at common-lisp.net  Fri Feb 26 08:07:41 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 26 Feb 2010 03:07:41 -0500
Subject: [isidorus-cvs] r212 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NkvEb-00011J-9q@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 26 03:07:41 2010
New Revision: 212

Log:
new-datamodel: added some unit-test for NameC; fixed a bug in delete-name and add-name

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 Feb 26 03:07:41 2010
@@ -948,15 +948,16 @@
                    an error is thrown.")
   (:method ((construct TopicC) (name NameC)
 	    &key (revision *TM-REVISION*))
-    (when (and (parent name)
-	       (not (eql (parent name) construct)))
+    (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)))
+	     name construct (parent name :revision revision)))
     (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) name)
+			       when (eql (parent-construct name-assoc)
+					 construct)
 			       return name-assoc)))
 	    (add-to-version-history name-assoc :start-revision revision))
 	  (let ((assoc
@@ -973,7 +974,7 @@
   (:method ((construct TopicC) (name NameC)
 	    &key (revision (error "From delete-name(): revision must be set")))
     (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
-			      when (eql (parent-construct name-assoc) name)
+			      when (eql (parent-construct name-assoc) construct)
 			      return name-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))

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 Feb 26 03:07:41 2010
@@ -29,7 +29,8 @@
 	   :test-get-item-by-psi
 	   :test-ReifiableConstructC
 	   :test-OccurrenceC
-	   :test-VariantC))
+	   :test-VariantC
+	   :test-NameC))
 
 
 ;;TODO: test delete-construct
@@ -573,7 +574,7 @@
 
 
 (test test-VariantC ()
-"Tests various functions of VariantC."
+  "Tests various functions of VariantC."
   (with-fixture with-empty-db (*db-dir*)
     (let ((v-1 (make-instance 'VariantC))
 	  (v-2 (make-instance 'VariantC))
@@ -618,7 +619,6 @@
       (is (eql (parent v-1) name-2))
       (is (eql (parent v-1 :revision revision-2) name-1))
       (delete-parent v-2 name-1 :revision revision-4)
-      (format t "-->")
       (is-false (parent v-2 :revision revision-4))
       (is (eql name-1 (parent v-2 :revision revision-3)))
       (add-parent v-2 name-1 :revision revision-5)
@@ -630,6 +630,65 @@
       (is-false (parent v-2))
       (add-parent v-2 name-1 :revision revision-8)
       (is (eql name-1 (parent v-2))))))
+
+
+(test test-NameC ()
+  "Tests various functions of NameC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((name-1 (make-instance 'NameC))
+	  (name-2 (make-instance 'NameC))
+	  (top-1 (make-instance 'TopicC))
+	  (top-2 (make-instance 'TopicC))
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300)
+	  (revision-4 400)
+	  (revision-5 500)
+	  (revision-6 600)
+	  (revision-7 700)
+	  (revision-8 800))
+      (setf *TM-REVISION* revision-1)
+      (is-false (parent name-1))
+      (is-false (names top-1))
+      (add-name top-1 name-1 :revision revision-1)
+      (is (= (length (union (list name-1)
+			    (names top-1))) 1))
+      (add-name top-1 name-2 :revision revision-2)
+      (is (= (length (union (list name-1 name-2)
+			    (names top-1))) 2))
+      (is (= (length (union (list name-1)
+			    (names top-1 :revision revision-1))) 1))
+      (add-name top-1 name-2 :revision revision-3)
+      (is (= (length (d::slot-p top-1 'd::names)) 2))
+      (delete-name top-1 name-1 :revision revision-4)
+      (is (= (length (union (list name-2)
+			    (names top-1 :revision revision-4))) 1))
+      (is (= (length (union (list name-2)
+			    (names top-1))) 1))
+      (is (= (length (union (list name-1 name-2)
+			    (names top-1 :revision revision-2))) 2))
+      (add-name top-1 name-1 :revision revision-4)
+      (is (= (length (union (list name-2 name-1)
+			    (names top-1))) 2))
+      (signals error (add-name top-2 name-1 :revision revision-4))
+      (delete-name top-1 name-1 :revision revision-5)
+      (is (= (length (union (list name-2)
+			    (names top-1 :revision revision-5))) 1))
+      (add-name top-2 name-1 :revision revision-5)
+      (is (eql (parent name-1) top-2))
+      (is (eql (parent name-1 :revision revision-2) top-1))
+      (delete-parent name-2 top-1 :revision revision-4)
+      (is-false (parent name-2 :revision revision-4))
+      (is (eql top-1 (parent name-2 :revision revision-3)))
+      (add-parent name-2 top-1 :revision revision-5)
+      (is-false (parent name-2 :revision revision-4))
+      (is (eql top-1 (parent name-2)))
+      (delete-parent name-2 top-1 :revision revision-6)
+      (add-parent name-2 top-2 :revision revision-7)
+      (delete-parent name-2 top-2 :revision revision-8)
+      (is-false (parent name-2))
+      (add-parent name-2 top-1 :revision revision-8)
+      (is (eql top-1 (parent name-2))))))
       
 
 
@@ -647,4 +706,5 @@
   (it.bese.fiveam:run! 'test-ReifiableConstructC)
   (it.bese.fiveam:run! 'test-OccurrenceC)
   (it.bese.fiveam:run! 'test-VariantC)
+  (it.bese.fiveam:run! 'test-NameC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Fri Feb 26 15:50:45 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 26 Feb 2010 10:50:45 -0500
Subject: [isidorus-cvs] r213 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1Nl2Sj-000353-Q0@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 26 10:50:44 2010
New Revision: 213

Log:
new-datamodel: added some unit-tests for the base class TypableC; optimized the function add-type.

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 Feb 26 10:50:44 2010
@@ -94,6 +94,9 @@
 (in-package :datamodel)
 
 
+;;TODO: add-type/add-parent/add-<x>-identifier handle situation where
+;;      new objects hve to be bound in an earlier revision than one
+;;      where a object is already bound
 ;;TODO: finalize add-reifier
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
@@ -170,7 +173,7 @@
 
 
 (defpclass TypableC()
-  ((instance-of :associate (TypeAssociationC type-topic)
+  ((instance-of :associate (TypeAssociationC typable-construct)
 		:inherit t
 		:documentation "Contains all association-objects that contain
                                 the actual type-topic."))
@@ -1527,6 +1530,7 @@
 	   (map 'list #'player-topic
 		(filter-slot-value-by-revision construct 'player
 					       :start-revision revision))))
+      ;;TODO: search a player-assoc for the passed construct that was set in an older version
       (cond ((and already-set-player
 		  (eql (first already-set-player) player-topic))
 	     (let ((player-assoc
@@ -1763,24 +1767,30 @@
     (let ((already-set-type
 	   (map 'list #'type-topic
 		(filter-slot-value-by-revision construct 'instance-of
-					       :start-revision revision))))
-      (cond ((and already-set-type
-		  (eql (first already-set-type) type-topic))
+					       :start-revision revision)))
+	  (same-type-assoc
+	   (loop for type-assoc in (slot-p construct 'instance-of)
+	      when (eql (type-topic type-assoc) type-topic)
+	      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))
+      (cond (already-set-type
 	     (let ((type-assoc
 		    (loop for type-assoc in (slot-p construct 'instance-of)
 		       when (eql type-topic (type-topic type-assoc))
 		       return type-assoc)))
 	       (add-to-version-history type-assoc :start-revision revision)))
-	    ((not already-set-type)
+	    (same-type-assoc
+	     (add-to-version-history same-type-assoc :start-revision revision))
+	    (t
 	     (let ((assoc
 		    (make-instance 'TypeAssociationC
 				   :type-topic type-topic
 				   :typable-construct construct)))
-	       (add-to-version-history assoc :start-revision revision)))
-	    (t
-	     (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a"
-		    construct type-topic already-set-type)))
-      construct)))
+	       (add-to-version-history assoc :start-revision revision)))))
+    construct))
 
 
 (defgeneric delete-type (construct type-topic &key revision)

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 Feb 26 10:50:44 2010
@@ -30,7 +30,8 @@
 	   :test-ReifiableConstructC
 	   :test-OccurrenceC
 	   :test-VariantC
-	   :test-NameC))
+	   :test-NameC
+	   :test-TypableC))
 
 
 ;;TODO: test delete-construct
@@ -689,6 +690,41 @@
       (is-false (parent name-2))
       (add-parent name-2 top-1 :revision revision-8)
       (is (eql top-1 (parent name-2))))))
+
+
+(test test-TypableC ()
+  "Tests various functions of the base class TypableC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((name-1 (make-instance 'NameC))
+	  (name-2 (make-instance 'NameC))
+	  (top-1 (make-instance 'TopicC))
+	  (top-2 (make-instance 'TopicC))
+	  (revision-0-5 50)
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300))
+      (setf *TM-REVISION* revision-1)
+      (is-false (instance-of name-1))
+      (add-type name-1 top-1)
+      (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))
+      (add-type name-2 top-1 :revision revision-2)
+      (is (= (length (union (list name-1 name-2)
+			    (used-as-type top-1))) 2))
+      (is (= (length (union (list name-1)
+			    (used-as-type top-1
+					  :revision revision-1))) 1))
+      (delete-type name-1 top-1 :revision revision-3)
+      (is-false (instance-of name-1))
+      (is (= (length (union (list name-2)
+			    (used-as-type top-1))) 1))
+      (add-type name-1 top-1 :revision revision-3)
+      (is (eql top-1 (instance-of name-1)))
+      (is (= (length (union (list name-1 name-2)
+			    (used-as-type top-1))) 2))
+      (is (= (length (slot-value top-1 'd::used-as-type)) 2)))))
       
 
 
@@ -707,4 +743,5 @@
   (it.bese.fiveam:run! 'test-OccurrenceC)
   (it.bese.fiveam:run! 'test-VariantC)
   (it.bese.fiveam:run! 'test-NameC)
+  (it.bese.fiveam:run! 'test-TypableC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Fri Feb 26 20:22:12 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 26 Feb 2010 15:22:12 -0500
Subject: [isidorus-cvs] r214 - in branches/new-datamodel: docs src/model
	src/unit_tests
Message-ID: <E1Nl6hQ-0003o7-T2@common-lisp.net>

Author: lgiessmann
Date: Fri Feb 26 15:22:11 2010
New Revision: 214

Log:
new-datamodel: added some unit-tests for the base class ScopableC.

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/unit_tests/datamodel_test.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Fri Feb 26 15:22:11 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Fri Feb 26 15:22:11 2010
@@ -1711,8 +1711,7 @@
   (:method ((construct ScopableC) (theme-topic TopicC)
 	    &key (revision *TM-REVISION*))
     (let ((all-themes
-	   (map 'list #'theme-topic
-		(remove-if #'marked-as-deleted-p (slot-p construct 'themes)))))
+	   (map 'list #'theme-topic (slot-p construct 'themes))))
       (if (find theme-topic all-themes)
 	  (let ((theme-assoc
 		 (loop for theme-assoc in (slot-p construct 'themes)
@@ -1720,7 +1719,7 @@
 		    return theme-assoc)))
 	    (add-to-version-history theme-assoc  :start-revision revision))
 	  (let ((assoc
-		 (make-instance 'ScopeAssociationCn
+		 (make-instance 'ScopeAssociationC
 				:theme-topic theme-topic
 				:scopable-construct construct)))
 	    (add-to-version-history assoc :start-revision revision))))

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 Feb 26 15:22:11 2010
@@ -31,7 +31,8 @@
 	   :test-OccurrenceC
 	   :test-VariantC
 	   :test-NameC
-	   :test-TypableC))
+	   :test-TypableC
+	   :test-ScopableC))
 
 
 ;;TODO: test delete-construct
@@ -725,6 +726,56 @@
       (is (= (length (union (list name-1 name-2)
 			    (used-as-type top-1))) 2))
       (is (= (length (slot-value top-1 'd::used-as-type)) 2)))))
+
+
+(test test-ScopableC ()
+  "Tests various functions of the base class ScopableC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((occ-1 (make-instance 'OccurrenceC))
+	  (occ-2 (make-instance 'OccurrenceC))
+	  (top-1 (make-instance 'TopicC))
+	  (top-2 (make-instance 'TopicC))
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300))
+      (setf *TM-REVISION* revision-1)
+      (is-false (themes occ-1))
+      (is-false (used-as-theme top-1))
+      (add-theme occ-1 top-1)
+      (is (= (length (union (list top-1)
+			    (themes occ-1))) 1))
+      (is (= (length (union (list occ-1)
+			    (used-as-theme top-1))) 1))
+      (delete-theme occ-1 top-1 :revision revision-2)
+      (is (= (length (union (list top-1)
+			    (themes occ-1 :revision revision-1))) 1))
+      (is-false (themes occ-1))
+      (is-false (used-as-theme top-1))
+      (is-false (themes occ-1 :revision revision-2))
+      (add-theme occ-1 top-1 :revision revision-3)
+      (is (= (length (union (list top-1)
+			    (themes occ-1))) 1))
+      (is (= (length (slot-value occ-1 'd::themes)) 1))
+      (add-theme occ-1 top-2 :revision revision-2)
+      (is (= (length (union (list top-1 top-2)
+			    (themes occ-1))) 2))
+      (is (= (length (union (list top-2)
+			    (themes occ-1 :revision revision-2))) 1))
+      (is (= (length (union (list top-1 top-2)
+			    (themes occ-1))) 2))
+      (add-theme occ-2 top-2 :revision revision-3)
+      (is (= (length (union (list top-1 top-2)
+			    (themes occ-1))) 2))
+      (is (= (length (union (list top-2)
+			    (themes occ-2))) 1))
+      (is (= (length (union (list occ-1)
+			    (used-as-theme top-1))) 1))
+      (is (= (length (union (list occ-1 occ-2)
+			    (used-as-theme top-2))) 2))
+      (is (= (length (slot-value occ-1 'd::themes)) 2))
+      (is (= (length (slot-value occ-2 'd::themes)) 1))
+      (is (= (length (slot-value top-1 'd::used-as-theme)) 1))
+      (is (= (length (slot-value top-2 'd::used-as-theme)) 2)))))
       
 
 
@@ -744,4 +795,5 @@
   (it.bese.fiveam:run! 'test-VariantC)
   (it.bese.fiveam:run! 'test-NameC)
   (it.bese.fiveam:run! 'test-TypableC)
+  (it.bese.fiveam:run! 'test-ScopableC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Sat Feb 27 10:22:24 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 27 Feb 2010 05:22:24 -0500
Subject: [isidorus-cvs] r215 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NlJoV-00080U-VW@common-lisp.net>

Author: lgiessmann
Date: Sat Feb 27 05:22:23 2010
New Revision: 215

Log:
new-datamodel: added some unit-tests for the class RoleC; fixed a bug in add-parent and add-role

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	Sat Feb 27 05:22:23 2010
@@ -94,9 +94,6 @@
 (in-package :datamodel)
 
 
-;;TODO: add-type/add-parent/add-<x>-identifier handle situation where
-;;      new objects hve to be bound in an earlier revision than one
-;;      where a object is already bound
 ;;TODO: finalize add-reifier
 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
 ;;      initarg in make-construct
@@ -265,7 +262,7 @@
 
 (defpclass AssociationC(ReifiableConstructC ScopableC TypableC
 					    VersionedConstructC)
-  ((roles :associate (RoleAssociationC association)
+  ((roles :associate (RoleAssociationC parent-construct)
 	  :documentation "Contains all association-objects of all roles this
                           association contains.")
    (in-topicmaps :associate (TopicMapC associations)
@@ -1424,8 +1421,7 @@
   (:method ((construct AssociationC) (role RoleC)
 	    &key (revision *TM-REVISION*))
     (let ((all-roles
-	   (map 'list #'role
-		(remove-if #'marked-as-deleted-p (slot-p construct '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)
@@ -1435,7 +1431,7 @@
 	  (let ((assoc
 		 (make-instance 'RoleAssociationC
 				:role role
-				:association construct)))
+				:parent-construct construct)))
 	    (add-to-version-history assoc :start-revision revision))))
     construct))
 
@@ -1477,27 +1473,29 @@
 
 (defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
 			    &key (revision *TM-REVISION*))
-  (let ((already-set-parent
-	   (map 'list #'parent
-		(filter-slot-value-by-revision construct 'parent
-					       :start-revision revision))))
-      (cond ((and already-set-parent
-		  (eql (first already-set-parent) parent-construct))
-	     (let ((parent-assoc
-		    (loop for parent-assoc in (slot-p construct 'parent)
-		       when (eql parent-construct
-				 (parent-construct parent-assoc))
-		       return parent-assoc)))
-	       (add-to-version-history parent-assoc :start-revision revision)))
-	    ((not already-set-parent)
-	     (let ((assoc (make-instance 'RoleAssociationC
-					 :role construct
-					 :parent-construct parent-construct)))
-	       (add-to-version-history assoc :start-revision revision)))
-	    (t
-	     (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a"
-		    parent-construct construct already-set-parent)))
-      construct))
+  (let ((already-set-parent (parent construct :revision revision))
+	(same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent)
+			      when (eql parent-construct (parent-construct parent-assoc))
+			      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))
+    (cond (already-set-parent
+	   (let ((parent-assoc
+		  (loop for parent-assoc in (slot-p construct 'parent)
+		     when (eql parent-construct
+			       (parent-construct parent-assoc))
+		     return parent-assoc)))
+	     (add-to-version-history parent-assoc :start-revision revision)))
+	  (same-parent-assoc
+	   (add-to-version-history same-parent-assoc :start-revision revision))
+	  (t
+	   (let ((assoc (make-instance 'RoleAssociationC
+				       :role construct
+				       :parent-construct parent-construct)))
+	     (add-to-version-history assoc :start-revision revision)))))
+  construct)
 
 
 (defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
@@ -1526,10 +1524,7 @@
   (:documentation "Adds a topic as a player to a role in the given revision.")
   (:method ((construct RoleC) (player-topic TopicC)
 	    &key (revision *TM-REVISION*))
-    (let ((already-set-player
-	   (map 'list #'player-topic
-		(filter-slot-value-by-revision construct 'player
-					       :start-revision revision))))
+    (let ((already-set-player (player construct :revision revision)))
       ;;TODO: search a player-assoc for the passed construct that was set in an older version
       (cond ((and already-set-player
 		  (eql (first already-set-player) player-topic))
@@ -1763,10 +1758,7 @@
                    set at the same revision.")
   (:method ((construct TypableC) (type-topic TopicC)
 	    &key (revision *TM-REVISION*))
-    (let ((already-set-type
-	   (map 'list #'type-topic
-		(filter-slot-value-by-revision construct 'instance-of
-					       :start-revision revision)))
+    (let ((already-set-type (instance-of construct :revision revision))
 	  (same-type-assoc
 	   (loop for type-assoc in (slot-p construct 'instance-of)
 	      when (eql (type-topic type-assoc) type-topic)

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	Sat Feb 27 05:22:23 2010
@@ -17,6 +17,7 @@
   (:import-from :exceptions
 		duplicate-identifier-error)
   (:export :run-datamodel-tests
+	   :datamodel-test
 	   :test-VersionInfoC
 	   :test-VersionedConstructC
 	   :test-ItemIdentifierC
@@ -32,7 +33,8 @@
 	   :test-VariantC
 	   :test-NameC
 	   :test-TypableC
-	   :test-ScopableC))
+	   :test-ScopableC
+	   :test-RoleC))
 
 
 ;;TODO: test delete-construct
@@ -776,6 +778,56 @@
       (is (= (length (slot-value occ-2 'd::themes)) 1))
       (is (= (length (slot-value top-1 'd::used-as-theme)) 1))
       (is (= (length (slot-value top-2 'd::used-as-theme)) 2)))))
+
+
+(test test-RoleC ()
+  "Tests various functions of the class RoleC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((role-1 (make-instance 'RoleC))
+	  (role-2 (make-instance 'RoleC))
+	  (assoc-1 (make-instance 'AssociationC))
+	  (assoc-2 (make-instance 'AssociationC))
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300))
+      (setf *TM-REVISION* revision-1)
+      (is-false (roles assoc-1))
+      (is-false (parent role-1))
+      (add-parent role-1 assoc-1)
+      (is (eql (parent role-1 :revision revision-1) assoc-1))
+      (is (= (length (union (list role-1)
+			    (roles assoc-1))) 1))
+      (add-role assoc-1 role-2 :revision revision-2)
+      (is (= (length (union (list role-1 role-2)
+			    (roles assoc-1))) 2))
+      (is (= (length (union (list role-1)
+			    (roles assoc-1 :revision revision-1))) 1))
+      (is (eql (parent role-1) assoc-1))
+      (is (eql (parent role-2 :revision revision-2)  assoc-1))
+      (is-false (parent role-2 :revision revision-1))
+      (signals error (add-parent role-2 assoc-2 :revision revision-2))
+      (delete-role assoc-1 role-1 :revision revision-3)
+      (is-false (parent role-1))
+      (is (= (length (union (list role-2)
+			    (roles assoc-1))) 1))
+      (delete-parent role-2 assoc-1 :revision revision-3)
+      (is-false (parent role-2))
+      (is (eql assoc-1 (parent role-2 :revision revision-2)))
+      (is-false (roles assoc-1))
+      (add-role assoc-2 role-1 :revision revision-3)
+      (add-parent role-2 assoc-2 :revision revision-3)
+      (is (eql (parent role-2) assoc-2))
+      (is (= (length (union (list role-1 role-2)
+			    (roles assoc-2))) 2))
+      (add-role assoc-2 role-1 :revision revision-3)
+      (add-parent role-2 assoc-2 :revision revision-3)
+      (is (eql (parent role-2) assoc-2))
+      (is (= (length (union (list role-1 role-2)
+			    (roles assoc-2))) 2))
+      (is (= (length (slot-value assoc-1 'roles)) 2))
+      (is (= (length (slot-value assoc-2 'roles)) 2))
+      (is (= (length (slot-value role-1 'parent)) 2))
+      (is (= (length (slot-value role-2 'parent)) 2)))))
       
 
 
@@ -796,4 +848,5 @@
   (it.bese.fiveam:run! 'test-NameC)
   (it.bese.fiveam:run! 'test-TypableC)
   (it.bese.fiveam:run! 'test-ScopableC)
+  (it.bese.fiveam:run! 'test-RoleC)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Sat Feb 27 10:43:01 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 27 Feb 2010 05:43:01 -0500
Subject: [isidorus-cvs] r216 - in branches/new-datamodel/src: model
	unit_tests
Message-ID: <E1NlK8T-0000k2-Qi@common-lisp.net>

Author: lgiessmann
Date: Sat Feb 27 05:43:01 2010
New Revision: 216

Log:
new-datamodel: added some unit-tests for the class RoleC --> player handling.

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	Sat Feb 27 05:43:01 2010
@@ -1524,24 +1524,29 @@
   (:documentation "Adds a topic as a player to a role in the given revision.")
   (:method ((construct RoleC) (player-topic TopicC)
 	    &key (revision *TM-REVISION*))
-    (let ((already-set-player (player construct :revision revision)))
-      ;;TODO: search a player-assoc for the passed construct that was set in an older version
-      (cond ((and already-set-player
-		  (eql (first already-set-player) player-topic))
+    (let ((already-set-player (player construct :revision revision))
+	  (same-player-assoc
+	   (loop for player-assoc in (slot-p construct 'player)
+	      when (eql (player-topic player-assoc) player-topic)
+	      return player-assoc)))
+      (when (and already-set-player
+		 (not (eql already-set-player player-topic)))
+	(error "From add-player(): ~a can't be palyed by ~a since it is played by ~a"
+	       construct player-topic already-set-player))
+      (cond (already-set-player
 	     (let ((player-assoc
 		    (loop for player-assoc in (slot-p construct 'player)
 		       when (eql player-topic (player-topic player-assoc))
 		       return player-assoc)))
 	       (add-to-version-history player-assoc :start-revision revision)))
-	    ((not already-set-player)
+	    (same-player-assoc
+	     (add-to-version-history same-player-assoc :start-revision revision))
+	    (t
 	     (let ((assoc (make-instance 'PlayerAssociationC
 					 :parent-construct construct
 					 :player-topic player-topic)))
-	       (add-to-version-history assoc :start-revision revision)))
-	    (t
-	     (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a"
-		    player-topic construct already-set-player)))
-      construct)))
+	       (add-to-version-history assoc :start-revision revision)))))
+    construct))
 
 
 (defgeneric delete-player (construct player-topic &key revision)

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	Sat Feb 27 05:43:01 2010
@@ -34,7 +34,8 @@
 	   :test-NameC
 	   :test-TypableC
 	   :test-ScopableC
-	   :test-RoleC))
+	   :test-RoleC
+	   :test-player))
 
 
 ;;TODO: test delete-construct
@@ -828,6 +829,45 @@
       (is (= (length (slot-value assoc-2 'roles)) 2))
       (is (= (length (slot-value role-1 'parent)) 2))
       (is (= (length (slot-value role-2 'parent)) 2)))))
+
+
+(test test-player ()
+  "Tests various functions of the topics that are used as player in roles."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((role-1 (make-instance 'RoleC))
+	  (role-2 (make-instance 'RoleC))
+	  (top-1 (make-instance 'TopicC))
+	  (top-2 (make-instance 'TopicC))
+	  (revision-0-5 50)
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300))
+      (setf *TM-REVISION* revision-1)
+      (is-false (player role-1))
+      (add-player role-1 top-1)
+      (is (eql top-1 (player role-1)))
+      (is-false (player role-1 :revision revision-0-5))
+      (is (eql top-1 (player role-1 :revision revision-2)))
+      (add-player role-1 top-1)
+      (is (eql top-1 (player role-1)))
+      (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))
+      (add-player role-2 top-1 :revision revision-2)
+      (is (= (length (union (list role-1 role-2)
+			    (player-in-roles top-1))) 2))
+      (is (= (length (union (list role-1)
+			    (player-in-roles top-1
+					  :revision revision-1))) 1))
+      (delete-player role-1 top-1 :revision revision-3)
+      (is-false (player role-1))
+      (is (= (length (union (list role-2)
+			    (player-in-roles top-1))) 1))
+      (add-player role-1 top-1 :revision revision-3)
+      (is (eql top-1 (player role-1)))
+      (is (= (length (union (list role-1 role-2)
+			    (player-in-roles top-1))) 2))
+      (is (= (length (slot-value top-1 'd::player-in-roles)) 2)))))
       
 
 
@@ -849,4 +889,5 @@
   (it.bese.fiveam:run! 'test-TypableC)
   (it.bese.fiveam:run! 'test-ScopableC)
   (it.bese.fiveam:run! 'test-RoleC)
+  (it.bese.fiveam:run! 'test-player)
 )
\ No newline at end of file



From lgiessmann at common-lisp.net  Sat Feb 27 11:37:57 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 27 Feb 2010 06:37:57 -0500
Subject: [isidorus-cvs] r217 - in branches/new-datamodel: docs src/model
	src/unit_tests
Message-ID: <E1NlKzd-0003p6-0j@common-lisp.net>

Author: lgiessmann
Date: Sat Feb 27 06:37:56 2010
New Revision: 217

Log:
new-datamodel: added some unit-tests for the class TopicMapC; added the generics add-to-tm and delete-from-tm.

Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/unit_tests/datamodel_test.lisp

Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Sat Feb 27 06:37:56 2010 differ

Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Sat Feb 27 06:37:56 2010
@@ -25,7 +25,7 @@
 	   :TopicIdentificationC
 	   :TopicC
 
-	   ;;methods and functions
+	   ;;methods, functions and macros
 	   :xtm-id
 	   :uri
 	   :identified-construct
@@ -56,6 +56,8 @@
 	   :delete-role
 	   :associations
 	   :topics
+	   :add-to-tm
+	   :delete-from-tm
 	   :psis
 	   :add-psi
 	   :delete-psi
@@ -86,6 +88,7 @@
 	   :get-item-by-item-identifier
 	   :get-item-by-locator
 	   :string-integer-p
+	   :with-revision
 
 	   ;;globals
 	   :*TM-REVISION*
@@ -281,11 +284,11 @@
 
 
 (elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
-  ((topics :accessor topics
-	   :associate (TopicC in-topicmaps)
+  ((topics :associate (TopicC in-topicmaps)
+	   :many-to-many t
 	   :documentation "List of topics that explicitly belong to this TM.")
-   (associations :accessor associations
-                 :associate (AssociationC in-topicmaps)
+   (associations :associate (AssociationC in-topicmaps)
+		 :many-to-many t
                  :documentation "List of associations that belong to this TM."))
   (:documentation "Represnets a topic map."))
 
@@ -557,6 +560,12 @@
 
 
 ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defmacro with-revision (revision &rest body)
+  `(let
+       ((*TM-REVISION* ,revision))
+     , at body))
+
+
 (defun slot-p (instance slot-symbol)
   "Returns t if the slot depending on slot-symbol is bound and not nil."
   (if (slot-boundp instance slot-symbol)
@@ -1803,7 +1812,45 @@
       construct)))
 
 
+;;; TopicMapC
+(defgeneric topics (construct &key revision)
+  (:documentation "Returns all TopicC-objects that are contained in the tm.")
+  (:method ((construct TopicMapC) &key (revision 0))
+    (filter-slot-value-by-revision construct 'topics
+				   :start-revision revision)))
+
+
+(defgeneric associations (construct &key revision)
+  (:documentation "Returns all AssociationC-objects that are contained in the tm.")
+  (:method ((construct TopicMapC) &key (revision 0))
+    (filter-slot-value-by-revision construct 'associations
+				   :start-revision revision)))
+
+
+(defgeneric add-to-tm (construct construct-to-add)
+  (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM."))
+
+
+(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
+  (add-association construct 'topics construct-to-add))
+
+
+(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC))
+  (add-association construct 'associations construct-to-add))
+
+
+(defgeneric delete-from-tm (construct construct-to-delete)
+  (:documentation "Deletes a TM construct (TopicC or AssociationC) from
+                   the TM."))
+
+
+(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC))
+  (remove-association construct 'topics construct-to-delete))
+
 
+(defmethod delete-from-tm ((construct TopicMapC)
+			   (construct-to-delete AssociationC))
+  (remove-association construct 'associations construct-to-delete))
 
 
 

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	Sat Feb 27 06:37:56 2010
@@ -35,7 +35,8 @@
 	   :test-TypableC
 	   :test-ScopableC
 	   :test-RoleC
-	   :test-player))
+	   :test-player
+	   :test-TopicMapC))
 
 
 ;;TODO: test delete-construct
@@ -868,10 +869,57 @@
       (is (= (length (union (list role-1 role-2)
 			    (player-in-roles top-1))) 2))
       (is (= (length (slot-value top-1 'd::player-in-roles)) 2)))))
+
+
+(test test-TopicMapC ()
+  "Tests various function of the class TopicMapC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((tm-1 (make-instance 'TopicMapC))
+	  (tm-2 (make-instance 'TopicMapC))
+	  (top-1 (make-instance 'TopicC))
+	  (assoc-1 (make-instance 'AssociationC))
+	  (revision-0-5 50)
+	  (revision-1 100))
+      (setf *TM-REVISION* revision-1)
+      (is-false (topics tm-1))
+      (is-false (in-topicmaps top-1))
+      (is-false (in-topicmaps assoc-1))
+      (d::add-to-version-history top-1 :start-revision revision-1)
+      (add-to-tm tm-1 top-1)
+      (is (= (length (union (list top-1)
+			    (topics tm-1))) 1))
+      (is (= (length (union (list tm-1)
+			    (in-topicmaps top-1))) 1))
+      (is-false (topics tm-1 :revision revision-0-5))
+      (is-false (in-topicmaps top-1 :revision revision-0-5))
+      (d::add-to-version-history assoc-1 :start-revision revision-1)
+      (add-to-tm tm-1 assoc-1)
+      (is (= (length (union (list assoc-1)
+			    (associations tm-1))) 1))
+      (is (= (length (union (list tm-1)
+			    (in-topicmaps assoc-1))) 1))
+      (is-false (associations tm-1 :revision revision-0-5))
+      (is-false (in-topicmaps assoc-1 :revision revision-0-5))
+      (add-to-tm tm-2 top-1)
+      (is (= (length (union (list top-1)
+			    (topics tm-2))) 1))
+      (is (= (length (union (list tm-2 tm-1)
+			    (in-topicmaps top-1))) 2))
+      (is-false (topics tm-2 :revision revision-0-5))
+      (is-false (in-topicmaps top-1 :revision revision-0-5))
+      (d::add-to-version-history assoc-1 :start-revision revision-1)
+      (add-to-tm tm-2 assoc-1)
+      (is (= (length (union (list assoc-1)
+			    (associations tm-2))) 1))
+      (is (= (length (union (list tm-2 tm-1)
+			    (in-topicmaps assoc-1))) 2))
+      (is-false (associations tm-2 :revision revision-0-5))
+      (is-false (in-topicmaps assoc-1 :revision revision-0-5)))))
       
 
 
 (defun run-datamodel-tests()
+  "Runs all tests of this test-suite."
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
   (it.bese.fiveam:run! 'test-ItemIdentifierC)
@@ -890,4 +938,4 @@
   (it.bese.fiveam:run! 'test-ScopableC)
   (it.bese.fiveam:run! 'test-RoleC)
   (it.bese.fiveam:run! 'test-player)
-)
\ No newline at end of file
+  (it.bese.fiveam:run! 'test-TopicMapC))
\ No newline at end of file