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

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

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

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

Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Thu Feb 11 14:21:40 2010 @@ -7,1670 +7,1962 @@ ;;+-----------------------------------------------------------------------------

-;-*- standard-indent: 2; indent-tabs-mode: nil -*- (defpackage :datamodel (:use :cl :elephant :constants) - (:nicknames :d) - (:import-from :exceptions - missing-reference-error - no-identifier-error - duplicate-identifier-error - object-not-found-error) - (:export :AssociationC ;; types - :CharacteristicC - :FragmentC - :IdentifierC - :IdentityC - :ItemIdentifierC - :NameC - :OccurrenceC - :PersistentIdC - :ReifiableConstructC - :RoleC - :ScopableC - :SubjectLocatorC - :TopicC - :TopicIdentificationC - :TopicMapC - :TopicMapConstructC - :TypableC - :VariantC - - ;; functions and slot accessors - :in-topicmaps - :add-to-topicmap - :add-source-locator - :associations - :changed-p - :charvalue - :check-for-duplicate-identifiers - :datatype - :equivalent-constructs - :find-item-by-revision - :find-most-recent-revision - :get-all-revisions - :get-all-revisions-for-tm - :get-fragment - :get-fragments - :get-revision - :get-item-by-content - :get-item-by-id - :get-item-by-item-identifier - :get-item-by-psi - :identified-construct - :identified-construct-p - :in-topicmap - :internal-id - :instance-of - :instance-of-p - :item-identifiers - :item-identifiers-p - :list-instanceOf - :list-super-types - :locators - :locators-p - :make-construct - :mark-as-deleted - :names - :namevalue - :occurrences - :name - :parent - :player - :player-in-roles - :players - :psis - :psis-p - :referenced-topics - :revision - :RoleC-p - :roleid - :roles - :themes - :xtm-id - :xtm-id-p - :topic - :topicid - :topic-identifiers - :topics - :unique-id - :uri - :uri-p - :used-as-type - :used-as-theme - :variants - :xor - :create-latest-fragment-of-topic - :reified - :reifier - :add-reifier - :remove-reifier - - :*current-xtm* ;; special variables - :*TM-REVISION* + (:nicknames :d))

- :with-revision ;;macros +(in-package :datamodel)

- :string-starts-with ;;helpers - ))

-(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0))) -(in-package :datamodel) +;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun slot-p (instance slot-symbol) + "Returns t if the slot depending on slot-symbol is bound and not nil." + (and (slot-boundp instance slot-symbol) + (slot-value instance slot-symbol))) +

-(defparameter *current-xtm* nil "Represents the currently active TM") +(defun delete-1-n-association(instance slot-symbol) + (when (slot-p instance slot-symbol) + (remove-association + instance slot-symbol (slot-value instance slot-symbol))))

