- isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

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

17 Feb '10

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

1 0

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

17 Feb '10

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

1 0

[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