isidorus-cvs February 2010

isidorus-cvs@common-lisp.net

1 participants
42 discussions

[isidorus-cvs] r192 - branches/new-datamodel/src/model
by Lukas Giessmann 17 Feb '10

17 Feb '10

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)))

1 0

[isidorus-cvs] r191 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 16 Feb '10

16 Feb '10

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

1 0

[isidorus-cvs] r190 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 16 Feb '10

16 Feb '10

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

1 0

[isidorus-cvs] r189 - branches/new-datamodel/src/model
by Lukas Giessmann 16 Feb '10

16 Feb '10

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

1 0

[isidorus-cvs] r188 - branches/new-datamodel/src/model
by Lukas Giessmann 16 Feb '10

16 Feb '10

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

1 0

[isidorus-cvs] r187 - branches/new-datamodel/src/model
by Lukas Giessmann 15 Feb '10

15 Feb '10

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

1 0

[isidorus-cvs] r186 - in branches/new-datamodel: docs src/model
by Lukas Giessmann 15 Feb '10

15 Feb '10

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."))

1 0

[isidorus-cvs] r185 - branches/new-datamodel/src/model
by Lukas Giessmann 13 Feb '10

13 Feb '10

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*) -;; ,@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

1 0

[isidorus-cvs] r184 - branches/new-datamodel/src/model
by Lukas Giessmann 12 Feb '10

12 Feb '10

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()

1 0

[isidorus-cvs] r183 - in branches/new-datamodel/src: . model unit_tests
by Lukas Giessmann 11 Feb '10

11 Feb '10

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*) - ,@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*) +;; ,@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

1 0

[isidorus-cvs] r182 - branches/new-datamodel/docs
by Lukas Giessmann 08 Feb '10

08 Feb '10

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.

1 0

[isidorus-cvs] r181 - branches/new-datamodel
by Lukas Giessmann 08 Feb '10

08 Feb '10

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/

1 0

[isidorus-cvs] r180 - trunk/src/model
by Lukas Giessmann 08 Feb '10

08 Feb '10

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

1 0

[isidorus-cvs] r179 - trunk/src/ajax/javascripts
by Lukas Giessmann 03 Feb '10

03 Feb '10

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()});

1 0

[isidorus-cvs] r178 - trunk/src/ajax/javascripts
by Lukas Giessmann 03 Feb '10

03 Feb '10

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(); }

1 0

[isidorus-cvs] r177 - trunk/src/json
by Lukas Giessmann 03 Feb '10

03 Feb '10

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

1 0

[isidorus-cvs] r176 - trunk/src/rest_interface
by Lukas Giessmann 03 Feb '10

03 Feb '10

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)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs February 2010