-(defmacro find-max-elem (candidate-list &key (relop #'> relop-p) (key #'identity key-p)) - "Given a non-empty list, return the maximum element in the list. - If provided, then relop must be a relational operator that determines the ordering; - else #'> is used. The keyword parameter key may name a function that is used to extract - the sort key; otherwise the elements themselves are the sort keys." - (let - ((candidate-list-value-name (gensym)) - (relop-value-name (gensym)) - (key-value-name (gensym)) - (best-seen-cand-name (gensym)) - (max-key-name (gensym)) - (inspected-cand-name (gensym)) - (inspected-key-name (gensym))) - (let - ((max-key-init (if key-p - `(funcall ,key-value-name ,best-seen-cand-name) - best-seen-cand-name)) - (inspected-key-init (if key-p - `(funcall ,key-value-name ,inspected-cand-name) - inspected-cand-name)) - (relexp (if relop-p - `(funcall ,relop-value-name ,inspected-key-name ,max-key-name) - `(> ,inspected-key-name ,max-key-name)))) - (let - ((initializers `((,candidate-list-value-name ,candidate-list) - (,best-seen-cand-name (first ,candidate-list-value-name)) - (,max-key-name ,max-key-init)))) - (when relop-p - (push `(,relop-value-name ,relop) initializers)) - (when key-p - (push `(,key-value-name ,key) initializers)) - `(let* - ,initializers - (dolist (,inspected-cand-name (rest ,candidate-list-value-name)) - (let - ((,inspected-key-name ,inspected-key-init)) - (when ,relexp - (setf ,best-seen-cand-name ,inspected-cand-name) - (setf ,max-key-name ,inspected-key-name)))) - ,best-seen-cand-name))))) - -(defvar *TM-REVISION* 0) - -(defmacro with-revision (revision &rest body) - `(let - ((*TM-REVISION* ,revision)) - ;(format t "*TM-REVISION* is ~a~&" *TM-REVISION*) - ,@body)) - - -(defmacro slot-predicate (instance slot) - (let - ((inst-name (gensym)) - (slot-name (gensym))) - `(let - ((,inst-name ,instance) - (,slot-name ,slot)) - (and (slot-boundp ,inst-name ,slot-name) - (slot-value ,inst-name ,slot-name))))) - -(defmacro delete-1-n-association (instance slot) - (let - ((inst-name (gensym)) - (slot-name (gensym))) - `(let - ((,inst-name ,instance) - (,slot-name ,slot)) - (when (slot-predicate ,inst-name ,slot-name) - (elephant:remove-association ,inst-name ,slot-name (slot-value ,inst-name ,slot-name)))))) - -(defun xor (a1 a2) - (and (or a1 a2) (not (and a1 a2))) - ) - -(defun remove-nil-values (plist) - (let - ((result nil)) - (do* ((rest plist (cddr rest)) - (key (first rest) (first rest)) - (val (second rest) (second rest))) - ((null rest)) - (when val - (pushnew val result) - (pushnew key result))) - result)) - -(defun get-revision () - "TODO: replace by something that does not suffer from a 1 second resolution." - (get-universal-time))

(defgeneric delete-construct (construct) - (:documentation "drops recursively construct and all its dependent objects from the elephant store")) + (:documentation "Drops recursively construct and all its dependent objects + from the elephant store.")) +

(defmethod delete-construct ((construct elephant:persistent)) nil)

+ (defmethod delete-construct :after ((construct elephant:persistent)) - (elephant:drop-instance construct)) + (drop-instance construct))

-(defgeneric find-all-equivalent (construct) - (:method ((construct t)) nil) - (:documentation "searches an existing object that is equivalent (but not identical) to construct"))

+;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass VersionInfoC() + ((start-revision :initarg :start-revision + :accessor start-revision + :type integer + :initform 0 + :documentation "The start-revision of the version's + interval of a versioned object.") + (end-revision :initarg :end-revision + :accessor end-revision + :type integer + :initform 0 + :documentation "The end-revision of the version's interval + of a versioned object.") + (versioned-construct :initarg :versioned-construct + :accessor versioned-construct + :associate VersionedConstructC + :documentation "The reference of the versioned + object that is described by this + VersionInfoC-object.")) + (:documentation "A VersionInfoC-object describes the revision information + of a versioned object in intervals starting by the value + start-revision and ending by the value end-revision - 1. + end-revision=0 means always the latest version.")) + + +(defmethod delete-construct :before ((version-info VersionInfoC)) + (delete-1-n-association version-info 'versioned-construct)) + + +(defgeneric versioned-construct-p (version-info) + (:documentation "Returns t if the passed object is already bound to a + VersionedObjectC.") + (:method ((version-info VersionInfoC)) + (slot-p version-info 'versioned-construct))) + + +;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass VersionedConstructC() + ((versions :initarg :versions + :accessor versions + :associate (VersionInfoC versioned-construct) + :documentation "Version infos for former versions of this base + class."))) + + +(defmethod delete-construct :before ((construct VersionedConstructC)) + (dolist (version-info (versions construct)) + (delete-construct version-info))) + + +(defgeneric get-most-recent-version-info (construct) + (:documentation "Returns the latest VersionInfoC object of the passed + versioned construct. + The latest construct is either the one with + end-revision=0 or with the highest end-revision value."))

-;;;;;;;;;;;;;; -;; -;; VersionInfoC

