[isidorus-cvs] r237 - branches/new-datamodel/src/model

[Lukas Giessmann]

Author: lgiessmann
Date: Sun Mar 21 05:14:10 2010
New Revision: 237

Log:
new-datamodel: fixed some sections that cauesd errors with the "changes.lisp"

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	Sun Mar 21 05:14:10 2010
@@ -14,6 +14,8 @@
 		duplicate-identifier-error)
   (:import-from :constants
 		*xml-string*)
+  (:import-from :constants
+		*instance-psi*)
   (:export ;;classes
            :TopicMapC
            :AssociationC
@@ -114,6 +116,9 @@
 	   :TopicMapConstructC-p
 	   :VersionedConstructC-p
 	   :make-construct
+	   :list-instanceOf
+	   :in-topicmap
+	   :string-start-with
 
 	   ;;globals
 	   :*TM-REVISION*
@@ -315,9 +320,11 @@
 (elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
   ((topics :associate (TopicC in-topicmaps)
 	   :many-to-many t
+	   :accessor topics
 	   :documentation "List of topics that explicitly belong to this TM.")
    (associations :associate (AssociationC in-topicmaps)
 		 :many-to-many t
+		 :accessor associations
                  :documentation "List of associations that belong to this TM."))
   (:documentation "Represnets a topic map."))
 
@@ -673,7 +680,28 @@
 		(merge-constructs merged-construct construct-to-be-merged)))))
 
 
+(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)))
+
+
+(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))))
+
+
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric get-all-identifiers-of-construct (construct &key revision)
+  (:documentation "Get all identifiers that a given construct has"))
+
+
 (defgeneric get-all-characteristics (parent-construct characteristic-symbol)
   (:documentation "Returns all characterisitcs of the passed type the parent
                    construct was ever associated with."))
@@ -700,7 +728,7 @@
 
 
 (defgeneric in-topicmaps (construct &key revision)
-  (:documentation "Returns all TopicMapS-obejcts where the constrict is
+  (:documentation "Returns all TopicMaps-obejcts where the construct is
                    contained in."))
 
 
@@ -1250,6 +1278,14 @@
       construct)))
 
 
+(defmethod get-all-identifiers-of-construct ((construct TopicC)
+					     &key (revision 0))
+  (declare (integer revision))
+  (append (psis construct :revision revision)
+          (locators construct :revision revision)
+          (item-identifiers construct :revision revision)))
+
+
 (defgeneric names (construct &key revision)
   (:documentation "Returns the NameC-objects that correspond
                    with the passed construct and the passed version.")
@@ -1489,6 +1525,30 @@
 			  :error-if-nil error-if-nil))
 
 
+
+(defgeneric list-instanceOf (topic &key tm)
+ (:documentation "Generates 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) constants:*instance-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)
+               (in-topicmap tm (parent role)))
+             (player-in-roles topic))
+            (player-in-roles topic)))))
+
+
 ;;; CharacteristicC
 (defgeneric CharacteristicC-p (class-symbol)
   (:documentation "Returns t if the passed symbol is equal to CharacteristicC
@@ -2135,6 +2195,13 @@
 	(mark-as-deleted assoc-to-delete :revision revision))
       construct)))
 
+
+(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC)
+					     &key (revision 0))
+  (declare (integer revision))
+  (item-identifiers construct :revision revision))
+
+
 ;;; TypableC
 (defgeneric TypableC-p (class-symbol)
   (:documentation "Returns t if the passed class is equal to TypableC or
@@ -2343,20 +2410,6 @@
     (remove-association construct 'associations assoc)))
 
 
-(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)))
-
-
 (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
   (add-association construct 'topics construct-to-add))
 
@@ -2374,6 +2427,21 @@
   (remove-association construct 'associations construct-to-delete))
 
 
+(defgeneric in-topicmap (tm construct &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 (internal-id top) (topics tm) :test #'= :key #'internal-id)))
+
+
+(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
+  (when (find-item-by-revision ass revision)
+    (find (internal-id ass) (associations tm)  :test #'= :key #'internal-id)))
+
+
 ;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun make-construct (class-symbol &rest args)
   "Creates a new topic map construct if necessary or
@@ -2386,7 +2454,7 @@
 	   ((PointerC-p class-symbol)
 	    (make-pointer class-symbol (getf args :uri) args))
 	   ((CharacteristicC-p class-symbol)
-	    (make-characteristic class-symbol (getf args :charvalue) args))
+	    (make-characteristic class-symbol args))
 	   ((TopicC-p class-symbol)
 	    (make-topic args))
 	   ((TopicMapC-p class-symbol)