[isidorus-cvs] r235 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Sat Mar 20 22:00:40 UTC 2010
Author: lgiessmann
Date: Sat Mar 20 18:00:40 2010
New Revision: 235
Log:
new-datamodel: finalized "make-construct"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Sat Mar 20 18:00:40 2010
@@ -663,6 +663,16 @@
(condition () nil)))
+(defun merge-all-constructs(constructs-to-be-merged)
+ "Merges all constructs contained in the given list."
+ (declare (list constructs-to-be-merged))
+ (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
+ (merged-construct (elt constructs-to-be-merged 0)))
+ (loop for construct-to-be-merged in constructs-to-be-merged
+ do (setf merged-construct
+ (merge-constructs merged-construct construct-to-be-merged)))))
+
+
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric get-all-characteristics (parent-construct characteristic-symbol)
(:documentation "Returns all characterisitcs of the passed type the parent
@@ -2378,29 +2388,104 @@
((CharacteristicC-p class-symbol)
(make-characteristic class-symbol (getf args :charvalue) args))
((TopicC-p class-symbol)
- (make-topic args)))))
+ (make-topic args))
+ ((TopicMapC-p class-symbol)
+ (make-tm args))
+ ((RoleC-p class-symbol)
+ (make-role args))
+ ((AssociationC-p class-symbol)
+ (make-association args)))))
construct))
-(defun merge-all-constructs(constructs-to-be-merged)
- "Merges all constructs contained in the given list."
- (declare (list constructs-to-be-merged))
- (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
- (merged-construct (elt constructs-to-be-merged 0)))
- (loop for construct-to-be-merged in constructs-to-be-merged
- do (setf merged-construct
- (merge-constructs merged-construct construct-to-be-merged)))))
+(defun make-association (args)
+ "Returns an association object. If the association has already existed the
+ existing one is returned otherwise a new one is created.
+ This function exists only for being used by make-construct!"
+ (let ((item-identifiers (getf (first args) :item-identifiers))
+ (reifier (getf (first args) :reifier))
+ (instance-of (getf (first args) :instance-of))
+ (start-revision (getf (first args) :start-revision))
+ (themes (get (first args) :themes))
+ (roles (get (first args) :roles))
+ (err "From make-association(): "))
+ (unless start-revision (error "~astart-revision must be set" err))
+ (unless roles (error "~aroles must be set" err))
+ (unless instance-of (error "~ainstance-of must be set" err))
+ (let ((association
+ (let ((existing-association
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-association)
+ (when (equivalent-construct
+ existing-association
+ :start-revision start-revision
+ :roles roles :themes themes
+ :instance-of instance-of)
+ existing-association))
+ (elephant:get-instances-by-class 'AssociationC)))))
+ (if existing-association
+ existing-association
+ (make-instance 'AssociationC)))))
+ (initialize-typable association instance-of :start-revision
+ start-revision)
+ (dolist (role roles)
+ (add-role association role :revision start-revision))
+ (dolist (theme themes)
+ (add-theme association theme :revision start-revision))
+ (initialize-reifiable association item-identifiers reifier
+ :start-revision start-revision))))
-(defun make-tm (&rest args)
+(defun make-role (args)
+ "Returns a role object. If the role has already existed the
+ existing one is returned otherwise a new one is created.
+ This function exists only for being used by make-construct!"
+ (let ((item-identifiers (getf args :item-identifiers))
+ (reifier (getf args :reifier))
+ (parent (getf args :parent))
+ (instance-of (getf args :instance-of))
+ (player (getf args :player))
+ (start-revision (getf args :start-revision))
+ (err "From make-role(): "))
+ (unless start-revision (error "~astart-revision must be set" err))
+ (unless instance-of (error "~ainstance-of must be set" err))
+ (unless player (error "~aplayer must be set" err))
+ (let ((role
+ (let ((existing-role
+ (remove-if
+ #'null
+ (map 'list #'(lambda(existing-role)
+ (when (equivalent-construct
+ existing-role
+ :player player
+ :instance-of instance-of)
+ existing-role))
+ (slot-p parent 'roles)))))
+ (if existing-role
+ existing-role
+ (make-instance 'RoleC)))))
+ (when player
+ (add-player role player :revision start-revision))
+ (initialize-typable role instance-of :start-revision start-revision)
+ (when parent
+ (add-parent role parent :revision start-revision))
+ (initialize-reifiable role item-identifiers reifier
+ :start-revision start-revision))))
+
+
+(defun make-tm (args)
"Returns a topic map object. If the topic map has already existed the
existing one is returned otherwise a new one is created.
This function exists only for being used by make-construct!"
- (let ((item-identifiers (getf (first args) :item-identifiers))
- (reifier (getf (first args) :reifier))
- (topics (getf (first args) :topics))
- (assocs (getf (first args) :associations))
- (start-revision (getf (first args) :start-revision)))
+ (let ((item-identifiers (getf args :item-identifiers))
+ (reifier (getf args :reifier))
+ (topics (getf args :topics))
+ (assocs (getf args :associations))
+ (start-revision (getf args :start-revision))
+ (err "From make-tm(): "))
+ (unless item-identifiers (error "~aitem-identifiers must be set" err))
+ (unless start-revision (error "~astart-revision must be set" err))
(let ((tm
(let ((existing-tms
(remove-if
@@ -2420,21 +2505,24 @@
(make-instance 'TopicMapC))))))
(dolist (top-or-assoc (union topics assocs))
(add-to-tm tm top-or-assoc))
- (add-to-version-history tm :start-revision start-revision)
- tm)))
+ (initialize-reifiable tm item-identifiers reifier
+ :start-revision start-revision))))
(defun make-topic (&rest args)
"Returns a topic object. If the topic has already existed the existing one is
returned otherwise a new one is created.
This function exists only for being used by make-construct!"
- (let ((start-revision (getf (first args) :start-revision))
- (psis (getf (first args) :psis))
- (locators (getf (first args) :locators))
- (item-identifiers (getf (first args) :item-identifiers))
- (topic-identifiers (getf (first args) :topic-identifiers))
- (names (getf (first args) :names))
- (occurrences (getf (first args) :occurrences)))
+ (let ((start-revision (getf args :start-revision))
+ (psis (getf args :psis))
+ (locators (getf args :locators))
+ (item-identifiers (getf args :item-identifiers))
+ (topic-identifiers (getf args :topic-identifiers))
+ (names (getf args :names))
+ (occurrences (getf args :occurrences))
+ (err "From make-topic(): "))
+ (unless topic-identifiers (error "~atopic-identifiers must be set" err))
+ (unless start-revision (error "~astart-revision must be set" err))
(let ((topic
(let ((existing-topics
(remove-if
@@ -2454,9 +2542,10 @@
(first existing-topics))
(t
(make-instance 'TopicC))))))
- (initialize-reifiable topic item-identifiers nil
- :start-revision start-revision)
(let ((merged-topic topic))
+ (setf merged-topic
+ (initialize-reifiable topic item-identifiers nil
+ :start-revision start-revision))
(dolist (psi psis)
(setf merged-topic (add-psi merged-topic psi
:revision start-revision)))
@@ -2464,10 +2553,10 @@
(setf merged-topic (add-locator merged-topic locator
:revision start-revision)))
(dolist (name names)
- (setf merged-topic (add-name topic name :revision start-revision)))
+ (setf merged-topic (add-name merged-topic name
+ :revision start-revision)))
(dolist (occ occurrences)
(add-occurrence merged-topic occ :revision start-revision))
- (add-to-version-history merged-topic :start-revision start-revision)
merged-topic))))
@@ -2484,11 +2573,17 @@
(themes (getf (first args) :themes))
(variants (getf (first args) :variants))
(reifier (getf (first args) :reifier))
- (parent-construct (getf (first args) :parent-construct))
- (item-identifiers (getf (first args) :item-identifiers)))
+ (parent (getf (first args) :parent))
+ (item-identifiers (getf (first args) :item-identifiers))
+ (err "From make-characteristic(): "))
+ (unless start-revision (error "~astart-revision must be set" err))
+ (unless charvalue (error "~acharvalue must be set" err))
+ (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol))
+ (not instance-of))
+ (error "~ainstance-of must be set" err))
(let ((characteristic
(let ((existing-characteristic
- (when parent-construct
+ (when parent
(remove-if
#'null
(map 'list #'(lambda(existing-characteristic)
@@ -2499,26 +2594,19 @@
:charvalue charvalue :themes themes
:instance-of instance-of)
existing-characteristic))
- (get-all-characteristics parent-construct
- class-symbol))))))
+ (get-all-characteristics parent class-symbol))))))
(if existing-characteristic
existing-characteristic
(make-instance class-symbol :charvalue charvalue
:datatype datatype)))))
- (let ((merged-characteristic characteristic))
- (setf merged-characteristic
- (initialize-reifiable merged-characteristic item-identifiers
- reifier :start-revision start-revision))
- (initialize-scopable merged-characteristic themes
- :start-revision start-revision)
- (initialize-typable merged-characteristic instance-of
- :start-revision start-revision)
- (initialize-name merged-characteristic variants
- :start-revision start-revision)
- (when parent-construct
- (add-parent merged-characteristic parent-construct
- :revision start-revision))
- merged-characteristic))))
+ (initialize-scopable characteristic themes :start-revision start-revision)
+ (initialize-typable characteristic instance-of
+ :start-revision start-revision)
+ (initialize-name characteristic variants :start-revision start-revision)
+ (when parent
+ (add-parent characteristic parent :revision start-revision))
+ (initialize-reifiable characteristic item-identifiers
+ reifier :start-revision start-revision))))
(defun make-pointer (class-symbol &rest args)
@@ -2528,7 +2616,10 @@
(let ((uri (getf (first args) :uri))
(xtm-id (getf (first args) :xtm-id))
(start-revision (getf (first args) :start-revision))
- (identified-construct (getf (first args) :identified-construct)))
+ (identified-construct (getf (first args) :identified-construct))
+ (err "From make-pointer(): "))
+ (when (and identified-construct (not start-revision))
+ (error "~astart-revision must be set" err))
(let ((identifier
(let ((existing-pointer
(remove-if
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Sat Mar 20 18:00:40 2010
@@ -61,11 +61,8 @@
:test-class-p))
-;;TODO: test merge-constructs when merging was caused by an item-dentifier,
-;; a psi, a subject-locator, a topic-id
-;;TODO: test merge-constructs when merging was caused by reifiers
-;; (occurrences, names, variants, associations, roles)
-;;TODO: test ReifiableConstructC --> reifier has to be merged
+;;TODO: test make-construct
+;;TODO: test merge-constructs
More information about the Isidorus-cvs
mailing list