+(defmethod get-most-recent-version-info ((construct VersionedConstructC)) + (let ((result (find 0 (versions construct) :key #'end-revision))) + (if result + result ;current version-info -> end-revision = 0 + (let ((sorted-list (sort (versions construct) + #'(lambda(x y) + (> (end-revision x) (end-revision y)))))) + (when sorted-list + (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer

-(elephant:defpclass VersionInfoC () - ((start-revision :accessor start-revision - :initarg :start-revision - :type integer - :initform 0 ;TODO: for now - :documentation "The first revison this AssociationC instance is associated with.") - (end-revision :accessor end-revision - :initarg :end-revision - :type integer - :initform 0 ;TODO: for now - :documentation "The first revison this AssociationC instance is no longer associated with.") - (versioned-construct :associate TopicMapConstructC - :accessor versioned-construct - :initarg :versioned-construct - :documentation "reifiable construct that is described by this info")) - (:documentation "Version Info for individual revisions"))

-(defgeneric versioned-construct-p (vi) - (:documentation "t if this version info is already bound to a TM construct") - (:method ((vi VersionInfoC)) (slot-predicate vi 'versioned-construct))) +(defgeneric add-to-version-history (construct &key start-revision end-revision) + (:documentation "Adds version history to a versioned construct"))

-(defmethod delete-construct :before ((vi VersionInfoC)) - (delete-1-n-association vi 'versioned-construct))

-(defgeneric get-most-recent-version-info (construct)) +(defmethod add-to-version-history ((construct VersionedConstructC) + &key (start-revision (error "From add-to-version-history(): start revision must be present")) + (end-revision 0)) + (let ((eql-version-info + (find-if #'(lambda(vi) + (and (= (start-revision vi) start-revision) + (= (end-revision vi) end-revision))) + (versions construct)))) + (if eql-version-info + eql-version-info + (let ((current-version-info + (get-most-recent-version-info construct))) + (cond + ((and current-version-info + (= (end-revision current-version-info) start-revision)) + (setf (end-revision current-version-info) 0) + current-version-info) + ((and current-version-info + (= (end-revision current-version-info) 0)) + (setf (end-revision current-version-info) start-revision) + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct)) + (t + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct))))))) + + +;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; SubjectLocatorAssociationC +;;; PersistentIdAssociationC +;;; TopicIdAssociationC +;;; ItemIdAssociationC +;;; PointerAssociationC +;;; VersionedAssociationC +(defpclass SubjectLocatorAssociationC(PointerAssociationC) + ((identified-construct :initarg :identified-construct + :accessor identified-construct + :associate TopicC + :documentation "The actual topic which is associated + with the subject-locator.")) + (:index t) + (:documentation "A pointer that associates subject-locators, versions + and topics."))

-;;;;;;;;;;;;;; -;; -;; ItemIdentifierC +(defpclass PersistentIdAssociationC(PointerAssociationC) + ((identified-construct :initarg :identified-construct + :accessor identified-construct + :associate TopicC + :documentation "The actual topic which is associated + with the subject-identifier/psi.")) + (:index t) + (:documentation "A pointer that associates subject-identifiers, versions + and topics.")) +

-(elephant:defpclass ItemIdentifierC (IdentifierC) +(defpclass TopicIdAssociationC(PointerAssociationC) + ((identified-construct :initarg :identified-construct + :accessor identified-construct + :associate TopicC + :documentation "The actual topic which is associated + with the topic-identifier.")) + (:index t) + (:documentation "A pointer that associates topic-identifiers, versions + and topics.")) + + +(defpclass ItemIdAssociationC(PointerAssociationC) + ((identified-construct :initarg :identified-construct + :accessor identified-construct + :associate ReifiableConstructC + :documentation "The actual parent which is associated + with the item-identifier.")) + (:index t) + (:documentation "A pointer that associates item-identifiers, versions + and reifiable-constructs.")) + + +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :associate PointerC + :documentation "The actual data that is associated with + the pointer-association's parent.")) + (:documentation "An abstract base class for all versioned + pointer-associations.")) + + +(defpclass VersionedAssociationC() + () + (:documentation "An abstract base class for all versioned associations.")) + + +;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; SubjectLocatorC +;;; PersistentIdC +;;; ItemIdentifierC +;;; IdentifierC +;;; TopicIdentificationC +;;; PointerC +(defpclass SubjectLocatorC(IdentifierC) () (:index t) - (:documentation "Represents an item identifier")) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's."))

-;;;;;;;;;;;;;; -;; -;; SubjectLocator +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's."))

-(elephant:defpclass SubjectLocatorC (IdentifierC) - ((identified-construct :accessor identified-construct - :initarg :identified-construct - :associate TopicC)) + +(defpclass ItemIdentifierC(IdentifierC) + () (:index t) - (:documentation "Represents a subject locator")) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's."))

-;;;;;;;;;;;;;; -;; -;; IdentifierC +(defpclass IdentifierC(PointerC) + () + (:documentation "An abstract base class for all TM-Identifiers."))

-(elephant:defpclass IdentifierC (PointerC) + +(defpclass TopicIdentificationC(PointerC) + ((xtm-id :initarg :xtm-id + :accessor xtm-id + :type string + :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") + :index t + :documentation "ID of the TM this identification came from.")) + (:index t) + (:documentation "Identify topic items through generalized topic-ids. + A topic may have many original topicids, the class + representing one of them.")) + + +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :initarg :identified-construct + :accessor identified-construct + :associate (PointerAssociationC identifier))) + (:documentation "An abstract base class for all pointers.")) + + +;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :initarg :item-identifiers + :associate (ItemIdAssociationC identified-construct) + :documentation "A relation to all item-identifiers of + this construct.") + (reifier :initarg :reifier + :associate (ReifierAssociationC reified-construct) + :documentation "A relation to a reifier-topic.")) + (:documentation "Reifiable constructs as per TMDM.")) + + +;;TODO: implement reader for item-identifiers and reifier (version) +;;TODO: implement add-item-identifier and add-reifier (version) + + +;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defpclass TopicMapConstructC() () - (:documentation "Abstract base class for ItemIdentifierC and - PersistentIdC, primarily in view of the equality rules")) + (:documentation "An abstract base class for all classes that describes + Topic Maps data."))

-;;;;;;;;;;;;;; -;; -;; PointerC

-(elephant:defpclass PointerC (TopicMapConstructC) - ((uri :accessor uri - :initarg :uri - :type string - :initform (error "The uri must be set for a pointer") - :index t) - (identified-construct :accessor identified-construct - :initarg :identified-construct - :associate ReifiableConstructC)) - (:documentation "Abstract base class for all types of pointers and identifiers")) - -(defmethod delete-construct :before ((construct PointerC)) - (delete-1-n-association construct 'identified-construct)) - -(defmethod find-all-equivalent ((construct PointerC)) - (delete construct - (elephant:get-instances-by-value (class-of construct) - 'uri - (uri construct)) - :key #'internal-id)) -(defgeneric uri-p (construct) - (:documentation "Check if the slot uri is bound in an identifier and not nil") - (:method ((identifier PointerC)) (slot-predicate identifier 'uri))) - -(defgeneric identified-construct-p (construct) - (:documentation "Check if the slot identified-construct is bound in an identifier and not nil") - (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct))) - -(defmethod print-object ((identifier PointerC) stream) - (format stream - "~a(href: ~a; Construct: ~a)" - (class-name (class-of identifier)) - (if (uri-p identifier) - (uri identifier) - "URI UNDEFINED") - (if (identified-construct-p identifier) - (identified-construct identifier) - "SLOT UNBOUND"))) - -(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC)) - (string= (uri identifier1) (uri identifier2))) - -(defmethod initialize-instance :around ((identifier PointerC) &key - (start-revision (error "Start revision must be present") ) - (end-revision 0)) - (call-next-method) - (add-to-version-history identifier - :start-revision start-revision - :end-revision end-revision) - identifier) - - -;;;;;;;;;;;;;; -;; -;; TopicMapConstrucC - - -(elephant:defpclass TopicMapConstructC () - ((versions :associate (VersionInfoC versioned-construct) - :accessor versions - :initarg :versions - :documentation "version infos for former versions of this reifiable construct"))) - - ;TODO: if, one day, we allow merges of already existing constructs, we'll need - ;a tree of predecessors rather then just a list of versions. A case in point - ;may be if a newly imported topic carries the PSIs of two existing topics, - ;thereby forcing a merge post factum" - -(defmethod delete-construct :before ((construct TopicMapConstructC)) - (dolist (versioninfo (versions construct)) - (delete-construct versioninfo)))

-(defgeneric add-to-version-history (construct &key start-revision end-revision) - (:documentation "Add version history to a topic map construct"))

-(defmethod add-to-version-history ((construct TopicMapConstructC) - &key - (start-revision (error "Start revision must be present") ) - (end-revision 0)) - "Adds relevant information to a construct's version info" - (let - ((current-version-info - (get-most-recent-version-info construct))) - (cond - ((and current-version-info - (= (end-revision current-version-info) start-revision)) ;the item was just marked as deleted - (setf (end-revision current-version-info) 0) ;just revitalize it, do not create a new version - current-version-info) ;TODO: this is not quite correct, the topic - ;might be recreated with new item - ;identifiers. Consider adding a new parameter - ;"revitalize" - ((and - current-version-info - (= (end-revision current-version-info) 0)) - (setf (end-revision current-version-info) start-revision) - (make-instance - 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)) - (t - (make-instance - 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct))))) - -(defgeneric revision (constr) - (:documentation "Essentially a convenience method for start-revision")) - -(defmethod revision ((constr TopicMapConstructC)) - (start-revision constr)) - -(defmethod (setf revision) ((constr TopicMapConstructC) (revision integer)) - (setf (start-revision constr) revision)) - - -(defgeneric find-item-by-revision (constr revision) - (:documentation "Get a given version of a construct (if any, nil if none can be found)")) - -(defmethod find-item-by-revision ((constr TopicMapConstructC) (revision integer)) - (cond - ((= revision 0) - (find-most-recent-revision constr)) - (t - (when (find-if - (lambda(version) - (and (>= revision (start-revision version)) - (or - (< revision (end-revision version)) - (= 0 (end-revision version))))) - (versions constr)) - constr)))) - -(defgeneric find-most-recent-revision (construct) - (:documentation "Get the most recent version of a construct (nil if -the construct doesn't have versions yet or not anymore)")) - -(defmethod find-most-recent-revision ((construct TopicMapConstructC)) - (when (find 0 (versions construct) :key #'end-revision) - construct)) - -(defmethod delete-construct :before ((construct TopicMapConstructC)) - (dolist (versionInfo (versions construct)) - (delete-construct versionInfo))) - - -(defgeneric check-for-duplicate-identifiers (top) - (:documentation "Check for possibly duplicate identifiers and signal an - duplicate-identifier-error is such duplicates are found")) - -(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)) - (declare (ignore construct)) - ;do nothing - ) - -(defgeneric filter-slot-value-by-revision (construct slot-name &key start-revision) - (:documentation "filter slot values by a given revision that is - either provided directly through the keyword argument start-revision - or through a bound variable named '*TM-REVISION*'")) - -(defmethod filter-slot-value-by-revision ((construct TopicMapConstructC) (slot-name symbol) &key (start-revision 0 start-revision-provided-p)) - (let - ((revision ;avoids warnings about undefined variables - (cond - (start-revision-provided-p - start-revision) - ((boundp '*TM-REVISION*) - (symbol-value '*TM-REVISION*)) - (t 0))) - (properties (slot-value construct slot-name))) - ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) - (cond - ((not properties) - nil) ;if we don't have any properties, we don't have to worry - ;about revisions - ((= 0 revision) - (remove - nil - (map 'list #'find-most-recent-revision - properties))) - (t - (remove nil - (map 'list - (lambda (constr) - (find-item-by-revision constr revision)) - properties)))))) - -(defgeneric make-construct (classsymbol &key start-revision &allow-other-keys) - (:documentation "create a new topic map construct if necessary or -retrieve an equivalent one if available and update the revision -history accordingly. Return the object in question. Methods use -specific keyword arguments for their purpose")) - -(defmethod make-construct ((classsymbol symbol) &rest args - &key start-revision) - (let* - ((cleaned-args (remove-nil-values args)) - (new-construct (apply #'make-instance classsymbol cleaned-args)) - (existing-construct (first (find-all-equivalent new-construct)))) - (if existing-construct - (progn - ;change over new item identifiers to the old construct - (when (copy-item-identifiers - new-construct existing-construct) - ;an existing construct other than a topic (which is handled - ;separatedly below) has changed only if it has received a new - ;item identifier - (add-to-version-history existing-construct :start-revision start-revision)) - (delete-construct new-construct) - existing-construct) - (progn - (add-to-version-history new-construct :start-revision start-revision) - (check-for-duplicate-identifiers new-construct) - new-construct)))) - -(defmethod get-most-recent-version-info ((construct TopicMapConstructC)) - (let ((result (find 0 (versions construct) :key #'end-revision))) - (if result - result ;current version-info -> end-revision = 0 - (let ((sorted-list (sort (versions construct) - #'(lambda(x y) - (> (end-revision x) (end-revision y)))))) - (when sorted-list - (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer

-(defgeneric equivalent-constructs (construct1 construct2) - (:documentation "checks if two topic map constructs are equal according to the TMDM equality rules"))

-(defgeneric strictly-equivalent-constructs (construct1 construct2) - (:documentation "checks if two topic map constructs are not identical but equal according to the TMDM equality rules") - (:method ((construct1 TopicMapConstructC) (construct2 TopicMapConstructC)) - (and (equivalent-constructs construct1 construct2) - (not (eq construct1 construct2))))) - -(defgeneric internal-id (construct) - (:documentation "returns the internal id that uniquely identifies a - construct (currently simply its OID)")) - -(defmethod internal-id ((construct TopicMapConstructC)) - (slot-value construct (find-symbol "OID" 'elephant))) - - -;;;;;;;;;;;;;; -;; -;; TopicIdentificationC - -(elephant:defpclass TopicIdentificationC (PointerC) - ((xtm-id - :accessor xtm-id - :type string - :initarg :xtm-id - :index t - :documentation "ID of the TM this identification came from")) - (:documentation "Identify topic items through generalized - topicids. A topic may have many original topicids, the class - representing one of them") ) - -(defmethod find-all-equivalent ((construct TopicIdentificationC)) - (delete (xtm-id construct) (call-next-method) :key #'xtm-id :test #'string=)) - -(defun init-topic-identification (top id xtm-id &key (revision *TM-REVISION*)) - "create a TopicIdentification object (if necessary) and initialize it with the - combination of the current topicid and the ID of the current XTM id" - ;(declare (TopicC top)) - (declare (string id)) - - (flet ;prevent unnecessary copies of TopicIdentificationC objects - ((has-topic-identifier (top uri xtm-id) - (remove-if-not - (lambda (ident) - (and (string= (uri ident) uri) - (string= (xtm-id ident) xtm-id))) - (topic-identifiers top)))) - (unless (has-topic-identifier top id xtm-id) - (let - ((ti - (make-instance - 'TopicIdentificationC - :uri id - :xtm-id xtm-id - :identified-construct top - :start-revision revision))) - ;(add-to-version-history ti :start-revision revision) - ti)))) - -(defun xtm-id-p (xtm-id) - "checks if a xtm-id has been used before" - (elephant:get-instance-by-value 'TopicIdentificationC - 'xtm-id xtm-id)) - - -;;;;;;;;;;;;;; -;; -;; PSI - -(elephant:defpclass PersistentIdC (IdentifierC) - ((identified-construct :accessor identified-construct - :initarg :identified-construct - :associate TopicC)) - (:index t) - (:documentation "Represents a PSI"))

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

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

Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/fixtures.lisp (original) +++ branches/new-datamodel/src/unit_tests/fixtures.lisp Thu Feb 11 14:21:40 2010 @@ -37,7 +37,8 @@ :*XTM-MERGE1-TM* :*XTM-MERGE2-TM* :rdf-init-db - :rdf-test-db)) + :rdf-test-db + :with-empty-db))

(in-package :fixtures)

@@ -210,4 +211,11 @@ (&body) (handler-case (delete-file exported-file-path) (error () )) ;do nothing - (tear-down-test-db))) \ No newline at end of file + (tear-down-test-db))) + + +(def-fixture with-empty-db (dir) + (clean-out-db dir) + (elephant:open-store (xml-importer:get-store-spec dir)) + (&body) + (tear-down-test-db)) \ No newline at end of file