From lgiessmann at common-lisp.net Thu Apr 1 09:40:23 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 01 Apr 2010 05:40:23 -0400 Subject: [isidorus-cvs] r255 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 1 05:40:23 2010 New Revision: 255 Log: new-datamodel: added the generic "find-oldest-construct" which is needed for "merge-constructs"; added unit-tests for "find-oldest-constructs" and "equivalent-constructs"; fixed a bug in "eqiuvalent-constructs" --> AssociaitonC; fixed a bug in "make-topic" which caused problems when adding topic-identifiers. 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 Thu Apr 1 05:40:23 2010 @@ -617,9 +617,23 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun find-version-info (versioned-constructs + &key (sort-function #'<) (sort-key 'start-revision)) + "Returns all version-infos sorted by the function sort-function which is + applied on the slot sort-key." + (declare (list versioned-constructs)) + (let ((vis + (sort + (loop for vc in versioned-constructs + append (versions vc)) + sort-function :key sort-key))) + (when vis + (first vis)))) + + (defun rec-remf (plist keyword) "Calls remf for the past plist with the given keyword until - all key-value-pairs corresponding to the passed keyword were removed." + all key-value-pairs corresponding to the passed keyword were removed." (declare (list plist) (keyword keyword)) (loop while (getf plist keyword) do (remf plist keyword)) @@ -741,6 +755,20 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric find-oldest-construct (construct-1 construct-2) + (:documentation "Returns the construct which owns the oldes version info. + If a construct is not a versioned construct the oldest + association determines the construct's version info.")) + + +(defgeneric merge-constructs (construct-1 construct-2 &key revision) + (:documentation "Merges two constructs of the same type if they are + mergable. The latest construct will be marked as deleted + The older one gets all characteristics of the marked as + deleted one. All referenced constructs are also updated + with the changeds that are caused by this operation.")) + + (defgeneric delete-parent (construct parent-construct &key revision) (:documentation "Sets the assoication-object between the passed constructs as marded-as-deleted.")) @@ -824,6 +852,22 @@ ;;; VersionedConstructC +(defmethod find-oldest-construct ((construct-1 VersionedConstructC) + (construct-2 VersionedConstructC)) + (let ((vi-1 (find-version-info (list construct-1))) + (vi-2 (find-version-info (list construct-2)))) + (cond ((not (or vi-1 vi-2)) + nil) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + (defgeneric VersionedConstructC-p (class-symbol) (:documentation "Returns t if the passed class is equal to VersionedConstructC or one of its subtypes.") @@ -965,6 +1009,21 @@ ;;; PointerC +(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC)) + (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct))) + (vi-2 (find-version-info (slot-p construct-2 'identified-construct)))) + (cond ((not (or vi-1 vi-2)) + nil) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + (defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) &key (revision nil)) (declare (ignorable revision)) @@ -1041,7 +1100,8 @@ ;;; TopicIdentificationC -(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) +(defmethod equivalent-constructs ((construct-1 TopicIdentificationC) + (construct-2 TopicIdentificationC) &key (revision nil)) (declare (ignorable revision)) (and (call-next-method) @@ -1177,15 +1237,14 @@ (defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) - (when (intersection (union - (union (item-identifiers construct-1 :revision revision) - (locators construct-1 :revision revision)) - (psis construct-1 :revision revision)) - (union - (union (item-identifiers construct-2 :revision revision) - (locators construct-2 :revision revision)) - (psis construct-2 :revision revision))) - t)) + (let ((ids-1 (union (union (item-identifiers construct-1 :revision revision) + (locators construct-1 :revision revision)) + (psis construct-1 :revision revision))) + (ids-2 (union (union (item-identifiers construct-2 :revision revision) + (locators construct-2 :revision revision)) + (psis construct-2 :revision revision)))) + (when (intersection ids-1 ids-2) + t))) (defgeneric TopicC-p (class-symbol) @@ -1195,7 +1254,7 @@ (defmethod equivalent-construct ((construct TopicC) - &key (start-revision 0) (psis nil) + &key (start-revision *TM-REVISION*) (psis nil) (locators nil) (item-identifiers nil) (topic-identifiers nil)) "Isidorus handles Topic-equality only by the topic's identifiers @@ -1759,6 +1818,22 @@ ;;; CharacteristicC +(defmethod find-oldest-construct ((construct-1 CharacteristicC) + (construct-2 CharacteristicC)) + (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) + (vi-2 (find-version-info (slot-p construct-2 'parent)))) + (cond ((not (or vi-1 vi-2)) + nil) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + (defmethod equivalent-constructs ((construct-1 CharacteristicC) (construct-2 CharacteristicC) &key (revision *TM-REVISION*)) @@ -2164,13 +2239,28 @@ ;;; RoleC +(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC)) + (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) + (vi-2 (find-version-info (slot-p construct-2 'parent)))) + (cond ((not (or vi-1 vi-2)) + nil) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + (defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC) &key (revision *TM-REVISION*)) (declare (integer revision)) (and (eql (instance-of construct-1 :revision revision) (instance-of construct-2 :revision revision)) (eql (player construct-1 :revision revision) - (player construct-1 :revision revision)))) + (player construct-2 :revision revision)))) (defgeneric RoleC-p (class-symbol) @@ -2455,11 +2545,6 @@ (let ((id-owner (identified-construct item-identifier :revision revision))) (when (not (eql id-owner construct)) - (unless (typep construct 'TopicC) - (error (make-condition 'duplicate-identifier-error - :message "From add-item-identifier(): duplicate ItemIdentifier has been found: ~a" - (uri item-identifier) - :uri (uri item-identifier)))) id-owner)))) (let ((merged-construct construct)) (cond (construct-to-be-merged @@ -2890,7 +2975,6 @@ (apply #'make-construct 'RoleC (append role-plist (list :parent association))) :revision (getf role-plist :start-revision))) - (format t "~%~%~%") association))) @@ -2997,6 +3081,9 @@ (t (make-instance 'TopicC)))))) (let ((merged-topic topic)) + (dolist (tid topic-identifiers) + (setf merged-topic (add-topic-identifier merged-topic tid + :revision start-revision))) (dolist (psi psis) (setf merged-topic (add-psi merged-topic psi :revision start-revision))) @@ -3134,9 +3221,39 @@ ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric merge-constructs(construct-1 construct-2 &key revision) - (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) - &key (revision *TM-REVISION*)) - (or revision) - (if construct-1 construct-1 construct-2))) -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file +(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) + &key (revision *TM-REVISION*)) + (or revision) + (if construct-1 construct-1 construct-2)) +;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (progn + (unless + (equivalent-constructs construct-1 construct-2 :revision revision) + (error "From merge-constructs(): the variants: ~a ~a are not mergable" + construct-1 construct-2)) + ;;... + ))) + + + + + + + + + + + + + + + + \ No newline at end of file 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 Thu Apr 1 05:40:23 2010 @@ -17,7 +17,8 @@ (:import-from :exceptions duplicate-identifier-error) (:import-from :constants - *xml-string*) + *xml-string* + *xml-uri*) (:export :run-datamodel-tests :datamodel-test :test-VersionInfoC @@ -72,7 +73,8 @@ :test-make-RoleC :test-make-TopicMapC :test-make-AssociationC - :test-make-TopicC)) + :test-make-TopicC + :test-find-oldest-construct)) ;;TODO: test equivalent-constructs @@ -1527,13 +1529,23 @@ (test test-equivalent-PointerC () - "Tests the functions equivalent-construct depending on PointerC - and its subclasses." + "Tests the functions equivalent-construct and strictly-equivalent-constructs + depending on PointerC and its subclasses." (with-fixture with-empty-db (*db-dir*) (let ((p-1 (make-instance 'd::PointerC :uri "p-1")) (tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1" :xtm-id "xtm-1")) - (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))) + (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-1")) + (tid-3 (make-instance 'd:TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-2")) + (tid-4 (make-instance 'd:TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")) + (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2")) + (psi-3 (make-instance 'd:PersistentIdC :uri "psi-1")) + (rev-1 100)) + (setf *TM-REVISION* rev-1) (is-true (d::equivalent-construct p-1 :uri "p-1")) (is-false (d::equivalent-construct p-1 :uri "p-2")) (is-true (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-1")) @@ -1541,138 +1553,250 @@ (is-false (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-2")) (is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-2")) (is-true (d::equivalent-construct psi-1 :uri "psi-1")) - (is-false (d::equivalent-construct psi-1 :uri "psi-2"))))) + (is-false (d::equivalent-construct psi-1 :uri "psi-2")) + (is-false (d::strictly-equivalent-constructs tid-1 tid-1)) + (is-false (d::strictly-equivalent-constructs tid-1 tid-2)) + (is-false (d::strictly-equivalent-constructs tid-1 tid-3)) + (is-true (d::strictly-equivalent-constructs tid-1 tid-4)) + (is-false (d::strictly-equivalent-constructs psi-1 psi-1)) + (is-false (d::strictly-equivalent-constructs psi-1 psi-2)) + (is-true (d::strictly-equivalent-constructs psi-1 psi-3))))) (test test-equivalent-OccurrenceC () "Tests the functions equivalent-construct depending on OccurrenceC." (with-fixture with-empty-db (*db-dir*) - (let ((occ-1 (make-instance 'd:OccurrenceC :charvalue "occ-1")) - (type-1 (make-instance 'd:TopicC)) + (let ((type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (revision-0-5 50) - (version-1 100)) - (setf *TM-REVISION* version-1) - (add-type occ-1 type-1) - (add-theme occ-1 scope-1) - (add-theme occ-1 scope-2) - (is-true (d::equivalent-construct - occ-1 :charvalue "occ-1" :datatype constants:*xml-string* - :instance-of type-1 :themes (list scope-2 scope-1))) - (is-false (d::equivalent-construct - occ-1 :charvalue "occ-1" :datatype constants:*xml-string* - :instance-of type-1 :themes (list scope-2 scope-1) - :start-revision revision-0-5)) - (is-false (d::equivalent-construct - occ-1 :charvalue "occ-1" :datatype constants:*xml-string* - :instance-of type-2 :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - occ-1 :charvalue "occ-1" :datatype constants:*xml-string* - :instance-of type-1 :themes (list scope-3 scope-2))) - (is-false (d::equivalent-construct - occ-1 :charvalue "occ-1" - :instance-of type-1 :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - occ-1 :charvalue "occ-2" :datatype constants:*xml-string* - :instance-of type-1 :themes (list scope-2 scope-1)))))) + (rev-0-5 50) + (rev-1 100)) + (let ((occ-1 (make-construct 'OccurrenceC + :charvalue "occ-1" + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (occ-2 (make-construct 'OccurrenceC + :charvalue "occ-1" + :instance-of type-2 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (occ-3 (make-construct 'OccurrenceC + :charvalue "occ-1" + :instance-of type-1 + :themes (list scope-3 scope-2) + :start-revision rev-1)) + (occ-4 (make-construct 'OccurrenceC + :charvalue "occ-2" + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (occ-5 (make-construct 'OccurrenceC + :charvalue "occ-1" + :datatype *xml-uri* + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (occ-6 (make-construct 'OccurrenceC + :charvalue "occ-1" + :instance-of type-1 + :themes (list scope-1) + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (add-theme occ-6 scope-2) + (is-true (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype *xml-string* + :instance-of type-1 :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype *xml-string* + :instance-of type-1 :themes (list scope-2 scope-1) + :start-revision rev-0-5)) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype *xml-string* + :instance-of type-2 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype *xml-string* + :instance-of type-1 :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-2" :datatype *xml-string* + :instance-of type-1 :themes (list scope-2 scope-1))) + (is-false (d::strictly-equivalent-constructs occ-1 occ-1)) + (is-false (d::strictly-equivalent-constructs occ-1 occ-2)) + (is-false (d::strictly-equivalent-constructs occ-1 occ-3)) + (is-false (d::strictly-equivalent-constructs occ-1 occ-4)) + (is-false (d::strictly-equivalent-constructs occ-1 occ-5)) + (is-true (d::strictly-equivalent-constructs occ-1 occ-6)))))) (test test-equivalent-NameC () "Tests the functions equivalent-construct depending on NameC." (with-fixture with-empty-db (*db-dir*) - (let ((nam-1 (make-instance 'd:NameC :charvalue "nam-1")) - (type-1 (make-instance 'd:TopicC)) + (let ((type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (revision-0-5 50) - (version-1 100)) - (setf *TM-REVISION* version-1) - (add-type nam-1 type-1) - (add-theme nam-1 scope-1) - (add-theme nam-1 scope-2) - (is-true (d::equivalent-construct - nam-1 :charvalue "nam-1" :instance-of type-1 - :themes (list scope-2 scope-1))) - (is-false (d::equivalent-construct - nam-1 :charvalue "nam-1" :instance-of type-1 - :themes (list scope-2 scope-1) - :start-revision revision-0-5)) - (is-false (d::equivalent-construct - nam-1 :charvalue "nam-1" :instance-of type-2 - :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - nam-1 :charvalue "nam-1" :instance-of type-1 - :themes (list scope-3 scope-2))) - (is-false (d::equivalent-construct - nam-1 :charvalue "nam-2" :instance-of type-1 - :themes (list scope-2 scope-1)))))) + (variant-1 (make-instance 'd:VariantC)) + (variant-2 (make-instance 'd:VariantC)) + (rev-0-5 50) + (rev-1 100)) + (let ((name-1 (make-construct 'NameC + :charvalue "name-1" + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (name-2 (make-construct 'NameC + :charvalue "name-2" + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (name-3 (make-construct 'NameC + :charvalue "name-1" + :instance-of type-2 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (name-4 (make-construct 'NameC + :charvalue "name-1" + :instance-of type-1 + :themes (list scope-3 scope-2) + :start-revision rev-1)) + (name-5 (make-construct 'NameC + :charvalue "name-1" + :instance-of type-1 + :themes (list scope-2) + :variants (list variant-1 variant-2) + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (add-theme name-5 scope-1) + (is-true (d::equivalent-construct + name-1 :charvalue "name-1" :instance-of type-1 + :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + name-1 :charvalue "name-1" :instance-of type-1 + :themes (list scope-2 scope-1) + :start-revision rev-0-5)) + (is-false (d::equivalent-construct + name-1 :charvalue "name-1" :instance-of type-2 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + name-1 :charvalue "name-1" :instance-of type-1 + :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + name-1 :charvalue "name-2" :instance-of type-1 + :themes (list scope-2 scope-1))) + (is-false (d::strictly-equivalent-constructs name-1 name-1)) + (is-false (d::strictly-equivalent-constructs name-1 name-2)) + (is-false (d::strictly-equivalent-constructs name-1 name-3)) + (is-false (d::strictly-equivalent-constructs name-1 name-4)) + (is-true (d::strictly-equivalent-constructs name-1 name-5)))))) (test test-equivalent-VariantC () "Tests the functions equivalent-construct depending on VariantC." (with-fixture with-empty-db (*db-dir*) - (let ((var-1 (make-instance 'd:OccurrenceC :charvalue "var-1")) - (scope-1 (make-instance 'd:TopicC)) + (let ((scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC)) - (revision-0-5 50) - (version-1 100)) - (setf *TM-REVISION* version-1) - (add-theme var-1 scope-1) - (add-theme var-1 scope-2) - (is-true (d::equivalent-construct - var-1 :charvalue "var-1" :datatype constants:*xml-string* - :themes (list scope-2 scope-1))) - (is-false (d::equivalent-construct - var-1 :charvalue "var-1" :datatype constants:*xml-string* - :themes (list scope-2 scope-1) - :start-revision revision-0-5)) - (is-false (d::equivalent-construct - var-1 :charvalue "var-1" :datatype constants:*xml-string* - :themes (list scope-3 scope-2))) - (is-false (d::equivalent-construct - var-1 :charvalue "var-1" - :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - var-1 :charvalue "var-2" :datatype constants:*xml-string* - :themes (list scope-2 scope-1)))))) + (rev-0-5 50) + (rev-1 100)) + (let ((var-1 (make-construct 'VariantC + :charvalue "var-1" + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (var-2 (make-construct 'VariantC + :charvalue "var-2" + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (var-3 (make-construct 'VariantC + :charvalue "var-1" + :themes (list scope-1 scope-3) + :start-revision rev-1)) + (var-4 (make-construct 'VariantC + :charvalue "var-1" + :datatype *xml-uri* + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (var-5 (make-construct 'VariantC + :charvalue "var-1" + :themes (list scope-1) + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (add-theme var-5 scope-2) + (is-true (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-2 scope-1) + :start-revision rev-0-5)) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-2" :datatype constants:*xml-string* + :themes (list scope-2 scope-1))) + (is-false (d::strictly-equivalent-constructs var-1 var-1)) + (is-false (d::strictly-equivalent-constructs var-1 var-2)) + (is-false (d::strictly-equivalent-constructs var-1 var-3)) + (is-false (d::strictly-equivalent-constructs var-1 var-4)) + (is-true (d::strictly-equivalent-constructs var-1 var-5)))))) (test test-equivalent-RoleC () "Tests the functions equivalent-construct depending on RoleC." (with-fixture with-empty-db (*db-dir*) - (let ((role-1 (make-instance 'd:RoleC)) - (type-1 (make-instance 'd:TopicC)) + (let ((type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) (player-1 (make-instance 'd:TopicC)) (player-2 (make-instance 'd:TopicC)) - (revision-1 100) - (revision-2 200)) - (setf *TM-REVISION* revision-1) - (add-type role-1 type-1) - (add-player role-1 player-1) - (is-true (d::equivalent-construct role-1 :player player-1 - :instance-of type-1)) - (is-false (d::equivalent-construct role-1 :player player-2 - :instance-of type-1)) - (is-false (d::equivalent-construct role-1 :player player-1 - :instance-of type-2)) - (setf *TM-REVISION* revision-2) - (delete-player role-1 player-1 :revision revision-2) - (add-player role-1 player-2) - (delete-type role-1 type-1 :revision revision-2) - (add-type role-1 type-2) - (is-true (d::equivalent-construct role-1 :player player-2 - :instance-of type-2)) - (is-false (d::equivalent-construct role-1 :player player-1 - :instance-of type-2)) - (is-false (d::equivalent-construct role-1 :player player-2 - :instance-of type-1))))) + (rev-1 100) + (rev-2 200)) + (let ((role-1 (make-construct 'RoleC + :player player-1 + :instance-of type-1 + :start-revision rev-1)) + (role-2 (make-construct 'RoleC + :player player-2 + :instance-of type-1 + :start-revision rev-1)) + (role-3 (make-construct 'RoleC + :player player-1 + :instance-of type-2 + :start-revision rev-1)) + (role-4 (make-construct 'RoleC + :instance-of type-1 + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (add-player role-4 player-1) + (is-true (d::equivalent-construct role-1 :player player-1 + :instance-of type-1)) + (is-false (d::equivalent-construct role-1 :player player-2 + :instance-of type-1)) + (is-false (d::equivalent-construct role-1 :player player-1 + :instance-of type-2)) + (is-false (d::strictly-equivalent-constructs role-1 role-1)) + (is-false (d::strictly-equivalent-constructs role-1 role-2)) + (is-false (d::strictly-equivalent-constructs role-1 role-3)) + (is-true (d::strictly-equivalent-constructs role-1 role-4)) + (setf *TM-REVISION* rev-2) + (delete-player role-1 player-1 :revision rev-2) + (add-player role-1 player-2) + (delete-type role-1 type-1 :revision rev-2) + (add-type role-1 type-2) + (is-true (d::equivalent-construct role-1 :player player-2 + :instance-of type-2)) + (is-false (d::equivalent-construct role-1 :player player-1 + :instance-of type-2)) + (is-false (d::equivalent-construct role-1 :player player-2 + :instance-of type-1)))))) (test test-equivalent-AssociationC () @@ -1684,67 +1808,80 @@ (r-type-1 (make-instance 'TopicC)) (r-type-2 (make-instance 'TopicC)) (r-type-3 (make-instance 'TopicC)) - (revision-1 100)) - (let ((assoc-1 (make-instance 'd:AssociationC)) - (role-1 (make-construct 'd:RoleC - :start-revision revision-1 - :player player-1 - :instance-of r-type-1)) - (role-2 (make-construct 'd:RoleC - :start-revision revision-1 - :player player-2 - :instance-of r-type-2)) + (rev-1 100)) + (let ((role-1 (list :player player-1 :instance-of r-type-1 + :start-revision rev-1)) + (role-2 (list :player player-2 :instance-of r-type-2 + :start-revision rev-1)) + (role-3 (list :instance-of r-type-3 :player player-3 + :start-revision rev-1)) (type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) (scope-1 (make-instance 'd:TopicC)) (scope-2 (make-instance 'd:TopicC)) (scope-3 (make-instance 'd:TopicC))) - (setf *TM-REVISION* revision-1) - (d:add-role assoc-1 role-1) - (d:add-role assoc-1 role-2) - (d:add-type assoc-1 type-1) - (d:add-theme assoc-1 scope-1) - (d:add-theme assoc-1 scope-2) - (is-true (d::equivalent-construct - assoc-1 :roles (list - (list :instance-of r-type-1 :player player-1 - :start-revision revision-1) - (list :instance-of r-type-2 :player player-2 - :start-revision revision-1)) - :instance-of type-1 :themes (list scope-1 scope-2) - :start-revision revision-1)) - (is-false (d::equivalent-construct - assoc-1 :roles (list - (list :instance-of r-type-1 :player player-1) - (list :instance-of r-type-2 :player player-2) - (list :instance-of r-type-3 :player player-3)) - :instance-of type-1 :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list - (list :instance-of r-type-1 :player player-1)) - :instance-of type-1 :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list - (list :instance-of r-type-1 :player player-1) - (list :instance-of r-type-3 :player player-3)) - :instance-of type-1 :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list - (list :instance-of r-type-1 :player player-1) - (list :instance-of r-type-2 :player player-2)) - :instance-of type-2 :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list - (list :instance-of r-type-1 :player player-1) - (list :instance-of r-type-2 :player player-2)) - :instance-of type-2 :themes (list scope-1 scope-3))))))) + (let ((assoc-1 (make-construct 'AssociationC + :roles (list role-1 role-2) + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (assoc-2 (make-construct 'AssociationC + :roles (list role-1 role-2 role-3) + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (assoc-3 (make-construct 'AssociationC + :roles (list role-1 role-3) + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (assoc-4 (make-construct 'AssociationC + :roles (list role-1 role-2) + :instance-of type-2 + :themes (list scope-1 scope-2) + :start-revision rev-1)) + (assoc-5 (make-construct 'AssociationC + :roles (list role-1 role-2) + :instance-of type-1 + :themes (list scope-1 scope-3) + :start-revision rev-1)) + (assoc-6 (make-construct 'AssociationC + :roles (list role-1) + :instance-of type-1 + :themes (list scope-1 scope-2) + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (add-role assoc-6 (apply #'make-construct 'RoleC role-2)) + (is-true (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2 role-3) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-3) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) + :instance-of type-2 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) + :instance-of type-2 :themes (list scope-1 scope-3))) + (is-false (d::strictly-equivalent-constructs assoc-1 assoc-1)) + (is-false (d::strictly-equivalent-constructs assoc-1 assoc-2)) + (is-false (d::strictly-equivalent-constructs assoc-1 assoc-3)) + (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4)) + (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5)) + (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) (test test-equivalent-TopicC () "Tests the functions equivalent-construct depending on TopicC." (with-fixture with-empty-db (*db-dir*) - (let ((top-1 (make-instance 'd:TopicC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (sl-1 (make-instance 'd:SubjectLocatorC :uri "sl-1")) (sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2")) @@ -1754,43 +1891,60 @@ :xtm-id "xtm-id-1")) (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2" :xtm-id "xtm-id-2")) - (revision-1 100)) - (setf *TM-REVISION* revision-1) - (d:add-item-identifier top-1 ii-1) - (d:add-locator top-1 sl-1) - (d:add-psi top-1 psi-1) - (d:add-topic-identifier top-1 tid-1) - (is-true (d::equivalent-construct top-1 - :item-identifiers (list ii-1 ii-2))) - (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2) - :psis (list psi-1 psi-2) - :item-identifiers (list ii-1 ii-2))) - (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) - (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) - (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1))) - (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2))) - (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) - :psis (list psi-2) - :locators (list sl-2)))))) + (rev-1 100)) + (let ((top-1 (make-construct 'TopicC + :item-identifiers (list ii-1) + :locators (list sl-1) + :psis (list psi-1) + :topic-identifiers (list tid-1) + :start-revision rev-1)) + (top-2 (make-construct 'TopicC + :item-identifiers (list ii-2) + :locators (list sl-2) + :psis (list psi-2) + :topic-identifiers (list tid-2) + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (is-true (d::equivalent-construct top-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2) + :psis (list psi-1 psi-2) + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) + (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) + (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1))) + (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2))) + (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) + :psis (list psi-2) + :locators (list sl-2))) + (is-false (d::strictly-equivalent-constructs top-1 top-1)) + (is-false (d::strictly-equivalent-constructs top-1 top-2)))))) (test test-equivalent-TopicMapC () "Tests the functions equivalent-construct depending on TopicMapC." (with-fixture with-empty-db (*db-dir*) - (let ((tm-1 (make-instance 'd:TopicMapC)) - (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) (reifier-1 (make-instance 'd:TopicC)) (reifier-2 (make-instance 'd:TopicC)) - (revision-1 100)) - (setf *TM-REVISION* revision-1) - (d:add-item-identifier tm-1 ii-1) - (d:add-reifier tm-1 reifier-1) - (is-true (d::equivalent-construct tm-1 - :item-identifiers (list ii-1 ii-2))) - (is-true (d::equivalent-construct tm-1 :reifier reifier-1)) - (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2))) - (is-false (d::equivalent-construct tm-1 :reifier reifier-2))))) + (rev-1 100)) + (let ((tm-1 (make-construct 'TopicMapC + :item-identifiers (list ii-1) + :reifier reifier-1 + :start-revision rev-1)) + (tm-2 (make-construct 'TopicMapC + :item-identifiers (list ii-2) + :reifier reifier-2 + :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (is-true (d::equivalent-construct tm-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct tm-1 :reifier reifier-1)) + (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2))) + (is-false (d::equivalent-construct tm-1 :reifier reifier-2)) + (is-false (d::strictly-equivalent-constructs tm-1 tm-1)) + (is-false (d::strictly-equivalent-constructs tm-1 tm-2)))))) (test test-class-p () @@ -2566,6 +2720,58 @@ (is (eql (first (occurrences top-3)) occ-1)))))))) +(test test-find-oldest-construct () + "Tests the generic find-oldest-construct." + (with-fixture with-empty-db (*db-dir*) + (let ((top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (tm-1 (make-instance 'TopicMapC)) + (tm-2 (make-instance 'TopicMapC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (variant-1 (make-instance 'VariantC)) + (variant-2 (make-instance 'VariantC)) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (rev-1 100) + (rev-2 200) + (rev-3 300)) + (setf *TM-REVISION* rev-1) + (is-false (d::find-oldest-construct ii-1 ii-2)) + (add-item-identifier top-1 ii-1 :revision rev-3) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier assoc-1 ii-2 :revision rev-2) + (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier top-2 ii-1 :revision rev-1) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (is-false (d::find-oldest-construct variant-1 variant-2)) + (add-variant name-1 variant-1 :revision rev-3) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (add-variant name-1 variant-2 :revision rev-2) + (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) + (add-variant name-2 variant-1 :revision rev-1) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (is-false (d::find-oldest-construct role-1 role-2)) + (add-role assoc-1 role-1 :revision rev-3) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) + (add-role assoc-1 role-2 :revision rev-2) + (is (eql role-2 (d::find-oldest-construct role-1 role-2))) + (add-role assoc-2 role-1 :revision rev-1) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) + (is-false (d::find-oldest-construct tm-1 tm-2)) + (d::add-to-version-history tm-1 :start-revision rev-3) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-2 :start-revision rev-1) + (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-1 :start-revision rev-1) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1)))))) + + (defun run-datamodel-tests() @@ -2623,4 +2829,5 @@ (it.bese.fiveam:run! 'test-make-TopicMapC) (it.bese.fiveam:run! 'test-make-AssociationC) (it.bese.fiveam:run! 'test-make-TopicC) + (it.bese.fiveam:run! 'test-find-oldest-construct) ) \ No newline at end of file From lgiessmann at common-lisp.net Thu Apr 1 20:31:30 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 01 Apr 2010 16:31:30 -0400 Subject: [isidorus-cvs] r256 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 1 16:31:29 2010 New Revision: 256 Log: new-datamodel: added the generic "merge-constructs" --> "ReifiableConstructC" 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 Thu Apr 1 16:31:29 2010 @@ -155,6 +155,9 @@ (in-package :datamodel) +;;TODO: check for duplicate identifiers after topic-creation/merge +;;TODO: add: add-to-version-history (parent) to all +;; "add-"/"delete-" generics ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -3229,18 +3232,63 @@ -(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC) +(defmethod merge-constructs ((construct-1 ReifiableConstructC) + (construct-2 ReifiableConstructC) &key (revision *TM-REVISION*)) (declare (integer revision)) (if (eql construct-1 construct-2) construct-1 - (progn - (unless - (equivalent-constructs construct-1 construct-2 :revision revision) - (error "From merge-constructs(): the variants: ~a ~a are not mergable" - construct-1 construct-2)) - ;;... - ))) + (let ((older-construct (find-oldest-construct construct-1 construct-2))) + (let ((newer-construct (if (eql older-construct construct-1) + construct-2 + construct-1))) + (dolist (ii (item-identifiers newer-construct :revision revision)) + (delete-item-identifier newer-construct ii :revision revision) + (add-item-identifier older-construct ii :revision revision)) + (let ((reifier-1 (reifier newer-construct :revision revision)) + (reifier-2 (reifier older-construct :revision revision))) + (when reifier-1 + (delete-reifier newer-construct reifier-1 :revision revision) + (let ((merged-reifier + (if reifier-2 + (progn + (delete-reifier older-construct reifier-2 + :revision revision) + (merge-constructs reifier-1 reifier-2 + :revision revision)) + reifier-1))) + (add-reifier older-construct merged-reifier :revision revision)))) + (when (eql (type-of newer-construct) 'ReifiableConstructC) + ;;If the older-construct is a "real" ReifiableConstructC and no sub + ;;class the older-construct must be marked as deleted. + ;;Sub classes are marked as deleted in the "next-method" calls. + (mark-as-deleted newer-construct :revision revision)) + older-construct)))) + + +(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-construct (call-next-method))) + (let ((newer-construct (if (eql older-construct construct-1) + construct-2 + construct-1))) + (dolist (psi (psis newer-construct :revision revision)) + (delete-psi newer-construct psi :revision revision) + (add-psi older-construct psi :revision revision)) + (dolist (locator (locators newer-construct :revision revision)) + (delete-locator newer-construct locator :revision revision) + (add-locator older-construct locator :revision revision)) + ;;occurrences + ;;names + variants + ;;player-in-roles + ;;used-as-type + ;;used-as-scope + ;;reified-construct + ;;in-topicmaps + )))) 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 Thu Apr 1 16:31:29 2010 @@ -77,7 +77,6 @@ :test-find-oldest-construct)) -;;TODO: test equivalent-constructs ;;TODO: test merge-constructs From lgiessmann at common-lisp.net Thu Apr 1 23:06:02 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 01 Apr 2010 19:06:02 -0400 Subject: [isidorus-cvs] r257 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Thu Apr 1 19:06:02 2010 New Revision: 257 Log: new-datamodel: added the generic "merge-constructs" --> "CharacteristicC" => "OccurrenceC" + "NameC" + "VariantC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 1 19:06:02 2010 @@ -3231,6 +3231,42 @@ ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun merge-characteristics (older-parent newer-parent + &key (revision *TM-REVISION*) + (characteristic-type 'OccurrenceC)) + "Deletes all characteristics of the given type from the newer-parent. + Merges equivalent characteristics between the newer and the older parent. + Adds all characteristics from the newer-parent to the older-parent or adds + the merged characterisitcs to the older-parent." + (declare (type (or TopicC NameC) older-parent newer-parent) + (integer revision) (symbol characteristic-type)) + (let ((object-name + (subseq (write-to-string characteristic-type) 0 + (- (length (write-to-string characteristic-type)) 1)))) + (let ((request-fun + (symbol-function + (find-symbol (concatenate 'string object-name "S")))) + (delete-fun + (symbol-function + (find-symbol (concatenate 'string "DELETE-" object-name)))) + (add-fun + (symbol-function + (find-symbol (concatenate 'string "ADD-" object-name))))) + (dolist (newer-char (funcall request-fun newer-parent :revision revision)) + (let ((older-char + (find-if #'(lambda(char) + (equivalent-constructs char newer-char + :revision revision)) + (funcall request-fun older-parent :revision revision)))) + (funcall delete-fun newer-parent newer-char :revision revision) + (if (and newer-char older-char) + (progn + (funcall delete-fun older-parent older-char :revision revision) + (funcall add-fun older-parent + (merge-constructs newer-char older-char + :revision revision))) + (funcall add-fun older-parent newer-char))))))) + (defmethod merge-constructs ((construct-1 ReifiableConstructC) (construct-2 ReifiableConstructC) @@ -3258,14 +3294,38 @@ :revision revision)) reifier-1))) (add-reifier older-construct merged-reifier :revision revision)))) - (when (eql (type-of newer-construct) 'ReifiableConstructC) + (when (and (eql (type-of newer-construct) 'ReifiableConstructC) + (eql (type-of newer-construct) 'ReifiableConstructC) + (typep newer-construct 'VersionedConstructC) + (typep older-construct 'VersionedConstructC)) ;;If the older-construct is a "real" ReifiableConstructC and no sub ;;class the older-construct must be marked as deleted. ;;Sub classes are marked as deleted in the "next-method" calls. - (mark-as-deleted newer-construct :revision revision)) + (mark-as-deleted newer-construct :revision revision) + (add-to-version-history older-construct :start-revision revision)) older-construct)))) +(defmethod merge-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (unless (equivalent-constructs construct-1 construct-2 :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-construct (call-next-method))) + (let ((newer-construct (if (eql older-construct construct-1) + construct-2 + construct-1))) + (when (and (typep construct-1 'NameC) (typep construct-2 'NameC)) + (merge-characteristics older-construct newer-construct + :revision revision + :characteristic-type 'VariantC))) + older-construct))) + + (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -3281,8 +3341,12 @@ (dolist (locator (locators newer-construct :revision revision)) (delete-locator newer-construct locator :revision revision) (add-locator older-construct locator :revision revision)) - ;;occurrences - ;;names + variants + (merge-characteristics older-construct newer-construct + :revision revision + :characteristic-type 'OccurrenceC) + (merge-characteristics older-construct newer-construct + :revision revision + :characteristic-type 'NameC) ;;player-in-roles ;;used-as-type ;;used-as-scope From lgiessmann at common-lisp.net Mon Apr 5 18:08:00 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 05 Apr 2010 14:08:00 -0400 Subject: [isidorus-cvs] r258 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Mon Apr 5 14:07:59 2010 New Revision: 258 Log: new-datamodel: added the generics "add-reified-construct" and "delet-reified-construct" for "TopicC"; added "merge-constructs" for "TopicC"; changed the behaviour of merging "CharacteristicC"s Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Apr 5 14:07:59 2010 @@ -155,6 +155,8 @@ (in-package :datamodel) +;;TODO: mark-as-deleted should call mark as deleted for every owned +;; versioned-construct of the called construct ;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: add: add-to-version-history (parent) to all ;; "add-"/"delete-" generics @@ -167,9 +169,7 @@ ;; and a merge should be done ;;TODO: use some exceptions --> more than one type, ;; identifier, not-mergable merges, missing-init-args... -;;TODO: implement merge-construct -> ReifiableConstructC -> ... -;; the method should merge two constructs that are inherited from -;; ReifiableConstructC + ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -758,6 +758,11 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric mark-as-deleted (construct &key source-locator revision) + (:documentation "Mark a construct as deleted if it comes from the source + indicated by source-locator")) + + (defgeneric find-oldest-construct (construct-1 construct-2) (:documentation "Returns the construct which owns the oldes version info. If a construct is not a versioned construct the oldest @@ -855,6 +860,17 @@ ;;; VersionedConstructC +(defgeneric does-not-exist-in-revision-history (versioned-construct) + (:documentation "Returns t if the passed construct does not exist in any + revision, i.e. the construct has no version-infos or exactly + one whose start-revision is equal to its end-revision.") + (:method ((versioned-construct VersionedConstructC)) + (or (not (versions versioned-construct)) + (and (= (length (versions versioned-construct)) 1) + (= (start-revision (first (versions versioned-construct))) + (end-revision (first (versions versioned-construct)))))))) + + (defmethod find-oldest-construct ((construct-1 VersionedConstructC) (construct-2 VersionedConstructC)) (let ((vi-1 (find-version-info (list construct-1))) @@ -963,16 +979,14 @@ t))) -(defgeneric mark-as-deleted (construct &key source-locator revision) - (:documentation "Mark a construct as deleted if it comes from the source - indicated by source-locator") - (:method ((construct VersionedConstructC) &key source-locator revision) - (declare (ignorable source-locator)) - (let - ((last-version ;the last active version - (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision))))) +(defmethod marks-as-deleted ((construct VersionedConstructC) + &key source-locator revision) + (declare (ignorable source-locator)) + (let + ((last-version ;the last active version + (find 0 (versions construct) :key #'end-revision))) + (when last-version + (setf (end-revision last-version) revision)))) ;;; TopicMapconstructC @@ -1661,6 +1675,24 @@ (reifiable-construct (first assocs)))))) +(defgeneric add-reified-construct (construct reified-construct &key revision) + (:documentation "Sets the passed construct as reified-consturct of the given + topic.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (add-reifier reified-construct construct :revision revision))) + + +(defgeneric delete-reified-construct (construct reified-construct &key revision) + (:documentation "Unsets the passed construct as reified-construct of the + given topic.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (delete-reifier reified-construct construct :revision revision))) + + (defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) @@ -1931,7 +1963,7 @@ (parent-construct ReifiableConstructC) &key (revision *TM-REVISION*)) (let ((already-set-parent (parent construct :revision revision)) - (same-parent-assoc ;should contain a object that was marked as deleted + (same-parent-assoc ;should contain an object that was marked as deleted (loop for parent-assoc in (slot-p construct 'parent) when (eql parent-construct (parent-construct parent-assoc)) return parent-assoc))) @@ -2598,13 +2630,14 @@ (merge-constructs (reifier construct :revision revision) reifier-topic) reifier-topic))) - (let ((all-constructs - (let ((inner-construct (reified-construct merged-reifier-topic - :revision revision))) - (when inner-construct - (list inner-construct))))) + (let ((all-constructs (map 'list #'reifiable-construct + (slot-p reifier-topic 'reified-construct)))) (let ((merged-construct construct)) - (cond ((find construct all-constructs) + (cond ((reified-construct merged-reifier-topic :revision revision) + (merge-constructs + (reified-construct merged-reifier-topic :revision revision) + construct)) + ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in (slot-p merged-reifier-topic 'reified-construct) @@ -2613,8 +2646,6 @@ return reifier-assoc))) (add-to-version-history reifier-assoc :start-revision revision))) - (all-constructs - (merge-constructs (first all-constructs) construct)) (t (make-construct 'ReifierAssociationC :reifiable-construct construct @@ -2959,7 +2990,7 @@ (not start-revision)) (error "From make-association(): start-revision must be set")) (let ((association - (let ((existing-association + (let ((existing-associations (remove-if #'null (map 'list #'(lambda(existing-association) @@ -2970,9 +3001,12 @@ :instance-of instance-of) existing-association)) (elephant:get-instances-by-class 'AssociationC))))) - (if existing-association - (first existing-association) - (make-instance 'AssociationC))))) + (cond ((> (length existing-associations) 1) + (merge-all-constructs existing-associations)) + (existing-associations + (first existing-associations)) + (t + (make-instance 'AssociationC)))))) (dolist (role-plist roles) (add-role association (apply #'make-construct 'RoleC @@ -2993,7 +3027,7 @@ (not start-revision)) (error "From make-role(): start-revision must be set")) (let ((role - (let ((existing-role + (let ((existing-roles (when parent (remove-if #'null @@ -3005,9 +3039,12 @@ :instance-of instance-of) existing-role)) (map 'list #'role (slot-p parent 'roles))))))) - (if existing-role - (first existing-role) - (make-instance 'RoleC))))) + (cond ((> (length existing-roles) 1) + (merge-all-constructs existing-roles)) + (existing-roles + (first existing-roles)) + (t + (make-instance 'RoleC)))))) (when player (add-player role player :revision start-revision)) (when parent @@ -3038,7 +3075,7 @@ :reifier reifier) existing-tm)) (elephant:get-instances-by-class 'TopicMapC))))) - (cond ((and existing-tms (> (length existing-tms) 1)) + (cond ((> (length existing-tms) 1) (merge-all-constructs existing-tms)) (existing-tms (first existing-tms)) @@ -3077,7 +3114,7 @@ :topic-identifiers topic-identifiers) existing-topic)) (elephant:get-instances-by-class 'TopicC))))) - (cond ((and existing-topics (> (length existing-topics) 1)) + (cond ((> (length existing-topics) 1) (merge-all-constructs existing-topics)) (existing-topics (first existing-topics)) @@ -3205,167 +3242,265 @@ - - - - - - - - - - - - - - +;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric move-identifiers (source destination &key revision) + (:documentation "Sets all identifiers as mark as deleted in the given + version and adds the marked identifiers to the + destination construct.")) +(defmethod move-identifiers ((source ReifiableConstructC) + (destination ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((iis (item-identifiers source :revision revision))) + (dolist (ii iis) + (delete-item-identifier source ii :revision revision) + (add-item-identifier destination ii :revision revision)) + iis)) -;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) +(defmethod move-identifiers ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) - (or revision) - (if construct-1 construct-1 construct-2)) -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (declare (integer revision)) + (let ((iis (call-next-method)) + (tids (topic-identifiers source :revision revision)) + (psis (psis source :revision revision)) + (sls (locators source :revision revision))) + (dolist (tid tids) + (delete-topic-identifier source tid :revision revision) + (add-topic-identifier destination tid :revision revision)) + (dolist (psi psis) + (delete-psi source psi :revision revision) + (add-psi destination psi :revision revision)) + (dolist (sl sls) + (delete-locator source sl :revision revision) + (add-locator destination sl :revision revision)) + (append tids iis psis sls))) + + +(defgeneric move-referenced-constructs (source destination &key revision) + (:documentation "Moves all referenced constructs in the given version from + the source TM-construct to the destination TM-construct.")) + + +(defmethod move-referenced-constructs ((source ReifiableConstructC) + (destination ReifiableConstructC) + &key (revision *TM-REVISION*)) + (let ((source-reifier (reifier source :revision revision)) + (destination-reifier (reifier destination :revision revision))) + (cond ((and source-reifier destination-reifier) + (delete-reifier (reified-construct source-reifier :revision revision) + source-reifier :revision revision) + (delete-reifier (reified-construct destination-reifier + :revision revision) + destination-reifier :revision revision) + (let ((merged-reifier + (merge-constructs source-reifier destination-reifier + :revision revision))) + (add-reifier destination merged-reifier :revision revision))) + (source-reifier + (delete-reifier (reified-construct source-reifier :revision revision) + source-reifier :revision revision) + (add-reifier destination source-reifier :revision revision) + source-reifier) + (destination-reifier + (add-reifier destination destination-reifier :revision revision) + destination-reifier)))) + + +(defmethod move-referenced-constructs ((source TopicC) (destination TopicC) + &key (revision *TM-REVISION*)) + (let ((roles (player-in-roles source :revision revision)) + (scopables (used-as-theme source :revision revision)) + (typables (used-as-type source :revision revision))) + (dolist (role roles) + (delete-player role source :revision revision) + (add-player role destination :revision revision)) + (dolist (scopable scopables) + (delete-theme scopable source :revision revision) + (add-theme scopable destination :revision revision)) + (dolist (typable typables) + (delete-type typable source :revision revision) + (add-type typable destination :revision revision)) + (append roles scopables typables))) + + +(defgeneric move-reified-construct (source destination &key revision) + (:documentation "Moves the refied TM-construct from the source topic + to the given destination topic.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((source-reified (reified-construct source :revision revision)) + (destination-reified (reified-construct destination + :revision revision))) + (unless (eql (type-of source-reified) (type-of destination-reified)) + (error "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" + source destination source-reified destination-reified)) + (cond ((and source-reified destination-reified) + (delete-reifier source-reified source :revision revision) + (delete-reifier destination-reified destination :revision revision) + (let ((merged-reified + (merge-constructs source-reified destination-reified + :revision revision))) + (add-reifier merged-reified destination :revision revision) + merged-reified)) + (source-reified + (delete-reifier source source-reified :revision revision) + (add-reifier destination source-reified :revision revision) + source-reified) + (destination-reified + (add-reifier destination destination-reified :revision revision) + destination-reified))))) + + +(defgeneric move-occurrences (source destination &key revision) + (:documentation "Moves all occurrences from the source topic to the + destination topic. If occurrences are TMDM equal + they are merged, i.e. one is marked-as-deleted.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((occs-to-move (occurrences source :revision revision))) + (dolist (occ occs-to-move) + (delete-occurrence occ source :revision revision) + (let ((equivalent-occ + (find-if #'(lambda (destination-occ) + (when + (strictly-equivalent-constructs + occ destination-occ :revision revision) + destination-occ)) + (occurrences destination :revision revision)))) + (if equivalent-occ + (progn + (add-occurrence destination equivalent-occ :revision revision) + (move-identifiers occ equivalent-occ :revision revision) + (move-referenced-constructs occ equivalent-occ + :revision revision)) + (add-occurrence destination occ :revision revision)))) + occs-to-move))) -(defun merge-characteristics (older-parent newer-parent - &key (revision *TM-REVISION*) - (characteristic-type 'OccurrenceC)) - "Deletes all characteristics of the given type from the newer-parent. - Merges equivalent characteristics between the newer and the older parent. - Adds all characteristics from the newer-parent to the older-parent or adds - the merged characterisitcs to the older-parent." - (declare (type (or TopicC NameC) older-parent newer-parent) - (integer revision) (symbol characteristic-type)) - (let ((object-name - (subseq (write-to-string characteristic-type) 0 - (- (length (write-to-string characteristic-type)) 1)))) - (let ((request-fun - (symbol-function - (find-symbol (concatenate 'string object-name "S")))) - (delete-fun - (symbol-function - (find-symbol (concatenate 'string "DELETE-" object-name)))) - (add-fun - (symbol-function - (find-symbol (concatenate 'string "ADD-" object-name))))) - (dolist (newer-char (funcall request-fun newer-parent :revision revision)) - (let ((older-char - (find-if #'(lambda(char) - (equivalent-constructs char newer-char - :revision revision)) - (funcall request-fun older-parent :revision revision)))) - (funcall delete-fun newer-parent newer-char :revision revision) - (if (and newer-char older-char) +(defgeneric move-variants (source destination &key revision) + (:documentation "Moves all variants from the source name to the destination + name. If any variants are TMDM equal they are merged --> + i.e. one of the variants is marked-as-deleted.") + (:method ((source NameC) (destination NameC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((vars-to-move (variants source :revision revision))) + (dolist (var vars-to-move) + (delete-variant source var :revision revision) + (let ((equivalent-var + (find-if #'(lambda (destination-var) + (when + (strictly-equivalent-constructs + var destination-var :revision revision) + destination-var)) + (variants destination :revision revision)))) + (if equivalent-var (progn - (funcall delete-fun older-parent older-char :revision revision) - (funcall add-fun older-parent - (merge-constructs newer-char older-char - :revision revision))) - (funcall add-fun older-parent newer-char))))))) + (add-variant destination equivalent-var :revision revision) + (move-identifiers var equivalent-var :revision revision) + (move-referenced-constructs var equivalent-var + :revision revision)) + (add-variant destination var :revision revision)))) + vars-to-move))) -(defmethod merge-constructs ((construct-1 ReifiableConstructC) - (construct-2 ReifiableConstructC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-construct (find-oldest-construct construct-1 construct-2))) - (let ((newer-construct (if (eql older-construct construct-1) - construct-2 - construct-1))) - (dolist (ii (item-identifiers newer-construct :revision revision)) - (delete-item-identifier newer-construct ii :revision revision) - (add-item-identifier older-construct ii :revision revision)) - (let ((reifier-1 (reifier newer-construct :revision revision)) - (reifier-2 (reifier older-construct :revision revision))) - (when reifier-1 - (delete-reifier newer-construct reifier-1 :revision revision) - (let ((merged-reifier - (if reifier-2 - (progn - (delete-reifier older-construct reifier-2 - :revision revision) - (merge-constructs reifier-1 reifier-2 - :revision revision)) - reifier-1))) - (add-reifier older-construct merged-reifier :revision revision)))) - (when (and (eql (type-of newer-construct) 'ReifiableConstructC) - (eql (type-of newer-construct) 'ReifiableConstructC) - (typep newer-construct 'VersionedConstructC) - (typep older-construct 'VersionedConstructC)) - ;;If the older-construct is a "real" ReifiableConstructC and no sub - ;;class the older-construct must be marked as deleted. - ;;Sub classes are marked as deleted in the "next-method" calls. - (mark-as-deleted newer-construct :revision revision) - (add-to-version-history older-construct :start-revision revision)) - older-construct)))) - +(defgeneric move-names (source destination &key revision) + (:documentation "Moves all names from the source topic to the destination + topic. If any names are equal they are merged, i.e. + one of the names is marked-as-deleted.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((names-to-move (names source :revision revision))) + (dolist (name names-to-move) + (delete-name source name :revision revision) + (let ((equivalent-name + (find-if #'(lambda (destination-name) + (when + (strictly-equivalent-constructs + name destination-name :revision revision) + destination-name)) + (names destination :revision revision)))) + (if equivalent-name + (progn + (move-variants name equivalent-name :revision revision) + (add-name destination equivalent-name :revision revision) + (move-identifiers name equivalent-name :revision revision) + (move-referenced-constructs name equivalent-name + :revision revision)) + (add-name destination name :revision revision)))) + names-to-move))) + + +(defun merge-changed-constructs (older-topic &key (revision *TM-REVISION*)) + (declare (TopicC older-topic)) + (dolist (construct (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision) + (player-in-roles older-topic :revision revision))) + (let ((parent (when (or (typep construct 'RoleC) + (typep construct 'CharacteristicC)) + (parent construct :revision revision)))) + (let ((found-equivalent + (find-if #'(lambda(other-construct) + (strictly-equivalent-constructs + other-construct construct :revision revision)) + (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision)) + ((typep construct 'AssociationC) + (elephant:get-instances-by-class 'AssociationC)))))) + (when found-equivalent + (merge-all-constructs (append found-equivalent (list construct)))))))) -(defmethod merge-constructs ((construct-1 CharacteristicC) - (construct-2 CharacteristicC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (unless (equivalent-constructs construct-1 construct-2 :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-construct (call-next-method))) - (let ((newer-construct (if (eql older-construct construct-1) - construct-2 - construct-1))) - (when (and (typep construct-1 'NameC) (typep construct-2 'NameC)) - (merge-characteristics older-construct newer-construct - :revision revision - :characteristic-type 'VariantC))) - older-construct))) (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-construct (call-next-method))) - (let ((newer-construct (if (eql older-construct construct-1) - construct-2 - construct-1))) - (dolist (psi (psis newer-construct :revision revision)) - (delete-psi newer-construct psi :revision revision) - (add-psi older-construct psi :revision revision)) - (dolist (locator (locators newer-construct :revision revision)) - (delete-locator newer-construct locator :revision revision) - (add-locator older-construct locator :revision revision)) - (merge-characteristics older-construct newer-construct - :revision revision - :characteristic-type 'OccurrenceC) - (merge-characteristics older-construct newer-construct - :revision revision - :characteristic-type 'NameC) - ;;player-in-roles - ;;used-as-type - ;;used-as-scope - ;;reified-construct - ;;in-topicmaps - )))) + (let ((older-topic (find-oldest-construct construct-1 construct-2))) + (let ((newer-topic (if (eql older-topic construct-1) + construct-2 + construct-1))) + (move-identifiers newer-topic older-topic :revision revision) + (dolist (tm (in-topicmaps newer-topic :revision revision)) + (add-to-tm tm older-topic)) + (move-names newer-topic older-topic :revision revision) + (move-occurrences newer-topic older-topic :revision revision) + (move-referenced-constructs newer-topic older-topic :revision revision) + (move-reified-construct newer-topic older-topic :revision revision) + (merge-changed-constructs older-topic :revision revision) + (mark-as-deleted newer-topic :revision revision) + (when (does-not-exist-in-revision-history newer-topic) + (delete-construct newer-topic)) + older-topic))) + +;TODO: merge-constructs: RoleC, AssociationC, TopicMapC, +; OccurrenceC, NameC, VariantC --> call merge-constructs of the parent +; and return the active construct on what merge-constructs was initialy +; called +;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) + &key (revision *TM-REVISION*)) + (or revision) + (if construct-1 construct-1 construct-2)) - \ No newline at end of file +;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file From lgiessmann at common-lisp.net Mon Apr 5 20:15:44 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 05 Apr 2010 16:15:44 -0400 Subject: [isidorus-cvs] r259 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Mon Apr 5 16:15:44 2010 New Revision: 259 Log: new-datamodel: fixed a bug in the declaration of "defmethod for mark-as-deleted"; fixed a bug in "merge-constructs" for "TopicC" when both merged constructs are references to the same object. Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Apr 5 16:15:44 2010 @@ -979,8 +979,8 @@ t))) -(defmethod marks-as-deleted ((construct VersionedConstructC) - &key source-locator revision) +(defmethod mark-as-deleted ((construct VersionedConstructC) + &key source-locator revision) (declare (ignorable source-locator)) (let ((last-version ;the last active version @@ -3462,22 +3462,24 @@ (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) - (let ((older-topic (find-oldest-construct construct-1 construct-2))) - (let ((newer-topic (if (eql older-topic construct-1) - construct-2 - construct-1))) - (move-identifiers newer-topic older-topic :revision revision) - (dolist (tm (in-topicmaps newer-topic :revision revision)) - (add-to-tm tm older-topic)) - (move-names newer-topic older-topic :revision revision) - (move-occurrences newer-topic older-topic :revision revision) - (move-referenced-constructs newer-topic older-topic :revision revision) - (move-reified-construct newer-topic older-topic :revision revision) - (merge-changed-constructs older-topic :revision revision) - (mark-as-deleted newer-topic :revision revision) - (when (does-not-exist-in-revision-history newer-topic) - (delete-construct newer-topic)) - older-topic))) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-topic (find-oldest-construct construct-1 construct-2))) + (let ((newer-topic (if (eql older-topic construct-1) + construct-2 + construct-1))) + (move-identifiers newer-topic older-topic :revision revision) + (dolist (tm (in-topicmaps newer-topic :revision revision)) + (add-to-tm tm older-topic)) + (move-names newer-topic older-topic :revision revision) + (move-occurrences newer-topic older-topic :revision revision) + (move-referenced-constructs newer-topic older-topic :revision revision) + (move-reified-construct newer-topic older-topic :revision revision) + (merge-changed-constructs older-topic :revision revision) + (mark-as-deleted newer-topic :revision revision) + (when (does-not-exist-in-revision-history newer-topic) + (delete-construct newer-topic)) + older-topic)))) From lgiessmann at common-lisp.net Mon Apr 5 20:50:11 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 05 Apr 2010 16:50:11 -0400 Subject: [isidorus-cvs] r260 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Mon Apr 5 16:50:11 2010 New Revision: 260 Log: new-datamodel: added "merge-constructs" for "OccurrenceC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Apr 5 16:50:11 2010 @@ -3459,7 +3459,6 @@ (merge-all-constructs (append found-equivalent (list construct)))))))) - (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) (if (eql construct-1 construct-2) @@ -3482,6 +3481,34 @@ older-topic)))) +(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) + &key (revision *TM-REVISION*)) + (if (eql construct-1 construct-2) + construct-1 + (progn + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a is not mergable with ~a" + construct-1 construct-2)) + (let ((parent-1 (parent construct-1 :revision revision)) + (parent-2 (parent construct-2 :revision revision))) + (when (not (and parent-1 parent-2)) + (error "From merge-constructs():~a and ~a must be associated with a topic" + construct-1 construct-2)) + (if (and parent-1 (eql parent-1 parent-2)) + (progn + (move-identifiers construct-1 construct-2 :revision revision) + (move-referenced-constructs construct-1 construct-2 + :revision revision) + (delete-occurrence parent-1 construct-1 :revision revision) + (add-occurrence parent-1 construct-2 :revision revision)) + (let ((active-topic + (merge-constructs parent-1 parent-2 :revision revision))) + (if (find construct-1 + (occurrences active-topic :revision revision)) + construct-1 + construct-2))))))) + From lgiessmann at common-lisp.net Tue Apr 6 06:30:27 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 02:30:27 -0400 Subject: [isidorus-cvs] r261 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Tue Apr 6 02:30:26 2010 New Revision: 261 Log: new-datamodel: optimized "merge-constructs" --> "OccurrenceC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 02:30:26 2010 @@ -3496,12 +3496,16 @@ (error "From merge-constructs():~a and ~a must be associated with a topic" construct-1 construct-2)) (if (and parent-1 (eql parent-1 parent-2)) - (progn - (move-identifiers construct-1 construct-2 :revision revision) - (move-referenced-constructs construct-1 construct-2 - :revision revision) - (delete-occurrence parent-1 construct-1 :revision revision) - (add-occurrence parent-1 construct-2 :revision revision)) + (let ((older-occ (find-oldest-construct construct-1 construct-2))) + (let ((newer-occ (if (eql older-occ construct-1) + construct-2 + construct-1))) + (move-identifiers newer-occ older-occ :revision revision) + (move-referenced-constructs newer-occ older-occ + :revision revision) + (delete-occurrence parent-1 construct-1 :revision revision) + (add-occurrence parent-1 construct-2 :revision revision) + older-occ)) (let ((active-topic (merge-constructs parent-1 parent-2 :revision revision))) (if (find construct-1 From lgiessmann at common-lisp.net Tue Apr 6 13:42:50 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 09:42:50 -0400 Subject: [isidorus-cvs] r262 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Tue Apr 6 09:42:50 2010 New Revision: 262 Log: new-datamodel: added "merge-constructs" for "NameC" and "VariantC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 09:42:50 2010 @@ -876,7 +876,7 @@ (let ((vi-1 (find-version-info (list construct-1))) (vi-2 (find-version-info (list construct-2)))) (cond ((not (or vi-1 vi-2)) - nil) + construct-1) ((not vi-1) construct-2) ((not vi-2) @@ -1030,7 +1030,7 @@ (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct))) (vi-2 (find-version-info (slot-p construct-2 'identified-construct)))) (cond ((not (or vi-1 vi-2)) - nil) + construct-1) ((not vi-1) construct-2) ((not vi-2) @@ -1858,7 +1858,7 @@ (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) (vi-2 (find-version-info (slot-p construct-2 'parent)))) (cond ((not (or vi-1 vi-2)) - nil) + construct-1) ((not vi-1) construct-2) ((not vi-2) @@ -2278,7 +2278,7 @@ (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) (vi-2 (find-version-info (slot-p construct-2 'parent)))) (cond ((not (or vi-1 vi-2)) - nil) + construct-1) ((not vi-1) construct-2) ((not vi-2) @@ -3536,4 +3536,83 @@ -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file +;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-var (find-oldest-construct construct-1 construct-2))) + (let ((newer-var (if (eql older-var construct-1) + construct-2 + construct-1))) + (let ((parent-1 (parent older-var :revision revision)) + (parent-2 (parent newer-var :revision revision))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (cond ((and parent-1 parent-2) + (let ((active-parent + (merge-constructs parent-1 parent-2 + :revision revision))) + (let ((all-names (names active-parent :revision revision))) + (if (find-if #'(lambda(name) + (find older-var (variants name :revision + revision))) + all-names) + older-var + newer-var)))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-var newer-var)) + (src (if parent-1 newer-var older-var))) + (move-identifiers src dst :revision revision) + (move-referenced-constructs src dst :revision revision) + dst)) + (t + (move-identifiers newer-var older-var :revision revision) + (move-referenced-constructs newer-var older-var + :revision revision) + older-var))))))) + + +(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-name (find-oldest-construct construct-1 construct-2))) + (let ((newer-name (if (eql older-name construct-1) + construct-2 + construct-1))) + (let ((parent-1 (parent older-name :revision revision)) + (parent-2 (parent newer-name :revision revision))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (cond ((and parent-1 parent-2) + (let ((active-parent (merge-constructs parent-1 parent-2 + :revision revision))) + (if (find older-name (names active-parent + :revision revision)) + older-name + newer-name))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-name newer-name)) + (src (if parent-1 newer-name older-name))) + (move-identifiers src dst :revision revision) + (move-referenced-constructs src dst :revision revision) + (move-variants src dst :revision revision) + dst)) + (t + (move-identifiers newer-name older-name :revision revision) + (move-referenced-constructs newer-name older-name + :revision revision) + (move-variants newer-name older-name :revision revision) + older-name))))))) + + +;TODO: --> include move-yx in move-referenced-constructs \ No newline at end of file From lgiessmann at common-lisp.net Tue Apr 6 15:44:47 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 11:44:47 -0400 Subject: [isidorus-cvs] r263 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Tue Apr 6 11:44:47 2010 New Revision: 263 Log: new-datamodel: replaced "merge-cosntructs" --> "NameC", "OccurrenceC", "VariantC" by a generic for "CharacteristicC"; added the generics "add-characteristic" and "delete-characteristic" for "NameC", "VariantC", "OccurrenceC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 11:44:47 2010 @@ -758,6 +758,18 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric add-characteristic (construct characteristic &key revision) + (:documentation "Adds the passed characterisitc to the given topic by calling + add-name or add-occurrences. + Variants are added to names by calling add-name.")) + + +(defgeneric delete-characteristic (construct characteristic &key revision) + (:documentation "Deletes the passed characteristic oif the given topic by + calling delete-name or delete-occurrence. + Variants are deleted from names by calling delete-variant.")) + + (defgeneric mark-as-deleted (construct &key source-locator revision) (:documentation "Mark a construct as deleted if it comes from the source indicated by source-locator")) @@ -832,7 +844,6 @@ The latest construct is either the one with end-revision=0 or with the highest end-revision value.")) - (defgeneric owned-p (construct) (:documentation "Returns t if the passed construct is referenced by a parent TM construct.")) @@ -1638,6 +1649,24 @@ construct))) +(defmethod add-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (add-name construct characteristic :revision revision) + (add-occurrence construct characteristic :revision revision))) + + +(defmethod delete-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (delete-name construct characteristic :revision revision) + (delete-occurrence construct characteristic :revision revision))) + + (defgeneric player-in-roles (construct &key revision) (:documentation "Returns the RoleC-objects that correspond with the passed construct and the passed version.") @@ -2156,6 +2185,18 @@ construct))) +(defmethod add-characteristic ((construct NameC) (characteristic VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (add-variant construct characteristic :revision revision)) + + +(defmethod delete-characteristic ((construct NameC) (characteristic VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (delete-variant construct characteristic :revision revision)) + + ;;; AssociationC (defmethod equivalent-constructs ((construct-1 AssociationC) (construct-2 AssociationC) @@ -3287,33 +3328,48 @@ (defmethod move-referenced-constructs ((source ReifiableConstructC) (destination ReifiableConstructC) &key (revision *TM-REVISION*)) - (let ((source-reifier (reifier source :revision revision)) - (destination-reifier (reifier destination :revision revision))) - (cond ((and source-reifier destination-reifier) - (delete-reifier (reified-construct source-reifier :revision revision) - source-reifier :revision revision) - (delete-reifier (reified-construct destination-reifier - :revision revision) - destination-reifier :revision revision) - (let ((merged-reifier - (merge-constructs source-reifier destination-reifier - :revision revision))) - (add-reifier destination merged-reifier :revision revision))) - (source-reifier - (delete-reifier (reified-construct source-reifier :revision revision) - source-reifier :revision revision) - (add-reifier destination source-reifier :revision revision) - source-reifier) - (destination-reifier - (add-reifier destination destination-reifier :revision revision) - destination-reifier)))) + (declare (integer revision)) + (remove-if + #'null + (append + (move-identifiers source destination :revision revision) + (let ((source-reifier (reifier source :revision revision)) + (destination-reifier (reifier destination :revision revision))) + (cond ((and source-reifier destination-reifier) + (delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (delete-reifier (reified-construct destination-reifier + :revision revision) + destination-reifier :revision revision) + (let ((merged-reifier + (merge-constructs source-reifier destination-reifier + :revision revision))) + (add-reifier destination merged-reifier :revision revision))) + (source-reifier + (delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (add-reifier destination source-reifier :revision revision) + source-reifier) + (destination-reifier + (add-reifier destination destination-reifier :revision revision) + destination-reifier)))))) + + +(defmethod move-referenced-constructs ((source NameC) (destination NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (append (call-next-method) + (move-variants source destination :revision revision))) (defmethod move-referenced-constructs ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) (let ((roles (player-in-roles source :revision revision)) (scopables (used-as-theme source :revision revision)) - (typables (used-as-type source :revision revision))) + (typables (used-as-type source :revision revision)) + (ids (move-identifiers source destination :revision revision))) (dolist (role roles) (delete-player role source :revision revision) (add-player role destination :revision revision)) @@ -3323,7 +3379,7 @@ (dolist (typable typables) (delete-type typable source :revision revision) (add-type typable destination :revision revision)) - (append roles scopables typables))) + (remove-if #'null (append roles scopables typables ids)))) (defgeneric move-reified-construct (source destination &key revision) @@ -3373,7 +3429,6 @@ (if equivalent-occ (progn (add-occurrence destination equivalent-occ :revision revision) - (move-identifiers occ equivalent-occ :revision revision) (move-referenced-constructs occ equivalent-occ :revision revision)) (add-occurrence destination occ :revision revision)))) @@ -3399,7 +3454,6 @@ (if equivalent-var (progn (add-variant destination equivalent-var :revision revision) - (move-identifiers var equivalent-var :revision revision) (move-referenced-constructs var equivalent-var :revision revision)) (add-variant destination var :revision revision)))) @@ -3423,10 +3477,8 @@ destination-name)) (names destination :revision revision)))) (if equivalent-name - (progn - (move-variants name equivalent-name :revision revision) + (progn (add-name destination equivalent-name :revision revision) - (move-identifiers name equivalent-name :revision revision) (move-referenced-constructs name equivalent-name :revision revision)) (add-name destination name :revision revision)))) @@ -3467,7 +3519,6 @@ (let ((newer-topic (if (eql older-topic construct-1) construct-2 construct-1))) - (move-identifiers newer-topic older-topic :revision revision) (dolist (tm (in-topicmaps newer-topic :revision revision)) (add-to-tm tm older-topic)) (move-names newer-topic older-topic :revision revision) @@ -3481,52 +3532,77 @@ older-topic)))) -(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) +(defmethod merge-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) (if (eql construct-1 construct-2) construct-1 - (progn - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) - (error "From merge-constructs(): ~a is not mergable with ~a" - construct-1 construct-2)) - (let ((parent-1 (parent construct-1 :revision revision)) - (parent-2 (parent construct-2 :revision revision))) - (when (not (and parent-1 parent-2)) - (error "From merge-constructs():~a and ~a must be associated with a topic" - construct-1 construct-2)) - (if (and parent-1 (eql parent-1 parent-2)) - (let ((older-occ (find-oldest-construct construct-1 construct-2))) - (let ((newer-occ (if (eql older-occ construct-1) - construct-2 - construct-1))) - (move-identifiers newer-occ older-occ :revision revision) - (move-referenced-constructs newer-occ older-occ - :revision revision) - (delete-occurrence parent-1 construct-1 :revision revision) - (add-occurrence parent-1 construct-2 :revision revision) - older-occ)) - (let ((active-topic - (merge-constructs parent-1 parent-2 :revision revision))) - (if (find construct-1 - (occurrences active-topic :revision revision)) - construct-1 - construct-2))))))) + (let ((older-char (find-oldest-construct construct-1 construct-2))) + (let ((newer-char (if (eql older-char construct-1) + construct-2 + construct-1))) + (let ((parent-1 (parent older-char :revision revision)) + (parent-2 (parent newer-char :revision revision))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (cond ((and parent-1 (eql parent-1 parent-2)) + (move-referenced-constructs newer-char older-char + :revision revision) + (delete-characteristic newer-char parent-2 + :revision revision) + older-char) + ((and parent-1 parent-2) + (let ((active-parent (merge-constructs parent-1 parent-2 + :revision revision))) + (let ((found-older-char + (cond ((typep older-char 'OccurrenceC) + (find older-char + (occurrences + active-parent :revision revision))) + ((typep older-char 'NameC) + (find older-char + (names + active-parent :revision revision))) + ((typep older-char 'VariantC) + (find-if + #'(lambda(name) + (find older-char + (variants name + :revision revision))) + (names active-parent :revision revision)))))) + (if found-older-char + older-char + newer-char)))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-char newer-char)) + (src (if parent-1 newer-char older-char))) + (move-referenced-constructs src dst :revision revision) + dst)) + (t + (move-referenced-constructs newer-char older-char + :revision revision) + older-char))))))) + -;TODO: merge-constructs: RoleC, AssociationC, TopicMapC, -; OccurrenceC, NameC, VariantC --> call merge-constructs of the parent -; and return the active construct on what merge-constructs was initialy -; called +;TODO: merge-constructs: RoleC (merge parents and return the active role object), +;; AssociationC, TopicMapC, + + + + ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) @@ -3539,80 +3615,7 @@ ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-var (find-oldest-construct construct-1 construct-2))) - (let ((newer-var (if (eql older-var construct-1) - construct-2 - construct-1))) - (let ((parent-1 (parent older-var :revision revision)) - (parent-2 (parent newer-var :revision revision))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) - (cond ((and parent-1 parent-2) - (let ((active-parent - (merge-constructs parent-1 parent-2 - :revision revision))) - (let ((all-names (names active-parent :revision revision))) - (if (find-if #'(lambda(name) - (find older-var (variants name :revision - revision))) - all-names) - older-var - newer-var)))) - ((or parent-1 parent-2) - (let ((dst (if parent-1 older-var newer-var)) - (src (if parent-1 newer-var older-var))) - (move-identifiers src dst :revision revision) - (move-referenced-constructs src dst :revision revision) - dst)) - (t - (move-identifiers newer-var older-var :revision revision) - (move-referenced-constructs newer-var older-var - :revision revision) - older-var))))))) - -(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-name (find-oldest-construct construct-1 construct-2))) - (let ((newer-name (if (eql older-name construct-1) - construct-2 - construct-1))) - (let ((parent-1 (parent older-name :revision revision)) - (parent-2 (parent newer-name :revision revision))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) - (cond ((and parent-1 parent-2) - (let ((active-parent (merge-constructs parent-1 parent-2 - :revision revision))) - (if (find older-name (names active-parent - :revision revision)) - older-name - newer-name))) - ((or parent-1 parent-2) - (let ((dst (if parent-1 older-name newer-name)) - (src (if parent-1 newer-name older-name))) - (move-identifiers src dst :revision revision) - (move-referenced-constructs src dst :revision revision) - (move-variants src dst :revision revision) - dst)) - (t - (move-identifiers newer-name older-name :revision revision) - (move-referenced-constructs newer-name older-name - :revision revision) - (move-variants newer-name older-name :revision revision) - older-name))))))) ;TODO: --> include move-yx in move-referenced-constructs \ No newline at end of file From lgiessmann at common-lisp.net Tue Apr 6 19:32:40 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 15:32:40 -0400 Subject: [isidorus-cvs] r264 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Tue Apr 6 15:32:40 2010 New Revision: 264 Log: new-datamodel: apat the datamodel's unit-tests to the last modifactions of "find-odlest-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 Tue Apr 6 15:32:40 2010 @@ -3589,20 +3589,13 @@ +;TODO: merge-constructs: RoleC (merge parents), AssociationC, TopicMapC, - - -;TODO: merge-constructs: RoleC (merge parents and return the active role object), -;; AssociationC, TopicMapC, - - - - ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) @@ -3613,9 +3606,3 @@ ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - - - -;TODO: --> include move-yx in move-referenced-constructs \ No newline at end of file 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 Tue Apr 6 15:32:40 2010 @@ -2740,28 +2740,28 @@ (rev-2 200) (rev-3 300)) (setf *TM-REVISION* rev-1) - (is-false (d::find-oldest-construct ii-1 ii-2)) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) (add-item-identifier top-1 ii-1 :revision rev-3) (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) (add-item-identifier assoc-1 ii-2 :revision rev-2) (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2))) (add-item-identifier top-2 ii-1 :revision rev-1) (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (is-false (d::find-oldest-construct variant-1 variant-2)) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) (add-variant name-1 variant-1 :revision rev-3) (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) (add-variant name-1 variant-2 :revision rev-2) (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) (add-variant name-2 variant-1 :revision rev-1) (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (is-false (d::find-oldest-construct role-1 role-2)) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) (add-role assoc-1 role-1 :revision rev-3) (is (eql role-1 (d::find-oldest-construct role-1 role-2))) (add-role assoc-1 role-2 :revision rev-2) (is (eql role-2 (d::find-oldest-construct role-1 role-2))) (add-role assoc-2 role-1 :revision rev-1) (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (is-false (d::find-oldest-construct tm-1 tm-2)) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) (d::add-to-version-history tm-1 :start-revision rev-3) (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) (d::add-to-version-history tm-2 :start-revision rev-1) From lgiessmann at common-lisp.net Tue Apr 6 19:44:44 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 15:44:44 -0400 Subject: [isidorus-cvs] r265 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Tue Apr 6 15:44:44 2010 New Revision: 265 Log: new-datamodel: added "merge-constructs" --> "TopicMapC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 15:44:44 2010 @@ -155,11 +155,12 @@ (in-package :datamodel) -;;TODO: mark-as-deleted should call mark as deleted for every owned +;;TODO: mark-as-deleted should call mark-as-deleted for every owned ;; versioned-construct of the called construct -;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: add: add-to-version-history (parent) to all ;; "add-"/"delete-" generics +;; ===>> adapt exist-in-revision-history +;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -871,7 +872,7 @@ ;;; VersionedConstructC -(defgeneric does-not-exist-in-revision-history (versioned-construct) +(defgeneric exist-in-revision-history-? (versioned-construct) (:documentation "Returns t if the passed construct does not exist in any revision, i.e. the construct has no version-infos or exactly one whose start-revision is equal to its end-revision.") @@ -3527,7 +3528,7 @@ (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) (mark-as-deleted newer-topic :revision revision) - (when (does-not-exist-in-revision-history newer-topic) + (when (exist-in-revision-history-? newer-topic) (delete-construct newer-topic)) older-topic)))) @@ -3587,9 +3588,28 @@ older-char))))))) +(defmethod merge-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-tm (find-oldest-construct construct-1 construct-2))) + (let ((newer-tm (if (eql older-tm construct-1) + construct-2 + construct-1))) + (move-referenced-constructs newer-tm older-tm :revision revision) + (dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm))) + (add-to-tm top-or-assoc top-or-assoc)) + (add-to-version-history older-tm :start-revision revision) + (mark-as-deleted newer-tm :revision revision) + (when (exist-in-revision-history-? newer-tm) + (delete-construct newer-tm)) + older-tm)))) + + -;TODO: merge-constructs: RoleC (merge parents), AssociationC, TopicMapC, +;TODO: merge-constructs: RoleC (merge parents), AssociationC From lgiessmann at common-lisp.net Tue Apr 6 19:56:28 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 15:56:28 -0400 Subject: [isidorus-cvs] r266 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Tue Apr 6 15:56:27 2010 New Revision: 266 Log: new-datamodel: added "merge-constructs" --> "AssociationC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 15:56:27 2010 @@ -3607,7 +3607,34 @@ older-tm)))) - +(defmethod merge-constructs ((construct-1 AssociationC) (construct-2 AssociationC) + &key revision) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-assoc (find-oldest-construct construct-1 construct-2))) + (let ((newer-assoc (if (eql older-assoc construct-1) + construct-2 + construct-1))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (move-referenced-constructs newer-assoc older-assoc) + (dolist (newer-role (roles newer-assoc :revision revision)) + (let ((equivalent-role + (find-if #'(lambda(older-role) + (strictly-equivalent-constructs + older-role newer-role :revision revision)) + (roles older-assoc :revision revision)))) + (move-referenced-constructs newer-role equivalent-role + :revision revision) + (delete-role newer-assoc newer-role :revision revision) + (add-role older-assoc equivalent-role :revision revision))) + (mark-as-deleted newer-assoc :revision revision) + (when (exist-in-revision-history-? newer-assoc) + (delete-construct newer-assoc)) + older-assoc)))) ;TODO: merge-constructs: RoleC (merge parents), AssociationC From lgiessmann at common-lisp.net Tue Apr 6 20:09:58 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 06 Apr 2010 16:09:58 -0400 Subject: [isidorus-cvs] r267 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Tue Apr 6 16:09:58 2010 New Revision: 267 Log: new-datamodel: added "merge-constructs" --> "RoleC" Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 16:09:58 2010 @@ -155,6 +155,10 @@ (in-package :datamodel) +;;TODO: call delete-construct for all child-constructs that are: +;; *exist-in-revision-history => nil +;; *are not referenced by other constructs +;; --> iis, psis, sls, tids, names, occs, variants, roles ;;TODO: mark-as-deleted should call mark-as-deleted for every owned ;; versioned-construct of the called construct ;;TODO: add: add-to-version-history (parent) to all @@ -3636,20 +3640,40 @@ (delete-construct newer-assoc)) older-assoc)))) -;TODO: merge-constructs: RoleC (merge parents), AssociationC - - - - - -;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) +(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC) &key (revision *TM-REVISION*)) - (or revision) - (if construct-1 construct-1 construct-2)) - - - - -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (declare (integer *TM-REVISION*)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-role (find-oldest-construct construct-1 construct-2))) + (let ((newer-role (if (eql older-role construct-1) + construct-2 + construct-1))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (let ((parent-1 (parent older-role :revision revision)) + (parent-2 (parent newer-role :revision revision))) + (cond ((and parent-1 (eql parent-1 parent-2)) + (move-referenced-constructs newer-role older-role + :revision revision) + (delete-role newer-role parent-2 :revision revision) + (add-role older-role parent-1 :revision revision)) + ((and parent-1 parent-2) + (let ((active-assoc (merge-constructs parent-1 parent-2 + :revision revision))) + (if (find older-role (roles active-assoc + :revision revision)) + older-role + newer-role))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-role newer-role)) + (src (if parent-1 newer-role older-role))) + (move-referenced-constructs src dst :revision revision) + dst)) + (t + (move-referenced-constructs newer-role older-role + :revision revision) + older-role))))))) \ No newline at end of file From lgiessmann at common-lisp.net Thu Apr 8 09:55:12 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 08 Apr 2010 05:55:12 -0400 Subject: [isidorus-cvs] r268 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 8 05:55:12 2010 New Revision: 268 Log: new-datamodel: fixed a versioning-problem in all "delete-\ generics; added the exceptions "tm-reference-error", "missing-argument-error" and "not-mergable-error"; adapt the data-model'S unit-tests to the last modifications Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/model/exceptions.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 Thu Apr 8 05:55:12 2010 @@ -11,12 +11,13 @@ (:use :cl :elephant :constants) (:nicknames :d) (:import-from :exceptions - duplicate-identifier-error) - (:import-from :exceptions - object-not-found-error) - (:import-from :constants - *xml-string*) + duplicate-identifier-error + object-not-found-error + missing-argument-error + not-mergable-error + tm-reference-error) (:import-from :constants + *xml-string* *instance-psi*) (:export ;;classes :TopicMapConstructC @@ -155,15 +156,9 @@ (in-package :datamodel) -;;TODO: call delete-construct for all child-constructs that are: -;; *exist-in-revision-history => nil -;; *are not referenced by other constructs -;; --> iis, psis, sls, tids, names, occs, variants, roles -;;TODO: mark-as-deleted should call mark-as-deleted for every owned -;; versioned-construct of the called construct -;;TODO: add: add-to-version-history (parent) to all -;; "add-"/"delete-" generics -;; ===>> adapt exist-in-revision-history + +;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? +;; versioned-construct of the called construct, same for add-xy ??? ;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs @@ -172,8 +167,6 @@ ;;TODO: implement a macro "with-merge-construct" that merges constructs ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done -;;TODO: use some exceptions --> more than one type, -;; identifier, not-mergable merges, missing-init-args... @@ -261,7 +254,11 @@ :accessor uri :inherit t :type string - :initform (error "From PointerC(): uri must be set for a pointer") + :initform (error + (make-condition 'missing-argument-error + :message "From PointerC(): uri must be set for a pointer" + :argument-symbol 'uri + :function-symbol ':uri)) :index t :documentation "The actual value of a pointer, i.e. uri or ID.") (identified-construct :associate (PointerAssociationC identifier) @@ -281,7 +278,11 @@ ((xtm-id :initarg :xtm-id :accessor xtm-id :type string - :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") + :initform (error + (make-condition 'missing-argument-error + :message "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" + :argument-symbol 'xtm-id + :function-symbol ':xtm-id)) :index t :documentation "ID of the TM this identification came from.")) (:index t) @@ -439,13 +440,21 @@ (defpclass TypeAssociationC(VersionedAssociationC) ((type-topic :initarg :type-topic :accessor type-topic - :initform (error "From TypeAssociationC(): type-topic must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From TypeAssociationC(): type-topic must be set" + :argument-symbol 'type-topic + :function-symbol ':type-topic)) :associate TopicC :documentation "Associates this object with a topic that is used as type.") (typable-construct :initarg :typable-construct :accessor typable-construct - :initform (error "From TypeAssociationC(): typable-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From TypeAssociationC(): typable-construct must be set" + :argument-symbol 'typable-construct + :function-symbol ':typable-construct)) :associate TypableC :documentation "Associates this object with the typable construct that is typed by the @@ -458,13 +467,21 @@ (defpclass ScopeAssociationC(VersionedAssociationC) ((theme-topic :initarg :theme-topic :accessor theme-topic - :initform (error "From ScopeAssociationC(): theme-topic must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From ScopeAssociationC(): theme-topic must be set" + :argument-symbol 'theme-topic + :function-symbol ':theme-topic)) :associate TopicC :documentation "Associates this opbject with a topic that is a scopable construct.") (scopable-construct :initarg :scopable-construct :accessor scopable-construct - :initform (error "From ScopeAssociationC(): scopable-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From ScopeAssociationC(): scopable-construct must be set" + :argument-symbol 'scopable-construct + :function-symbol ':scopable-construct)) :associate ScopableC :documentation "Associates this object with the socpable construct that is scoped by the @@ -477,13 +494,21 @@ (defpclass ReifierAssociationC(VersionedAssociationC) ((reifiable-construct :initarg :reifiable-construct :accessor reifiable-construct - :initform (error "From ReifierAssociation(): reifiable-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From ReifierAssociation(): reifiable-construct must be set" + :argument-symbol 'reifiable-construct + :function-symbol ':reifiable-construct)) :associate ReifiableConstructC :documentation "The actual construct which is reified by a topic.") (reifier-topic :initarg :reifier-topic :accessor reifier-topic - :initform (error "From ReifierAssociationC(): reifier-topic must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From ReifierAssociationC(): reifier-topic must be set" + :argument-symbol 'reifier-topic + :function-symbol ':reifier-topic)) :associate TopicC :documentation "The reifier-topic that reifies the reifiable-construct.")) @@ -496,7 +521,11 @@ ((identifier :initarg :identifier :accessor identifier :inherit t - :initform (error "From PointerAssociationC(): identifier must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From PointerAssociationC(): identifier must be set" + :argument-symbol 'identifier + :function-symbol ':identifier)) :associate PointerC :documentation "The actual data that is associated with the pointer-association's parent.")) @@ -507,7 +536,11 @@ (defpclass SubjectLocatorAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From SubjectLocatorAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-symbol)) :associate TopicC :documentation "The actual topic which is associated with the subject-locator.")) @@ -518,7 +551,11 @@ (defpclass PersistentIdAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From PersistentIdAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From PersistentIdAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :associate TopicC :documentation "The actual topic which is associated with the subject-identifier/psi.")) @@ -529,7 +566,11 @@ (defpclass TopicIdAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From TopicIdAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-arguement-error + :message "From TopicIdAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :associate TopicC :documentation "The actual topic which is associated with the topic-identifier.")) @@ -540,7 +581,11 @@ (defpclass ItemIdAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From ItemIdAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From ItemIdAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :associate ReifiableConstructC :documentation "The actual parent which is associated with the item-identifier.")) @@ -553,7 +598,11 @@ ((characteristic :initarg :characteristic :accessor characteristic :inherit t - :initform (error "From CharacteristicCAssociation(): characteristic must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From CharacteristicCAssociation(): characteristic must be set" + :argument-symbol 'characteristic + :function-symbol ':characteristic)) :associate CharacteristicC :documentation "Associates this object with the actual characteristic object.")) @@ -564,7 +613,11 @@ (defpclass VariantAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From VariantAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From VariantAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :associate NameC :documentation "Associates this object with a name.")) (:documentation "Associates variant objects with name obejcts. @@ -574,7 +627,11 @@ (defpclass NameAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From NameAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From NameAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :associate TopicC :documentation "Associates this object with a topic.")) (:documentation "Associates name objects with their parent topics. @@ -584,7 +641,11 @@ (defpclass OccurrenceAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error "From OccurrenceAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From OccurrenceAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :associate TopicC :documentation "Associates this object with a topic.")) (:documentation "Associates occurrence objects with their parent topics. @@ -596,13 +657,21 @@ ((player-topic :initarg :player-topic :accessor player-topic :associate TopicC - :initform (error "From PlayerAssociationC(): player-topic must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From PlayerAssociationC(): player-topic must be set" + :argument-symbol 'player-topic + :function-symbol ':player-topic)) :documentation "Associates this object with a topic that is a player.") (parent-construct :initarg :parent-construct :accessor parent-construct :associate RoleC - :initform (error "From PlayerAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From PlayerAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :documentation "Associates this object with the parent-association.")) (:documentation "This class associates roles and their player in given revisions.")) @@ -612,12 +681,20 @@ ((role :initarg :role :accessor role :associate RoleC - :initform (error "From RoleAssociationC(): role must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From RoleAssociationC(): role must be set" + :argument-symbol 'role + :function-symbol ':role)) :documentation "Associates this objetc with a role-object.") (parent-construct :initarg :parent-construct :accessor parent-construct :associate AssociationC - :initform (error "From RoleAssociationC(): parent-construct must be set") + :initform (error + (make-condition 'missing-argument-error + :message "From RoleAssociationC(): parent-construct must be set" + :argument-symbol 'parent-construct + :function-symbol ':parent-construct)) :documentation "Assocates thius object with an association-object.")) (:documentation "Associates roles with assoications and adds some @@ -763,6 +840,11 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric delete-if-not-referenced (construct) + (:documentation "Calls delete-construct for the given object if it is + not referenced by any other construct.")) + + (defgeneric add-characteristic (construct characteristic &key revision) (:documentation "Adds the passed characterisitc to the given topic by calling add-name or add-occurrences. @@ -955,7 +1037,11 @@ (defgeneric add-to-version-history (construct &key start-revision end-revision) (:documentation "Adds version history to a versioned construct") (:method ((construct VersionedConstructC) - &key (start-revision (error "From add-to-version-history(): start revision must be present")) + &key (start-revision (error + (make-condition 'missing-argument-error + :message "From add-to-version-history(): start revision must be present" + :argument-symbol 'start-revision + :function-symbol 'add-to-version-history))) (end-revision 0)) (let ((eql-version-info (find-if #'(lambda(vi) @@ -1370,7 +1456,6 @@ construct xtm-id)))) (uri (first possible-identifiers))) (concatenate 'string "t" (write-to-string (internal-id construct)))))) - (defgeneric topic-identifiers (construct &key revision) @@ -1422,13 +1507,16 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (topic-identifier TopicIdentificationC) - &key (revision (error "From delete-topic-identifier(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-topic-identifier(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-topic-identifier)))) (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers) when (eql (identifier ti-assoc) topic-identifier) return ti-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1478,13 +1566,16 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (psi PersistentIdC) - &key (revision (error "From delete-psi(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-psi(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-psi)))) (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis) when (eql (identifier psi-assoc) psi) return psi-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1535,13 +1626,16 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (locator SubjectLocatorC) - &key (revision (error "From delete-locator(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-locator(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-locator)))) (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators) when (eql (identifier loc-assoc) locator) return loc-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1572,8 +1666,12 @@ &key (revision *TM-REVISION*)) (when (and (parent name :revision revision) (not (eql (parent name :revision revision) construct))) - (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" - name construct (parent name :revision revision))) + (error (make-condition 'tm-reference-error + :message (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" + name construct (parent name :revision revision)) + :referenced-construct name + :existing-reference (parent name :revision revision) + :new-reference construct))) (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) @@ -1594,13 +1692,16 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (name NameC) - &key (revision (error "From delete-name(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-name(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-name)))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) when (eql (characteristic name-assoc) name) return name-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1623,8 +1724,12 @@ &key (revision *TM-REVISION*)) (when (and (parent occurrence :revision revision) (not (eql (parent occurrence :revision revision) construct))) - (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" - occurrence construct (parent occurrence :revision revision))) + (error 'tm-reference-error + :message (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" + occurrence construct (parent occurrence :revision revision)) + :referenced-construct occurrence + :existing-reference (parent occurrence :revision revision) + :new-reference construct)) (let ((all-occurrences (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) @@ -1644,13 +1749,16 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (occurrence OccurrenceC) - &key (revision (error "From delete-occurrence(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-occurrence(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-construct)))) (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) when (eql (characteristic occ-assoc) occurrence) return occ-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history construct :start-revision revision)) construct))) @@ -1777,7 +1885,9 @@ (when (find-item-by-revision top-from-oid revision) top-from-oid)))))) (if (and error-if-nil (not result)) - (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision) + (error (make-condition 'object-not-found-error + :message (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" + topic-id xtm-id revision))) result))) @@ -1802,12 +1912,13 @@ :uri uri))) (identified-construct (first possible-ids) :revision revision))))) - ;no revision need not to be checked, since the revision + ;no revision need to be checked, since the revision ;is implicitely checked by the function identified-construct (if result result (when error-if-nil - (error "No such item is bound to the given identifier uri."))))) + (error (make-condition 'object-not-found-error + :message "No such item is bound to the given identifier uri.")))))) (defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*) @@ -1887,6 +1998,13 @@ ;;; CharacteristicC +(defmethod delete-if-not-referenced ((construct CharacteristicC)) + (let ((references (slot-p construct 'parent))) + (when (and (<= (length references) 1) + (marked-as-deleted-p (first references))) + (delete-construct construct)))) + + (defmethod find-oldest-construct ((construct-1 CharacteristicC) (construct-2 CharacteristicC)) (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) @@ -2003,8 +2121,12 @@ return parent-assoc))) (when (and already-set-parent (not (eql already-set-parent parent-construct))) - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" - construct parent-construct already-set-parent)) + (error (make-condition 'tm-reference-error + :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent) + :referenced-construct construct + :existing-reference (parent construct :revision revision) + :new-reference parent-construct))) (cond (already-set-parent (let ((parent-assoc (loop for parent-assoc in (slot-p construct 'parent) @@ -2032,15 +2154,18 @@ (defmethod delete-parent ((construct CharacteristicC) (parent-construct ReifiableConstructC) - &key (revision (error "From delete-parent(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-parent(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-parent)))) (let ((assoc-to-delete (loop for parent-assoc in (slot-p construct 'parent) when (eql (parent-construct parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (when (typep parent-construct 'VersionedConstructC) - (add-to-version-history parent-construct :start-revision revision)) + (mark-as-deleted assoc-to-delete :revision revision) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision))) construct)) @@ -2159,8 +2284,12 @@ &key (revision *TM-REVISION*)) (when (and (parent variant :revision revision) (not (eql (parent variant :revision revision) construct))) - (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" - variant construct (parent variant :revision revision))) + (error (make-condition 'tm-reference-error + :message (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" + variant construct (parent variant :revision revision)) + :referenced-construct variant + :existing-reference (parent variant :revision revision) + :new-reference construct))) (let ((all-variants (map 'list #'characteristic (slot-p construct 'variants)))) (if (find variant all-variants) @@ -2180,7 +2309,10 @@ (:documentation "Deletes the passed variant by marking it's association as deleted in the passed revision.") (:method ((construct NameC) (variant VariantC) - &key (revision (error "From delete-variant(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-variant(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-variant)))) (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct 'variants) when (eql (characteristic variant-assoc) variant) @@ -2305,13 +2437,16 @@ (:documentation "Deletes the passed role by marking it's association as deleted in the passed revision.") (:method ((construct AssociationC) (role RoleC) - &key (revision (error "From delete-role(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-role(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-role)))) (let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles) when (eql (role role-assoc) role) return role-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2320,6 +2455,13 @@ ;;; RoleC +(defmethod delete-if-not-referenced ((construct RoleC)) + (let ((references (slot-p construct 'parent))) + (when (and (<= (length references) 1) + (marked-as-deleted-p (first references))) + (delete-construct construct)))) + + (defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC)) (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) (vi-2 (find-version-info (slot-p construct-2 'parent)))) @@ -2429,8 +2571,12 @@ return parent-assoc))) (when (and already-set-parent (not (eql already-set-parent parent-construct))) - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" - construct parent-construct already-set-parent)) + (error (make-condition 'tm-reference-error + :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent) + :referenced-construct construct + :existing-reference (parent construct :revision revision) + :new-reference parent-construct))) (cond (already-set-parent (let ((parent-assoc (loop for parent-assoc in (slot-p construct 'parent) @@ -2450,14 +2596,17 @@ (defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision (error "From delete-parent(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-parent(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-parent)))) (let ((assoc-to-delete (loop for parent-assoc in (slot-p construct 'parent) when (eql (parent-construct parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (add-to-version-history parent-construct :start-revision revision) + (mark-as-deleted assoc-to-delete :revision revision) + (add-to-version-history parent-construct :start-revision revision)) construct)) @@ -2483,8 +2632,12 @@ return player-assoc))) (when (and already-set-player (not (eql already-set-player player-topic))) - (error "From add-player(): ~a can't be played by ~a since it is played by ~a" - construct player-topic already-set-player)) + (error (make-condition 'tm-reference-error + :message (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" + construct player-topic already-set-player) + :referenced-construct construct + :existing-reference (player construct :revision revision) + :new-reference player-topic))) (cond (already-set-player (let ((player-assoc (loop for player-assoc in (slot-p construct 'player) @@ -2505,7 +2658,10 @@ (:documentation "Deletes the passed topic as a player of the passed role object by marking its association-object as deleted.") (:method ((construct RoleC) (player-topic TopicC) - &key (revision (error "From delete-parent(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-parent(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-player)))) (let ((assoc-to-delete (loop for player-assoc in (slot-p construct 'player) when (eql (parent-construct player-assoc) construct) @@ -2652,14 +2808,17 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) - &key (revision (error "From delete-item-identifier(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-item-identifier(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-item-identifier)))) (let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers) when (eql (identifier ii-assoc) item-identifier) return ii-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (when (typep construct 'VersionedConstructC) - (add-to-version-history construct :start-revision revision)) + (mark-as-deleted assoc-to-delete :revision revision) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision))) construct))) @@ -2706,14 +2865,17 @@ (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct ReifiableConstructC) (reifier TopicC) - &key (revision (error "From delete-reifier(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-reifier(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-reifier)))) (let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier) when (eql (reifier-topic reifier-assoc) reifier) return reifier-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (when (typep construct 'VersionedConstructC) - (add-to-version-history construct :start-revision revision)) + (mark-as-deleted assoc-to-delete :revision revision) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision))) construct))) @@ -2824,7 +2986,10 @@ (:documentation "Deletes the passed theme by marking it's association as deleted in the passed revision.") (:method ((construct ScopableC) (theme-topic TopicC) - &key (revision (error "From delete-theme(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-theme(): revision must be set" + :argument-symbol 'revsion + :function-symbol 'delete-theme)))) (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes) when (eql (theme-topic theme-assoc) theme-topic) return theme-assoc))) @@ -2873,8 +3038,12 @@ return type-assoc))) (when (and already-set-type (not (eql type-topic already-set-type))) - (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a" - construct type-topic already-set-type)) + (error (make-condition 'tm-reference-error + :message (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a" + construct type-topic already-set-type) + :referenced-construct construct + :existing-reference (instance-of construct :revision revision) + :new-reference type-topic))) (cond (already-set-type (let ((type-assoc (loop for type-assoc in (slot-p construct 'instance-of) @@ -2897,7 +3066,10 @@ (:documentation "Deletes the passed type by marking it's association as deleted in the passed revision.") (:method ((construct TypableC) (type-topic TopicC) - &key (revision (error "From delete-type(): revision must be set"))) + &key (revision (error (make-condition 'missing-argument-error + :message "From delete-type(): revision must be set" + :argument-symbol 'revision + :function-symbol 'delete-type)))) (let ((assoc-to-delete (loop for type-assoc in (slot-p construct 'instance-of) when (eql (type-topic type-assoc) type-topic) @@ -2986,7 +3158,10 @@ (and (ReifiableConstructC-p class-symbol) (or (getf args :item-identifiers) (getf args :reifier)))) (not (getf args :start-revision))) - (error "From make-construct(): start-revision must be set")) + (error (make-condition 'missing-argument-error + :message "From make-construct(): start-revision must be set" + :argument-symbol 'start-revision + :function-symbol 'make-construct))) (let ((construct (cond ((PointerC-p class-symbol) @@ -3034,7 +3209,10 @@ (roles (getf args :roles))) (when (and (or roles instance-of themes) (not start-revision)) - (error "From make-association(): start-revision must be set")) + (error (make-condition 'missing-argument-error + :message "From make-association(): start-revision must be set" + :argument-symbol 'start-revision + :function-symbol 'make-association))) (let ((association (let ((existing-associations (remove-if @@ -3071,7 +3249,10 @@ (start-revision (getf args :start-revision))) (when (and (or instance-of player parent) (not start-revision)) - (error "From make-role(): start-revision must be set")) + (error (make-condition 'missing-argument-error + :message "From make-role(): start-revision must be set" + :argument-symbol 'start-revision + :function-symbol 'make-role))) (let ((role (let ((existing-roles (when parent @@ -3109,7 +3290,10 @@ (start-revision (getf args :start-revision))) (when (and (or item-identifiers reifier) (not start-revision)) - (error "From make-tm(): start-revision must be set")) + (error (make-condition 'missing-argument-error + :message "From make-tm(): start-revision must be set" + :argument-symbol 'start-revision + :function-symbol 'make-tm))) (let ((tm (let ((existing-tms (remove-if @@ -3146,7 +3330,10 @@ (when (and (or psis locators item-identifiers topic-identifiers names occurrences) (not start-revision)) - (error "From make-topic(): start-revision must be set")) + (error (make-condition 'missing-argument-error + :message "From make-topic(): start-revision must be set" + :argument-symbol 'start-revision + :function-symbol 'make-topic))) (let ((topic (let ((existing-topics (remove-if @@ -3199,7 +3386,10 @@ (parent (getf args :parent))) (when (and (or instance-of themes variants parent) (not start-revision)) - (error "From make-characteristic(): start-revision must be set")) + (error (make-condition 'missing-argument-error + :message "From make-characteristic(): start-revision must be set" + :argument-symbol 'start-revsion + :function-symbol 'make-characgteristic))) (let ((characteristic (let ((existing-characteristic (when parent @@ -3235,12 +3425,21 @@ (identified-construct (getf args :identified-construct)) (err "From make-pointer(): ")) (when (and identified-construct (not start-revision)) - (error "~astart-revision must be set" err)) + (error (make-condition 'missing-argument-error + :message (format nil "~astart-revision must be set" err) + :argument-symbol 'start-revision + :function-symbol 'make-pointer))) (unless uri - (error "~auri must be set" err)) + (error (make-condition 'missing-argument-error + :message (format nil "~auri must be set" err) + :argument-symbol 'uri + :function-symbol 'make-pointer))) (when (and (TopicIdentificationC-p class-symbol) (not xtm-id)) - (error "~axtm-id must be set" err)) + (error (make-condition 'missing-argument-error + :message (format nil "~axtm-id must be set" err) + :argument-symbol 'xtm-id + :function-symbol 'make-pointer))) (let ((identifier (let ((existing-pointer (remove-if @@ -3396,8 +3595,11 @@ (destination-reified (reified-construct destination :revision revision))) (unless (eql (type-of source-reified) (type-of destination-reified)) - (error "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" - source destination source-reified destination-reified)) + (error (make-condition 'not-mergable-error + :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" + source destination source-reified destination-reified) + :construct-1 source + :construct-2 destination))) (cond ((and source-reified destination-reified) (delete-reifier source-reified source :revision revision) (delete-reifier destination-reified destination :revision revision) @@ -3551,8 +3753,11 @@ (parent-2 (parent newer-char :revision revision))) (unless (strictly-equivalent-constructs construct-1 construct-2 :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) + (error (make-condition 'not-mergable-error + :message (format nil "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2) + :construct-1 construct-1 + :construct-2 construct-2))) (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-char older-char :revision revision) @@ -3585,10 +3790,12 @@ (let ((dst (if parent-1 older-char newer-char)) (src (if parent-1 newer-char older-char))) (move-referenced-constructs src dst :revision revision) + (delete-if-not-referenced src) dst)) (t (move-referenced-constructs newer-char older-char :revision revision) + (delete-if-not-referenced newer-char) older-char))))))) @@ -3622,8 +3829,11 @@ construct-1))) (unless (strictly-equivalent-constructs construct-1 construct-2 :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) + (error (make-condition 'not-mergable-error + :message (format nil "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2) + :construct-1 construct-1 + :construct-2 construct-2))) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -3652,8 +3862,11 @@ construct-1))) (unless (strictly-equivalent-constructs construct-1 construct-2 :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) + (error (make-condition 'not-mergable-error + :message (format nil "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2) + :construct-1 construct-1 + :construct-2 construct-2))) (let ((parent-1 (parent older-role :revision revision)) (parent-2 (parent newer-role :revision revision))) (cond ((and parent-1 (eql parent-1 parent-2)) @@ -3672,8 +3885,10 @@ (let ((dst (if parent-1 older-role newer-role)) (src (if parent-1 newer-role older-role))) (move-referenced-constructs src dst :revision revision) + (delete-if-not-referenced src) dst)) (t (move-referenced-constructs newer-role older-role :revision revision) + (delete-if-not-referenced newer-role) older-role))))))) \ No newline at end of file Modified: branches/new-datamodel/src/model/exceptions.lisp ============================================================================== --- branches/new-datamodel/src/model/exceptions.lisp (original) +++ branches/new-datamodel/src/model/exceptions.lisp Thu Apr 8 05:55:12 2010 @@ -13,7 +13,10 @@ :missing-reference-error :no-identifier-error :duplicate-identifier-error - :object-not-found-error)) + :object-not-found-error + :not-mergable-error + :missing-argument-error + :tm-reference-error)) (in-package :exceptions) @@ -22,6 +25,7 @@ :initarg :message :accessor message))) + (define-condition missing-reference-error(error) ((message :initarg :message @@ -31,6 +35,7 @@ :initarg :reference)) (:documentation "thrown is a reference is missing")) + (define-condition duplicate-identifier-error(error) ((message :initarg :message @@ -40,12 +45,14 @@ :initarg :reference)) (:documentation "thrown if the same identifier is already in use")) + (define-condition object-not-found-error(error) ((message :initarg :message :accessor message)) (:documentation "thrown if the object could not be found")) + (define-condition no-identifier-error(error) ((message :initarg :message @@ -54,3 +61,48 @@ :initarg :internal-id :accessor internal-id)) (:documentation "thrown if the topic has no identifier")) + + +(define-condition not-mergable-error (error) + ((message + :initarg :message + :accessor message) + (construc-1 + :initarg :construct-1 + :accessor construct-1) + (construc-2 + :initarg :construct-2 + :accessor construct-2)) + (:documentation "Thrown if two constructs are not mergable since + they have e.g. difference types.")) + + +(define-condition missing-argument-error (error) + ((message + :initarg :message + :accessor message) + (argument-symbol + :initarg :argument-symbol + :accessor argument-symbol) + (function-symbol + :initarg :function-symbol + :accessor function-symbol)) + (:documentation "Thrown if a argument is missing in a function.")) + + +(define-condition tm-reference-error (error) + ((message + :initarg :message + :accessor message) + (referenced-construct + :initarg :referenced-construct + :accessor referenced-construct) + (existing-reference + :initarg :existing-reference + :accessor existing-reference) + (new-reference + :initarg :new-reference + :accessor new-reference)) + (:documentation "Thrown of the referenced-construct is already owned by another + TM-construct (existing-reference) and is going to be referenced + by a second TM-construct (new-reference) at the same time.")) \ No newline at end of file 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 Thu Apr 8 05:55:12 2010 @@ -15,7 +15,10 @@ :fixtures :unittests-constants) (:import-from :exceptions - duplicate-identifier-error) + duplicate-identifier-error + missing-argument-error + tm-reference-error + object-not-found-error) (:import-from :constants *xml-string* *xml-uri*) @@ -166,7 +169,7 @@ (revision-4 400)) (setf d:*TM-REVISION* revision-1) (is-false (identified-construct ii-1)) - (signals error (make-instance 'ItemIdentifierC)) + (signals missing-argument-error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) (add-item-identifier topic-1 ii-1) (is (= (length (d::versions topic-1)) 1)) @@ -232,7 +235,7 @@ (revision-4 400)) (setf d:*TM-REVISION* revision-1) (is-false (identified-construct psi-1)) - (signals error (make-instance 'PersistentIdC)) + (signals missing-argument-error (make-instance 'PersistentIdC)) (is-false (psis topic-1)) (add-psi topic-1 psi-1) (is (= (length (d::versions topic-1)) 1)) @@ -296,7 +299,7 @@ (revision-4 400)) (setf d:*TM-REVISION* revision-1) (is-false (identified-construct sl-1)) - (signals error (make-instance 'SubjectLocatorC)) + (signals missing-argument-error (make-instance 'SubjectLocatorC)) (is-false (locators topic-1)) (add-locator topic-1 sl-1) (is (= (length (d::versions topic-1)) 1)) @@ -362,9 +365,9 @@ (revision-4 400)) (setf d:*TM-REVISION* revision-1) (is-false (identified-construct ti-1)) - (signals error (make-instance 'TopicIdentificationC + (signals missing-argument-error (make-instance 'TopicIdentificationC :uri "ti-1")) - (signals error (make-instance 'TopicIdentificationC + (signals missing-argument-error (make-instance 'TopicIdentificationC :xtm-id "xtm-id-1")) (is-false (topic-identifiers topic-1)) (add-topic-identifier topic-1 ti-1) @@ -436,11 +439,10 @@ (rev-2 200)) (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-top-id" :revision rev-0)) - (signals error (is-false (get-item-by-id - "any-top-id" :xtm-id "any-xtm-id" - :error-if-nil t))) - (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t - :revision rev-0))) + (signals object-not-found-error + (get-item-by-id "any-top-id" :xtm-id "any-xtm-id" :error-if-nil t)) + (signals object-not-found-error + (get-item-by-id "any-top-id" :error-if-nil t :revision rev-0)) (is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id")) (add-topic-identifier top-1 top-id-3-1 :revision rev-1) (add-topic-identifier top-1 top-id-3-2 :revision rev-1) @@ -497,12 +499,12 @@ (rev-2 200)) (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-ii-id")) - (signals error (is-false (get-item-by-item-identifier - "any-ii-id" :error-if-nil t - :revision rev-1))) - (signals error (is-false (get-item-by-item-identifier - "any-ii-id" :error-if-nil t - :revision rev-1))) + (signals object-not-found-error + (get-item-by-item-identifier + "any-ii-id" :error-if-nil t :revision rev-1)) + (signals object-not-found-error + (get-item-by-item-identifier + "any-ii-id" :error-if-nil t :revision rev-1)) (is-false (get-item-by-item-identifier "any-ii-id")) (add-item-identifier top-1 ii-3-1 :revision rev-1) (add-item-identifier top-1 ii-3-2 :revision rev-1) @@ -542,12 +544,10 @@ (rev-2 200)) (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-sl-id")) - (signals error (is-false (get-item-by-locator - "any-sl-id" :error-if-nil t - :revision rev-0))) - (signals error (is-false (get-item-by-locator - "any-sl-id" :error-if-nil t - :revision rev-0))) + (signals object-not-found-error + (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0)) + (signals object-not-found-error + (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0)) (is-false (get-item-by-locator "any-sl-id" :revision rev-0)) (add-locator top-1 sl-3-1 :revision rev-1) (add-locator top-1 sl-3-2 :revision rev-1) @@ -587,12 +587,10 @@ (rev-2 200)) (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-psi-id")) - (signals error (is-false (get-item-by-locator - "any-psi-id" :error-if-nil t - :revision rev-0))) - (signals error (is-false (get-item-by-locator - "any-psi-id" :error-if-nil t - :revision rev-0))) + (signals object-not-found-error + (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0)) + (signals object-not-found-error + (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0)) (is-false (get-item-by-locator "any-psi-id")) (add-psi top-1 psi-3-1 :revision rev-1) (add-psi top-1 psi-3-2 :revision rev-1) @@ -699,7 +697,7 @@ (add-occurrence top-1 occ-1 :revision rev-4) (is (= (length (union (list occ-2 occ-1) (occurrences top-1 :revision rev-0))) 2)) - (signals error (add-occurrence top-2 occ-1 :revision rev-4)) + (signals tm-reference-error (add-occurrence top-2 occ-1 :revision rev-4)) (delete-occurrence top-1 occ-1 :revision rev-5) (is (= (length (union (list occ-2) (occurrences top-1 :revision rev-5))) 1)) @@ -769,7 +767,7 @@ (add-variant name-1 v-1 :revision rev-4) (is (= (length (union (list v-2 v-1) (variants name-1 :revision rev-0))) 2)) - (signals error (add-variant name-2 v-1 :revision rev-4)) + (signals tm-reference-error (add-variant name-2 v-1 :revision rev-4)) (delete-variant name-1 v-1 :revision rev-5) (is (= (length (union (list v-2) (variants name-1 :revision rev-5))) 1)) @@ -844,7 +842,7 @@ (add-name top-1 name-1 :revision rev-4) (is (= (length (union (list name-2 name-1) (names top-1 :revision rev-0))) 2)) - (signals error (add-name top-2 name-1 :revision rev-4)) + (signals tm-reference-error (add-name top-2 name-1 :revision rev-4)) (delete-name top-1 name-1 :revision rev-5) (is (= (length (union (list name-2) (names top-1 :revision rev-5))) 1)) @@ -893,7 +891,7 @@ (is (eql top-1 (instance-of name-1))) (is-false (instance-of name-1 :revision revision-0-5)) (is (eql top-1 (instance-of name-1 :revision revision-2))) - (signals error (add-type name-1 top-2 :revision revision-0)) + (signals tm-reference-error (add-type name-1 top-2 :revision revision-0)) (add-type name-2 top-1 :revision revision-2) (is (= (length (union (list name-1 name-2) (used-as-type top-1 :revision revision-0))) 2)) @@ -998,7 +996,7 @@ (is (eql (parent role-1 :revision rev-0) assoc-1)) (is (eql (parent role-2 :revision rev-2) assoc-1)) (is-false (parent role-2 :revision rev-1)) - (signals error (add-parent role-2 assoc-2 :revision rev-2)) + (signals tm-reference-error (add-parent role-2 assoc-2 :revision rev-2)) (delete-role assoc-1 role-1 :revision rev-3) (is (= (length (d::versions assoc-1)) 3)) (is-true (find-if #'(lambda(vi) @@ -1056,7 +1054,7 @@ (is (eql top-1 (player role-1 :revision revision-0))) (is-false (player role-1 :revision revision-0-5)) (is (eql top-1 (player role-1 :revision revision-2))) - (signals error (add-player role-1 top-2)) + (signals tm-reference-error (add-player role-1 top-2)) (add-player role-2 top-1 :revision revision-2) (is (= (length (union (list role-1 role-2) (player-in-roles top-1 :revision revision-0))) 2)) @@ -2097,11 +2095,12 @@ :start-revision rev-1 :identifier psi-1 :parent-construct top-1))) - (signals error (make-construct 'd::PersistentIdAssociationC - :start-revision rev-1 - :identifier psi-1)) + (signals missing-argument-error + (make-construct 'd::PersistentIdAssociationC + :start-revision rev-1 + :identifier psi-1)) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'VersionedConstructC)) + (signals missing-argument-error (make-construct 'VersionedConstructC)) (is (= (length (d::versions vc)) 1)) (is-true (find-if #'(lambda(vi) (and (= (d::start-revision vi) rev-2) @@ -2127,13 +2126,14 @@ :uri "tid-2" :xtm-id "xtm-id-2" :identified-construct top-1 :start-revision rev-1))) - (signals error (make-construct 'TopicIdentificationC + (signals missing-argument-error (make-construct 'TopicIdentificationC :uri "uri")) - (signals error (make-construct 'TopicIdentificationC + (signals missing-argument-error (make-construct 'TopicIdentificationC :xtm-id "xtm-id")) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'TopicIdentificationC :uri "uri" - :identified-construct top-1)) + (signals missing-argument-error + (make-construct 'TopicIdentificationC :uri "uri" + :identified-construct top-1)) (is (string= (uri tid-1) "tid-1")) (is (string= (xtm-id tid-1) "xtm-id-1")) (is-false (d::slot-p tid-1 'd::identified-construct)) @@ -2168,8 +2168,8 @@ :identified-construct top-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'PersistentIdC)) - (signals error (make-construct 'PersistentIdC :uri "uri" + (signals missing-argument-error (make-construct 'PersistentIdC)) + (signals missing-argument-error (make-construct 'PersistentIdC :uri "uri" :identified-construct top-1)) (is (string= (uri psi-1) "psi-1")) (is-false (d::slot-p psi-1 'd::identified-construct)) @@ -2203,8 +2203,8 @@ :identified-construct top-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'SubjectLocatorC)) - (signals error (make-construct 'SubjectLocatorC :uri "uri" + (signals missing-argument-error (make-construct 'SubjectLocatorC)) + (signals missing-argument-error (make-construct 'SubjectLocatorC :uri "uri" :identified-construct top-1)) (is (string= (uri sl-1) "sl-1")) (is-false (d::slot-p sl-1 'd::identified-construct)) @@ -2238,8 +2238,8 @@ :identified-construct top-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'ItemIdentifierC)) - (signals error (make-construct 'ItemIdentifierC :uri "uri" + (signals missing-argument-error (make-construct 'ItemIdentifierC)) + (signals missing-argument-error (make-construct 'ItemIdentifierC :uri "uri" :identified-construct top-1)) (is (string= (uri ii-1) "ii-1")) (is-false (d::slot-p ii-1 'd::identified-construct)) @@ -2287,12 +2287,16 @@ :parent top-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'OccurrenceC - :item-identifiers (list ii-1))) - (signals error (make-construct 'OccurrenceC :reifier reifier-1)) - (signals error (make-construct 'OccurrenceC :parent top-1)) - (signals error (make-construct 'OccurrenceC :instance-of type-1)) - (signals error (make-construct 'OccurrenceC :themes (list theme-1))) + (signals missing-argument-error + (make-construct 'OccurrenceC :item-identifiers (list ii-1))) + (signals missing-argument-error + (make-construct 'OccurrenceC :reifier reifier-1)) + (signals missing-argument-error + (make-construct 'OccurrenceC :parent top-1)) + (signals missing-argument-error + (make-construct 'OccurrenceC :instance-of type-1)) + (signals missing-argument-error + (make-construct 'OccurrenceC :themes (list theme-1))) (is (string= (charvalue occ-1) "")) (is (string= (datatype occ-1) *xml-string*)) (is-false (item-identifiers occ-1)) @@ -2344,13 +2348,18 @@ :parent top-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'NameC - :item-identifiers (list ii-1))) - (signals error (make-construct 'NameC :reifier reifier-1)) - (signals error (make-construct 'NameC :parent top-1)) - (signals error (make-construct 'NameC :instance-of type-1)) - (signals error (make-construct 'NameC :themes (list theme-1))) - (signals error (make-construct 'NameC :variants (list variant-1))) + (signals missing-argument-error + (make-construct 'NameC :item-identifiers (list ii-1))) + (signals missing-argument-error + (make-construct 'NameC :reifier reifier-1)) + (signals missing-argument-error + (make-construct 'NameC :parent top-1)) + (signals missing-argument-error + (make-construct 'NameC :instance-of type-1)) + (signals missing-argument-error + (make-construct 'NameC :themes (list theme-1))) + (signals missing-argument-error + (make-construct 'NameC :variants (list variant-1))) (is (string= (charvalue name-1) "")) (is-false (item-identifiers name-1)) (is-false (reifier name-1)) @@ -2399,11 +2408,14 @@ :parent name-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'VariantC - :item-identifiers (list ii-1))) - (signals error (make-construct 'VariantC :reifier reifier-1)) - (signals error (make-construct 'VariantC :parent name-1)) - (signals error (make-construct 'VariantC :themes (list theme-1))) + (signals missing-argument-error + (make-construct 'VariantC :item-identifiers (list ii-1))) + (signals missing-argument-error + (make-construct 'VariantC :reifier reifier-1)) + (signals missing-argument-error + (make-construct 'VariantC :parent name-1)) + (signals missing-argument-error + (make-construct 'VariantC :themes (list theme-1))) (is (string= (charvalue variant-1) "")) (is (string= (datatype variant-1) *xml-string*)) (is-false (item-identifiers variant-1)) @@ -2448,12 +2460,16 @@ :parent assoc-1 :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'RoleC - :item-identifiers (list ii-1))) - (signals error (make-construct 'RoleC :reifier reifier-1)) - (signals error (make-construct 'RoleC :parent assoc-1)) - (signals error (make-construct 'RoleC :instance-of type-1)) - (signals error (make-construct 'RoleC :player player-1)) + (signals missing-argument-error + (make-construct 'RoleC :item-identifiers (list ii-1))) + (signals missing-argument-error + (make-construct 'RoleC :reifier reifier-1)) + (signals missing-argument-error + (make-construct 'RoleC :parent assoc-1)) + (signals missing-argument-error + (make-construct 'RoleC :instance-of type-1)) + (signals missing-argument-error + (make-construct 'RoleC :player player-1)) (is-false (item-identifiers role-1)) (is-false (reifier role-1)) (is-false (instance-of role-1)) @@ -2496,7 +2512,7 @@ :start-revision rev-1 :item-identifiers (list ii-3)))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'TopicMapC)) + (signals missing-argument-error (make-construct 'TopicMapC)) (is (eql (reifier tm-1) reifier-1)) (is (= (length (item-identifiers tm-1)) 2)) (is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2)) @@ -2566,12 +2582,12 @@ :roles (list role-1 role-2 role-2-2))) (assoc-2 (make-construct 'AssociationC :start-revision rev-1))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'AssociationC)) - (signals error (make-construct 'AssociationC - :start-revision rev-1 - :roles (list - (list :player player-1 - :instance-of r-type-1)))) + (signals missing-argument-error (make-construct 'AssociationC)) + (signals missing-argument-error + (make-construct 'AssociationC + :start-revision rev-1 + :roles (list (list :player player-1 + :instance-of r-type-1)))) (is (eql (instance-of assoc-1) type-1)) (is-true (themes assoc-1)) (is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2)) @@ -2684,7 +2700,7 @@ :names (list name-1) :occurrences (list occ-1)))) (setf *TM-REVISION* rev-1) - (signals error (make-construct 'TopicC)) + (signals missing-argument-error (make-construct 'TopicC)) (is-false (item-identifiers top-1)) (is-false (psis top-1)) (is-false (locators top-1)) From lgiessmann at common-lisp.net Thu Apr 8 11:21:51 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 08 Apr 2010 07:21:51 -0400 Subject: [isidorus-cvs] r269 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 8 07:21:50 2010 New Revision: 269 Log: new-datamodel: fixed 2 bugs in "move-referenced-constructs" --> "ReifiableConstructC" 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 Thu Apr 8 07:21:50 2010 @@ -3539,26 +3539,28 @@ (move-identifiers source destination :revision revision) (let ((source-reifier (reifier source :revision revision)) (destination-reifier (reifier destination :revision revision))) - (cond ((and source-reifier destination-reifier) - (delete-reifier (reified-construct source-reifier - :revision revision) - source-reifier :revision revision) - (delete-reifier (reified-construct destination-reifier - :revision revision) - destination-reifier :revision revision) - (let ((merged-reifier - (merge-constructs source-reifier destination-reifier - :revision revision))) - (add-reifier destination merged-reifier :revision revision))) - (source-reifier - (delete-reifier (reified-construct source-reifier - :revision revision) - source-reifier :revision revision) - (add-reifier destination source-reifier :revision revision) - source-reifier) - (destination-reifier - (add-reifier destination destination-reifier :revision revision) - destination-reifier)))))) + (list + (cond ((and source-reifier destination-reifier) + (delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (delete-reifier (reified-construct destination-reifier + :revision revision) + destination-reifier :revision revision) + (let ((merged-reifier + (merge-constructs source-reifier destination-reifier + :revision revision))) + (add-reifier destination merged-reifier :revision revision) + merged-reifier)) + (source-reifier + (delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (add-reifier destination source-reifier :revision revision) + source-reifier) + (destination-reifier + (add-reifier destination destination-reifier :revision revision) + destination-reifier))))))) (defmethod move-referenced-constructs ((source NameC) (destination NameC) 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 Thu Apr 8 07:21:50 2010 @@ -18,7 +18,8 @@ duplicate-identifier-error missing-argument-error tm-reference-error - object-not-found-error) + object-not-found-error + not-mergable-error) (:import-from :constants *xml-string* *xml-uri*) @@ -77,7 +78,8 @@ :test-make-TopicMapC :test-make-AssociationC :test-make-TopicC - :test-find-oldest-construct)) + :test-find-oldest-construct + :test-move-referenced-constructs-ReifiableConstructC)) ;;TODO: test merge-constructs @@ -2787,6 +2789,53 @@ (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1)))))) +(test test-move-referenced-constructs-ReifiableConstructC () + "Tests the generic move-referenced-constructs corresponding to ReifiableConstructC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))) + (let ((reifier-1 (make-construct 'TopicC :start-revision rev-2)) + (reifier-2 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :instance-of type-2 + :themes (list theme-1 theme-2) + :charvalue "occ")) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-3) + :charvalue "occ" + :instance-of type-1 + :themes (list theme-1 theme-2) + :reifier reifier-2))) + (setf *TM-REVISION* rev-1) + (delete-type occ-1 type-2 :revision rev-2) + (add-type occ-1 type-1 :revision rev-2) + (is (eql reifier-1 (reifier occ-1 :revision rev-2))) + (is (eql reifier-2 (reifier occ-2 :revision rev-2))) + (is (= (length (union (list ii-1 ii-2 reifier-2) + (d::move-referenced-constructs occ-1 occ-2 + :revision rev-2))) + 3)) + (is (= (length (item-identifiers occ-2 :revision rev-2)) 3)) + (is (= (length (union (item-identifiers occ-2 :revision rev-2) + (list ii-1 ii-2 ii-3))) + 3)) + (is-false (item-identifiers occ-1 :revision rev-2)) + (is-false (reifier occ-1 :revision rev-2)) + (is (eql (reifier occ-2 :revision rev-2) reifier-2)) + (is-true (d::marked-as-deleted-p reifier-1))))))) + + (defun run-datamodel-tests() @@ -2845,4 +2894,5 @@ (it.bese.fiveam:run! 'test-make-AssociationC) (it.bese.fiveam:run! 'test-make-TopicC) (it.bese.fiveam:run! 'test-find-oldest-construct) + (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) ) \ No newline at end of file From lgiessmann at common-lisp.net Thu Apr 8 15:00:35 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 08 Apr 2010 11:00:35 -0400 Subject: [isidorus-cvs] r270 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 8 11:00:35 2010 New Revision: 270 Log: new-datamodel: modified "move-referenced-constructs" --> "NameC"; added some unti-tests 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 Thu Apr 8 11:00:35 2010 @@ -3539,28 +3539,30 @@ (move-identifiers source destination :revision revision) (let ((source-reifier (reifier source :revision revision)) (destination-reifier (reifier destination :revision revision))) - (list - (cond ((and source-reifier destination-reifier) - (delete-reifier (reified-construct source-reifier - :revision revision) - source-reifier :revision revision) - (delete-reifier (reified-construct destination-reifier - :revision revision) - destination-reifier :revision revision) - (let ((merged-reifier - (merge-constructs source-reifier destination-reifier - :revision revision))) - (add-reifier destination merged-reifier :revision revision) - merged-reifier)) - (source-reifier - (delete-reifier (reified-construct source-reifier - :revision revision) - source-reifier :revision revision) - (add-reifier destination source-reifier :revision revision) - source-reifier) - (destination-reifier - (add-reifier destination destination-reifier :revision revision) - destination-reifier))))))) + (let ((result + (cond ((and source-reifier destination-reifier) + (delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (delete-reifier (reified-construct destination-reifier + :revision revision) + destination-reifier :revision revision) + (let ((merged-reifier + (merge-constructs source-reifier destination-reifier + :revision revision))) + (add-reifier destination merged-reifier :revision revision) + merged-reifier)) + (source-reifier + (delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (add-reifier destination source-reifier :revision revision) + source-reifier) + (destination-reifier + (add-reifier destination destination-reifier :revision revision) + nil)))) + (when result + (list result))))))) (defmethod move-referenced-constructs ((source NameC) (destination NameC) 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 Thu Apr 8 11:00:35 2010 @@ -79,7 +79,8 @@ :test-make-AssociationC :test-make-TopicC :test-find-oldest-construct - :test-move-referenced-constructs-ReifiableConstructC)) + :test-move-referenced-constructs-ReifiableConstructC + :test-move-referenced-constructs-NameC)) ;;TODO: test merge-constructs @@ -2836,6 +2837,86 @@ (is-true (d::marked-as-deleted-p reifier-1))))))) +(test test-move-referenced-constructs-NameC () + "Tests the generic move-referenced-constructs corresponding to NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200)) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (reifier-2 (make-construct 'TopicC :start-revision rev-2)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :themes (list theme-1) + :charvalue "var-1" + :item-identifiers (list ii-1) + :reifier reifier-2)) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :themes (list theme-1) + :charvalue "var-2+4")) + (variant-3 (make-construct 'VariantC + :start-revision rev-1 + :themes (list theme-2) + :charvalue "var-3")) + (variant-4 (make-construct 'VariantC + :start-revision rev-1 + :themes (list theme-1) + :charvalue "var-2+4"))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name" + :variants (list variant-1 variant-2) + :instance-of type-1 + :item-identifiers (list ii-2))) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name" + :variants (list variant-3 variant-4) + :instance-of type-1 + :reifier reifier-1))) + (setf *TM-REVISION* rev-1) + (is (= (length (union (list variant-1 variant-2) + (variants name-1))) 2)) + (is (= (length (union (list variant-3 variant-4) + (variants name-2))) 2)) + (is-false (reifier name-1)) + (is (eql reifier-1 (reifier name-2))) + (is (= (length + (union (list variant-1 variant-2 ii-2) + (d::move-referenced-constructs name-1 name-2 + :revision rev-2))) + 3)) + (is-false (item-identifiers name-1 :revision rev-2)) + (is-false (reifier name-1 :revision rev-2)) + (is-false (variants name-1 :revision rev-2)) + (is (= (length (item-identifiers name-2 :revision rev-2)) 1)) + (is (= (length (union (list ii-2) + (item-identifiers name-2 :revision rev-2))) + 1)) + (is (eql (reifier name-2 :revision rev-2) reifier-1)) + (is (= (length (variants name-2 :revision rev-2)) 3)) + (is (= (length (union (list variant-1 variant-3 variant-4) + (variants name-2 :revision rev-2))) + 3)) + (is-true + (find-if + #'(lambda(var) + (and (= (length (item-identifiers var :revision rev-2)) 1) + (string= (uri (first (item-identifiers var + :revision rev-2))) + "ii-1"))) + (variants name-2 :revision rev-2))) + (is-true + (find-if #'(lambda(var) + (eql (reifier var :revision rev-2) reifier-2)) + (variants name-2 :revision rev-2))))))))) + + (defun run-datamodel-tests() @@ -2895,4 +2976,5 @@ (it.bese.fiveam:run! 'test-make-TopicC) (it.bese.fiveam:run! 'test-find-oldest-construct) (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) + (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) ) \ No newline at end of file From lgiessmann at common-lisp.net Fri Apr 9 15:36:02 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 09 Apr 2010 11:36:02 -0400 Subject: [isidorus-cvs] r271 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Fri Apr 9 11:36:02 2010 New Revision: 271 Log: new-datamodel: added some unit-tests; fixed bugs in "add-name", "add-occurrence", "add-role" and "find-oldest-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 Fri Apr 9 11:36:02 2010 @@ -157,16 +157,18 @@ +;;TODO: modify 2x add-parent --> use add-characteristic and add-role +;;TODO: call merge-if-equivalent in 2x add-parent ;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? ;; versioned-construct of the called construct, same for add-xy ??? +;; and associations of player ;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), ;; add-psi, add-locator (--> duplicate-identifier-error) -;;TODO: implement a macro "with-merge-construct" that merges constructs -;; after some data-operations are completed (should be passed as body) -;; and a merge should be done +;;TODO: implement a macro with-merge-constructs, that merges constructs +;; after all operations in the body were called @@ -840,6 +842,19 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric merge-if-equivalent (new-characteristic parent-construct + &key revision) + (:documentation "Merges the new characteristic/role with one equivalent of the + parent's charateristics/roles instead of adding the entire new + characteristic/role to the parent.")) + + +(defgeneric parent (construct &key revision) + (:documentation "Returns the parent construct of the passed object that + corresponds with the given revision. The returned construct + can be a TopicC or a NameC.")) + + (defgeneric delete-if-not-referenced (construct) (:documentation "Calls delete-construct for the given object if it is not referenced by any other construct.")) @@ -1672,20 +1687,22 @@ :referenced-construct name :existing-reference (parent name :revision revision) :new-reference construct))) - (let ((all-names - (map 'list #'characteristic (slot-p construct 'names)))) - (if (find name all-names) - (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) - construct) - return name-assoc))) - (add-to-version-history name-assoc :start-revision revision)) - (make-construct 'NameAssociationC - :parent-construct construct - :characteristic name - :start-revision revision))) - (add-to-version-history construct :start-revision revision) - construct)) + (if (merge-if-equivalent name construct :revision revision) + construct + (let ((all-names + (map 'list #'characteristic (slot-p construct 'names)))) + (if (find name all-names) + (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) + when (eql (parent-construct name-assoc) + construct) + return name-assoc))) + (add-to-version-history name-assoc :start-revision revision)) + (make-construct 'NameAssociationC + :parent-construct construct + :characteristic name + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) (defgeneric delete-name (construct name &key revision) @@ -1730,19 +1747,21 @@ :referenced-construct occurrence :existing-reference (parent occurrence :revision revision) :new-reference construct)) - (let ((all-occurrences - (map 'list #'characteristic (slot-p construct 'occurrences)))) - (if (find occurrence all-occurrences) - (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) construct) - return occ-assoc))) - (add-to-version-history occ-assoc :start-revision revision)) - (make-construct 'OccurrenceAssociationC - :parent-construct construct - :characteristic occurrence - :start-revision revision))) - (add-to-version-history construct :start-revision revision) - construct)) + (if (merge-if-equivalent occurrence construct :revision revision) + construct + (let ((all-occurrences + (map 'list #'characteristic (slot-p construct 'occurrences)))) + (if (find occurrence all-occurrences) + (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (parent-construct occ-assoc) construct) + return occ-assoc))) + (add-to-version-history occ-assoc :start-revision revision)) + (make-construct 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) (defgeneric delete-occurrence (construct occurrence &key revision) @@ -2000,8 +2019,9 @@ ;;; CharacteristicC (defmethod delete-if-not-referenced ((construct CharacteristicC)) (let ((references (slot-p construct 'parent))) - (when (and (<= (length references) 1) - (marked-as-deleted-p (first references))) + (when (or (not references) + (and (= (length references) 1) + (marked-as-deleted-p (first references)))) (delete-construct construct)))) @@ -2099,16 +2119,12 @@ t)) -(defgeneric parent (construct &key revision) - (:documentation "Returns the parent construct of the passed object that - corresponds with the given revision. The returned construct - can be a TopicC or a NameC.") - (:method ((construct CharacteristicC) &key (revision *TM-REVISION*)) - (let ((valid-associations - (filter-slot-value-by-revision construct 'parent - :start-revision revision))) - (when valid-associations - (parent-construct (first valid-associations)))))) +(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'parent + :start-revision revision))) + (when valid-associations + (parent-construct (first valid-associations))))) (defmethod add-parent ((construct CharacteristicC) @@ -2290,19 +2306,21 @@ :referenced-construct variant :existing-reference (parent variant :revision revision) :new-reference construct))) - (let ((all-variants - (map 'list #'characteristic (slot-p construct 'variants)))) - (if (find variant all-variants) - (let ((variant-assoc - (loop for variant-assoc in (slot-p construct 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (add-to-version-history variant-assoc :start-revision revision)) - (make-construct 'VariantAssociationC - :characteristic variant - :parent-construct construct - :start-revision revision))) - construct)) + (if (merge-if-equivalent variant construct :revision revision) + construct + (let ((all-variants + (map 'list #'characteristic (slot-p construct 'variants)))) + (if (find variant all-variants) + (let ((variant-assoc + (loop for variant-assoc in (slot-p construct 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (add-to-version-history variant-assoc :start-revision revision)) + (make-construct 'VariantAssociationC + :characteristic variant + :parent-construct construct + :start-revision revision)) + construct)))) (defgeneric delete-variant (construct variant &key revision) @@ -2417,20 +2435,22 @@ (:documentation "Adds the given role to the passed association-construct.") (:method ((construct AssociationC) (role RoleC) &key (revision *TM-REVISION*)) - (let ((all-roles - (map 'list #'role (slot-p construct 'roles)))) - (if (find role all-roles) - (let ((role-assoc - (loop for role-assoc in (slot-p construct 'roles) - when (eql (role role-assoc) role) - return role-assoc))) - (add-to-version-history role-assoc :start-revision revision)) - (make-construct 'RoleAssociationC - :role role - :parent-construct construct - :start-revision revision))) - (add-to-version-history construct :start-revision revision) - construct)) + (if (merge-if-equivalent role construct :revision revision) + construct + (let ((all-roles + (map 'list #'role (slot-p construct 'roles)))) + (if (find role all-roles) + (let ((role-assoc + (loop for role-assoc in (slot-p construct 'roles) + when (eql (role role-assoc) role) + return role-assoc))) + (add-to-version-history role-assoc :start-revision revision)) + (make-construct 'RoleAssociationC + :role role + :parent-construct construct + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) (defgeneric delete-role (construct role &key revision) @@ -2457,8 +2477,9 @@ ;;; RoleC (defmethod delete-if-not-referenced ((construct RoleC)) (let ((references (slot-p construct 'parent))) - (when (and (<= (length references) 1) - (marked-as-deleted-p (first references))) + (when (or (not references) + (and (= (length references) 1) + (marked-as-deleted-p (first references)))) (delete-construct construct)))) @@ -2988,7 +3009,7 @@ (:method ((construct ScopableC) (theme-topic TopicC) &key (revision (error (make-condition 'missing-argument-error :message "From delete-theme(): revision must be set" - :argument-symbol 'revsion + :argument-symbol 'revision :function-symbol 'delete-theme)))) (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes) when (eql (theme-topic theme-assoc) theme-topic) @@ -3388,7 +3409,7 @@ (not start-revision)) (error (make-condition 'missing-argument-error :message "From make-characteristic(): start-revision must be set" - :argument-symbol 'start-revsion + :argument-symbol 'start-revision :function-symbol 'make-characgteristic))) (let ((characteristic (let ((existing-characteristic @@ -3895,4 +3916,59 @@ (move-referenced-constructs newer-role older-role :revision revision) (delete-if-not-referenced newer-role) - older-role))))))) \ No newline at end of file + older-role))))))) + + +(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((possible-roles + (remove-if #'(lambda(role) + (when (parent role :revision revision) + role)) + (map 'list #'role (slot-p parent-construct 'roles))))) + (let ((equivalent-role + (remove-if + #'null + (map 'list + #'(lambda(role) + (when + (strictly-equivalent-constructs role new-role + :revision revision) + role)) + possible-roles)))) + (when equivalent-role + (merge-constructs (first equivalent-role) new-role + :revision revision))))) + + +(defmethod merge-if-equivalent ((new-characteristic CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or TopicC NameC) parent-construct)) + (let ((all-existing-characteristics + (map 'list #'characteristic + (cond ((typep new-characteristic 'OccurrenceC) + (slot-p parent-construct 'occurrences)) + ((typep new-characteristic 'NameC) + (slot-p parent-construct 'names)) + ((typep new-characteristic 'VariantC) + (slot-p parent-construct 'variants)))))) + (let ((possible-characteristics ;all characteristics that are not referenced + ;other constructs at the given revision + (remove-if #'(lambda(char) + (parent char :revision revision)) + all-existing-characteristics))) + (let ((equivalent-construct + (remove-if + #'null + (map 'list + #'(lambda(char) + (when + (strictly-equivalent-constructs char new-characteristic + :revision revision) + char)) + possible-characteristics)))) + (when equivalent-construct + (merge-constructs (first equivalent-construct) new-characteristic + :revision revision)))))) \ No newline at end of file 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 Fri Apr 9 11:36:02 2010 @@ -2741,53 +2741,67 @@ (test test-find-oldest-construct () "Tests the generic find-oldest-construct." (with-fixture with-empty-db (*db-dir*) - (let ((top-1 (make-instance 'TopicC)) - (top-2 (make-instance 'TopicC)) - (tm-1 (make-instance 'TopicMapC)) - (tm-2 (make-instance 'TopicMapC)) - (assoc-1 (make-instance 'AssociationC)) - (assoc-2 (make-instance 'AssociationC)) - (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) - (variant-1 (make-instance 'VariantC)) - (variant-2 (make-instance 'VariantC)) - (name-1 (make-instance 'NameC)) - (name-2 (make-instance 'NameC)) - (role-1 (make-instance 'RoleC)) - (role-2 (make-instance 'RoleC)) - (rev-1 100) + (let ((rev-1 100) (rev-2 200) (rev-3 300)) - (setf *TM-REVISION* rev-1) - (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (add-item-identifier top-1 ii-1 :revision rev-3) - (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (add-item-identifier assoc-1 ii-2 :revision rev-2) - (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2))) - (add-item-identifier top-2 ii-1 :revision rev-1) - (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (add-variant name-1 variant-1 :revision rev-3) - (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (add-variant name-1 variant-2 :revision rev-2) - (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) - (add-variant name-2 variant-1 :revision rev-1) - (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (add-role assoc-1 role-1 :revision rev-3) - (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (add-role assoc-1 role-2 :revision rev-2) - (is (eql role-2 (d::find-oldest-construct role-1 role-2))) - (add-role assoc-2 role-1 :revision rev-1) - (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) - (d::add-to-version-history tm-1 :start-revision rev-3) - (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) - (d::add-to-version-history tm-2 :start-revision rev-1) - (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2))) - (d::add-to-version-history tm-1 :start-revision rev-1) - (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) - (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1)))))) + (let ((theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (tm-1 (make-instance 'TopicMapC)) + (tm-2 (make-instance 'TopicMapC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-2" + :themes (list theme-2))) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (role-1 (make-construct 'RoleC + :start-revision rev-1 + :player player-1)) + (role-2 (make-construct 'RoleC + :start-revision rev-1 + :player player-2))) + (setf *TM-REVISION* rev-1) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier top-1 ii-1 :revision rev-3) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier assoc-1 ii-2 :revision rev-2) + (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier top-2 ii-1 :revision rev-1) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (add-variant name-1 variant-1 :revision rev-3) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (add-variant name-1 variant-2 :revision rev-2) + (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) ;x + (add-variant name-2 variant-1 :revision rev-1) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) + (add-role assoc-1 role-1 :revision rev-3) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) ;x + (add-role assoc-1 role-2 :revision rev-2) + (is (eql role-2 (d::find-oldest-construct role-1 role-2))) + (add-role assoc-2 role-1 :revision rev-1) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-1 :start-revision rev-3) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-2 :start-revision rev-1) + (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-1 :start-revision rev-1) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1)))))))) (test test-move-referenced-constructs-ReifiableConstructC () From lgiessmann at common-lisp.net Sun Apr 11 13:16:12 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 11 Apr 2010 09:16:12 -0400 Subject: [isidorus-cvs] r272 - in trunk/src: ajax/javascripts unit_tests Message-ID: Author: lgiessmann Date: Sun Apr 11 09:16:12 2010 New Revision: 272 Log: service-registry: added the file textgrid.xtm which constraints an ontology for isidorus used as textgrid-service-registry; ajax: fixed a bug when there are no players available for role-player-constraints; ajax: fixed a bug when there are no players available for other-role-player-constraints Added: trunk/src/unit_tests/textgrid.xtm Modified: trunk/src/ajax/javascripts/tmcl_tools.js Modified: trunk/src/ajax/javascripts/tmcl_tools.js ============================================================================== --- trunk/src/ajax/javascripts/tmcl_tools.js (original) +++ trunk/src/ajax/javascripts/tmcl_tools.js Sun Apr 11 09:16:12 2010 @@ -209,6 +209,7 @@ for(var k = 0; k !== rpcs[j].playerType.length; ++k){ for(var l = 0; l !== rpcs[j].playerType[k].length; ++l){ if(instanceOfsPsis.indexOf(rpcs[j].playerType[k][l]) !== -1){ + if(!rpcs[j].players) rpcs[j].players = new Array(); rpcs[j].players.push(new Array(CURRENT_TOPIC)); break; } @@ -224,6 +225,7 @@ for(var k = 0; k !== orcs[j].playerType.length; ++k){ for(var l = 0; l !== orcs[j].playerType[k].length; ++l){ if(instanceOfsPsis.indexOf(orcs[j].playerType[k][l]) !== -1){ + if(!orcs[j].players) orcs[j].players = new Array(); orcs[j].players.push(new Array(CURRENT_TOPIC)); break; } @@ -232,6 +234,7 @@ for(var k = 0; k !== orcs[j].otherPlayerType.length; ++k){ for(var l = 0; l !== orcs[j].otherPlayerType[k].length; ++l){ if(instanceOfsPsis.indexOf(orcs[j].otherPlayerType[k][l]) !== -1){ + if (!orcs[j].otherPlayers) orcs[j].otherPlayers = new Array(); orcs[j].otherPlayers.push(new Array(CURRENT_TOPIC)); break; } Added: trunk/src/unit_tests/textgrid.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/textgrid.xtm Sun Apr 11 09:16:12 2010 @@ -0,0 +1,1667 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^http://textgrid.org/isidorus/.+/.+$ + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^http://textgrid.org/isidorus/url/.+$ + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^http://textgrid.org/isidorus/parameter/.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 0 + + + + ^.*$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 1 + + + + .* + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#string + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#anyUri + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 1 + + + + ^.*$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 1 + + + + .* + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From lgiessmann at common-lisp.net Sun Apr 11 17:55:05 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 11 Apr 2010 13:55:05 -0400 Subject: [isidorus-cvs] r273 - trunk/src/json Message-ID: Author: lgiessmann Date: Sun Apr 11 13:55:05 2010 New Revision: 273 Log: registry: modified "make-tree-view" --> currently all constraints and types are not displayed, except the user-defined topic-types Modified: trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_constants.lisp Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Sun Apr 11 13:55:05 2010 @@ -1275,15 +1275,43 @@ (remove-if #'(lambda(x) (when (eql topic-instance x) t)) (get-direct-subtypes-of-topic topic-instance))))))) - (list :topic topic-instance - :is-type is-type - :is-instance is-instance - :instances (map 'list #'(lambda(x) - (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) - isas-of-this) - :subtypes (map 'list #'(lambda(x) - (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) - akos-of-this))))) + (let ((cleaned-isas ;;all constraint topics are removed + (remove-if #'null (map 'list #'(lambda(top-entry) + (when (find-if #'(lambda(psi) + (unless (or (string= (uri psi) *constraint-psi*) + (string= (uri psi) *occurrencetype-psi*) + (string= (uri psi) *nametype-psi*) + (string= (uri psi) *associationtype-psi*) + (string= (uri psi) *roletype-psi*) + (string= (uri psi) *scopetype-psi*) + (string= (uri psi) *schema-psi*)) + top-entry)) + (psis (getf top-entry :topic))) + top-entry)) + isas-of-this))) + (cleaned-akos ;;all constraint topics are removed + (remove-if #'null (map 'list #'(lambda(top-entry) + (when (find-if #'(lambda(psi) + (unless (or (string= (uri psi) *constraint-psi*) + (string= (uri psi) *occurrencetype-psi*) + (string= (uri psi) *nametype-psi*) + (string= (uri psi) *associationtype-psi*) + (string= (uri psi) *roletype-psi*) + (string= (uri psi) *scopetype-psi*) + (string= (uri psi) *schema-psi*)) + top-entry)) + (psis (getf top-entry :topic))) + top-entry)) + akos-of-this)))) + (list :topic topic-instance + :is-type is-type + :is-instance is-instance + :instances (map 'list #'(lambda(x) + (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) + cleaned-isas) + :subtypes (map 'list #'(lambda(x) + (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) + cleaned-akos)))))) (defun get-all-tree-roots () Modified: trunk/src/json/json_tmcl_constants.lisp ============================================================================== --- trunk/src/json/json_tmcl_constants.lisp (original) +++ trunk/src/json/json_tmcl_constants.lisp Sun Apr 11 13:55:05 2010 @@ -9,7 +9,9 @@ (defpackage :json-tmcl-constants (:use :cl) - (:export :*topictype-psi* + (:export :*schema-psi* + :*constraint-psi* + :*topictype-psi* :*topictype-constraint-psi* :*associationtype-psi* :*associationtype-constraint-psi* @@ -51,6 +53,9 @@ (in-package :json-tmcl-constants) + +(defparameter *schema-psi* "http://psi.topicmaps.org/tmcl/schema") +(defparameter *constraint-psi* "http://psi.topicmaps.org/tmcl/constraint") (defparameter *topictype-psi* "http://psi.topicmaps.org/tmcl/topic-type") (defparameter *topictype-constraint-psi* "http://psi.topicmaps.org/tmcl/topic-type-constraint") (defparameter *associationtype-psi* "http://psi.topicmaps.org/tmcl/association-type") From lgiessmann at common-lisp.net Mon Apr 12 15:06:20 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 12 Apr 2010 11:06:20 -0400 Subject: [isidorus-cvs] r274 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Mon Apr 12 11:06:19 2010 New Revision: 274 Log: new-datamodel: added merging of characteristics when added with "add-" 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 Mon Apr 12 11:06:19 2010 @@ -157,12 +157,9 @@ -;;TODO: modify 2x add-parent --> use add-characteristic and add-role -;;TODO: call merge-if-equivalent in 2x add-parent ;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? ;; versioned-construct of the called construct, same for add-xy ??? ;; and associations of player -;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -842,6 +839,12 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric find-self-or-equal (construct parent-construct &key revision) + (:documentation "Returns the construct 'construct' if is owned by the + parent-construct or an equal construct or nil if there + is no equal one.")) + + (defgeneric merge-if-equivalent (new-characteristic parent-construct &key revision) (:documentation "Merges the new characteristic/role with one equivalent of the @@ -1692,10 +1695,11 @@ (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) - (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) - construct) - return name-assoc))) + (let ((name-assoc + (loop for name-assoc in (slot-p construct 'names) + when (eql (parent-construct name-assoc) + construct) + return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) (make-construct 'NameAssociationC :parent-construct construct @@ -1752,9 +1756,10 @@ (let ((all-occurrences (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) - (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) construct) - return occ-assoc))) + (let ((occ-assoc + (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (parent-construct occ-assoc) construct) + return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) (make-construct 'OccurrenceAssociationC :parent-construct construct @@ -2017,6 +2022,27 @@ ;;; CharacteristicC +(defmethod find-self-or-equal ((construct CharacteristicC) + (parent-construct TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or OccurrenceC NameC) construct)) + (let ((chars (if (typep construct 'OccurrenceC) + (occurrences parent-construct :revision revision) + (names parent-construct :revision revision)))) + (let ((self (find construct chars))) + (if self + self + (let ((equal-char + (remove-if #'null + (map 'list + #'(lambda(char) + (strictly-equivalent-constructs + char construct :revision revision)) + chars)))) + (when equal-char + (first equal-char))))))) + + (defmethod delete-if-not-referenced ((construct CharacteristicC)) (let ((references (slot-p construct 'parent))) (when (or (not references) @@ -2130,6 +2156,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (declare (integer revision)) (let ((already-set-parent (parent construct :revision revision)) (same-parent-assoc ;should contain an object that was marked as deleted (loop for parent-assoc in (slot-p construct 'parent) @@ -2143,29 +2170,36 @@ :referenced-construct construct :existing-reference (parent construct :revision revision) :new-reference parent-construct))) - (cond (already-set-parent - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (let ((association-type (cond ((typep construct 'OccurrenceC) - 'OccurrenceAssociationC) - ((typep construct 'NameC) - 'NameAssociationC) - (t - 'VariantAssociationC)))) - (make-construct association-type - :characteristic construct - :parent-construct parent-construct - :start-revision revision))))) - (when (typep parent-construct 'VersionedConstructC) - (add-to-version-history parent-construct :start-revision revision)) - construct) + (let ((merged-char + (merge-if-equivalent construct parent-construct :revision revision))) + (if merged-char + merged-char + (progn + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc + :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc + :start-revision revision)) + (t + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision)))) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct))))) (defmethod delete-parent ((construct CharacteristicC) @@ -2215,6 +2249,24 @@ ;;; VariantC +(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((vars (variants parent-construct :revision revision))) + (let ((self (find construct vars))) + (if self + self + (let ((equal-var + (remove-if #'null + (map 'list + #'(lambda(var) + (strictly-equivalent-constructs + var construct :revision revision)) + vars)))) + (when equal-var + (first equal-var))))))) + + (defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC) &key (revision *TM-REVISION*)) (declare (ignorable revision)) @@ -2475,6 +2527,24 @@ ;;; RoleC +(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((p-roles (roles parent-construct :revision revision))) + (let ((self (find construct p-roles))) + (if self + self + (let ((equal-role + (remove-if #'null + (map 'list + #'(lambda(role) + (strictly-equivalent-constructs + role construct :revision revision)) + p-roles)))) + (when equal-role + (first equal-role))))))) + + (defmethod delete-if-not-referenced ((construct RoleC)) (let ((references (slot-p construct 'parent))) (when (or (not references) @@ -2586,6 +2656,7 @@ (defmethod add-parent ((construct RoleC) (parent-construct AssociationC) &key (revision *TM-REVISION*)) + (declare (integer revision)) (let ((already-set-parent (parent construct :revision revision)) (same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent) when (eql parent-construct (parent-construct parent-assoc)) @@ -2598,22 +2669,29 @@ :referenced-construct construct :existing-reference (parent construct :revision revision) :new-reference parent-construct))) - (cond (already-set-parent - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (make-construct 'RoleAssociationC - :role construct - :parent-construct parent-construct - :start-revision revision)))) - (add-to-version-history parent-construct :start-revision revision) - construct) + (let ((merged-role + (merge-if-equivalent construct parent-construct :revision revision))) + (if merged-role + merged-role + (progn + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc + :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc + :start-revision revision)) + (t + (make-construct 'RoleAssociationC + :role construct + :parent-construct parent-construct + :start-revision revision))) + (add-to-version-history parent-construct :start-revision revision) + construct))))) (defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) @@ -3287,12 +3365,16 @@ :instance-of instance-of) existing-role)) (map 'list #'role (slot-p parent 'roles))))))) - (cond ((> (length existing-roles) 1) - (merge-all-constructs existing-roles)) - (existing-roles - (first existing-roles)) - (t - (make-instance 'RoleC)))))) + (if (and existing-roles + (or (eql parent (parent (first existing-roles) + :revision start-revision)) + (not (parent (first existing-roles) + :revision start-revision)))) + (progn + (add-role parent (first existing-roles) + :revision start-revision) + (first existing-roles)) + (make-instance 'RoleC))))) (when player (add-player role player :revision start-revision)) (when parent @@ -3412,7 +3494,7 @@ :argument-symbol 'start-revision :function-symbol 'make-characgteristic))) (let ((characteristic - (let ((existing-characteristic + (let ((existing-characteristics (when parent (remove-if #'null @@ -3425,8 +3507,15 @@ :instance-of instance-of) existing-characteristic)) (get-all-characteristics parent class-symbol)))))) - (if existing-characteristic - (first existing-characteristic) + (if (and existing-characteristics + (or (eql parent (parent (first existing-characteristics) + :revision start-revision)) + (not (parent (first existing-characteristics) + :revision start-revision)))) + (progn + (add-characteristic parent (first existing-characteristics) + :revision start-revision) + (first existing-characteristics)) (make-instance class-symbol :charvalue charvalue :datatype datatype))))) (when (typep characteristic 'NameC) 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 Mon Apr 12 11:06:19 2010 @@ -80,7 +80,8 @@ :test-make-TopicC :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC - :test-move-referenced-constructs-NameC)) + :test-move-referenced-constructs-NameC + :test-move-referenced-constructs-TopicC)) ;;TODO: test merge-constructs @@ -2931,6 +2932,57 @@ (variants name-2 :revision rev-2))))))))) +(test test-move-referenced-constructs-TopicC () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200)) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-2")) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-2" + :themes (list theme-2))) + (variant-3 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1))) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-2" + :instance-of type-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1)))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1)) + ) + )))))) (defun run-datamodel-tests() @@ -2991,4 +3043,5 @@ (it.bese.fiveam:run! 'test-find-oldest-construct) (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) + (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC) ) \ No newline at end of file From lgiessmann at common-lisp.net Mon Apr 12 20:56:37 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 12 Apr 2010 16:56:37 -0400 Subject: [isidorus-cvs] r275 - in trunk/src: ajax/javascripts json rest_interface Message-ID: Author: lgiessmann Date: Mon Apr 12 16:56:36 2010 New Revision: 275 Log: json: started to implement a mark-as-deleted-handler that deleted from a given json-package topics, names, variants, occurrences and roles Modified: trunk/src/ajax/javascripts/constants.js trunk/src/json/json_tmcl.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Mon Apr 12 16:56:36 2010 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = /*"http://localhost:8000/";*/ "192.168.178.23:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Mon Apr 12 16:56:36 2010 @@ -11,6 +11,86 @@ ;; ============================================================================= +;; --- mark-as-deleted handler ------------------------------------------------- +;; ============================================================================= +; a test string ... +(defvar cl-user::*js-1* + "{\"type\":\"Topic\", + \"topics\":[\"http://textgrid.org/isidorus/tmcl/service\"], + \"associations\":[{\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"], + \"scopes\":null, + \"roles\":[{\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], + \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}, + {\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/topictype-role\"], + \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]}], + \"parent-topic\":[\"http://textgrid.org/isidorus/my-service/my-service\"], + \"parent-name\":{\"itemIdentities\":null, + \"type\":[\"http://textgrid.org/isidorus/tmcl/service-name\"], + \"scopes\":null, + \"value\":\"my-service\", + \"variants\":null}, + \"names\":[{\"itemIdentities\":null, + \"type\":[\"http://textgrid.org/isidorus/tmcl/service-name\"], + \"scopes\":null, + \"value\":\"my-service\", + \"variants\":null}], + \"variants\":[{\"itemIdentities\":null, + \"scopes\":[[\"http://textgrid.org/isidorus/tmcl/display\"]], + \"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", + \"value\":\"http://textgrid.org/isidorus/tmcl/service\"}, + \"resourceRef\":null}, + {\"itemIdentities\":null, + \"scopes\":[[\"http://textgrid.org/isidorus/tmcl/is-ref\"]], + \"resourceData\":null, + \"resourceRef\":\"http://any-ref.org\"}], + \"occurrences\":[{\"itemIdentities\":null, + \"type\":[\"http://textgrid.org/isidorus/tmcl/service-key\"], + \"scopes\":null, + \"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", + \"value\":\"service-key\"}}], + \"parent-association\":{\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"], + \"scopes\":null, + \"roles\":[{\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], + \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}, + {\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/topictype-role\"], + \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]}, + \"roles\":[{\"itemIdentities\":null, + \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], + \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}]}") + + +(defun mark-as-deleted-from-json (json-data) + (declare (string json-data)) + +;{\"type\":<\"Topic\" | \"Occurrence\" | \"Name\" +; \"Association\" | \"Role\" | \"Variant\" >, +; \"topics\": , +; \"associations\": , +; \"parent-topic\": , +; \"parent-name\": , +; \"names\": , +; \"variants\": , +; \"occurrences\": , +; \"parent-association\": +; \"roles\": } + (let ((values (json:decode-json-from-string json-data))) + values + )) + + + +;; ============================================================================= ;; --- all fragment constraints ------------------------------------------------ ;; ============================================================================= (defun get-constraints-of-fragment(topic-psis &key (treat-as 'type)) Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Mon Apr 12 16:56:36 2010 @@ -40,7 +40,8 @@ :*ajax-user-interface-url* :*ajax-user-interface-file-path* :*ajax-javascript-directory-path* - :*ajax-javascript-url-prefix*)) + :*ajax-javascript-url-prefix* + :*mark-as-deleted-url*)) (in-package :rest-interface) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Mon Apr 12 16:56:36 2010 @@ -26,6 +26,7 @@ (defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface (defparameter *ajax-javascript-directory-path* "ajax/javascripts") ;the directory which contains all necessary javascript files (defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files +(defparameter *mark-as-deleted-url* "/mark-as-deleted") ; the url suffix that calls the mark-as-deleted handler (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) (get-rdf-prefix *get-rdf-prefix*) @@ -43,7 +44,8 @@ (ajax-user-interface-css-prefix *ajax-user-interface-css-prefix*) (ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*) (ajax-javascripts-directory-path *ajax-javascript-directory-path*) - (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)) + (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) + (mark-as-deleted-url *mark-as-deleted-url*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -111,6 +113,9 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-summary-url #'return-topic-summaries) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -342,6 +347,31 @@ (format nil "Condition: \"~a\"" err)))))) +(defun mark-as-deleted-handler (&optional param) + "Marks the corresponding elem as deleted. + {\"type\":<\"'TopicC\" | \"'OccurrenceC\" | \"'NameC\" + \"'AssociationC\" | \"'RoleC\" | \"VariantC\" >, + \"object\":, + \"parent-topic\":, + \"parent-name\": }." + (declare (ignorable param)) ;param is currently not used + (let ((http-method (hunchentoot:request-method*))) + (if (or (eq http-method :PUT) + (eq http-method :POST)) + (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) + (handler-case + (with-writer-lock + (json-tmcl::mark-as-deleted-from-json json-data)) + (condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= From lgiessmann at common-lisp.net Tue Apr 13 12:06:02 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 13 Apr 2010 08:06:02 -0400 Subject: [isidorus-cvs] r276 - in trunk/src: . json Message-ID: Author: lgiessmann Date: Tue Apr 13 08:06:00 2010 New Revision: 276 Log: json: added the functionality to deleted topics and associations to the json/RESTful-interface Modified: trunk/src/isidorus.asd trunk/src/json/json_tmcl.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Apr 13 08:06:00 2010 @@ -162,7 +162,7 @@ :depends-on ("json_tmcl_constants" "json_exporter" )) (:file "json_tmcl_constants") (:file "json_tmcl" - :depends-on ("json_tmcl_validation"))) + :depends-on ("json_tmcl_validation" "json_importer"))) :depends-on ("model" "xml")) (:module "ajax" Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Tue Apr 13 08:06:00 2010 @@ -15,8 +15,9 @@ ;; ============================================================================= ; a test string ... (defvar cl-user::*js-1* - "{\"type\":\"Topic\", - \"topics\":[\"http://textgrid.org/isidorus/tmcl/service\"], + "{\"type\":\"Association\", + \"topics\":[\"http://textgrid.org/isidorus/tmcl/service\", + \"http://textgrid.org/isidorus/tmcl/parameter\"], \"associations\":[{\"itemIdentities\":null, \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"], \"scopes\":null, @@ -24,7 +25,7 @@ \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}, {\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/topictype-role\"], + \"type\":[\"http://psi.topicmaps.org/tmcl/topic-type-role\"], \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]}], \"parent-topic\":[\"http://textgrid.org/isidorus/my-service/my-service\"], \"parent-name\":{\"itemIdentities\":null, @@ -85,9 +86,109 @@ ; role> ; \"roles\": } (let ((values (json:decode-json-from-string json-data))) - values - )) + (let ((type nil) + (topics nil) + (associations nil) + (parent-topic nil) + (parent-name nil) + (names nil) + (variants nil) + (occurrences nil) + (parent-association nil) + (roles nil) + (rev (get-revision))) + (loop for entry in values + when (consp entry) + do (let ((st (car entry)) + (nd (cdr entry))) + (cond ((eql st :type) (setf type nd)) + ((eql st :topics) (setf topics nd)) + ((eql st :associations) (setf associations nd)) + ((eql st :parent-topic) (setf parent-topic nd)) + ((eql st :parent-name) (setf parent-name nd)) + ((eql st :names) (setf names nd)) + ((eql st :variants) (setf variants nd)) + ((eql st :occurrences) (setf occurrences nd)) + ((eql st :parent-association) (setf parent-association nd)) + ((eql st :roles) (setf roles nd))))) + (cond ((string= type "Topic") + (delete-topics-from-json topics rev)) + ((string= type "Association") + (delete-associations-from-json associations rev)) + ((string= type "Occurrence") + nil) + ((string= type "Name") + nil) + ((string= type "Variant") + nil) + ((string= type "Role") + nil) + (t + (error "From mark-as-deleted-from-json(): the type ~a is not defined" + type)))))) + + +(defun find-association-from-json (json-plist) + (declare (list json-plist)) + (let ((type-assocs + (elephant:get-instances-by-value + 'd:AssociationC 'd:instance-of + (d:get-item-by-psi (first (getf json-plist :type))))) + (scopes nil) + (err "From find-association-from-json(): ")) + (loop for scope-entry in (getf json-plist :scopes) + do (let ((top (d:get-item-by-psi (first scope-entry)))) + (unless top + (error "~a ~a not found" + err (first scope-entry))) + (pushnew top scopes))) + (let ((scope-assocs + (loop for assoc in type-assocs + when (not (set-exclusive-or scopes (themes assoc))) + collect assoc))) + (loop for assoc in scope-assocs + when (let ((found-roles + (loop for j-role in (getf json-plist :roles) + when (let ((j-player (when (getf j-role :topicRef) + (d:get-item-by-psi (first (getf j-role :topicRef))))) + (j-type (when (getf j-role :type) + (d:get-item-by-psi (first (getf j-role :type)))))) + (find-if #'(lambda(role) + (and (eql (instance-of role) j-type) + (eql (player role) j-player))) + (roles assoc))) + collect j-role))) + (= (length (roles assoc)) (length (getf json-plist :roles)) + (length found-roles))) + return assoc)))) + + +(defun delete-associations-from-json (associations revision) + (declare (list associations) (integer revision)) + (dolist (j-assoc associations) + (let ((plist (json-importer::get-association-values-from-json-list j-assoc)) + (err "From delete-association-from-json(): ")) + (let ((assoc (find-association-from-json plist))) + (unless assoc + (error "~a ~a not found" err plist)) + (mark-as-deleted assoc :revision revision))))) + + +(defun delete-topics-from-json (topics revision) + (declare (list topics) (integer revision)) + (let ((psis nil)) + (dolist (uri topics) + (let ((psi (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri uri))) + (unless psi + (error "From delete-topic-from-json(): PSI ~a not found" uri)) + (pushnew psi psis))) + (let ((tops + (remove-duplicates + (map 'list #'d:identified-construct psis)))) + (dolist (top tops) + (let ((psi (uri (first (psis top))))) + (mark-as-deleted top :source-locator psi :revision revision)))))) ;; ============================================================================= From lgiessmann at common-lisp.net Wed Apr 14 14:51:13 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 14 Apr 2010 10:51:13 -0400 Subject: [isidorus-cvs] r277 - trunk/src/json Message-ID: Author: lgiessmann Date: Wed Apr 14 10:51:13 2010 New Revision: 277 Log: rest-interface: finalized and tested the mark-as-deleted-handler of the RESTful interface; json: added some helpers for the rest-interface-mark-as-deleted-handler; added the corresponding docu into json.ebnf and xtm_json.txt Modified: trunk/src/json/json_tmcl.lisp Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Wed Apr 14 10:51:13 2010 @@ -13,78 +13,9 @@ ;; ============================================================================= ;; --- mark-as-deleted handler ------------------------------------------------- ;; ============================================================================= -; a test string ... -(defvar cl-user::*js-1* - "{\"type\":\"Association\", - \"topics\":[\"http://textgrid.org/isidorus/tmcl/service\", - \"http://textgrid.org/isidorus/tmcl/parameter\"], - \"associations\":[{\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"], - \"scopes\":null, - \"roles\":[{\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], - \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}, - {\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/topic-type-role\"], - \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]}], - \"parent-topic\":[\"http://textgrid.org/isidorus/my-service/my-service\"], - \"parent-name\":{\"itemIdentities\":null, - \"type\":[\"http://textgrid.org/isidorus/tmcl/service-name\"], - \"scopes\":null, - \"value\":\"my-service\", - \"variants\":null}, - \"names\":[{\"itemIdentities\":null, - \"type\":[\"http://textgrid.org/isidorus/tmcl/service-name\"], - \"scopes\":null, - \"value\":\"my-service\", - \"variants\":null}], - \"variants\":[{\"itemIdentities\":null, - \"scopes\":[[\"http://textgrid.org/isidorus/tmcl/display\"]], - \"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", - \"value\":\"http://textgrid.org/isidorus/tmcl/service\"}, - \"resourceRef\":null}, - {\"itemIdentities\":null, - \"scopes\":[[\"http://textgrid.org/isidorus/tmcl/is-ref\"]], - \"resourceData\":null, - \"resourceRef\":\"http://any-ref.org\"}], - \"occurrences\":[{\"itemIdentities\":null, - \"type\":[\"http://textgrid.org/isidorus/tmcl/service-key\"], - \"scopes\":null, - \"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", - \"value\":\"service-key\"}}], - \"parent-association\":{\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/applies-to\"], - \"scopes\":null, - \"roles\":[{\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], - \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}, - {\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/topictype-role\"], - \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/service\"]}]}, - \"roles\":[{\"itemIdentities\":null, - \"type\":[\"http://psi.topicmaps.org/tmcl/constraint-role\"], - \"topicRef\":[\"http://textgrid.org/isidorus/tmcl/exc\"]}]}") - - (defun mark-as-deleted-from-json (json-data) + "Marks an object that is specified by the given JSON data as deleted." (declare (string json-data)) - -;{\"type\":<\"Topic\" | \"Occurrence\" | \"Name\" -; \"Association\" | \"Role\" | \"Variant\" >, -; \"topics\": , -; \"associations\": , -; \"parent-topic\": , -; \"parent-name\": , -; \"names\": , -; \"variants\": , -; \"occurrences\": , -; \"parent-association\": -; \"roles\": } (let ((values (json:decode-json-from-string json-data))) (let ((type nil) (topics nil) @@ -116,18 +47,204 @@ ((string= type "Association") (delete-associations-from-json associations rev)) ((string= type "Occurrence") - nil) + (delete-occurrences-from-json occurrences parent-topic rev)) ((string= type "Name") - nil) + (delete-names-from-json names parent-topic rev)) ((string= type "Variant") - nil) + (delete-variants-from-json variants parent-topic parent-name rev)) ((string= type "Role") - nil) + (delete-roles-from-json roles parent-association rev)) (t (error "From mark-as-deleted-from-json(): the type ~a is not defined" type)))))) +(defun find-role-from-json (parent-association json-plist) + (declare (AssociationC parent-association) (list json-plist)) + (let ((found-role + (find-if + #'(lambda(role) + (let ((type (when (getf json-plist :type) + (d:get-item-by-psi (first (getf json-plist :type))))) + (player (when (getf json-plist :topicRef) + (d:get-item-by-psi + (first (getf json-plist :topicRef)))))) + (and (eql type (d:instance-of role)) + (eql player (d:player role))))) + (d:roles parent-association)))) + found-role)) + + +(defun delete-roles-from-json (roles parent-association revision) + (declare (list roles parent-association) (integer revision)) + (let ((err "From delete-roles-from-association(): ") + (parent-assoc + (find-association-from-json + (json-importer::get-association-values-from-json-list + parent-association)))) + (unless parent-assoc + (error "~a~a not found" err parent-association)) + (dolist (j-role roles) + (let ((plist (json-importer::get-role-values-from-json-list j-role))) + (let ((role (find-role-from-json parent-assoc plist))) + (unless role + (error "~a~a not found" err plist)) + (format t "~a~%" role) + (mark-as-deleted role :revision revision)))))) + + +(defun find-variant-from-json (parent-name json-plist) + (declare (NameC parent-name) (list json-plist)) + (let ((err "From find-variant-from-json(): ")) + (let ((found-var + (find-if + #'(lambda(var) + (let ((datatype (cond ((getf json-plist :datatype) + (getf json-plist :datatype)) + ((getf json-plist :resourceRef) + constants:*xml-uri*) + ((getf json-plist :resourceData) + (let ((val + (getf + (getf json-plist :resourceData) + :datatype))) + (if val val constants:*xml-string*))) + (t + constants:*xml-string*))) + (charvalue (cond ((getf json-plist :resourceRef) + (getf json-plist :resourceRef)) + ((getf json-plist :resourceData) + (getf (getf json-plist :resourceData) + :value)) + (t + ""))) + (scopes nil)) + (loop for scope-entry in (getf json-plist :scopes) + do (let ((top (d:get-item-by-psi (first scope-entry)))) + (unless top + (error "~a ~a not found" err (first scope-entry))) + (pushnew top scopes))) + (and (not (set-exclusive-or scopes (d:themes var))) + (string= datatype (d:datatype var)) + (string= charvalue (d:charvalue var))))) + (d:variants parent-name :revision 0)))) + found-var))) + + +(defun delete-variants-from-json (variants parent-psi parent-name revision) + (declare (string parent-psi) (list variants parent-name)) + (let ((err "From delete-variants-from-json(): ") + (parent-topic (d:get-item-by-psi parent-psi))) + (unless parent-topic + (error "~a~a not found" err parent-psi)) + (let ((v-name + (find-name-from-json + parent-topic + (json-importer::get-name-values-from-json-list parent-name)))) + (unless v-name + (error "~a~a not found" err parent-name)) + (dolist (j-variant variants) + (let ((plist + (json-importer::get-variant-values-from-json-list j-variant))) + (let ((variant (find-variant-from-json v-name plist))) + (unless variant + (error "~a~a not found" err plist)) + (mark-as-deleted variant :revision revision))))))) + + +(defun find-name-from-json(parent-topic json-plist) + (declare (TopicC parent-topic) (list json-plist)) + (let ((err "From find-name-from-json(): ")) + (let ((found-name + (find-if + #'(lambda(name) + (let ((type (when (getf json-plist :type) + (d:get-item-by-psi (first (getf json-plist :type))))) + (charvalue (if (getf json-plist :value) + (getf json-plist :value) + "")) + (scopes nil)) + (loop for scope-entry in (getf json-plist :scopes) + do (let ((top (d:get-item-by-psi (first scope-entry)))) + (unless top + (error "~a ~a not found" err (first scope-entry))) + (pushnew top scopes))) + (and (eql type (d:instance-of name)) + (not (set-exclusive-or scopes (d:themes name))) + (string= charvalue (d:charvalue name))))) + (names parent-topic :revision 0)))) + found-name))) + + +(defun delete-names-from-json (names parent-psi revision) + (declare (list names) (string parent-psi) (integer revision)) + (let ((parent-topic (d:get-item-by-psi parent-psi)) + (err "From delete-name-from-json(): ")) + (unless parent-topic + (error "~a~a not found" + err parent-psi)) + (dolist (j-name names) + (let ((plist (json-importer::get-name-values-from-json-list j-name))) + (let ((name (find-name-from-json parent-topic plist))) + (unless name + (error "~a~a not found" err plist)) + (mark-as-deleted name :revision revision)))))) + + +(defun find-occurrence-from-json(parent-topic json-plist) + (declare (TopicC parent-topic) (list json-plist)) + (let ((err "From find-occurrence-from-json(): ")) + (let ((found-occ + (find-if + #'(lambda(occ) + (let ((type (when (getf json-plist :type) + (d:get-item-by-psi (first (getf json-plist :type))))) + (datatype (cond ((getf json-plist :datatype) + (getf json-plist :datatype)) + ((getf json-plist :resourceRef) + constants:*xml-uri*) + ((getf json-plist :resourceData) + (let ((val + (getf + (getf json-plist :resourceData) + :datatype))) + (if val val constants:*xml-string*))) + (t + constants:*xml-string*))) + (charvalue (cond ((getf json-plist :resourceRef) + (getf json-plist :resourceRef)) + ((getf json-plist :resourceData) + (getf (getf json-plist :resourceData) + :value)) + (t + ""))) + (scopes nil)) + (loop for scope-entry in (getf json-plist :scopes) + do (let ((top (d:get-item-by-psi (first scope-entry)))) + (unless top + (error "~a ~a not found" err (first scope-entry))) + (pushnew top scopes))) + (and (eql type (d:instance-of occ)) + (not (set-exclusive-or scopes (d:themes occ))) + (string= datatype (d:datatype occ)) + (string= charvalue (d:charvalue occ))))) + (occurrences parent-topic :revision 0)))) + found-occ))) + + +(defun delete-occurrences-from-json(occurrences parent-psi revision) + (declare (list occurrences) (string parent-psi) (integer revision)) + (let ((parent-topic (d:get-item-by-psi parent-psi)) + (err "From delete-occurrence-from-json(): ")) + (unless parent-topic + (error "~a~a not found" err parent-psi)) + (dolist (j-occ occurrences) + (let ((plist (json-importer::get-occurrence-values-from-json-list j-occ))) + (let ((occ (find-occurrence-from-json parent-topic plist))) + (unless occ + (error "~a~a not found" err plist)) + (mark-as-deleted occ :revision revision)))))) + (defun find-association-from-json (json-plist) (declare (list json-plist)) @@ -140,8 +257,7 @@ (loop for scope-entry in (getf json-plist :scopes) do (let ((top (d:get-item-by-psi (first scope-entry)))) (unless top - (error "~a ~a not found" - err (first scope-entry))) + (error "~a ~a not found" err (first scope-entry))) (pushnew top scopes))) (let ((scope-assocs (loop for assoc in type-assocs From lgiessmann at common-lisp.net Wed Apr 14 14:52:52 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 14 Apr 2010 10:52:52 -0400 Subject: [isidorus-cvs] r278 - trunk/docs Message-ID: Author: lgiessmann Date: Wed Apr 14 10:52:52 2010 New Revision: 278 Log: docs: added documentation to the RESTful-interface --> mark-as-deleted-handler Modified: trunk/docs/json.ebnf trunk/docs/xtm_json.txt Modified: trunk/docs/json.ebnf ============================================================================== --- trunk/docs/json.ebnf (original) +++ trunk/docs/json.ebnf Wed Apr 14 10:52:52 2010 @@ -4,7 +4,7 @@ //+ *Part 2: XTM - data model //+ *Part 3: Object summaries //+ *Part 4: TMCL - data model -//+ *Part 5: Server-side RESTful interface +//+ *Part 5: Object notation for marking objects as deleted //+----------------------------------------------------------------------------- //+----------------------------------------------------------------------------- @@ -173,16 +173,36 @@ // Contains the entire TMCL information FragmentConstraint ="{" TopicConstraints "," AssociationsConstraints "}" + + //+----------------------------------------------------------------------------- -//+ Part 5: Server-side RESTful interface -//+----------------------------------------------------------------------------- -"/json/get/(.+)$" returns a Fragment after a HTTP-GET -"/json/commit/?$" processes a Fragment as HTTP-POST or HTTP-PUT -"/json/psis/?$" returns a PsiSummary after a HTTP-GET -"/json/summary/?$" returns a TopicSummaries after A HTTP-GET -"/json/tmcl/types/?$" returns a PsiSummary after A HTTP-GET with all types -"/json/tmcl/instances/?$" returns a PsiSummary after a HTTP-GET with all instances -"/json/topicstubs/(.+)$" returns a topicStub after a HTTP-GET -"/json/tmcl/type/?$" returns a FragmentConstraint after a HTTP-POST/HTTP-PUT -"/json/tmcl/instance/?$" returns a FragmentConstraint after a HTTP-POST/HTTP-PUT -"/json/tmcl/overview/?$" returns a TreeView after a HTTP-GET \ No newline at end of file +//+ Part 5: Object notation for marking objects as deleted +//+ type: the type of the deleted object, e.g. Topic for TopicC +//+ topics: a list of PSIs, where every single PSI represents a topic that +//+ has to be deleted +//+ associations: a list of associations that have to be deleted +//+ parent-topic: a single PSI of the name's, occurrence's or variant's owner +//+ topic +//+ parent-name: the parent name of the variants that have to be deleted +//+ (in this case the parent-topic is the topic of the name) +//+ names: a list of the deletable names +//+ variants: a list of deletable names +//+ occurrences: a list of the deletable occurrences +//+ parent-association: the parent association of the deletable roles +//+ roles: a list of the deltable roles +//+----------------------------------------------------------------------------- +DeleteType = "\"type\":" ("Topic" | "Occurrence" | "Name" | "Association" | "Role" | "Variant") +DeleteTopics = "\"topics\":" List +DeleteAssociations = "\"associations\":" Associations +DeleteParentTopic = "\"parent-topic\":" String +DeleteParentName = "\"parent-name\":" Name +DeleteNames = "\"names\":" Names +DeleteVariants = "\"variants\":" Variants +DeleteOccurrences = "\"occurrences\":" Occurrences +DeleteParentAssociation = "\"parent-association\":" Association +DeleteRoles = "\"roles\":" Roles + +DeleteObject = "{" DeleteType "," DeleteTopics "," DeleteAssociations "," + DeleteParentTopic "," DeleteParentName "," DeleteNames "," + DeleteVariants "," DeleteOccurrences "," DeleteParentAssociation + "," DeleteRoles "}" \ No newline at end of file Modified: trunk/docs/xtm_json.txt ============================================================================== --- trunk/docs/xtm_json.txt (original) +++ trunk/docs/xtm_json.txt Wed Apr 14 10:52:52 2010 @@ -3,6 +3,7 @@ //+ *Part 1: XTM - data model //+ *Part 2: Object summaries //+ *Part 3: TMCL - data model +//+ *Part 4: Object notation for marking objects as deleted //+----------------------------------------------------------------------------- @@ -443,3 +444,34 @@ "topicConstraints" : , "associationsConstraints" : [ , <...> ] } + + + +//+----------------------------------------------------------------------------- +//+ *Part 4: Object notation for marking objects as deleted +//+ type: the type of the deleted object, e.g. Topic for TopicC +//+ topics: a list of PSIs, where every single PSI represents a topic that +//+ has to be deleted +//+ associations: a list of associations that have to be deleted +//+ parent-topic: a single PSI of the name's, occurrence's or variant's owner +//+ topic +//+ parent-name: the parent name of the variants that have to be deleted +//+ (in this case the parent-topic is the topic of the name) +//+ names: a list of the deletable names +//+ variants: a list of deletable names +//+ occurrences: a list of the deletable occurrences +//+ parent-association: the parent association of the deletable roles +//+ roles: a list of the deltable roles +//+----------------------------------------------------------------------------- +{ + "type":<"Topic" | "Occurrence" | "Name" | "Association" | "Role" | "Variant" >, + "topics": [, , <...>], + "associations": [, , <...>], + "parent-topic": "topic-psi", + "parent-name": , + "names": [, , <...>], + "variants": [, , <...>], + "occurrences": [, , <...>], + "parent-association": , + "roles": [, , <...>] +} From lgiessmann at common-lisp.net Thu Apr 15 17:52:45 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 15 Apr 2010 13:52:45 -0400 Subject: [isidorus-cvs] r279 - in trunk: docs src/ajax/css src/ajax/javascripts src/json src/rest_interface Message-ID: Author: lgiessmann Date: Thu Apr 15 13:52:44 2010 New Revision: 279 Log: docs: fixed some bad ebnf definitions of the json interface; json: currently only active topics are exported, mark-as-deleted topics are not exported; ajax: added the possibility that the ui is able to mark topics, names and occurrences as deleted ---> at the moment there is a problem when recreating occurrences and names that have already existed Modified: trunk/docs/json.ebnf trunk/docs/xtm_json.txt trunk/src/ajax/css/frame.css trunk/src/ajax/javascripts/constants.js trunk/src/ajax/javascripts/datamodel.js trunk/src/ajax/javascripts/requests.js trunk/src/json/json_exporter.lisp trunk/src/json/json_importer.lisp trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_validation.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/docs/json.ebnf ============================================================================== --- trunk/docs/json.ebnf (original) +++ trunk/docs/json.ebnf Thu Apr 15 13:52:44 2010 @@ -194,12 +194,12 @@ DeleteType = "\"type\":" ("Topic" | "Occurrence" | "Name" | "Association" | "Role" | "Variant") DeleteTopics = "\"topics\":" List DeleteAssociations = "\"associations\":" Associations -DeleteParentTopic = "\"parent-topic\":" String -DeleteParentName = "\"parent-name\":" Name +DeleteParentTopic = "\"parentTopic\":" String +DeleteParentName = "\"parentName\":" Name DeleteNames = "\"names\":" Names DeleteVariants = "\"variants\":" Variants DeleteOccurrences = "\"occurrences\":" Occurrences -DeleteParentAssociation = "\"parent-association\":" Association +DeleteParentAssociation = "\"parentAssociation\":" Association DeleteRoles = "\"roles\":" Roles DeleteObject = "{" DeleteType "," DeleteTopics "," DeleteAssociations "," Modified: trunk/docs/xtm_json.txt ============================================================================== --- trunk/docs/xtm_json.txt (original) +++ trunk/docs/xtm_json.txt Thu Apr 15 13:52:44 2010 @@ -467,11 +467,11 @@ "type":<"Topic" | "Occurrence" | "Name" | "Association" | "Role" | "Variant" >, "topics": [, , <...>], "associations": [, , <...>], - "parent-topic": "topic-psi", - "parent-name": , + "parentTopic": "topic-psi", + "parentName": , "names": [, , <...>], "variants": [, , <...>], "occurrences": [, , <...>], - "parent-association": , + "parentAssociation": , "roles": [, , <...>] } Modified: trunk/src/ajax/css/frame.css ============================================================================== --- trunk/src/ajax/css/frame.css (original) +++ trunk/src/ajax/css/frame.css Thu Apr 15 13:52:44 2010 @@ -27,6 +27,18 @@ background-color: #eaeaee; } +tr.removeNameRow { + background-color: #eaeaee; +} + +tr.removeOccurrenceRow { + background-color: #eaeaee; +} + +tr.removeTopicRow { + background-color: #eaeaee; +} + li.errorMessage { margin-top: 1em; font-size: 1.2em; @@ -139,6 +151,17 @@ margin-top: 1px; } +span.removeLink { + cursor: pointer; + font-size: 0.75em; + float: right; + margin-right: 1em; +} + +span.removeLink:hover { + color:#ff7f00; +} + /* === topic frame ========================================================== */ table.topicFrame { Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Thu Apr 15 13:52:44 2010 @@ -22,6 +22,7 @@ var INSTANCE_PSIS_URL = HOST_PREF + "json/tmcl/instances/"; var OWN_URL = HOST_PREF + "isidorus"; var SUMMARY_URL = HOST_PREF + "json/summary" + var MARK_AS_DELETED_URL = HOST_PREF + "mark-as-deleted"; var TM_OVERVIEW = "/json/tmcl/overview/"; var TIMEOUT = 10000; // const TIMEOUT = 10000 --> "const" doesn't work under IE @@ -89,5 +90,9 @@ "treeView" : function(){ return "treeView"; }, "instances" : function(){ return "instances"; }, "subtypes" : function(){ return "subtypes"; }, - "topicPsis" : function(){ return "topicPsis"; } + "topicPsis" : function(){ return "topicPsis"; }, + "removeLink" : function(){ return "removeLink"; }, + "removeNameRow" : function(){ return "removeOccurrenceRow"; }, + "removeOccurrenceRow" : function(){ return "removeNameRow"; }, + "removeTopicRow" : function(){ return "removeTopicRow"; } }; \ No newline at end of file Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Thu Apr 15 13:52:44 2010 @@ -1447,6 +1447,11 @@ dblClickHandler(owner, event); }); } + + var myself = this; + this.__table__.insert({"bottom" : makeRemoveLink(function(event){ + makeDeleteObject("Name", myself); + }, "delete Name")}); } catch(err){ alert("From NameC(): " + err); @@ -1491,6 +1496,7 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].hide(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].hide(); this.getFrame().select("tr." + CLASSES.variantContainer())[0].hide(); + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].hide(); this.__isMinimized__ = true; } else { @@ -1500,6 +1506,7 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].show(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].show(); this.getFrame().select("tr." + CLASSES.variantContainer())[0].show(); + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].show(); this.__isMinimized__ = false; } }, @@ -1512,6 +1519,7 @@ this.__variants__.disable(); this.getFrame().writeAttribute({"class" : CLASSES.disabled()}); this.getFrame().writeAttribute({"title" : this.__cssTitle__}); + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].disable(); this.hideAddButton(); this.__disabled__ = true; }, @@ -1523,6 +1531,7 @@ this.__variants__.enable(); this.getFrame().writeAttribute({"class" : CLASSES.nameFrame()}); this.getFrame().removeAttribute("title"); + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].enable(); checkRemoveAddButtons(this.__owner__, 1, this.__max__, this); this.__disabled__ = false; }}); @@ -1742,6 +1751,92 @@ }}); +function makeRemoveLink (removeHandler, textContent){ + var link = new Element("span", {"class" : CLASSES.removeLink()}).update(textContent); + var trClass = null; + switch(textContent){ + case "delete Occurrence" : trClass = CLASSES.removeOccurrenceRow(); break; + case "delete Topic" : trClass = CLASSES.removeTopicRow(); break; + case "delete Name" : trClass = CLASSES.removeNameRow(); break; + } + + var tr = new Element("tr", {"class" : trClass}).insert(new Element("td", {"colspan" : 3}).insert(link)); + if(removeHandler){ link.observe("click", removeHandler); } + return tr; +} + + +function makeDeleteObject(type, objectToDelete){ + if(type !== "Occurrence" && type !== "Name" && type !== "Variant" + && type !== "Topic" && type !== "Association"){ + throw "From makeDeleteObject(): type must be: \"Occurrence\" || \"Name\" " + + "|| \"Variant\" || \"Topic\" || \"Association\" but is " + type; + } + if (!objectToDelete){ + throw "From makeDeleteObject(): objectToDelete must be set"; + } + + var parentTopic = "null"; + if(type === "Occurrence" || type === "Name"){ + var psiFrame = objectToDelete.getFrame().parentNode.parentNode.parentNode.parentNode.select("tr." + CLASSES.subjectIdentifierFrame())[0]; + var psiFields = psiFrame.select("input"); + for(i = 0; psiFields && i !== psiFields.length; ++i){ + var psiValue = psiFields[i].value; + if(psiValue.strip().length !== 0){ + parentTopic = psiValue.strip().toJSON(); + break; + } + } + } + + var topics = "null"; + if (type === "Topic"){ + var psiFrame = objectToDelete.getFrame().select("tr." + CLASSES.subjectIdentifierFrame())[0]; + var psiFields = psiFrame.select("input"); + for(i = 0; psiFields && i !== psiFields.length; ++i){ + var psiValue = psiFields[i].value; + if(psiValue.strip().length !== 0){ + topics = new Array(psiValue.strip()).toJSON(); + break; + } + } + } + + var deletedObjects = null; + if(type === "Topic"){ deletedObjects = topics; } + else { deletedObjects = "[" + objectToDelete.toJSON() + "]"; } + + var jsonData = "{\"type\":\"" + type + "\"," + + "\"topics\":" + topics + "," + + "\"associations\":" + "null" + "," + + "\"parentTopic\":" + parentTopic + "," + + "\"parentName\":" + "null" + "," + + "\"names\":" + (type === "Name" ? deletedObjects : "null") + "," + + "\"variants\":" + "null" + "," + + "\"occurrences\":" + (type === "Occurrence" ? deletedObjects : "null") + "," + + "\"parentAssociation\":" + "null" + "," + + "\"roles\":" + "null" + "}"; + + commitDeletedObject(jsonData, function(xhr){ + alert("Objected deleted"); + if(type === "Topic"){ + $(CLASSES.subPage()).update(); + makeHome(); + } + else if (type === "Occurrence" || type === "Name"){ + if(objectToDelete.__owner__.__frames__.length > objectToDelete.__max__ + && objectToDelete.__owner__.__frames__.length > 1){ + objectToDelete.remove(); + } + else { + if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } + else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); } + } + } + }); + +} + // --- represenation of an occurrence element var OccurrenceC = Class.create(ContainerC, {"initialize" : function($super, contents, occurrenceTypes, constraint, uniqueConstraints, owner, min, max, cssTitle, dblClickHandler){ $super(); @@ -1826,6 +1921,10 @@ dblClickHandler(owner, event); }); } + var myself = this; + this.__table__.insert({"bottom" : makeRemoveLink(function(event){ + makeDeleteObject("Occurrence", myself); + }, "delete Occurrence")}); } catch(err){ alert("From OccurrenceC(): " + err); @@ -1894,6 +1993,7 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].hide(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].hide(); this.getFrame().select("tr." + CLASSES.datatypeFrame())[0].hide(); + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].hide(); this.__isMinimized__ = true; } else { @@ -1903,6 +2003,9 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].show(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].show(); this.getFrame().select("tr." + CLASSES.datatypeFrame())[0].show(); + if(this.__disabled__ === false){ + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].show(); + } this.__isMinimized__ = false; } }, @@ -1916,6 +2019,7 @@ this.getFrame().writeAttribute({"class" : CLASSES.disabled()}); this.getFrame().writeAttribute({"title" : this.__cssTitle__}); this.hideAddButton(); + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].hide(); this.__disabled__ = true; }, "enable" : function(){ @@ -1928,6 +2032,7 @@ this.getFrame().removeAttribute("style"); this.getFrame().removeAttribute("title"); checkRemoveAddButtons(this.__owner__, 1, this.__max__, this); + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].show(); this.__disabled__ = false; }}); @@ -2222,6 +2327,11 @@ _constraints = (constraints ? constraints.topicOccurrenceConstraints : null); this.__occurrence__ = new OccurrenceContainerC(occurrencesContent, _constraints); this.__table__.insert({"bottom" : newRow(CLASSES.occurrenceContainer(), "Occurrences", this.__occurrence__.getFrame())}); + + var myself = this; + this.__table__.insert({"bottom" : makeRemoveLink(function(event){ + makeDeleteObject("Topic", myself); + }, "delete Topic")}); }catch(err){ alert("From TopciC(): " + err); } @@ -2261,7 +2371,8 @@ this.getFrame().select("tr." + CLASSES.subjectLocatorFrame())[0], this.getFrame().select("tr." + CLASSES.subjectIdentifierFrame())[0], this.getFrame().select("tr." + CLASSES.nameContainer())[0], - this.getFrame().select("tr." + CLASSES.occurrenceContainer())[0]); + this.getFrame().select("tr." + CLASSES.occurrenceContainer())[0], + this.getFrame().select("tr." + CLASSES.removeTopicRow())[0]); for(var i = 0; i != rows.length; ++i){ if(this.__minimized__ === false) rows[i].hide(); else rows[i].show(); Modified: trunk/src/ajax/javascripts/requests.js ============================================================================== --- trunk/src/ajax/javascripts/requests.js (original) +++ trunk/src/ajax/javascripts/requests.js Thu Apr 15 13:52:44 2010 @@ -219,6 +219,27 @@ } +// --- Sends a POST-Message to the server. The sent message enables the server +// --- to find the spcified object and mark it as deleted +function commitDeletedObject(json, onSuccessHandler, onFailureHandler) +{ + if(!json || !onSuccessHandler) throw "From commitDeletedObject(): json and onSuccessHandler must be set!"; + try{ + var onFailure = onFailureHandler ? onFailureHandler : defaultFailureHandler; + var timeFun = setAjaxTimeout(TIMEOUT, COMMIT_URL); + + new Ajax.Request(MARK_AS_DELETED_URL, { + "method" : "post", + "postBody" : json, + "onSuccess" : createXHRHandler(onSuccessHandler, timeFun), + "onFailure" : createXHRHandler(onFailure, timeFun)}); + } + catch(err){ + alert("From commitDeletedObject(): " + err); + } +} + + // --- Requests a JSON-Fragment for the passed psi and calls the onSuccessHandler function // --- after a succeeded request. function requestFragment(psi, onSuccessHandler, onFailureHandler) Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Thu Apr 15 13:52:44 2010 @@ -8,7 +8,7 @@ (defpackage :json-exporter - (:use :cl :json :datamodel) + (:use :cl :json :datamodel :json-tmcl-constants) (:export :to-json-string :get-all-topic-psis :to-json-string-summary @@ -298,7 +298,8 @@ (remove-if #'null (map 'list #'(lambda(psi-list) (when psi-list (map 'list #'uri psi-list))) - (map 'list #'psis (elephant:get-instances-by-class 'TopicC)))))) + (json-tmcl::clean-topics + (elephant:get-instances-by-class 'TopicC)))))) (defun to-json-string-summary (topic) @@ -350,4 +351,14 @@ do (setf inner-string (concatenate 'string inner-string (to-json-string-summary topic) ",")))) (subseq inner-string 0 (- (length inner-string) 1))))) (concatenate 'string "[" json-string "]")) - "null")) \ No newline at end of file + "null")) + + +(defun clean-topics(isas-or-akos) + (remove-if + #'null + (map 'list + #'(lambda(top) + (when (d:find-item-by-revision top 0) + top)) + isas-or-akos))) \ No newline at end of file Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Thu Apr 15 13:52:44 2010 @@ -362,7 +362,7 @@ (setf tm-ids (cdr j-elem))) (t (error "json-importer:get-fragment-values-from-json-string: - bad item-specifier found in json-list")))) + bad item-specifier found in json-list (~a)" (car j-elem))))) (unless topic (error "json-importer:get-fragment-values-from-json-string: the element topic must be set")) (unless (= (length tm-ids) 1) Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Thu Apr 15 13:52:44 2010 @@ -179,7 +179,7 @@ (defun delete-names-from-json (names parent-psi revision) (declare (list names) (string parent-psi) (integer revision)) (let ((parent-topic (d:get-item-by-psi parent-psi)) - (err "From delete-name-from-json(): ")) + (err "From delete-names-from-json(): ")) (unless parent-topic (error "~a~a not found" err parent-psi)) @@ -235,7 +235,7 @@ (defun delete-occurrences-from-json(occurrences parent-psi revision) (declare (list occurrences) (string parent-psi) (integer revision)) (let ((parent-topic (d:get-item-by-psi parent-psi)) - (err "From delete-occurrence-from-json(): ")) + (err "From delete-occurrences-from-json(): ")) (unless parent-topic (error "~a~a not found" err parent-psi)) (dolist (j-occ occurrences) @@ -284,7 +284,7 @@ (declare (list associations) (integer revision)) (dolist (j-assoc associations) (let ((plist (json-importer::get-association-values-from-json-list j-assoc)) - (err "From delete-association-from-json(): ")) + (err "From delete-associations-from-json(): ")) (let ((assoc (find-association-from-json plist))) (unless assoc (error "~a ~a not found" err plist)) @@ -297,7 +297,7 @@ (dolist (uri topics) (let ((psi (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri uri))) (unless psi - (error "From delete-topic-from-json(): PSI ~a not found" uri)) + (error "From delete-topics-from-json(): PSI ~a not found" uri)) (pushnew psi psis))) (let ((tops (remove-duplicates @@ -1573,33 +1573,9 @@ t)) (get-direct-subtypes-of-topic topic-instance))))))) (let ((cleaned-isas ;;all constraint topics are removed - (remove-if #'null (map 'list #'(lambda(top-entry) - (when (find-if #'(lambda(psi) - (unless (or (string= (uri psi) *constraint-psi*) - (string= (uri psi) *occurrencetype-psi*) - (string= (uri psi) *nametype-psi*) - (string= (uri psi) *associationtype-psi*) - (string= (uri psi) *roletype-psi*) - (string= (uri psi) *scopetype-psi*) - (string= (uri psi) *schema-psi*)) - top-entry)) - (psis (getf top-entry :topic))) - top-entry)) - isas-of-this))) + (clean-topic-entries isas-of-this)) (cleaned-akos ;;all constraint topics are removed - (remove-if #'null (map 'list #'(lambda(top-entry) - (when (find-if #'(lambda(psi) - (unless (or (string= (uri psi) *constraint-psi*) - (string= (uri psi) *occurrencetype-psi*) - (string= (uri psi) *nametype-psi*) - (string= (uri psi) *associationtype-psi*) - (string= (uri psi) *roletype-psi*) - (string= (uri psi) *scopetype-psi*) - (string= (uri psi) *schema-psi*)) - top-entry)) - (psis (getf top-entry :topic))) - top-entry)) - akos-of-this)))) + (clean-topic-entries akos-of-this))) (list :topic topic-instance :is-type is-type :is-instance is-instance @@ -1610,12 +1586,37 @@ (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) cleaned-akos)))))) +(defun clean-topic-entries(isas-or-akos) + (remove-if + #'null + (map 'list + #'(lambda(top-entry) + (when (and (d:find-item-by-revision (getf top-entry :topic) 0) + (find-if + #'(lambda(psi) + (unless (or (string= (uri psi) *constraint-psi*) + (string= (uri psi) *occurrencetype-psi*) + (string= (uri psi) *nametype-psi*) + (string= (uri psi) *associationtype-psi*) + (string= (uri psi) *roletype-psi*) + (string= (uri psi) *scopetype-psi*) + (string= (uri psi) *schema-psi*)) + top-entry)) + (psis (getf top-entry :topic)))) + top-entry)) + isas-or-akos))) + (defun get-all-tree-roots () "Returns all topics that are no instanceOf and no subtype of any other topic." (let ((all-topics - (elephant:get-instances-by-class 'd:TopicC))) + (remove-if #'null + (map 'list + #'(lambda(top) + (when (d:find-item-by-revision top 0) + top)) + (elephant:get-instances-by-class 'd:TopicC))))) (remove-if #'null (map 'list #'(lambda(x) (let ((isas-of-x Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Thu Apr 15 13:52:44 2010 @@ -375,7 +375,8 @@ (defun return-all-tmcl-types () "Returns all topics that are valid tmcl-types" (let ((all-topics - (elephant:get-instances-by-class 'd:TopicC)) + (json-exporter::clean-topics + (elephant:get-instances-by-class 'd:TopicC))) (topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*)) (topictype-constraint (is-type-constrained))) (let ((all-types @@ -399,7 +400,8 @@ The validity is only oriented on the typing of topics, e.g. type-instance or supertype-subtype." (let ((all-topics - (elephant:get-instances-by-class 'd:TopicC))) + (json-exporter::clean-topics + (elephant:get-instances-by-class 'd:TopicC)))) (let ((valid-instances (remove-if #'null (map 'list #'(lambda(x) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Apr 15 13:52:44 2010 @@ -115,7 +115,7 @@ (create-regex-dispatcher json-get-summary-url #'return-topic-summaries) hunchentoot:*dispatch-table*) (push - (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted) + (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -302,7 +302,12 @@ (condition () nil)))) (handler-case (with-reader-lock (let ((topics - (elephant:get-instances-by-class 'd:TopicC))) + (remove-if + #'null + (map 'list #'(lambda(top) + (when (d:find-item-by-revision top 0) + top)) + (elephant:get-instances-by-class 'd:TopicC))))) (let ((end (cond ((not end-idx) @@ -372,6 +377,7 @@ (format nil "Condition: \"~a\"" err)))))) (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= From lgiessmann at common-lisp.net Thu Apr 15 21:08:47 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 15 Apr 2010 17:08:47 -0400 Subject: [isidorus-cvs] r280 - in trunk/src: . json Message-ID: Author: lgiessmann Date: Thu Apr 15 17:08:47 2010 New Revision: 280 Log: json: fixed a function-reference error Modified: trunk/src/isidorus.asd trunk/src/json/json_exporter.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Thu Apr 15 17:08:47 2010 @@ -156,7 +156,8 @@ "json" "threading")) (:module "json" - :components ((:file "json_exporter") + :components ((:file "json_exporter" + :depends-on ("json_tmcl_constants")) (:file "json_importer") (:file "json_tmcl_validation" :depends-on ("json_tmcl_constants" "json_exporter" )) Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Thu Apr 15 17:08:47 2010 @@ -298,7 +298,7 @@ (remove-if #'null (map 'list #'(lambda(psi-list) (when psi-list (map 'list #'uri psi-list))) - (json-tmcl::clean-topics + (clean-topics (elephant:get-instances-by-class 'TopicC)))))) From lgiessmann at common-lisp.net Fri Apr 16 06:20:22 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 16 Apr 2010 02:20:22 -0400 Subject: [isidorus-cvs] r281 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Fri Apr 16 02:20:22 2010 New Revision: 281 Log: ui: the delete-buttons are only displayed if the object exists --> empty templates have no delete-button Modified: trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Apr 16 02:20:22 2010 @@ -1448,10 +1448,14 @@ }); } - var myself = this; - this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Name", myself); - }, "delete Name")}); + + // --- mark-as-deleted + if(contents){ + var myself = this; + this.__table__.insert({"bottom" : makeRemoveLink(function(event){ + makeDeleteObject("Name", myself); + }, "delete Name")}); + } } catch(err){ alert("From NameC(): " + err); @@ -1496,7 +1500,9 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].hide(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].hide(); this.getFrame().select("tr." + CLASSES.variantContainer())[0].hide(); - this.getFrame().select("tr." + CLASSES.removeNameRow())[0].hide(); + if(this.getFrame().select("tr." + CLASSES.removeNameRow()).length > 0){ + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].hide(); + } this.__isMinimized__ = true; } else { @@ -1506,7 +1512,11 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].show(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].show(); this.getFrame().select("tr." + CLASSES.variantContainer())[0].show(); - this.getFrame().select("tr." + CLASSES.removeNameRow())[0].show(); + if(this.getFrame().select("tr." + CLASSES.removeNameRow()).length > 0){ + if(this.__disabled__ === false){ + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].show(); + } + } this.__isMinimized__ = false; } }, @@ -1520,6 +1530,9 @@ this.getFrame().writeAttribute({"class" : CLASSES.disabled()}); this.getFrame().writeAttribute({"title" : this.__cssTitle__}); this.getFrame().select("tr." + CLASSES.removeNameRow())[0].disable(); + if(this.getFrame().select("tr." + CLASSES.removeNameRow()).length > 0){ + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].hide(); + } this.hideAddButton(); this.__disabled__ = true; }, @@ -1532,6 +1545,9 @@ this.getFrame().writeAttribute({"class" : CLASSES.nameFrame()}); this.getFrame().removeAttribute("title"); this.getFrame().select("tr." + CLASSES.removeNameRow())[0].enable(); + if(this.getFrame().select("tr." + CLASSES.removeNameRow()).length > 0){ + this.getFrame().select("tr." + CLASSES.removeNameRow())[0].show(); + } checkRemoveAddButtons(this.__owner__, 1, this.__max__, this); this.__disabled__ = false; }}); @@ -1751,91 +1767,6 @@ }}); -function makeRemoveLink (removeHandler, textContent){ - var link = new Element("span", {"class" : CLASSES.removeLink()}).update(textContent); - var trClass = null; - switch(textContent){ - case "delete Occurrence" : trClass = CLASSES.removeOccurrenceRow(); break; - case "delete Topic" : trClass = CLASSES.removeTopicRow(); break; - case "delete Name" : trClass = CLASSES.removeNameRow(); break; - } - - var tr = new Element("tr", {"class" : trClass}).insert(new Element("td", {"colspan" : 3}).insert(link)); - if(removeHandler){ link.observe("click", removeHandler); } - return tr; -} - - -function makeDeleteObject(type, objectToDelete){ - if(type !== "Occurrence" && type !== "Name" && type !== "Variant" - && type !== "Topic" && type !== "Association"){ - throw "From makeDeleteObject(): type must be: \"Occurrence\" || \"Name\" " + - "|| \"Variant\" || \"Topic\" || \"Association\" but is " + type; - } - if (!objectToDelete){ - throw "From makeDeleteObject(): objectToDelete must be set"; - } - - var parentTopic = "null"; - if(type === "Occurrence" || type === "Name"){ - var psiFrame = objectToDelete.getFrame().parentNode.parentNode.parentNode.parentNode.select("tr." + CLASSES.subjectIdentifierFrame())[0]; - var psiFields = psiFrame.select("input"); - for(i = 0; psiFields && i !== psiFields.length; ++i){ - var psiValue = psiFields[i].value; - if(psiValue.strip().length !== 0){ - parentTopic = psiValue.strip().toJSON(); - break; - } - } - } - - var topics = "null"; - if (type === "Topic"){ - var psiFrame = objectToDelete.getFrame().select("tr." + CLASSES.subjectIdentifierFrame())[0]; - var psiFields = psiFrame.select("input"); - for(i = 0; psiFields && i !== psiFields.length; ++i){ - var psiValue = psiFields[i].value; - if(psiValue.strip().length !== 0){ - topics = new Array(psiValue.strip()).toJSON(); - break; - } - } - } - - var deletedObjects = null; - if(type === "Topic"){ deletedObjects = topics; } - else { deletedObjects = "[" + objectToDelete.toJSON() + "]"; } - - var jsonData = "{\"type\":\"" + type + "\"," + - "\"topics\":" + topics + "," + - "\"associations\":" + "null" + "," + - "\"parentTopic\":" + parentTopic + "," + - "\"parentName\":" + "null" + "," + - "\"names\":" + (type === "Name" ? deletedObjects : "null") + "," + - "\"variants\":" + "null" + "," + - "\"occurrences\":" + (type === "Occurrence" ? deletedObjects : "null") + "," + - "\"parentAssociation\":" + "null" + "," + - "\"roles\":" + "null" + "}"; - - commitDeletedObject(jsonData, function(xhr){ - alert("Objected deleted"); - if(type === "Topic"){ - $(CLASSES.subPage()).update(); - makeHome(); - } - else if (type === "Occurrence" || type === "Name"){ - if(objectToDelete.__owner__.__frames__.length > objectToDelete.__max__ - && objectToDelete.__owner__.__frames__.length > 1){ - objectToDelete.remove(); - } - else { - if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } - else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); } - } - } - }); - -} // --- represenation of an occurrence element var OccurrenceC = Class.create(ContainerC, {"initialize" : function($super, contents, occurrenceTypes, constraint, uniqueConstraints, owner, min, max, cssTitle, dblClickHandler){ @@ -1921,10 +1852,15 @@ dblClickHandler(owner, event); }); } - var myself = this; - this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Occurrence", myself); - }, "delete Occurrence")}); + + + // --- mark-as-deleted + if(contents){ + var myself = this; + this.__table__.insert({"bottom" : makeRemoveLink(function(event){ + makeDeleteObject("Occurrence", myself); + }, "delete Occurrence")}); + } } catch(err){ alert("From OccurrenceC(): " + err); @@ -1993,7 +1929,9 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].hide(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].hide(); this.getFrame().select("tr." + CLASSES.datatypeFrame())[0].hide(); - this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].hide(); + if(this.getFrame().select("tr." + CLASSES.removeOccurrenceRow()).length > 0){ + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].hide(); + } this.__isMinimized__ = true; } else { @@ -2003,10 +1941,12 @@ this.getFrame().select("tr." + CLASSES.scopeContainer())[0].show(); this.getFrame().select("tr." + CLASSES.valueFrame())[0].show(); this.getFrame().select("tr." + CLASSES.datatypeFrame())[0].show(); - if(this.__disabled__ === false){ - this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].show(); + if(this.getFrame().select("tr." + CLASSES.removeOccurrenceRow()).length > 0){ + if(this.__disabled__ === false){ + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].show(); + } } - this.__isMinimized__ = false; + this.__isMinimized__ = false; } }, "disable" : function(){ @@ -2019,7 +1959,9 @@ this.getFrame().writeAttribute({"class" : CLASSES.disabled()}); this.getFrame().writeAttribute({"title" : this.__cssTitle__}); this.hideAddButton(); - this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].hide(); + if(this.getFrame().select("tr." + CLASSES.removeOccurrenceRow()).length > 0){ + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].hide(); + } this.__disabled__ = true; }, "enable" : function(){ @@ -2032,7 +1974,9 @@ this.getFrame().removeAttribute("style"); this.getFrame().removeAttribute("title"); checkRemoveAddButtons(this.__owner__, 1, this.__max__, this); - this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].show(); + if(this.getFrame().select("tr." + CLASSES.removeOccurrenceRow()).length > 0){ + this.getFrame().select("tr." + CLASSES.removeOccurrenceRow())[0].show(); + } this.__disabled__ = false; }}); @@ -2328,10 +2272,12 @@ this.__occurrence__ = new OccurrenceContainerC(occurrencesContent, _constraints); this.__table__.insert({"bottom" : newRow(CLASSES.occurrenceContainer(), "Occurrences", this.__occurrence__.getFrame())}); - var myself = this; - this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Topic", myself); - }, "delete Topic")}); + // --- mark-as-deleted + if(content){ + var myself = this; + this.__table__.insert({"bottom" : makeRemoveLink(function(event){ + makeDeleteObject("Topic", myself); + }, "delete Topic")});} }catch(err){ alert("From TopciC(): " + err); } @@ -2371,8 +2317,10 @@ this.getFrame().select("tr." + CLASSES.subjectLocatorFrame())[0], this.getFrame().select("tr." + CLASSES.subjectIdentifierFrame())[0], this.getFrame().select("tr." + CLASSES.nameContainer())[0], - this.getFrame().select("tr." + CLASSES.occurrenceContainer())[0], - this.getFrame().select("tr." + CLASSES.removeTopicRow())[0]); + this.getFrame().select("tr." + CLASSES.occurrenceContainer())[0]); + if(this.getFrame().select("tr." + CLASSES.removeTopicRow()).length > 0){ + rows.push(this.getFrame().select("tr." + CLASSES.removeTopicRow())[0]); + } for(var i = 0; i != rows.length; ++i){ if(this.__minimized__ === false) rows[i].hide(); else rows[i].show(); @@ -4382,4 +4330,93 @@ var tr = newRow(CLASSES.typeFrame(), "Type", new SelectrowC(types, myself.__type__, 1, 1).getFrame()); myself.__table__.insert({"bottom" : tr}); return types; +} + + +// --- Returns a span that works like a button and calls the removeHandler +// --- by a click event +function makeRemoveLink (removeHandler, textContent){ + var link = new Element("span", {"class" : CLASSES.removeLink()}).update(textContent); + var trClass = null; + switch(textContent){ + case "delete Occurrence" : trClass = CLASSES.removeOccurrenceRow(); break; + case "delete Topic" : trClass = CLASSES.removeTopicRow(); break; + case "delete Name" : trClass = CLASSES.removeNameRow(); break; + } + + var tr = new Element("tr", {"class" : trClass}).insert(new Element("td", {"colspan" : 3}).insert(link)); + if(removeHandler){ link.observe("click", removeHandler); } + return tr; +} + + +// --- calls the given object's mark-as-deleted service +function makeDeleteObject(type, objectToDelete){ + if(type !== "Occurrence" && type !== "Name" && type !== "Variant" + && type !== "Topic" && type !== "Association"){ + throw "From makeDeleteObject(): type must be: \"Occurrence\" || \"Name\" " + + "|| \"Variant\" || \"Topic\" || \"Association\" but is " + type; + } + if (!objectToDelete){ + throw "From makeDeleteObject(): objectToDelete must be set"; + } + + var parentTopic = "null"; + if(type === "Occurrence" || type === "Name"){ + var psiFrame = objectToDelete.getFrame().parentNode.parentNode.parentNode.parentNode.select("tr." + CLASSES.subjectIdentifierFrame())[0]; + var psiFields = psiFrame.select("input"); + for(i = 0; psiFields && i !== psiFields.length; ++i){ + var psiValue = psiFields[i].value; + if(psiValue.strip().length !== 0){ + parentTopic = psiValue.strip().toJSON(); + break; + } + } + } + + var topics = "null"; + if (type === "Topic"){ + var psiFrame = objectToDelete.getFrame().select("tr." + CLASSES.subjectIdentifierFrame())[0]; + var psiFields = psiFrame.select("input"); + for(i = 0; psiFields && i !== psiFields.length; ++i){ + var psiValue = psiFields[i].value; + if(psiValue.strip().length !== 0){ + topics = new Array(psiValue.strip()).toJSON(); + break; + } + } + } + + var deletedObjects = null; + if(type === "Topic"){ deletedObjects = topics; } + else { deletedObjects = "[" + objectToDelete.toJSON() + "]"; } + + var jsonData = "{\"type\":\"" + type + "\"," + + "\"topics\":" + topics + "," + + "\"associations\":" + "null" + "," + + "\"parentTopic\":" + parentTopic + "," + + "\"parentName\":" + "null" + "," + + "\"names\":" + (type === "Name" ? deletedObjects : "null") + "," + + "\"variants\":" + "null" + "," + + "\"occurrences\":" + (type === "Occurrence" ? deletedObjects : "null") + "," + + "\"parentAssociation\":" + "null" + "," + + "\"roles\":" + "null" + "}"; + + commitDeletedObject(jsonData, function(xhr){ + alert("Objected deleted"); + if(type === "Topic"){ + $(CLASSES.subPage()).update(); + makeHome(); + } + else if (type === "Occurrence" || type === "Name"){ + if(objectToDelete.__owner__.__frames__.length > objectToDelete.__max__ + && objectToDelete.__owner__.__frames__.length > 1){ + objectToDelete.remove(); + } + else { + if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } + else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); } + } + } + }); } \ No newline at end of file From lgiessmann at common-lisp.net Fri Apr 16 09:16:36 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 16 Apr 2010 05:16:36 -0400 Subject: [isidorus-cvs] r282 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Fri Apr 16 05:16:36 2010 New Revision: 282 Log: ui: after deleting an occurrence or name, the item-identifiers which existed before the deleteing-operation are removed Modified: trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Apr 16 05:16:36 2010 @@ -4416,6 +4416,10 @@ else { if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); } + var ii = objectToDelete.__itemIdentity__; + objectToDelete.__itemIdentity__ = new ItemIdentityC(null, objectToDelete); + ii.append(objectToDelete.__itemIdentity__.getFrame()); + ii.remove(); } } }); From lgiessmann at common-lisp.net Fri Apr 16 20:08:54 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 16 Apr 2010 16:08:54 -0400 Subject: [isidorus-cvs] r283 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Fri Apr 16 16:08:53 2010 New Revision: 283 Log: ui: after deleting names all variants of the deleted name are removed Modified: trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Apr 16 16:08:53 2010 @@ -1453,7 +1453,7 @@ if(contents){ var myself = this; this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Name", myself); + makeRemoveObject("Name", myself); }, "delete Name")}); } } @@ -1858,7 +1858,7 @@ if(contents){ var myself = this; this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Occurrence", myself); + makeRemoveObject("Occurrence", myself); }, "delete Occurrence")}); } } @@ -2276,7 +2276,7 @@ if(content){ var myself = this; this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Topic", myself); + makeRemoveObject("Topic", myself); }, "delete Topic")});} }catch(err){ alert("From TopciC(): " + err); @@ -4351,14 +4351,14 @@ // --- calls the given object's mark-as-deleted service -function makeDeleteObject(type, objectToDelete){ +function makeRemoveObject(type, objectToDelete){ if(type !== "Occurrence" && type !== "Name" && type !== "Variant" && type !== "Topic" && type !== "Association"){ - throw "From makeDeleteObject(): type must be: \"Occurrence\" || \"Name\" " + + throw "From makeRemoveObject(): type must be: \"Occurrence\" || \"Name\" " + "|| \"Variant\" || \"Topic\" || \"Association\" but is " + type; } if (!objectToDelete){ - throw "From makeDeleteObject(): objectToDelete must be set"; + throw "From makeRemoveObject(): objectToDelete must be set"; } var parentTopic = "null"; @@ -4415,7 +4415,13 @@ } else { if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } - else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); } + else { + objectToDelete.__value__.__frames__[0].__content__.setValue(""); + var vars = objectToDelete.__variants__; + objectToDelete.__variants__ = new VariantContainerC(null, objectToDelete); + vars.append(objectToDelete.__variants__.getFrame()); + vars.remove(); + } var ii = objectToDelete.__itemIdentity__; objectToDelete.__itemIdentity__ = new ItemIdentityC(null, objectToDelete); ii.append(objectToDelete.__itemIdentity__.getFrame()); From lgiessmann at common-lisp.net Sun Apr 18 12:50:40 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 18 Apr 2010 08:50:40 -0400 Subject: [isidorus-cvs] r284 - in trunk/src: json model Message-ID: Author: lgiessmann Date: Sun Apr 18 08:50:40 2010 New Revision: 284 Log: json+datamodel: modified the procedure of adding constructs to a new version-history --> currently a construct gets a new version-info if it was marked-as-deleted before or it has new item-identifiers Modified: trunk/src/json/json_importer.lisp trunk/src/model/datamodel.lisp Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Sun Apr 18 08:50:40 2010 @@ -38,7 +38,7 @@ (first psi-uris))))) (elephant:ensure-transaction (:txn-nosync nil) (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) - (loop for topicStub-values in (append topicStubs-values (list topic-values)) + (loop for topicStub-values in topicStubs-values do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) (loop for association-values in associations-values @@ -103,31 +103,29 @@ elements from the json-decoded-list" (when json-decoded-list (elephant:ensure-transaction (:txn-nosync t) - (let ((top - (d:get-item-by-id - (getf json-decoded-list :id) - :revision start-revision - :xtm-id xtm-id))) +; (let ((top +; (d:get-item-by-id +; (getf json-decoded-list :id) +; :revision start-revision +; :xtm-id xtm-id))) + (let ((top (json-to-stub json-decoded-list start-revision + :tm tm :xtm-id xtm-id))) (declare (list json-decoded-list)) (declare (integer start-revision)) (declare (TopicMapC tm)) (unless top (error "topic ~a could not be found" (getf json-decoded-list :id))) - (let ((instanceof-topics (remove-duplicates (map 'list #'psis-to-topic (getf json-decoded-list :instanceOfs))))) - (loop for name-values in (getf json-decoded-list :names) do (json-to-name name-values top start-revision)) - (loop for occurrence-values in (getf json-decoded-list :occurrences) do (json-to-occurrence occurrence-values top start-revision)) (dolist (instanceOf-top instanceof-topics) (json-create-instanceOf-association instanceOf-top top start-revision :tm tm)) -; (add-to-topicmap tm top) ; will be done in "json-to-stub" top))))) @@ -246,10 +244,8 @@ (psis-to-topic (getf json-decoded-list :type)))) (declare (list json-decoded-list)) (declare (TopicC top)) - (unless namevalue (error "A name must have exactly one namevalue")) - (let ((name (make-construct 'NameC :start-revision start-revision :topic top Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Apr 18 08:50:40 2010 @@ -495,13 +495,14 @@ (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)) + ;change over new item identifiers to the old construct + ;the version-history is also changed if the construct was + ;marked-as-deleted before + (when (or (copy-item-identifiers new-construct existing-construct) + (not (find-most-recent-revision existing-construct))) + (add-to-version-history existing-construct + :start-revision start-revision)) + (delete-construct new-construct) existing-construct) (progn From lgiessmann at common-lisp.net Thu Apr 22 10:51:40 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 22 Apr 2010 06:51:40 -0400 Subject: [isidorus-cvs] r285 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 22 06:51:39 2010 New Revision: 285 Log: new-datamodel: adapted the "mark-as-deleted" and "marked-as-deleted-p" methods to the new datamodel; added some unit-tests for mergeing topics Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Thu Apr 22 06:51:39 2010 @@ -7,7 +7,6 @@ ;;+----------------------------------------------------------------------------- -;-*- standard-indent:2; tab-width:2; indent-tabs-mode:nil -*- (in-package :datamodel) (defun get-all-revisions () @@ -36,19 +35,28 @@ (sort revision-set #'<))) -(defun find-associations-for-topic (top) - "find all associations of this topic" +(defun find-all-associations-for-topic (top &key (revision *TM-REVISION*)) + "Finds all associations for a topic." + (remove-duplicates + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles top :revision revision)))) + + +(defun find-associations-for-topic (top &key (revision *TM-REVISION*)) + "Finds all associations of this topic except type-instance-associations." (let ((type-instance-topic (d:identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/type-instance")))) - (remove - type-instance-topic - (remove-duplicates - (map 'list #'parent (player-in-roles top))) - :key #'instance-of))) + (remove-if + #'(lambda(assoc) + (when (eql (instance-of assoc :revision revision) + type-instance-topic) + t)) + (find-all-associations-for-topic top :revision revision)))) (defgeneric find-referenced-topics (construct) @@ -208,53 +216,9 @@ 'unique-id unique-id)) -;(defgeneric mark-as-deleted (construct &key source-locator revision) -; (:documentation "Mark a construct as deleted if it comes from the source indicated by -;source-locator")) - -;(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision) -; "Mark a topic as deleted if it comes from the source indicated by -;source-locator" -; (declare (ignorable source-locator)) -; (let -; ((last-version ;the last active version -; (find 0 (versions construct) :key #'end-revision))) -; (when last-version -; (setf (end-revision last-version) revision)))) -; -;(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision) -; "Mark an association and its roles as deleted" -; (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator)) -; (roles ass)) -; (call-next-method)) -; -;(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision) -; "Mark a topic as deleted if it comes from the source indicated by -;source-locator" -; ;;Part 1b, 1.4.3.3.1: -; ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F -; ;; * Let SI be the value of TopicSI element in ATOM entry E -; ;; * feed F contains E -; ;; * entry E references topic fragment TF -; ;; * Let LTM be the local topic map -; ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI -; ;; * For all names, occurrences and associations in which T plays a role, TMC -; ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC -; ;; * Merge in the fragment TF using SP as the base all generated source locators. -; -; (when -; (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top)) -; (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator)) -; (names top)) -; (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator)) -; (occurrences top)) -; (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator)) -; (find-associations-for-topic top)) -; (call-next-method))) - (defgeneric add-source-locator (construct &key source-locator revision) (:documentation "adds an item identifier to a given construct based on the source -locator and an internally generated id (ideally a uuid)")) + locator and an internally generated id (ideally a uuid)")) (defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision) (declare (ignorable revision)) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 22 06:51:39 2010 @@ -839,6 +839,15 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric mark-as-deleted (construct &key source-locator revision) + (:documentation "Mark a construct as deleted if it comes from the source + indicated by source-locator")) + + +(defgeneric marked-as-deleted-p (construct) + (:documentation "Returns t if the construct was marked-as-deleted.")) + + (defgeneric find-self-or-equal (construct parent-construct &key revision) (:documentation "Returns the construct 'construct' if is owned by the parent-construct or an equal construct or nil if there @@ -875,11 +884,6 @@ Variants are deleted from names by calling delete-variant.")) -(defgeneric mark-as-deleted (construct &key source-locator revision) - (:documentation "Mark a construct as deleted if it comes from the source - indicated by source-locator")) - - (defgeneric find-oldest-construct (construct-1 construct-2) (:documentation "Returns the construct which owns the oldes version info. If a construct is not a versioned construct the oldest @@ -1089,14 +1093,11 @@ :versioned-construct construct)))))))) -(defgeneric marked-as-deleted-p (construct) - (:documentation "Returns t if the construct was marked-as-deleted.") - (:method ((construct VersionedConstructC)) - (if (find-if #'(lambda(vi) +(defmethod marked-as-deleted-p ((construct VersionedConstructC)) + (unless (find-if #'(lambda(vi) (= (end-revision vi) 0)) (versions construct)) - nil - t))) + t)) (defmethod mark-as-deleted ((construct VersionedConstructC) @@ -1107,7 +1108,7 @@ (find 0 (versions construct) :key #'end-revision))) (when last-version (setf (end-revision last-version) revision)))) - + ;;; TopicMapconstructC (defgeneric strictly-equivalent-constructs (construct-1 construct-2 @@ -1146,6 +1147,27 @@ ;;; PointerC +(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision) + "Marks the last active relation between a pointer and its parent construct + as deleted." + (declare (ignorable source-locator)) + (let ((owner (identified-construct construct :revision 0))) + (when owner + (cond ((typep construct 'PersistentIdC) + (delete-psi owner construct :revision revision)) + ((typep construct 'SubjectLocatorC) + (delete-locator owner construct :revision revision)) + ((typep construct 'ItemIdentifierC) + (delete-item-identifier owner construct :revision revision)) + ((typep construct 'TopicIdentificationC) + (delete-topic-identifier owner construct :revision revision)))))) + + +(defmethod marked-as-deleted-p ((construct PointerC)) + (unless (identified-construct construct :revision 0) + t)) + + (defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC)) (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct))) (vi-2 (find-version-info (slot-p construct-2 'identified-construct)))) @@ -1371,6 +1393,44 @@ ;;; TopicC +(defmethod mark-as-deleted :around ((top TopicC) + &key (source-locator nil sl-provided-p) + revision) + "Mark a topic as deleted if it comes from the source indicated by + source-locator" + ;;Part 1b, 1.4.3.3.1: + ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F + ;; * Let SI be the value of TopicSI element in ATOM entry E + ;; * feed F contains E) + ;; * entry E references topic fragment TF + ;; * Let LTM be the local topic map + ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI + ;; * For all names, occurrences and associations in which T plays a role, TMC + ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC + ;; * Merge in the fragment TF using SP as the base all generated source locators. + (when (or (and (not source-locator) sl-provided-p) + (and sl-provided-p + (some (lambda (psi) (string-starts-with (uri psi) source-locator)) + (psis top :revision 0)))) + (unless sl-provided-p + (mapc (lambda(psi)(mark-as-deleted psi :revision revision + :source-locator source-locator)) + (psis top :revision 0))) + (mapc (lambda(sl)(mark-as-deleted sl :revision revision + :source-locator source-locator)) + (locators top :revision 0)) + (mapc (lambda (name) (mark-as-deleted name :revision revision + :source-locator source-locator)) + (names top :revision 0)) + (mapc (lambda (occ) (mark-as-deleted occ :revision revision + :source-locator source-locator)) + (occurrences top :revision 0)) + (mapc (lambda (ass) (mark-as-deleted ass :revision revision + :source-locator source-locator)) + (find-all-associations-for-topic top :revision 0)) + (call-next-method))) + + (defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -2022,6 +2082,20 @@ ;;; CharacteristicC +(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision) + "Marks the last active relation between a characteristic and its parent topic + as deleted." + (declare (ignorable source-locator)) + (let ((owner (parent construct :revision 0))) + (when owner + (delete-characteristic owner construct :revision revision)))) + + +(defmethod marked-as-deleted-p ((construct CharacteristicC)) + (unless (parent construct :revision 0) + t)) + + (defmethod find-self-or-equal ((construct CharacteristicC) (parent-construct TopicC) &key (revision *TM-REVISION*)) @@ -2405,6 +2479,14 @@ ;;; AssociationC +(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision) + "Marks an association and its roles as deleted" + (mapc (lambda (role) + (mark-as-deleted role :revision revision :source-locator source-locator)) + (roles ass :revision 0)) + (call-next-method)) + + (defmethod equivalent-constructs ((construct-1 AssociationC) (construct-2 AssociationC) &key (revision *TM-REVISION*)) @@ -2527,6 +2609,20 @@ ;;; RoleC +(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision) + "Marks the last active relation between a role and its parent association + as deleted." + (declare (ignorable source-locator)) + (let ((owner (parent construct :revision 0))) + (when owner + (delete-role owner construct :revision revision)))) + + +(defmethod marked-as-deleted-p ((construct RoleC)) + (unless (parent construct :revision 0) + t)) + + (defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -2771,6 +2867,15 @@ ;;; ReifiableConstructC +(defmethod mark-as-deleted :around ((construct ReifiableConstructC) + &key source-locator revision) + "Marks all item-identifiers of a given reifiable-construct as deleted." + (declare (ignorable source-locator)) + (call-next-method) + (dolist (ii (item-identifiers construct :revision 0)) + (delete-item-identifier construct ii :revision revision))) + + (defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -3739,7 +3844,7 @@ (declare (integer revision)) (let ((occs-to-move (occurrences source :revision revision))) (dolist (occ occs-to-move) - (delete-occurrence occ source :revision revision) + (delete-occurrence source occ :revision revision) (let ((equivalent-occ (find-if #'(lambda (destination-occ) (when @@ -3847,7 +3952,7 @@ (move-referenced-constructs newer-topic older-topic :revision revision) (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) - (mark-as-deleted newer-topic :revision revision) + (mark-as-deleted newer-topic :revision revision :source-locator nil) (when (exist-in-revision-history-? newer-topic) (delete-construct newer-topic)) older-topic)))) 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 Thu Apr 22 06:51:39 2010 @@ -81,10 +81,11 @@ :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC :test-move-referenced-constructs-NameC - :test-move-referenced-constructs-TopicC)) + :test-merge-constructs-TopicC-1)) ;;TODO: test merge-constructs +;;TODO: test mark-as-deleted @@ -2932,13 +2933,15 @@ (variants name-2 :revision rev-2))))))))) -(test test-move-referenced-constructs-TopicC () +(test test-merge-constructs-TopicC-1 () "Tests the generic move-referenced-constructs corresponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) - (rev-2 200)) + (rev-2 200) + (rev-3 300)) (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) @@ -2956,7 +2959,7 @@ :charvalue "var-1" :themes (list theme-1))) (variant-2 (make-construct 'VariantC - :start-revision rev-1 + :start-revision rev-2 :charvalue "var-2" :themes (list theme-2))) (variant-3 (make-construct 'VariantC @@ -2973,7 +2976,8 @@ :charvalue "occ-2" :instance-of type-2)) (occ-3 (make-construct 'OccurrenceC - :start-revision rev-1 + :start-revision rev-2 + :item-identifiers (list ii-3) :charvalue "occ-1" :instance-of type-1 :themes (list theme-1)))) @@ -2981,8 +2985,68 @@ :start-revision rev-1 :charvalue "name-1" :instance-of type-1)) - ) - )))))) + (name-2 (make-construct 'NameC + :start-revision rev-2 + :charvalue "name-2" + :instance-of type-1 + :variants (list variant-1 variant-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1 + :variants (list variant-3)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :topic-identifiers (list tid-1) + :item-identifiers (list ii-1) + :locators (list sl-1) + :psis (list psi-1) + :names (list name-1 name-2) + :occurrences (list occ-1 occ-2))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :topic-identifiers (list tid-2) + :item-identifiers (list ii-2) + :locators (list sl-2) + :psis (list psi-2) + :names (list name-3) + :occurrences (list occ-3)))) + (setf *TM-REVISION* rev-3) + (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) + (is (eql top top-1)) + (is-true (d::marked-as-deleted-p top-2)) + (is-false (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + (setf *TM-REVISION* rev-2) + (is (= (length (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + 6)) + (setf *TM-REVISION* rev-3) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers top-1))) + (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (set-exclusive-or (list psi-1) + (psis top-1 :revision rev-2))) + (is-false (set-exclusive-or (list name-1 name-2) + (names top-1))) + (is-false (set-exclusive-or (variants name-1) + (list variant-3))) + (is-false (variants name-3)) + (is-false (set-exclusive-or (occurrences top-1) + (list occ-1 occ-2))) + (is-false (set-exclusive-or (item-identifiers occ-1) + (list ii-3))) + (is-false (item-identifiers occ-3)) + (is-true (d::marked-as-deleted-p name-3)) + (is-true (d::marked-as-deleted-p occ-3)))))))))) + + + (defun run-datamodel-tests() @@ -3043,5 +3107,5 @@ (it.bese.fiveam:run! 'test-find-oldest-construct) (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) - (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) ) \ No newline at end of file From lgiessmann at common-lisp.net Fri Apr 23 18:47:37 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 23 Apr 2010 14:47:37 -0400 Subject: [isidorus-cvs] r286 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Fri Apr 23 14:47:37 2010 New Revision: 286 Log: new-datamodel: fixed an elephant bug that appears in the current version --> "get-instances-by-class" is embraced within a function that filters all instances by typep and optional a given revision; fixed a potential versioning bug in "merge-all-constructs"; fixed a bug in "equivalent-construct" --> AssociationC; fixed a bug in "merge-changed-constructs"; fixed a bug in "merge-constructs" --> the returned association object is added to the union of all tms the given associations were present in; added some unit-tests 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 Fri Apr 23 14:47:37 2010 @@ -148,6 +148,9 @@ :check-for-duplicate-identifiers :find-item-by-content :rec-remf + :get-all-topics + :get-all-associations + :get-all-tms ;;globals :*TM-REVISION* @@ -156,10 +159,10 @@ (in-package :datamodel) - -;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? -;; versioned-construct of the called construct, same for add-xy ??? -;; and associations of player +;;TODO: replace add- + add-parent in all merge-constructs where the +;; characteristics are readded to make sure they are added to the current +;; version --> collidates with merge-if-equivalent!!! in merge-constructs +;;TODO: adapt changes-lisp ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -701,6 +704,34 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) + "Returns all instances of the given type and the given revision that are + stored in the db." + (declare (symbol class-symbol) (type (or null integer) revision)) + (let ((db-instances (elephant:get-instances-by-class class-symbol))) + (let ((filtered-instances (remove-if-not #'(lambda(inst) + (typep inst class-symbol)) + db-instances))) + (if revision + (remove-if #'null + (map 'list #'(lambda(inst) + (find-item-by-revision inst revision)) + filtered-instances)) + filtered-instances)))) + + +(defun get-all-topics (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicC :revision revision)) + + +(defun get-all-associations (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'AssociationC :revision revision)) + + +(defun get-all-tms (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicMapC :revision revision)) + + (defun find-version-info (versioned-constructs &key (sort-function #'<) (sort-key 'start-revision)) "Returns all version-infos sorted by the function sort-function which is @@ -811,14 +842,15 @@ (condition () nil))) -(defun merge-all-constructs(constructs-to-be-merged) +(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*)) "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))))) + (merge-constructs merged-construct construct-to-be-merged + :revision revision))))) (defgeneric internal-id (construct) @@ -980,7 +1012,7 @@ ;;; VersionedConstructC -(defgeneric exist-in-revision-history-? (versioned-construct) +(defgeneric exist-in-version-history-p (versioned-construct) (:documentation "Returns t if the passed construct does not exist in any revision, i.e. the construct has no version-infos or exactly one whose start-revision is equal to its end-revision.") @@ -1106,8 +1138,16 @@ (let ((last-version ;the last active version (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision)))) + (if (and last-version + (= (start-revision last-version) revision)) + (progn + (delete-construct last-version) + (let ((sorted-versions + (sort (versions construct) #'> :key #'end-revision))) + (when sorted-versions + (setf (end-revision (first sorted-versions)) revision)))) + (when last-version + (setf (end-revision last-version) revision))))) ;;; TopicMapconstructC @@ -2494,9 +2534,14 @@ (and (eql (instance-of construct-1 :revision revision) (instance-of construct-2 :revision revision)) (not (set-exclusive-or (themes construct-1 :revision revision) - (themes construct-1 :revision revision))) - (not (set-exclusive-or (roles construct-1 :revision revision) - (roles construct-2 :revision revision))))) + (themes construct-2 :revision revision))) + + (not (set-exclusive-or + (roles construct-1 :revision revision) + (roles construct-2 :revision revision) + :test #'(lambda(role-1 role-2) + (strictly-equivalent-constructs role-1 role-2 + :revision revision)))))) (defgeneric AssociationC-p (class-symbol) @@ -2517,21 +2562,22 @@ (type (or null TopicC) instance-of)) ;; item-identifiers and reifers are not checked because the equality have to ;; be variafied without them - (let ((checked-roles - (loop for assoc-role in (roles construct :revision start-revision) - when (loop for plist in roles - when (equivalent-construct - assoc-role :player (getf plist :player) - :start-revision (or (getf plist :start-revision) - start-revision) - :instance-of (getf plist :instance-of)) - return t) - collect assoc-role))) + (let ((checked-roles nil)) + (loop for plist in roles + do (let ((found-role + (find-if #'(lambda(assoc-role) + (equivalent-construct + assoc-role :player (getf plist :player) + :start-revision (or (getf plist :start-revision) + start-revision) + :instance-of (getf plist :instance-of))) + (roles construct :revision start-revision)))) + (when found-role + (push found-role checked-roles)))) (and (not (set-exclusive-or (roles construct :revision start-revision) checked-roles)) - (= (length (roles construct :revision start-revision)) - (length roles)) + (= (length checked-roles) (length roles)) (equivalent-typable-construct construct instance-of :start-revision start-revision) (equivalent-scopable-construct construct themes @@ -3428,9 +3474,10 @@ :roles roles :themes themes :instance-of instance-of) existing-association)) - (elephant:get-instances-by-class 'AssociationC))))) + (get-all-associations nil))))) (cond ((> (length existing-associations) 1) - (merge-all-constructs existing-associations)) + (merge-all-constructs existing-associations + :revision start-revision)) (existing-associations (first existing-associations)) (t @@ -3512,9 +3559,9 @@ :item-identifiers item-identifiers :reifier reifier) existing-tm)) - (elephant:get-instances-by-class 'TopicMapC))))) + (get-all-tms start-revision))))) (cond ((> (length existing-tms) 1) - (merge-all-constructs existing-tms)) + (merge-all-constructs existing-tms :revision start-revision)) (existing-tms (first existing-tms)) (t @@ -3554,9 +3601,9 @@ :item-identifiers item-identifiers :topic-identifiers topic-identifiers) existing-topic)) - (elephant:get-instances-by-class 'TopicC))))) + (get-all-topics start-revision))))) (cond ((> (length existing-topics) 1) - (merge-all-constructs existing-topics)) + (merge-all-constructs existing-topics :revision start-revision)) (existing-topics (first existing-topics)) (t @@ -3919,23 +3966,61 @@ (let ((parent (when (or (typep construct 'RoleC) (typep construct 'CharacteristicC)) (parent construct :revision revision)))) - (let ((found-equivalent - (find-if #'(lambda(other-construct) - (strictly-equivalent-constructs - other-construct construct :revision revision)) - (cond ((typep construct 'OccurrenceC) - (occurrences parent :revision revision)) - ((typep construct 'NameC) - (names parent :revision revision)) - ((typep construct 'VariantC) - (variants parent :revision revision)) - ((typep construct 'RoleC) - (roles parent :revision revision)) - ((typep construct 'AssociationC) - (elephant:get-instances-by-class 'AssociationC)))))) - (when found-equivalent - (merge-all-constructs (append found-equivalent (list construct)))))))) - + (let ((all-other (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision))))) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(other) + (when (strictly-equivalent-constructs + construct other :revision revision) + other)) + all-other)))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list construct)) + :revision revision)))))) + (merge-changed-associations older-topic :revision revision)) + + +(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) + "Merges all associations that became TMDM-equal since two referenced topics + were merged, e.g. the association types." + (declare (TopicC older-topic)) + (let ((all-assocs + (remove-duplicates + (append + (remove-if + #'null + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles older-topic :revision revision))) + (remove-if + #'null + (map + 'list #'(lambda(constr) + (when (typep constr 'AssociationC) + constr)) + (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision)))))))) + (dolist (assoc all-assocs) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(db-assoc) + (when (strictly-equivalent-constructs + assoc db-assoc :revision revision) + db-assoc)) + (get-all-associations nil))))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list assoc)) + :revision revision)))))) + (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) @@ -3953,7 +4038,7 @@ (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) (mark-as-deleted newer-topic :revision revision :source-locator nil) - (when (exist-in-revision-history-? newer-topic) + (when (exist-in-version-history-p newer-topic) (delete-construct newer-topic)) older-topic)))) @@ -3980,7 +4065,7 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-char older-char :revision revision) - (delete-characteristic newer-char parent-2 + (delete-characteristic parent-2 newer-char :revision revision) older-char) ((and parent-1 parent-2) @@ -4032,7 +4117,7 @@ (add-to-tm top-or-assoc top-or-assoc)) (add-to-version-history older-tm :start-revision revision) (mark-as-deleted newer-tm :revision revision) - (when (exist-in-revision-history-? newer-tm) + (when (exist-in-version-history-p newer-tm) (delete-construct newer-tm)) older-tm)))) @@ -4053,6 +4138,8 @@ construct-1 construct-2) :construct-1 construct-1 :construct-2 construct-2))) + (dolist (tm (in-topicmaps newer-assoc :revision revision)) + (add-to-tm tm older-assoc)) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4065,7 +4152,7 @@ (delete-role newer-assoc newer-role :revision revision) (add-role older-assoc equivalent-role :revision revision))) (mark-as-deleted newer-assoc :revision revision) - (when (exist-in-revision-history-? newer-assoc) + (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) older-assoc)))) @@ -4091,8 +4178,14 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-role older-role :revision revision) - (delete-role newer-role parent-2 :revision revision) - (add-role older-role parent-1 :revision revision)) + (delete-role parent-2 newer-role :revision revision) + (let ((r-assoc + (find-if + #'(lambda(r-assoc) + (and (eql (role r-assoc) older-role) + (eql (parent-construct r-assoc) parent-1))) + (slot-p parent-1 'roles)))) + (add-to-version-history r-assoc :start-revision revision))) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision revision))) 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 Fri Apr 23 14:47:37 2010 @@ -81,7 +81,12 @@ :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC :test-move-referenced-constructs-NameC - :test-merge-constructs-TopicC-1)) + :test-merge-constructs-TopicC-1 + :test-merge-constructs-TopicC-2 + :test-merge-constructs-TopicC-3 + :test-merge-constructs-TopicC-4 + :test-merge-constructs-TopicC-5 + :test-merge-constructs-TopicC-6)) ;;TODO: test merge-constructs @@ -1815,7 +1820,7 @@ :start-revision rev-1)) (role-2 (list :player player-2 :instance-of r-type-2 :start-revision rev-1)) - (role-3 (list :instance-of r-type-3 :player player-3 + (role-3 (list :player player-3 :instance-of r-type-3 :start-revision rev-1)) (type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) @@ -1877,7 +1882,7 @@ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-3)) (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4)) (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5)) - (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) + (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) (test test-equivalent-TopicC () @@ -3046,6 +3051,414 @@ (is-true (d::marked-as-deleted-p occ-3)))))))))) +(test test-merge-constructs-TopicC-2 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-2")) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (variant-2 (make-construct 'VariantC + :start-revision rev-2 + :charvalue "var-2" + :themes (list theme-2))) + (variant-3 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1))) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-2" + :instance-of type-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-3) + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1)))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1)) + (name-2 (make-construct 'NameC + :start-revision rev-2 + :charvalue "name-2" + :instance-of type-1 + :variants (list variant-1 variant-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1 + :variants (list variant-3)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :topic-identifiers (list tid-1) + :item-identifiers (list ii-1) + :locators (list sl-1) + :psis (list psi-1) + :names (list name-1 name-2) + :occurrences (list occ-1 occ-2))) + (top-2 (make-construct 'TopicC + :start-revision rev-3 + :topic-identifiers (list tid-2) + :item-identifiers (list ii-2) + :locators (list sl-2) + :psis (list psi-2) + :names (list name-3) + :occurrences (list occ-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (is (eql top top-1)) + (is-false (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers top-1))) + (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (set-exclusive-or (list psi-1) + (psis top-1 :revision rev-2))) + (is-false (set-exclusive-or (list name-1 name-2) + (names top-1))) + (is-false (set-exclusive-or (variants name-1) + (list variant-3))) + (is-false (variants name-3)) + (is-false (set-exclusive-or (occurrences top-1) + (list occ-1 occ-2))) + (is-false (set-exclusive-or (item-identifiers occ-1) + (list ii-3))) + (is-false (item-identifiers occ-3)) + (is-true (d::marked-as-deleted-p name-3)) + (is-true (d::marked-as-deleted-p occ-3)))))))))) + + +(test test-merge-constructs-TopicC-3 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (n-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")) + (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5")) + (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6")) + (var-0-1 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1")) + (var-0-2 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1"))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :charvalue "occ" + :instance-of type-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-2) + :charvalue "occ" + :instance-of type-2)) + (name-1 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-3) + :variants (list var-0-1) + :charvalue "name" + :instance-of type-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-4) + :variants (list var-0-2) + :charvalue "name" + :instance-of type-2)) + (var-1 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-5) + :charvalue "var" + :themes (list type-1))) + (var-2 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-6) + :charvalue "var" + :themes (list type-2)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :occurrences (list occ-1 occ-2) + :names (list name-1 name-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3" + :instance-of n-type + :variants (list var-1 var-2)))) + (let ((top-2 (make-construct 'TopicC + :start-revision rev-1 + :names (list name-3)))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (occurrences top-1)) 1)) + (is-false (set-exclusive-or + (list ii-1 ii-2) + (item-identifiers (first (occurrences top-1))))) + (is (= (length (slot-value top-1 'd::occurrences)) 2)) + (is (= (length (names top-1)) 1)) + (is-false (set-exclusive-or + (list ii-3 ii-4) + (item-identifiers (first (names top-1))))) + (is (= (length (slot-value top-1 'd::names)) 2)) + (is-false (set-exclusive-or (list var-0-1 var-0-2) + (variants (first (names top-1))))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(occ) + (eql occ (first (occurrences top-1)))) + (slot-value top-1 'd::occurrences)))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(name) + (eql name (first (names top-1)))) + (slot-value top-1 'd::names)))) + (is (= (length (variants (first (names top-2)))) 1)) + (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2)) + (is (eql (first (themes (first (variants (first (names top-2)))))) + type-1))))))))) + + +(test test-merge-constructs-TopicC-4 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (r-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player type-1 + :instance-of r-type + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player type-2 + :item-identifiers (list ii-2) + :instance-of r-type + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-1)) 1)) + (is (= (length (slot-value assoc-1 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-1))) r-type)) + (is (eql (player (first (roles assoc-1))) type-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-1))))) + (let ((active-role (first (roles assoc-1))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-1)))) + (slot-value assoc-1 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-5 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player player-1 + :instance-of type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-1 + :item-identifiers (list ii-2) + :instance-of type-2 + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-2)) 1)) + (is (= (length (slot-value assoc-2 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-2))) type-1)) + (is (eql (player (first (roles assoc-2))) player-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-2))))) + (let ((active-role (first (roles assoc-2))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-2)))) + (slot-value assoc-2 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-6 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :item-identifiers (list ii-3) + :roles (list (list :player player-1 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-2 + :instance-of r-type-2 + :start-revision rev-1)))) + (assoc-4 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-2 + :item-identifiers (list ii-4) + :roles (list (list :player player-1 + :instance-of r-type-1 + :start-revision rev-2) + (list :player player-2 + :item-identifiers (list ii-2) + :instance-of r-type-2 + :start-revision rev-2))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (d::versions assoc-3)) 2)) + (is (= (length (d::versions assoc-4)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-1) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-2) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-4))) + (is (= (length (roles assoc-3)) 2)) + (is (= (length (item-identifiers (first (roles assoc-3)))) 1)) + (is (= (length (item-identifiers (second (roles assoc-3)))) 1)) + (is (or (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-1") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-2")) + (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-2") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-1"))))))))) + + + + + + +;;TODO: merge topics/associations caused by a merge of their characteristics +;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified +;; by the same reifier @@ -3108,4 +3521,9 @@ (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) ) \ No newline at end of file From lgiessmann at common-lisp.net Fri Apr 23 19:51:28 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 23 Apr 2010 15:51:28 -0400 Subject: [isidorus-cvs] r287 - branches/new-datamodel/src/model Message-ID: Author: lgiessmann Date: Fri Apr 23 15:51:28 2010 New Revision: 287 Log: new-datamodel: fixed a versioningproblem in "merge-constructs" --> CharacteristicC Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Apr 23 15:51:28 2010 @@ -159,9 +159,6 @@ (in-package :datamodel) -;;TODO: replace add- + add-parent in all merge-constructs where the -;; characteristics are readded to make sure they are added to the current -;; version --> collidates with merge-if-equivalent!!! in merge-constructs ;;TODO: adapt changes-lisp ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs @@ -4067,6 +4064,18 @@ :revision revision) (delete-characteristic parent-2 newer-char :revision revision) + (let ((c-assoc + (find-if + #'(lambda(c-assoc) + (and (eql (characteristic c-assoc) older-char) + (eql (parent-construct c-assoc) parent-1))) + (cond ((typep older-char 'OccurrenceC) + (slot-p parent-1 'occurrences)) + ((typep older-char 'NameC) + (slot-p parent-1 'names)) + ((typep older-char 'VariantC) + (slot-p parent-1 'variants)))))) + (add-to-version-history c-assoc :start-revision revision)) older-char) ((and parent-1 parent-2) (let ((active-parent (merge-constructs parent-1 parent-2 @@ -4185,7 +4194,8 @@ (and (eql (role r-assoc) older-role) (eql (parent-construct r-assoc) parent-1))) (slot-p parent-1 'roles)))) - (add-to-version-history r-assoc :start-revision revision))) + (add-to-version-history r-assoc :start-revision revision) + older-role)) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision revision))) From lgiessmann at common-lisp.net Tue Apr 27 19:51:48 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 27 Apr 2010 15:51:48 -0400 Subject: [isidorus-cvs] r288 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Tue Apr 27 15:51:47 2010 New Revision: 288 Log: new-datamodel: fixed bugs in the function: "add-item-identifier", "add-variant" and "make-topic"; added new unit-tests 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 Tue Apr 27 15:51:47 2010 @@ -98,7 +98,7 @@ :charvalue :reified-construct :mark-as-deleted - :mark-as-deleted-p + :marked-as-deleted-p :in-topicmaps :delete-construct :get-revision @@ -152,6 +152,7 @@ :get-all-associations :get-all-tms + ;;globals :*TM-REVISION* :*CURRENT-XTM*)) @@ -159,11 +160,8 @@ (in-package :datamodel) +;;TODO: remove- --> add to version history??? ;;TODO: adapt changes-lisp -;;TODO: check merge-constructs in add-topic-identifier, -;; add-item-identifier/add-reifier (can merge the parent constructs -;; and the parent's parent construct + the reifier constructs), -;; add-psi, add-locator (--> duplicate-identifier-error) ;;TODO: implement a macro with-merge-constructs, that merges constructs ;; after all operations in the body were called @@ -2483,6 +2481,9 @@ :characteristic variant :parent-construct construct :start-revision revision)) + (when (parent construct :revision revision) + (add-name (parent construct :revision revision) construct + :revision revision)) construct)))) @@ -3046,8 +3047,16 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (when (typep construct 'VersionedConstructC) - (add-to-version-history merged-construct :start-revision revision)) + (cond ((typep merged-construct 'VersionedConstructC) + (add-to-version-history merged-construct :start-revision revision)) + ((and (typep merged-construct 'CharacteristicC) + (parent merged-construct :revision revision)) + (add-characteristic (parent merged-construct :revision revision) + merged-construct :revision revision)) + ((and (typep merged-construct 'RoleC) + (parent merged-construct :revision revision)) + (add-role (parent merged-construct :revision revision) + merged-construct :revision revision))) merged-construct)))) @@ -3086,9 +3095,11 @@ (slot-p reifier-topic 'reified-construct)))) (let ((merged-construct construct)) (cond ((reified-construct merged-reifier-topic :revision revision) - (merge-constructs - (reified-construct merged-reifier-topic :revision revision) - construct)) + (let ((merged-reified + (merge-constructs + (reified-construct merged-reifier-topic + :revision revision) construct))) + (setf merged-construct merged-reified))) ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in @@ -3578,7 +3589,8 @@ (item-identifiers (getf args :item-identifiers)) (topic-identifiers (getf args :topic-identifiers)) (names (getf args :names)) - (occurrences (getf args :occurrences))) + (occurrences (getf args :occurrences)) + (reified-construct (getf args :refied-construct))) (when (and (or psis locators item-identifiers topic-identifiers names occurrences) (not start-revision)) @@ -3620,6 +3632,9 @@ :revision start-revision))) (dolist (occ occurrences) (add-occurrence merged-topic occ :revision start-revision)) + (when reified-construct + (add-reified-construct merged-topic reified-construct + :revision start-revision)) merged-topic)))) @@ -3724,26 +3739,6 @@ (add-locator identified-construct identifier :revision start-revision)))) identifier))) - - - - - - - - - - - - - - - - - - - - ;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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 Tue Apr 27 15:51:47 2010 @@ -86,10 +86,13 @@ :test-merge-constructs-TopicC-3 :test-merge-constructs-TopicC-4 :test-merge-constructs-TopicC-5 - :test-merge-constructs-TopicC-6)) + :test-merge-constructs-TopicC-6 + :test-merge-constructs-TopicC-7 + :test-merge-constructs-TopicC-8)) -;;TODO: test merge-constructs +;;TODO: test merge-constructs --> associations when merge was caused by +;; item-identifier of two roles ;;TODO: test mark-as-deleted @@ -3452,13 +3455,113 @@ "ii-1"))))))))) +(test test-merge-constructs-TopicC-7 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (tid-1 (make-construct 'TopicIdentificationC + :uri "tid-1" :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC + :uri "tid-2" :xtm-id "xtm-2")) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-2 (make-construct 'TopicC :start-revision rev-1)) + (top-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list psi-1) + :topic-identifiers (list tid-1))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :locators (list sl-1) + :topic-identifiers (list tid-2)))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :instance-of type-1 + :themes (list scope-1 scope-2) + :charvalue "occ" + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-2) + :instance-of type-1 + :themes (list scope-1 scope-2) + :charvalue "occ" + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-3) + :instance-of type-1 + :themes (list scope-1) + :charvalue "occ" + :parent top-1))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-topics rev-1)) 4)) + (is (= (length (get-all-topics rev-3)) 5)) + (is (= (length (d::get-db-instances-by-class + 'd::OccurrenceC :revision nil)) 3)) + (signals not-mergable-error (add-item-identifier occ-3 ii-1)) + (is (eql occ-1 (add-item-identifier occ-1 ii-2))) + (is (= (length (get-all-topics rev-3)) 4)) + (is-true (d::marked-as-deleted-p occ-2)) + (is-true (d::marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers occ-1))) + (is-false (item-identifiers occ-2)) + (is-false (set-exclusive-or (list ii-2) + (item-identifiers occ-2 :revision rev-2))) + (is-false (set-exclusive-or (list psi-1) (psis top-1))) + (is-false (set-exclusive-or (list sl-1) (locators top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (locators top-2))))))) +(test test-merge-constructs-TopicC-8 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((top-1 (make-construct 'TopicC :start-revision rev-1)) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-1 + :charvalue "occ" + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-2 + :charvalue "occ" + :parent top-1))) + (setf *TM-REVISION* rev-3) + (signals not-mergable-error (add-reifier occ-3 reifier-1)) + (is (eql (add-reifier occ-2 reifier-1) occ-1)) + (is-true (marked-as-deleted-p top-2)) + (is-true (marked-as-deleted-p occ-2))))))) + +;;TODO: merge topics caused by variant-item-identifiers +;;TODO: mrege topics caused by reifying the same reified-construct +;;TODO: merge associations caused by a merge of their characteristics -;;TODO: merge topics/associations caused by a merge of their characteristics -;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified -;; by the same reifier @@ -3526,4 +3629,6 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) ) \ No newline at end of file From lgiessmann at common-lisp.net Wed Apr 28 09:35:03 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 28 Apr 2010 05:35:03 -0400 Subject: [isidorus-cvs] r289 - trunk/src/json Message-ID: Author: lgiessmann Date: Wed Apr 28 05:35:03 2010 New Revision: 289 Log: json-exporter: fixed a bug in the function "get-all-topics" Modified: trunk/src/json/json_exporter.lisp Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Wed Apr 28 05:35:03 2010 @@ -298,8 +298,10 @@ (remove-if #'null (map 'list #'(lambda(psi-list) (when psi-list (map 'list #'uri psi-list))) - (clean-topics - (elephant:get-instances-by-class 'TopicC)))))) + (map 'list + #'d:psis + (clean-topics + (elephant:get-instances-by-class 'TopicC))))))) (defun to-json-string-summary (topic) From lgiessmann at common-lisp.net Thu Apr 29 10:17:21 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 29 Apr 2010 06:17:21 -0400 Subject: [isidorus-cvs] r290 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 29 06:17:20 2010 New Revision: 290 Log: new-datamodel: fixed a problem when topic-merging was caused by reifying the same "ReifiableConstructC"; fixed a bug when two topics are merged and every of these topics reifies a construct that can't be merged with the other one. 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 Thu Apr 29 06:17:20 2010 @@ -3086,6 +3086,15 @@ the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) &key (revision *TM-REVISION*)) + (when (and (reified-construct reifier-topic :revision revision) + (not (equivalent-constructs construct + (reified-construct + reifier-topic :revision revision)))) + (error (make-condition 'not-mergable-error + :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" + reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) + :construct-1 construct + :construct-2 (reified-construct reifier-topic :revision revision)))) (let ((merged-reifier-topic (if (reifier construct :revision revision) (merge-constructs (reifier construct :revision revision) @@ -3852,7 +3861,9 @@ (let ((source-reified (reified-construct source :revision revision)) (destination-reified (reified-construct destination :revision revision))) - (unless (eql (type-of source-reified) (type-of destination-reified)) + (when (and source-reified destination-reified + (not (eql (type-of source-reified) + (type-of destination-reified)))) (error (make-condition 'not-mergable-error :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" source destination source-reified destination-reified) @@ -3868,10 +3879,10 @@ merged-reified)) (source-reified (delete-reifier source source-reified :revision revision) - (add-reifier destination source-reified :revision revision) + (add-reifier source-reified destination :revision revision) source-reified) (destination-reified - (add-reifier destination destination-reified :revision revision) + (add-reifier destination-reified destination :revision revision) destination-reified))))) 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 Thu Apr 29 06:17:20 2010 @@ -88,7 +88,8 @@ :test-merge-constructs-TopicC-5 :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 - :test-merge-constructs-TopicC-8)) + :test-merge-constructs-TopicC-8 + :test-merge-constructs-TopicC-9)) ;;TODO: test merge-constructs --> associations when merge was caused by @@ -3554,12 +3555,96 @@ (setf *TM-REVISION* rev-3) (signals not-mergable-error (add-reifier occ-3 reifier-1)) (is (eql (add-reifier occ-2 reifier-1) occ-1)) + (is-false (set-exclusive-or (list occ-1 occ-3) (occurrences top-1))) (is-true (marked-as-deleted-p top-2)) - (is-true (marked-as-deleted-p occ-2))))))) + (is-true (marked-as-deleted-p occ-2)) + (is (= (length (d::versions top-1)) 2)) + (is (= (length (d::versions top-2)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (d::versions top-2))) + (is (= (length (slot-value occ-2 'd::parent)) 1)) + (is (= (length (slot-value occ-1 'd::parent)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (first (map 'list #'d::versions + (slot-value occ-2 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent)))))))))) + + +(test test-merge-constructs-TopicC-9 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))) + (let ((top-1 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-2))) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (top-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (reifier-2 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-1))) + (reifier-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-4 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-2 + :charvalue "occ" + :reifier reifier-3 + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-4 + :parent top-3))) + (setf *TM-REVISION* rev-3) + (is (eql (reifier occ-2) reifier-3)) + (signals not-mergable-error (add-reifier occ-1 reifier-3)) + (is (eql occ-1 (add-reifier occ-1 reifier-2))) + (is-true (marked-as-deleted-p reifier-2)) + (is-false (set-exclusive-or (list psi-1) (psis reifier-1))) + (setf *TM-REVISION* rev-4) + (is (eql (add-reifier occ-1 reifier-4) occ-3)) + (is-true (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p top-3)) + (is-false (set-exclusive-or (list psi-2) (psis top-3))) + (is-false (marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list occ-2) (occurrences top-2)))))))) ;;TODO: merge topics caused by variant-item-identifiers -;;TODO: mrege topics caused by reifying the same reified-construct ;;TODO: merge associations caused by a merge of their characteristics @@ -3631,4 +3716,5 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) ) \ No newline at end of file From lgiessmann at common-lisp.net Thu Apr 29 10:47:47 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 29 Apr 2010 06:47:47 -0400 Subject: [isidorus-cvs] r291 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 29 06:47:46 2010 New Revision: 291 Log: new-datamodel: fixed a bug when merging topics by adding an item-identifier to two different variants of the topic's names that are mergable 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 Thu Apr 29 06:47:46 2010 @@ -4101,7 +4101,10 @@ (find older-char (variants name :revision revision))) - (names active-parent :revision revision)))))) + (if (parent active-parent :revision revision) + (names (parent active-parent :revision revision) + :revision revision) + (list active-parent))))))) (if found-older-char older-char newer-char)))) 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 Thu Apr 29 06:47:46 2010 @@ -89,13 +89,8 @@ :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 - :test-merge-constructs-TopicC-9)) - - -;;TODO: test merge-constructs --> associations when merge was caused by -;; item-identifier of two roles -;;TODO: test mark-as-deleted - + :test-merge-constructs-TopicC-9 + :test-merge-constructs-TopicC-10)) (declaim (optimize (debug 3))) @@ -3644,8 +3639,87 @@ (is-false (set-exclusive-or (list occ-2) (occurrences top-2)))))))) -;;TODO: merge topics caused by variant-item-identifiers -;;TODO: merge associations caused by a merge of their characteristics + +(test test-merge-constructs-TopicC-10 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list psi-1))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :psis (list psi-2))) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-1 (make-construct 'TopicC :start-revision rev-1))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :instance-of nil + :charvalue "name" + :themes (list scope-1) + :item-identifiers (list ii-1) + :parent top-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :instance-of type-1 + :charvalue "name" + :themes (list scope-1) + :parent top-1)) + (name-3 (make-construct 'NameC + :start-revision rev-2 + :instance-of nil + :charvalue "name" + :themes (list scope-1) + :item-identifiers (list ii-2) + :parent top-2)) + (name-4 (make-construct 'NameC + :start-revision rev-2 + :instance-of type-1 + :charvalue "name" + :themes nil + :parent top-2))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "variant" + :themes (list scope-1) + :item-identifiers (list ii-3 ii-4) + :parent name-1)) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "variant" + :themes (list scope-1) + :parent name-4)) + (variant-3 (make-construct 'VariantC + :start-revision rev-2 + :charvalue "variant" + :themes (list scope-1) + :parent name-3))) + (setf *TM-REVISION* rev-3) + (signals not-mergable-error (add-item-identifier variant-2 ii-4)) + (is-false (marked-as-deleted-p top-2)) + (is-false (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p name-4)) + (is (eql (add-item-identifier variant-3 ii-4) variant-1)) + (is-true (marked-as-deleted-p top-2)) + (is-false (names top-2)) + (is-false (psis top-2)) + (is-false (set-exclusive-or (list name-1 name-2 name-4) (names top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list variant-1) (variants name-1))) + (is-false (set-exclusive-or (list variant-2) (variants name-4))) + (is (= (length (d::versions top-1)) 2)))))))) + + + +;;TODO: merge associations caused by a merge of their roles @@ -3717,4 +3791,5 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) ) \ No newline at end of file From lgiessmann at common-lisp.net Thu Apr 29 15:07:07 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 29 Apr 2010 11:07:07 -0400 Subject: [isidorus-cvs] r292 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Apr 29 11:07:06 2010 New Revision: 292 Log: new-datamodel: fixed two bugs in "merge-constructs" corresponding to "AssociationC" 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 Thu Apr 29 11:07:06 2010 @@ -4149,8 +4149,15 @@ (let ((newer-assoc (if (eql older-assoc construct-1) construct-2 construct-1))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) + ;(unless (strictly-equivalent-constructs construct-1 construct-2 + ; :revision revision) + ;;associations that have different roles can be although merged, e.g. + ;;two roles are in two different association objects references + ;;the same item-identifier or reifier + (when (or (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision)) + (not (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)))) (error (make-condition 'not-mergable-error :message (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) @@ -4158,6 +4165,8 @@ :construct-2 construct-2))) (dolist (tm (in-topicmaps newer-assoc :revision revision)) (add-to-tm tm older-assoc)) + (delete-type newer-assoc (instance-of newer-assoc :revision revision) + :revision revision) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4165,10 +4174,14 @@ (strictly-equivalent-constructs older-role newer-role :revision revision)) (roles older-assoc :revision revision)))) - (move-referenced-constructs newer-role equivalent-role - :revision revision) + (when equivalent-role + (move-referenced-constructs newer-role equivalent-role + :revision revision)) (delete-role newer-assoc newer-role :revision revision) - (add-role older-assoc equivalent-role :revision revision))) + (add-role older-assoc (if equivalent-role + equivalent-role + newer-role) + :revision revision))) (mark-as-deleted newer-assoc :revision revision) (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) 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 Thu Apr 29 11:07:06 2010 @@ -90,7 +90,8 @@ :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 :test-merge-constructs-TopicC-9 - :test-merge-constructs-TopicC-10)) + :test-merge-constructs-TopicC-10 + :test-merge-constructs-AssociationC)) (declaim (optimize (debug 3))) @@ -2938,7 +2939,7 @@ (test test-merge-constructs-TopicC-1 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3051,7 +3052,7 @@ (test test-merge-constructs-TopicC-2 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3165,7 +3166,7 @@ (test test-merge-constructs-TopicC-3 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3265,7 +3266,7 @@ (test test-merge-constructs-TopicC-4 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3323,7 +3324,7 @@ (test test-merge-constructs-TopicC-5 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3381,7 +3382,7 @@ (test test-merge-constructs-TopicC-6 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3452,7 +3453,7 @@ (test test-merge-constructs-TopicC-7 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3521,7 +3522,7 @@ (test test-merge-constructs-TopicC-8 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3587,7 +3588,7 @@ (test test-merge-constructs-TopicC-9 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3641,7 +3642,7 @@ (test test-merge-constructs-TopicC-10 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corres?ponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3716,12 +3717,82 @@ (is-false (set-exclusive-or (list variant-1) (variants name-1))) (is-false (set-exclusive-or (list variant-2) (variants name-4))) (is (= (length (d::versions top-1)) 2)))))))) - - - -;;TODO: merge associations caused by a merge of their roles +(test test-merge-constructs-AssociationC () + "Tests merge-constructs corresponding to AssociationC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-1)) + (role-2-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-2)) + (role-2-2 (list :start-revision rev-2 + :player player-1 + :item-identifiers (list ii-2) + :instance-of r-type-2)) + (role-3 (list :start-revision rev-2 + :player player-2 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :instance-of r-type-2))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :roles (list role-1 role-2-1))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-2-2 role-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-associations nil)) 2)) + (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-1 role-2-1)) + (is (= (length (get-all-associations nil)) 2)) + (let ((role-2-1-inst + (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1))) + (roles assoc-1)))) + (is-true role-2-1-inst) + (is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst)) + (is-true (marked-as-deleted-p assoc-2)) + (is-false (roles assoc-2)) + (is-false (instance-of assoc-2)) + (is-false (themes assoc-2)) + (is (eql (instance-of assoc-2 :revision rev-2) type-1)) + (is (= (length (roles assoc-1)) 3)) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-1))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-2) + (not (set-exclusive-or + (list ii-1) + (item-identifiers role))))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1) + (not (set-exclusive-or + (list ii-2) + (item-identifiers role))))) + (roles assoc-1)))))))))) (defun run-datamodel-tests() @@ -3792,4 +3863,4 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) - ) \ No newline at end of file + (it.bese.fiveam:run! 'test-merge-constructs-AssociationC)) \ No newline at end of file