Changeset 286 for branches/new-datamodel
- Timestamp:
- 04/23/10 18:47:37 (15 years ago)
- Location:
- branches/new-datamodel/src
- Files:
-
- 2 edited
-
model/datamodel.lisp (modified) (19 diffs)
-
unit_tests/datamodel_test.lisp (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
TabularUnified branches/new-datamodel/src/model/datamodel.lisp ¶
r285 r286 149 149 :find-item-by-content 150 150 :rec-remf 151 :get-all-topics 152 :get-all-associations 153 :get-all-tms 151 154 152 155 ;;globals … … 157 160 158 161 159 160 ;; TODO: mark-as-deleted should call mark-as-deleted for every owned ???161 ;; version ed-construct of the called construct, same for add-xy ???162 ;; and associations of player162 ;;TODO: replace add-<xy> + add-parent in all merge-constructs where the 163 ;; characteristics are readded to make sure they are added to the current 164 ;; version --> collidates with merge-if-equivalent!!! in merge-constructs 165 ;;TODO: adapt changes-lisp 163 166 ;;TODO: check merge-constructs in add-topic-identifier, 164 167 ;; add-item-identifier/add-reifier (can merge the parent constructs … … 702 705 703 706 ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 707 (defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) 708 "Returns all instances of the given type and the given revision that are 709 stored in the db." 710 (declare (symbol class-symbol) (type (or null integer) revision)) 711 (let ((db-instances (elephant:get-instances-by-class class-symbol))) 712 (let ((filtered-instances (remove-if-not #'(lambda(inst) 713 (typep inst class-symbol)) 714 db-instances))) 715 (if revision 716 (remove-if #'null 717 (map 'list #'(lambda(inst) 718 (find-item-by-revision inst revision)) 719 filtered-instances)) 720 filtered-instances)))) 721 722 723 (defun get-all-topics (&optional (revision *TM-REVISION*)) 724 (get-db-instances-by-class 'TopicC :revision revision)) 725 726 727 (defun get-all-associations (&optional (revision *TM-REVISION*)) 728 (get-db-instances-by-class 'AssociationC :revision revision)) 729 730 731 (defun get-all-tms (&optional (revision *TM-REVISION*)) 732 (get-db-instances-by-class 'TopicMapC :revision revision)) 733 734 704 735 (defun find-version-info (versioned-constructs 705 736 &key (sort-function #'<) (sort-key 'start-revision)) … … 812 843 813 844 814 (defun merge-all-constructs(constructs-to-be-merged )845 (defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*)) 815 846 "Merges all constructs contained in the given list." 816 847 (declare (list constructs-to-be-merged)) … … 819 850 (loop for construct-to-be-merged in constructs-to-be-merged 820 851 do (setf merged-construct 821 (merge-constructs merged-construct construct-to-be-merged))))) 852 (merge-constructs merged-construct construct-to-be-merged 853 :revision revision))))) 822 854 823 855 … … 981 1013 982 1014 ;;; VersionedConstructC 983 (defgeneric exist-in- revision-history-?(versioned-construct)1015 (defgeneric exist-in-version-history-p (versioned-construct) 984 1016 (:documentation "Returns t if the passed construct does not exist in any 985 1017 revision, i.e. the construct has no version-infos or exactly … … 1107 1139 ((last-version ;the last active version 1108 1140 (find 0 (versions construct) :key #'end-revision))) 1109 (when last-version 1110 (setf (end-revision last-version) revision)))) 1141 (if (and last-version 1142 (= (start-revision last-version) revision)) 1143 (progn 1144 (delete-construct last-version) 1145 (let ((sorted-versions 1146 (sort (versions construct) #'> :key #'end-revision))) 1147 (when sorted-versions 1148 (setf (end-revision (first sorted-versions)) revision)))) 1149 (when last-version 1150 (setf (end-revision last-version) revision))))) 1111 1151 1112 1152 … … 2495 2535 (instance-of construct-2 :revision revision)) 2496 2536 (not (set-exclusive-or (themes construct-1 :revision revision) 2497 (themes construct-1 :revision revision))) 2498 (not (set-exclusive-or (roles construct-1 :revision revision) 2499 (roles construct-2 :revision revision))))) 2537 (themes construct-2 :revision revision))) 2538 2539 (not (set-exclusive-or 2540 (roles construct-1 :revision revision) 2541 (roles construct-2 :revision revision) 2542 :test #'(lambda(role-1 role-2) 2543 (strictly-equivalent-constructs role-1 role-2 2544 :revision revision)))))) 2500 2545 2501 2546 … … 2518 2563 ;; item-identifiers and reifers are not checked because the equality have to 2519 2564 ;; be variafied without them 2520 (let ((checked-roles 2521 (loop for assoc-role in (roles construct :revision start-revision) 2522 when (loop for plist in roles 2523 when (equivalent-construct 2524 assoc-role :player (getf plist :player) 2525 :start-revision (or (getf plist :start-revision) 2526 start-revision) 2527 :instance-of (getf plist :instance-of)) 2528 return t) 2529 collect assoc-role))) 2565 (let ((checked-roles nil)) 2566 (loop for plist in roles 2567 do (let ((found-role 2568 (find-if #'(lambda(assoc-role) 2569 (equivalent-construct 2570 assoc-role :player (getf plist :player) 2571 :start-revision (or (getf plist :start-revision) 2572 start-revision) 2573 :instance-of (getf plist :instance-of))) 2574 (roles construct :revision start-revision)))) 2575 (when found-role 2576 (push found-role checked-roles)))) 2530 2577 (and 2531 2578 (not (set-exclusive-or (roles construct :revision start-revision) 2532 2579 checked-roles)) 2533 (= (length (roles construct :revision start-revision)) 2534 (length roles)) 2580 (= (length checked-roles) (length roles)) 2535 2581 (equivalent-typable-construct construct instance-of 2536 2582 :start-revision start-revision) … … 3429 3475 :instance-of instance-of) 3430 3476 existing-association)) 3431 ( elephant:get-instances-by-class 'AssociationC)))))3477 (get-all-associations nil))))) 3432 3478 (cond ((> (length existing-associations) 1) 3433 (merge-all-constructs existing-associations)) 3479 (merge-all-constructs existing-associations 3480 :revision start-revision)) 3434 3481 (existing-associations 3435 3482 (first existing-associations)) … … 3513 3560 :reifier reifier) 3514 3561 existing-tm)) 3515 ( elephant:get-instances-by-class 'TopicMapC)))))3562 (get-all-tms start-revision))))) 3516 3563 (cond ((> (length existing-tms) 1) 3517 (merge-all-constructs existing-tms ))3564 (merge-all-constructs existing-tms :revision start-revision)) 3518 3565 (existing-tms 3519 3566 (first existing-tms)) … … 3555 3602 :topic-identifiers topic-identifiers) 3556 3603 existing-topic)) 3557 ( elephant:get-instances-by-class 'TopicC)))))3604 (get-all-topics start-revision))))) 3558 3605 (cond ((> (length existing-topics) 1) 3559 (merge-all-constructs existing-topics ))3606 (merge-all-constructs existing-topics :revision start-revision)) 3560 3607 (existing-topics 3561 3608 (first existing-topics)) … … 3920 3967 (typep construct 'CharacteristicC)) 3921 3968 (parent construct :revision revision)))) 3922 (let ((found-equivalent 3923 (find-if #'(lambda(other-construct) 3924 (strictly-equivalent-constructs 3925 other-construct construct :revision revision)) 3926 (cond ((typep construct 'OccurrenceC) 3927 (occurrences parent :revision revision)) 3928 ((typep construct 'NameC) 3929 (names parent :revision revision)) 3930 ((typep construct 'VariantC) 3931 (variants parent :revision revision)) 3932 ((typep construct 'RoleC) 3933 (roles parent :revision revision)) 3934 ((typep construct 'AssociationC) 3935 (elephant:get-instances-by-class 'AssociationC)))))) 3936 (when found-equivalent 3937 (merge-all-constructs (append found-equivalent (list construct)))))))) 3938 3969 (let ((all-other (cond ((typep construct 'OccurrenceC) 3970 (occurrences parent :revision revision)) 3971 ((typep construct 'NameC) 3972 (names parent :revision revision)) 3973 ((typep construct 'VariantC) 3974 (variants parent :revision revision)) 3975 ((typep construct 'RoleC) 3976 (roles parent :revision revision))))) 3977 (let ((all-equivalent 3978 (remove-if 3979 #'null 3980 (map 'list #'(lambda(other) 3981 (when (strictly-equivalent-constructs 3982 construct other :revision revision) 3983 other)) 3984 all-other)))) 3985 (when all-equivalent 3986 (merge-all-constructs (append all-equivalent (list construct)) 3987 :revision revision)))))) 3988 (merge-changed-associations older-topic :revision revision)) 3989 3990 3991 (defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) 3992 "Merges all associations that became TMDM-equal since two referenced topics 3993 were merged, e.g. the association types." 3994 (declare (TopicC older-topic)) 3995 (let ((all-assocs 3996 (remove-duplicates 3997 (append 3998 (remove-if 3999 #'null 4000 (map 'list #'(lambda(role) 4001 (parent role :revision revision)) 4002 (player-in-roles older-topic :revision revision))) 4003 (remove-if 4004 #'null 4005 (map 4006 'list #'(lambda(constr) 4007 (when (typep constr 'AssociationC) 4008 constr)) 4009 (append (used-as-type older-topic :revision revision) 4010 (used-as-theme older-topic :revision revision)))))))) 4011 (dolist (assoc all-assocs) 4012 (let ((all-equivalent 4013 (remove-if 4014 #'null 4015 (map 'list #'(lambda(db-assoc) 4016 (when (strictly-equivalent-constructs 4017 assoc db-assoc :revision revision) 4018 db-assoc)) 4019 (get-all-associations nil))))) 4020 (when all-equivalent 4021 (merge-all-constructs (append all-equivalent (list assoc)) 4022 :revision revision)))))) 4023 3939 4024 3940 4025 (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) … … 3954 4039 (merge-changed-constructs older-topic :revision revision) 3955 4040 (mark-as-deleted newer-topic :revision revision :source-locator nil) 3956 (when (exist-in- revision-history-?newer-topic)4041 (when (exist-in-version-history-p newer-topic) 3957 4042 (delete-construct newer-topic)) 3958 4043 older-topic)))) … … 3981 4066 (move-referenced-constructs newer-char older-char 3982 4067 :revision revision) 3983 (delete-characteristic newer-char parent-24068 (delete-characteristic parent-2 newer-char 3984 4069 :revision revision) 3985 4070 older-char) … … 4033 4118 (add-to-version-history older-tm :start-revision revision) 4034 4119 (mark-as-deleted newer-tm :revision revision) 4035 (when (exist-in- revision-history-?newer-tm)4120 (when (exist-in-version-history-p newer-tm) 4036 4121 (delete-construct newer-tm)) 4037 4122 older-tm)))) … … 4054 4139 :construct-1 construct-1 4055 4140 :construct-2 construct-2))) 4141 (dolist (tm (in-topicmaps newer-assoc :revision revision)) 4142 (add-to-tm tm older-assoc)) 4056 4143 (move-referenced-constructs newer-assoc older-assoc) 4057 4144 (dolist (newer-role (roles newer-assoc :revision revision)) … … 4066 4153 (add-role older-assoc equivalent-role :revision revision))) 4067 4154 (mark-as-deleted newer-assoc :revision revision) 4068 (when (exist-in- revision-history-?newer-assoc)4155 (when (exist-in-version-history-p newer-assoc) 4069 4156 (delete-construct newer-assoc)) 4070 4157 older-assoc)))) … … 4092 4179 (move-referenced-constructs newer-role older-role 4093 4180 :revision revision) 4094 (delete-role newer-role parent-2 :revision revision) 4095 (add-role older-role parent-1 :revision revision)) 4181 (delete-role parent-2 newer-role :revision revision) 4182 (let ((r-assoc 4183 (find-if 4184 #'(lambda(r-assoc) 4185 (and (eql (role r-assoc) older-role) 4186 (eql (parent-construct r-assoc) parent-1))) 4187 (slot-p parent-1 'roles)))) 4188 (add-to-version-history r-assoc :start-revision revision))) 4096 4189 ((and parent-1 parent-2) 4097 4190 (let ((active-assoc (merge-constructs parent-1 parent-2 -
TabularUnified branches/new-datamodel/src/unit_tests/datamodel_test.lisp ¶
r285 r286 82 82 :test-move-referenced-constructs-ReifiableConstructC 83 83 :test-move-referenced-constructs-NameC 84 :test-merge-constructs-TopicC-1)) 84 :test-merge-constructs-TopicC-1 85 :test-merge-constructs-TopicC-2 86 :test-merge-constructs-TopicC-3 87 :test-merge-constructs-TopicC-4 88 :test-merge-constructs-TopicC-5 89 :test-merge-constructs-TopicC-6)) 85 90 86 91 … … 1816 1821 (role-2 (list :player player-2 :instance-of r-type-2 1817 1822 :start-revision rev-1)) 1818 (role-3 (list : instance-of r-type-3 :player player-31823 (role-3 (list :player player-3 :instance-of r-type-3 1819 1824 :start-revision rev-1)) 1820 1825 (type-1 (make-instance 'd:TopicC)) … … 1878 1883 (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4)) 1879 1884 (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5)) 1880 (is- false (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))1885 (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) 1881 1886 1882 1887 … … 3047 3052 3048 3053 3054 (test test-merge-constructs-TopicC-2 () 3055 "Tests the generic move-referenced-constructs corresponding to TopicC." 3056 (with-fixture with-empty-db (*db-dir*) 3057 (let ((rev-1 100) 3058 (rev-2 200) 3059 (rev-3 300)) 3060 (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) 3061 (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) 3062 (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) 3063 (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) 3064 (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) 3065 (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) 3066 (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) 3067 (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1" 3068 :xtm-id "xtm-1")) 3069 (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2" 3070 :xtm-id "xtm-2")) 3071 (type-1 (make-construct 'TopicC :start-revision rev-1)) 3072 (type-2 (make-construct 'TopicC :start-revision rev-1)) 3073 (theme-1 (make-construct 'TopicC :start-revision rev-1)) 3074 (theme-2 (make-construct 'TopicC :start-revision rev-1))) 3075 (let ((variant-1 (make-construct 'VariantC 3076 :start-revision rev-1 3077 :charvalue "var-1" 3078 :themes (list theme-1))) 3079 (variant-2 (make-construct 'VariantC 3080 :start-revision rev-2 3081 :charvalue "var-2" 3082 :themes (list theme-2))) 3083 (variant-3 (make-construct 'VariantC 3084 :start-revision rev-1 3085 :charvalue "var-1" 3086 :themes (list theme-1))) 3087 (occ-1 (make-construct 'OccurrenceC 3088 :start-revision rev-1 3089 :charvalue "occ-1" 3090 :instance-of type-1 3091 :themes (list theme-1))) 3092 (occ-2 (make-construct 'OccurrenceC 3093 :start-revision rev-1 3094 :charvalue "occ-2" 3095 :instance-of type-2)) 3096 (occ-3 (make-construct 'OccurrenceC 3097 :start-revision rev-2 3098 :item-identifiers (list ii-3) 3099 :charvalue "occ-1" 3100 :instance-of type-1 3101 :themes (list theme-1)))) 3102 (let ((name-1 (make-construct 'NameC 3103 :start-revision rev-1 3104 :charvalue "name-1" 3105 :instance-of type-1)) 3106 (name-2 (make-construct 'NameC 3107 :start-revision rev-2 3108 :charvalue "name-2" 3109 :instance-of type-1 3110 :variants (list variant-1 variant-2))) 3111 (name-3 (make-construct 'NameC 3112 :start-revision rev-1 3113 :charvalue "name-1" 3114 :instance-of type-1 3115 :variants (list variant-3)))) 3116 (let ((top-1 (make-construct 'TopicC 3117 :start-revision rev-1 3118 :topic-identifiers (list tid-1) 3119 :item-identifiers (list ii-1) 3120 :locators (list sl-1) 3121 :psis (list psi-1) 3122 :names (list name-1 name-2) 3123 :occurrences (list occ-1 occ-2))) 3124 (top-2 (make-construct 'TopicC 3125 :start-revision rev-3 3126 :topic-identifiers (list tid-2) 3127 :item-identifiers (list ii-2) 3128 :locators (list sl-2) 3129 :psis (list psi-2) 3130 :names (list name-3) 3131 :occurrences (list occ-3)))) 3132 (setf *TM-REVISION* rev-3) 3133 (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) 3134 (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) 3135 (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) 3136 (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) 3137 (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) 3138 (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) 3139 (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) 3140 (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) 3141 (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) 3142 (is (eql top top-1)) 3143 (is-false (append (psis top-2) (item-identifiers top-2) 3144 (locators top-2) (topic-identifiers top-2) 3145 (names top-2) (occurrences top-2))) 3146 (is-false (set-exclusive-or (list ii-1 ii-2) 3147 (item-identifiers top-1))) 3148 (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1))) 3149 (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) 3150 (is-false (set-exclusive-or (list tid-1 tid-2) 3151 (topic-identifiers top-1))) 3152 (is-false (set-exclusive-or (list psi-1) 3153 (psis top-1 :revision rev-2))) 3154 (is-false (set-exclusive-or (list name-1 name-2) 3155 (names top-1))) 3156 (is-false (set-exclusive-or (variants name-1) 3157 (list variant-3))) 3158 (is-false (variants name-3)) 3159 (is-false (set-exclusive-or (occurrences top-1) 3160 (list occ-1 occ-2))) 3161 (is-false (set-exclusive-or (item-identifiers occ-1) 3162 (list ii-3))) 3163 (is-false (item-identifiers occ-3)) 3164 (is-true (d::marked-as-deleted-p name-3)) 3165 (is-true (d::marked-as-deleted-p occ-3)))))))))) 3166 3167 3168 (test test-merge-constructs-TopicC-3 () 3169 "Tests the generic move-referenced-constructs corresponding to TopicC." 3170 (with-fixture with-empty-db (*db-dir*) 3171 (let ((rev-1 100) 3172 (rev-3 300)) 3173 (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) 3174 (type-2 (make-construct 'TopicC :start-revision rev-1)) 3175 (n-type (make-construct 'TopicC :start-revision rev-1)) 3176 (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) 3177 (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) 3178 (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) 3179 (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")) 3180 (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5")) 3181 (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6")) 3182 (var-0-1 3183 (make-construct 'VariantC 3184 :start-revision rev-1 3185 :themes (list 3186 (make-construct 'TopicC 3187 :start-revision rev-1)) 3188 :charvalue "var-0-1")) 3189 (var-0-2 3190 (make-construct 'VariantC 3191 :start-revision rev-1 3192 :themes (list 3193 (make-construct 'TopicC 3194 :start-revision rev-1)) 3195 :charvalue "var-0-1"))) 3196 (let ((occ-1 (make-construct 'OccurrenceC 3197 :start-revision rev-1 3198 :item-identifiers (list ii-1) 3199 :charvalue "occ" 3200 :instance-of type-1)) 3201 (occ-2 (make-construct 'OccurrenceC 3202 :start-revision rev-1 3203 :item-identifiers (list ii-2) 3204 :charvalue "occ" 3205 :instance-of type-2)) 3206 (name-1 (make-construct 'NameC 3207 :start-revision rev-1 3208 :item-identifiers (list ii-3) 3209 :variants (list var-0-1) 3210 :charvalue "name" 3211 :instance-of type-1)) 3212 (name-2 (make-construct 'NameC 3213 :start-revision rev-1 3214 :item-identifiers (list ii-4) 3215 :variants (list var-0-2) 3216 :charvalue "name" 3217 :instance-of type-2)) 3218 (var-1 (make-construct 'VariantC 3219 :start-revision rev-1 3220 :item-identifiers (list ii-5) 3221 :charvalue "var" 3222 :themes (list type-1))) 3223 (var-2 (make-construct 'VariantC 3224 :start-revision rev-1 3225 :item-identifiers (list ii-6) 3226 :charvalue "var" 3227 :themes (list type-2)))) 3228 (let ((top-1 (make-construct 'TopicC 3229 :start-revision rev-1 3230 :occurrences (list occ-1 occ-2) 3231 :names (list name-1 name-2))) 3232 (name-3 (make-construct 'NameC 3233 :start-revision rev-1 3234 :charvalue "name-3" 3235 :instance-of n-type 3236 :variants (list var-1 var-2)))) 3237 (let ((top-2 (make-construct 'TopicC 3238 :start-revision rev-1 3239 :names (list name-3)))) 3240 (setf *TM-REVISION* rev-3) 3241 (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) 3242 (is (= (length (occurrences top-1)) 1)) 3243 (is-false (set-exclusive-or 3244 (list ii-1 ii-2) 3245 (item-identifiers (first (occurrences top-1))))) 3246 (is (= (length (slot-value top-1 'd::occurrences)) 2)) 3247 (is (= (length (names top-1)) 1)) 3248 (is-false (set-exclusive-or 3249 (list ii-3 ii-4) 3250 (item-identifiers (first (names top-1))))) 3251 (is (= (length (slot-value top-1 'd::names)) 2)) 3252 (is-false (set-exclusive-or (list var-0-1 var-0-2) 3253 (variants (first (names top-1))))) 3254 (is-true (d::marked-as-deleted-p 3255 (find-if-not #'(lambda(occ) 3256 (eql occ (first (occurrences top-1)))) 3257 (slot-value top-1 'd::occurrences)))) 3258 (is-true (d::marked-as-deleted-p 3259 (find-if-not #'(lambda(name) 3260 (eql name (first (names top-1)))) 3261 (slot-value top-1 'd::names)))) 3262 (is (= (length (variants (first (names top-2)))) 1)) 3263 (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2)) 3264 (is (eql (first (themes (first (variants (first (names top-2)))))) 3265 type-1))))))))) 3266 3267 3268 (test test-merge-constructs-TopicC-4 () 3269 "Tests the generic move-referenced-constructs corresponding to TopicC." 3270 (with-fixture with-empty-db (*db-dir*) 3271 (let ((rev-1 100) 3272 (rev-3 300)) 3273 (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) 3274 (type-2 (make-construct 'TopicC :start-revision rev-1)) 3275 (a-type (make-construct 'TopicC :start-revision rev-1)) 3276 (r-type (make-construct 'TopicC :start-revision rev-1)) 3277 (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) 3278 (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) 3279 (let ((assoc-1 (make-construct 'AssociationC 3280 :start-revision rev-1 3281 :instance-of a-type 3282 :roles (list (list :player type-1 3283 :instance-of r-type 3284 :item-identifiers (list ii-1) 3285 :start-revision rev-1) 3286 (list :player type-2 3287 :item-identifiers (list ii-2) 3288 :instance-of r-type 3289 :start-revision rev-1))))) 3290 (setf *TM-REVISION* rev-3) 3291 (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) 3292 (is (= (length (roles assoc-1)) 1)) 3293 (is (= (length (slot-value assoc-1 'd::roles)) 2)) 3294 (is (eql (instance-of (first (roles assoc-1))) r-type)) 3295 (is (eql (player (first (roles assoc-1))) type-1)) 3296 (is-false (set-exclusive-or (list ii-1 ii-2) 3297 (item-identifiers (first (roles assoc-1))))) 3298 (let ((active-role (first (roles assoc-1))) 3299 (non-active-role 3300 (let ((r-assoc (find-if-not #'(lambda(role) 3301 (eql role (first (roles assoc-1)))) 3302 (slot-value assoc-1 'd::roles)))) 3303 (when r-assoc 3304 (d::role r-assoc))))) 3305 (is (= (length (d::versions 3306 (first (slot-value active-role 'd::parent)))) 2)) 3307 (is (= (length (d::versions 3308 (first (slot-value non-active-role 'd::parent)))) 1)) 3309 (is-true (find-if #'(lambda(vi) 3310 (and (= rev-1 (d::start-revision vi)) 3311 (= rev-3 (d::end-revision vi)))) 3312 (d::versions (first (slot-value non-active-role 3313 'd::parent))))) 3314 (is-true (find-if #'(lambda(vi) 3315 (and (= rev-1 (d::start-revision vi)) 3316 (= rev-3 (d::end-revision vi)))) 3317 (d::versions (first (slot-value active-role 3318 'd::parent))))) 3319 (is-true (find-if #'(lambda(vi) 3320 (and (= rev-3 (d::start-revision vi)) 3321 (= 0 (d::end-revision vi)))) 3322 (d::versions (first (slot-value active-role 3323 'd::parent))))))))))) 3324 3325 3326 (test test-merge-constructs-TopicC-5 () 3327 "Tests the generic move-referenced-constructs corresponding to TopicC." 3328 (with-fixture with-empty-db (*db-dir*) 3329 (let ((rev-1 100) 3330 (rev-3 300)) 3331 (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) 3332 (type-2 (make-construct 'TopicC :start-revision rev-1)) 3333 (a-type (make-construct 'TopicC :start-revision rev-1)) 3334 (player-1 (make-construct 'TopicC :start-revision rev-1)) 3335 (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) 3336 (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) 3337 (let ((assoc-2 (make-construct 'AssociationC 3338 :start-revision rev-1 3339 :instance-of a-type 3340 :roles (list (list :player player-1 3341 :instance-of type-1 3342 :item-identifiers (list ii-1) 3343 :start-revision rev-1) 3344 (list :player player-1 3345 :item-identifiers (list ii-2) 3346 :instance-of type-2 3347 :start-revision rev-1))))) 3348 (setf *TM-REVISION* rev-3) 3349 (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) 3350 (is (= (length (roles assoc-2)) 1)) 3351 (is (= (length (slot-value assoc-2 'd::roles)) 2)) 3352 (is (eql (instance-of (first (roles assoc-2))) type-1)) 3353 (is (eql (player (first (roles assoc-2))) player-1)) 3354 (is-false (set-exclusive-or (list ii-1 ii-2) 3355 (item-identifiers (first (roles assoc-2))))) 3356 (let ((active-role (first (roles assoc-2))) 3357 (non-active-role 3358 (let ((r-assoc (find-if-not #'(lambda(role) 3359 (eql role (first (roles assoc-2)))) 3360 (slot-value assoc-2 'd::roles)))) 3361 (when r-assoc 3362 (d::role r-assoc))))) 3363 (is (= (length (d::versions 3364 (first (slot-value active-role 'd::parent)))) 2)) 3365 (is (= (length (d::versions 3366 (first (slot-value non-active-role 'd::parent)))) 1)) 3367 (is-true (find-if #'(lambda(vi) 3368 (and (= rev-1 (d::start-revision vi)) 3369 (= rev-3 (d::end-revision vi)))) 3370 (d::versions (first (slot-value non-active-role 3371 'd::parent))))) 3372 (is-true (find-if #'(lambda(vi) 3373 (and (= rev-1 (d::start-revision vi)) 3374 (= rev-3 (d::end-revision vi)))) 3375 (d::versions (first (slot-value active-role 3376 'd::parent))))) 3377 (is-true (find-if #'(lambda(vi) 3378 (and (= rev-3 (d::start-revision vi)) 3379 (= 0 (d::end-revision vi)))) 3380 (d::versions (first (slot-value active-role 3381 'd::parent))))))))))) 3382 3383 3384 (test test-merge-constructs-TopicC-6 () 3385 "Tests the generic move-referenced-constructs corresponding to TopicC." 3386 (with-fixture with-empty-db (*db-dir*) 3387 (let ((rev-1 100) 3388 (rev-2 200) 3389 (rev-3 300)) 3390 (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) 3391 (type-2 (make-construct 'TopicC :start-revision rev-1)) 3392 (r-type-1 (make-construct 'TopicC :start-revision rev-1)) 3393 (r-type-2 (make-construct 'TopicC :start-revision rev-1)) 3394 (player-1 (make-construct 'TopicC :start-revision rev-1)) 3395 (player-2 (make-construct 'TopicC :start-revision rev-1)) 3396 (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) 3397 (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) 3398 (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) 3399 (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) 3400 (let ((assoc-3 (make-construct 'AssociationC 3401 :start-revision rev-1 3402 :instance-of type-1 3403 :item-identifiers (list ii-3) 3404 :roles (list (list :player player-1 3405 :instance-of r-type-1 3406 :item-identifiers (list ii-1) 3407 :start-revision rev-1) 3408 (list :player player-2 3409 :instance-of r-type-2 3410 :start-revision rev-1)))) 3411 (assoc-4 (make-construct 'AssociationC 3412 :start-revision rev-2 3413 :instance-of type-2 3414 :item-identifiers (list ii-4) 3415 :roles (list (list :player player-1 3416 :instance-of r-type-1 3417 :start-revision rev-2) 3418 (list :player player-2 3419 :item-identifiers (list ii-2) 3420 :instance-of r-type-2 3421 :start-revision rev-2))))) 3422 (setf *TM-REVISION* rev-3) 3423 (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) 3424 (is (= (length (d::versions assoc-3)) 2)) 3425 (is (= (length (d::versions assoc-4)) 1)) 3426 (is-true (find-if #'(lambda(vi) 3427 (and (= (d::start-revision vi) rev-1) 3428 (= (d::end-revision vi) rev-3))) 3429 (d::versions assoc-3))) 3430 (is-true (find-if #'(lambda(vi) 3431 (and (= (d::start-revision vi) rev-3) 3432 (= (d::end-revision vi) 0))) 3433 (d::versions assoc-3))) 3434 (is-true (find-if #'(lambda(vi) 3435 (and (= (d::start-revision vi) rev-2) 3436 (= (d::end-revision vi) rev-3))) 3437 (d::versions assoc-4))) 3438 (is (= (length (roles assoc-3)) 2)) 3439 (is (= (length (item-identifiers (first (roles assoc-3)))) 1)) 3440 (is (= (length (item-identifiers (second (roles assoc-3)))) 1)) 3441 (is (or (and (string= (uri (first (item-identifiers 3442 (first (roles assoc-3))))) 3443 "ii-1") 3444 (string= (uri (first (item-identifiers 3445 (second (roles assoc-3))))) 3446 "ii-2")) 3447 (and (string= (uri (first (item-identifiers 3448 (first (roles assoc-3))))) 3449 "ii-2") 3450 (string= (uri (first (item-identifiers 3451 (second (roles assoc-3))))) 3452 "ii-1"))))))))) 3453 3454 3455 3456 3457 3458 3459 ;;TODO: merge topics/associations caused by a merge of their characteristics 3460 ;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified 3461 ;; by the same reifier 3049 3462 3050 3463 … … 3109 3522 (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) 3110 3523 (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) 3524 (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2) 3525 (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3) 3526 (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) 3527 (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) 3528 (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) 3111 3529 )
Note: See TracChangeset
for help on using the changeset viewer.
