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