Author: lgiessmann Date: Wed Oct 6 17:30:04 2010 New Revision: 320 Log: new-datamodel: adapted the rdf-importer unit-tests to the new datamodel; adapted the rdf-importer and the rdf-importer-mapping-tools to the new datamodel; fixed a bug in elephant where all subclasses of PointerC are returned when requesting one particular subctype Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/fixtures.lisp branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp branches/new-datamodel/src/xml/rdf/importer.lisp branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Wed Oct 6 17:30:04 2010 @@ -2056,14 +2056,15 @@ (let ((possible-top-ids (delete-if-not #'(lambda(top-id) - (and (string= (xtm-id top-id) xtm-id) + (and (typep top-id 'd:TopicIdentificationC) + ;fixes a bug in elephant -> all PointerCs are returned + (string= (xtm-id top-id) xtm-id) (string= (uri top-id) topic-id))) ;fixes a bug in get-instances-by-value that does a ;case-insensitive comparision (elephant:get-instances-by-value 'TopicIdentificationC - 'uri - topic-id)))) + 'uri topic-id)))) (when (and possible-top-ids (identified-construct (first possible-top-ids) :revision revision)) @@ -2074,7 +2075,7 @@ topic-id))) (identified-construct (first possible-top-ids) :revision revision) - ;no revision need not to be chaecked, since the revision + ;no revision need not to be checked, since the revision ;is implicitely checked by the function identified-construct )) (when (and (> (length topic-id) 0) @@ -2100,12 +2101,14 @@ (let ((possible-ids (delete-if-not #'(lambda(id) - (string= (uri id) uri)) + (and (typep id identifier-type-symbol) + (string= (uri id) uri))) (get-instances-by-value identifier-type-symbol 'uri uri)))) (when (and possible-ids (identified-construct (first possible-ids) :revision revision)) (unless (= (length possible-ids) 1) + (format t "==> ~a~%" possible-ids) (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri))) (identified-construct (first possible-ids) :revision revision))))) @@ -3039,12 +3042,19 @@ (declare (integer revision)) (dolist (id (get-all-identifiers-of-construct construct :revision revision)) (when (> - (length - (union - (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id)) - (union - (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id)) - (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id))))) + (length + (delete-if-not #'(lambda(identifier) + (or (typep identifier 'PersistentIdC) + (typep identifier 'SubjectLocatorC) + (typep identifier 'ItemIdentifierC))) + (union + (elephant:get-instances-by-value + 'ItemIdentifierC 'uri (uri id)) + (union + (elephant:get-instances-by-value + 'PersistentIdC 'uri (uri id)) + (elephant:get-instances-by-value + 'SubjectLocatorC 'uri (uri id)))))) 1) (error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id)))))) @@ -3829,8 +3839,10 @@ #'null (map 'list #'(lambda(existing-pointer) - (when (equivalent-construct existing-pointer :uri uri - :xtm-id xtm-id) + (when (and (typep existing-pointer class-symbol) + (equivalent-construct existing-pointer + :uri uri + :xtm-id xtm-id)) existing-pointer)) (elephant:get-instances-by-value class-symbol 'd::uri uri))))) (if existing-pointer Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/fixtures.lisp (original) +++ branches/new-datamodel/src/unit_tests/fixtures.lisp Wed Oct 6 17:30:04 2010 @@ -190,7 +190,8 @@ (setf d:*current-xtm* document-id) (rdf-importer:setup-rdf-module *poems_light.rdf* db-dir :tm-id tm-id :document-id document-id) - (elephant:open-store (xml-importer:get-store-spec db-dir)) + + ;(elephant:open-store (xml-importer:get-store-spec db-dir)) (&body) (tear-down-test-db))) Modified: branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp Wed Oct 6 17:30:04 2010 @@ -1054,9 +1054,11 @@ :document-id document-id) (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20)) (let ((first-node (get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (first-type (get-item-by-id "http://test-tm/first-type" - :xtm-id document-id))) + :xtm-id document-id + :revision 0))) (is-true first-node) (is (= (length (d::versions first-node)) 1)) (is (= (d::start-revision (first (d::versions first-node))) @@ -1066,11 +1068,12 @@ (is (= (length (d:player-in-roles first-node)) 1)) (is (= (length (d:player-in-roles first-type)) 1)) (let ((instance-role - (first (d:player-in-roles first-node))) + (first (d:player-in-roles first-node :revision 0))) (type-role - (first (d:player-in-roles first-type))) + (first (d:player-in-roles first-type :revision 0))) (type-assoc - (d:parent (first (d:player-in-roles first-node))))) + (d:parent (first (d:player-in-roles first-node :revision 0)) + :revision 0))) (is (= (length (d::versions type-assoc)) 1)) (is (= (d::start-revision (first (d::versions type-assoc))) revision-2)) @@ -1080,7 +1083,7 @@ (d:get-item-by-psi *type-psi*))) (is (eql (d:instance-of type-assoc) (d:get-item-by-psi *type-instance-psi*))) - (is (= (length (d:roles type-assoc)) 2)) + (is (= (length (d:roles type-assoc :revision 0)) 2)) (is (= (length (d:psis first-node)) 1)) (is (= (length (d:psis first-type)) 1)) (is (string= (d:uri (first (d:psis first-node))) @@ -1095,19 +1098,24 @@ tm-id revision-3 :document-id document-id)) (let ((first-node (get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (first-type (get-item-by-id "http://test-tm/first-type" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (second-node (get-item-by-id "second-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (second-type (get-item-by-id "http://test-tm/second-type" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (third-node (get-item-by-id "http://test-tm#third-node" - :xtm-id document-id))) + :xtm-id document-id + :revision 0))) (is-true second-node) - (is-false (d:psis second-node)) - (is-false (d:occurrences second-node)) - (is-false (d:names second-node)) + (is-false (d:psis second-node :revision 0)) + (is-false (d:occurrences second-node :revision 0)) + (is-false (d:names second-node :revision 0)) (is-true first-node) (is (= (length (d::versions first-node)) 2)) (is-true (find-if #'(lambda(x) @@ -1119,18 +1127,22 @@ (= (d::end-revision x) 0))) (d::versions first-node))) (let ((instance-role - (first (d:player-in-roles first-node))) + (first (d:player-in-roles first-node :revision 0))) (type-role - (first (d:player-in-roles first-type))) + (first (d:player-in-roles first-type :revision 0))) (type-assoc - (d:parent (first (d:player-in-roles first-node)))) - (type-topic (get-item-by-psi *type-psi*)) - (instance-topic (get-item-by-psi *instance-psi*)) - (type-instance-topic (get-item-by-psi *type-instance-psi*)) - (supertype-topic (get-item-by-psi *supertype-psi*)) - (subtype-topic (get-item-by-psi *subtype-psi*)) + (d:parent (first (d:player-in-roles first-node + :revision 0)))) + (type-topic (get-item-by-psi *type-psi* :revision 0)) + (instance-topic (get-item-by-psi *instance-psi* :revision 0)) + (type-instance-topic (get-item-by-psi *type-instance-psi* + :revision 0)) + (supertype-topic (get-item-by-psi *supertype-psi* + :revision 0)) + (subtype-topic (get-item-by-psi *subtype-psi* + :revision 0)) (supertype-subtype-topic - (get-item-by-psi *supertype-subtype-psi*)) + (get-item-by-psi *supertype-subtype-psi* :revision 0)) (arc2-occurrence (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "arc-2")) (arc3-occurrence @@ -1138,18 +1150,19 @@ 'd:OccurrenceC 'd:charvalue "<root><content type=\"anyContent\">content</content></root>")) (fifth-node (d:get-item-by-id "http://test-tm#fifth-node" - :xtm-id document-id))) - (is (eql (d:instance-of instance-role) - (d:get-item-by-psi *instance-psi*))) - (is (eql (d:instance-of type-role) - (d:get-item-by-psi *type-psi*))) - (is (eql (d:instance-of type-assoc) - (d:get-item-by-psi *type-instance-psi*))) - (is (= (length (d:roles type-assoc)) 2)) - (is (= (length (d:psis first-node)) 1)) - (is (= (length (d:psis first-type)) 1)) - (is (= (length (d::versions type-assoc)) 1)) - (is (= (length (d:player-in-roles second-node)) 2)) + :xtm-id document-id + :revision 0))) + (is (eql (d:instance-of instance-role :revision 0) + (d:get-item-by-psi *instance-psi* :revision 0))) + (is (eql (d:instance-of type-role :revision 0) + (d:get-item-by-psi *type-psi* :revision 0))) + (is (eql (d:instance-of type-assoc :revision 0) + (d:get-item-by-psi *type-instance-psi* :revision 0))) + (is (= (length (d:roles type-assoc :revision 0)) 2)) + (is (= (length (d:psis first-node :revision 0)) 1)) + (is (= (length (d:psis first-type :revision 0)) 1)) + (is (= (length (d::versions type-assoc)) 2)) + (is (= (length (d:player-in-roles second-node :revision 0)) 2)) (is-true (find-if #'(lambda(x) (and (eql (d:instance-of x) instance-topic) @@ -1176,16 +1189,16 @@ (d:player-in-roles third-node))) (is-true arc2-occurrence) (is (string= (d:datatype arc2-occurrence) "http://test-tm/dt")) - (is-false (d:psis (d:topic arc2-occurrence))) - (is (= (length (d::versions (d:topic arc2-occurrence))) 1)) + (is-false (d:psis (d:parent arc2-occurrence))) + (is (= (length (d::versions (d:parent arc2-occurrence))) 1)) (is (= (d::start-revision - (first (d::versions (d:topic arc2-occurrence)))) + (first (d::versions (d:parent arc2-occurrence)))) revision-3)) (is (= (d::end-revision - (first (d::versions (d:topic arc2-occurrence)))) 0)) + (first (d::versions (d:parent arc2-occurrence)))) 0)) (is-true arc3-occurrence) - (is (= (length (d:psis (d:topic arc3-occurrence))))) - (is (string= (d:uri (first (d:psis (d:topic arc3-occurrence)))) + (is (= (length (d:psis (d:parent arc3-occurrence))))) + (is (string= (d:uri (first (d:psis (d:parent arc3-occurrence)))) "http://test-tm/fourth-node")) (is (string= (d:datatype arc3-occurrence) *xml-string*)) @@ -1592,8 +1605,8 @@ (concatenate 'string arcs "firstName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) goethe))) occs) 1)) @@ -1604,8 +1617,8 @@ (concatenate 'string arcs "lastName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) goethe))) occs) 1)) @@ -1616,8 +1629,8 @@ (concatenate 'string arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) weimar))) occs) 1)) @@ -1628,8 +1641,8 @@ (concatenate 'string arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) frankfurt))) occs) 1)) @@ -1641,8 +1654,8 @@ (string= *xml-string* (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) germany))) occs) 1)) @@ -1655,8 +1668,8 @@ (string= (d:charvalue x) "Der Zauberlehrling") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) zauberlehrling))) occs) 1)) @@ -1668,8 +1681,8 @@ (= 0 (length (d:themes x))) (string= (d:charvalue x) "Prometheus") (string= *xml-string* (d:datatype x)) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) prometheus))) occs) 1)) @@ -1682,8 +1695,8 @@ (string= (d:charvalue x) "Der Erlkönig") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) erlkoenig))) occs) 1)) @@ -1696,8 +1709,8 @@ (string= (d:charvalue x) "Hat der alte Hexenmeister ...") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) zauberlehrling))) occs) 1)) @@ -1711,8 +1724,8 @@ " Bedecke deinen Himmel, Zeus, ... ") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) prometheus))) occs) 1)) @@ -1726,8 +1739,8 @@ "Wer reitet so spät durch Nacht und Wind? ...") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) erlkoenig))) occs) 1)) @@ -1738,8 +1751,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) weimar))) occs) 1)) @@ -1750,8 +1763,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) frankfurt))) occs) 1)) @@ -1762,8 +1775,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) berlin))) occs) 1)) @@ -1774,8 +1787,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) germany))) occs) 1)) @@ -1786,7 +1799,7 @@ (concatenate 'string arcs "date")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2)) (is (= (count-if @@ -1797,7 +1810,7 @@ (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 1)) @@ -1808,7 +1821,7 @@ (concatenate 'string arcs "start")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2)) @@ -1820,7 +1833,7 @@ (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 1)) (is (= (count-if @@ -1830,7 +1843,7 @@ (concatenate 'string arcs "end")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2))))) @@ -2853,7 +2866,7 @@ (rdf-importer:rdf-importer rdf-file dir :tm-id tm-id :document-id document-id) - (elephant:open-store (xml-importer:get-store-spec dir)) + ;(elephant:open-store (xml-importer:get-store-spec dir)) (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) @@ -2937,16 +2950,18 @@ (is-true marge-ln) (is (string= (d:charvalue marge-fn) "Marjorie")) (is (string= (d:charvalue marge-ln) "Simpson")) - (is (= (length (d:variants marge-fn)) 1)) - (is (= (length (d:themes (first (d:variants marge-fn)))) 1)) - (is (eql (first (d:themes (first (d:variants marge-fn)))) display)) - (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge")) - (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*)) + (is (= (length (d:variants marge-fn :revision 0)) 1)) + (is (= (length (d:themes (first (d:variants marge-fn :revision 0)) + :revision 0)) 1)) + (is (eql (first (d:themes (first (d:variants marge-fn :revision 0)) + :revision 0)) display)) + (is (string= (d:charvalue (first (d:variants marge-fn :revision 0))) "Marge")) + (is (string= (d:datatype (first (d:variants marge-fn :revision 0))) *xml-string*)) (is-true marge-occ) (is (string= (d:charvalue marge-occ) "Housewife")) (is (string= (d:datatype marge-occ) *xml-string*)) - (is (= (length (d:themes marge-occ)) 0)) - (is (= (length (d:psis marge)) 2)))))) + (is (= (length (d:themes marge-occ :revision 0)) 0)) + (is (= (length (d:psis marge :revision 0)) 2)))))) (test test-full-mapping-homer Modified: branches/new-datamodel/src/xml/rdf/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/importer.lisp (original) +++ branches/new-datamodel/src/xml/rdf/importer.lisp Wed Oct 6 17:30:04 2010 @@ -72,7 +72,7 @@ (defun import-dom (rdf-dom start-revision &key (tm-id nil) (document-id *document-id*)) - "Imports the entire dom of a rdf-xml-file." + "Imports the entire dom of an rdf-xml-file." (setf *_n-map* nil) ;in case of an failed last call (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) @@ -137,7 +137,7 @@ (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) (parent-xml-base nil) (parent-xml-lang nil)) - "Imports a property that is an blank_node and continues the recursion + "Imports a property that is a blank_node and continues the recursion on this element." (declare (dom:element elem)) (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) @@ -351,9 +351,11 @@ (error "~aone of the role types ~a ~a is missing!" err-pref *supertype-psi* *subtype-psi*)) (let ((a-roles (list (list :instance-of role-type-1 - :player super-top) + :player super-top + :start-revision start-revision) (list :instance-of role-type-2 - :player sub-top)))) + :player sub-top + :start-revision start-revision)))) (let ((assoc (add-to-tm tm @@ -392,9 +394,11 @@ (error "~aone of the role types ~a ~a is missing!" err-pref *type-psi* *instance-psi*)) (let ((a-roles (list (list :instance-of roletype-1 - :player type-top) + :player type-top + :start-revision start-revision) (list :instance-of roletype-2 - :player instance-top)))) + :player instance-top + :start-revision start-revision)))) (let ((assoc (add-to-tm tm @@ -420,40 +424,35 @@ (ii-uri (unless (or about ID) (concatenate 'string *rdf2tm-blank-node-prefix* (or nodeID UUID))))) - (let ((top - ;seems like there is a bug in d:get-item-by-id: - ;this functions returns an emtpy topic although there is no one - ;with a corresponding topic id and/or version. - ;Thus the version is temporary checked manually. - (let ((inner-top - (get-item-by-id topic-id :xtm-id document-id - :revision start-revision))) - (when inner-top - (let ((versions (d::versions inner-top))) - (when (find-if #'(lambda(version) - (= start-revision - (d::start-revision version))) - versions) - inner-top)))))) + (let ((top (get-item-by-id topic-id :xtm-id document-id + :revision start-revision))) (if top - top + (progn + (d::add-to-version-history top :start-revision start-revision) + top) (elephant:ensure-transaction (:txn-nosync t) (let ((psis (when psi-uri (list - (make-instance 'PersistentIdC + (make-construct 'PersistentIdC :uri psi-uri :start-revision start-revision)))) (iis (when ii-uri (list - (make-instance 'ItemIdentifierC + (make-construct 'ItemIdentifierC :uri ii-uri - :start-revision start-revision))))) + :start-revision start-revision)))) + (topic-ids (when topic-id + (list + (make-construct 'TopicIdentificationC + :uri topic-id + :xtm-id document-id + :start-revision start-revision))))) (handler-case (let ((top (add-to-tm tm (make-construct - 'TopicC - :topicid topic-id + 'TopicC + :topic-identifiers topic-ids :psis psis :item-identifiers iis :xtm-id document-id @@ -498,9 +497,11 @@ (type-top (make-topic-stub type nil nil nil start-revision tm :document-id document-id))) (let ((roles (list (list :instance-of role-type-1 - :player player-1) + :player player-1 + :start-revision start-revision) (list :instance-of role-type-2 - :player top)))) + :player top + :start-revision start-revision)))) (let ((assoc (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -527,9 +528,11 @@ (make-topic-stub *rdf2tm-object* nil nil nil start-revision tm :document-id document-id))) (let ((roles (list (list :instance-of role-type-1 - :player subject-topic) + :player subject-topic + :start-revision start-revision) (list :instance-of role-type-2 - :player object-topic)))) + :player object-topic + :start-revision start-revision)))) (let ((assoc (add-to-tm tm (make-construct 'AssociationC @@ -541,13 +544,14 @@ -(defun make-reification(reifier-id reifiable-construct start-revision tm &key (document-id *document-id*)) +(defun make-reification(reifier-id reifiable-construct start-revision tm &key + (document-id *document-id*)) (declare (string reifier-id)) (declare (ReifiableConstructC reifiable-construct)) (declare (TopicMapC tm)) (let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm :document-id document-id))) - (add-reifier reifiable-construct reifier-topic))) + (add-reifier reifiable-construct reifier-topic :revision start-revision))) (defun make-occurrence (top literal start-revision tm-id @@ -572,7 +576,7 @@ (let ((occurrence (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes (when lang-top (list lang-top)) :instance-of type-top Modified: branches/new-datamodel/src/xml/rdf/map_to_tm.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/map_to_tm.lisp (original) +++ branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Wed Oct 6 17:30:04 2010 @@ -57,42 +57,51 @@ (let ((type-topic (get-item-by-psi type-psi :revision start-revision))) (when type-topic - (when (and (not (player-in-roles type-topic)) - (not (used-as-type type-topic)) - (not (used-as-theme type-topic))) + (when (and (not (player-in-roles type-topic :revision start-revision)) + (not (used-as-type type-topic :revision start-revision)) + (not (used-as-theme type-topic :revision start-revision))) (d::delete-construct type-topic))))) -(defun delete-instance-of-association(instance-topic type-topic) +(defun delete-instance-of-association(instance-topic type-topic start-revision) "Deletes a type-instance associaiton that corresponds with the passed parameters." (when (and instance-topic type-topic) - (let ((instance (get-item-by-psi *instance-psi*)) - (type-instance (get-item-by-psi *type-instance-psi*)) - (type (get-item-by-psi *type-psi*))) - (declare (TopicC instance-topic type-topic)) + (let ((instance (get-item-by-psi *instance-psi* :revision start-revision)) + (type-instance (get-item-by-psi *type-instance-psi* + :revision start-revision)) + (type (get-item-by-psi *type-psi* :revision start-revision))) + (declare (TopicC instance-topic type-topic) + (integer start-revision)) (let ((assocs (remove-if #'null (map 'list #'(lambda(role) - (when (and (eql (instance-of role) instance) - (eql (instance-of (parent role)) - type-instance)) - (parent role))) - (player-in-roles instance-topic))))) + (when (and + (eql (instance-of role :revision start-revision) + instance) + (eql (instance-of + (parent role :revision start-revision) + :revision start-revision) + type-instance)) + (parent role :revision start-revision))) + (player-in-roles instance-topic :revision start-revision))))) (map 'list #'(lambda(assoc) - (when (find-if #'(lambda(role) - (and (eql (instance-of role) type) - (eql (player role) type-topic))) - (roles assoc)) + (when (find-if + #'(lambda(role) + (and (eql (instance-of role :revision start-revision) + type) + (eql (player role :revision start-revision) + type-topic))) + (roles assoc :revision start-revision)) (d::delete-construct assoc))) assocs) nil)))) -(defun delete-related-associations (top) +(defun delete-related-associations (top start-revision) "Deletes all associaitons related to the passed topic." - (dolist (assoc-role (player-in-roles top)) + (dolist (assoc-role (player-in-roles top :revision start-revision)) (d::delete-construct (parent assoc-role))) top) @@ -141,11 +150,12 @@ (when (= 0 (length role-players)) (error "~aexpect one player but found: ~a" err-pref (length role-players))) - (delete-related-associations role-top) + (delete-related-associations role-top start-revision) (d::delete-construct role-top) (list :instance-of (first types) :player (first role-players) :item-identifiers ids + :start-revision start-revision :reifiers reifiers))))) @@ -185,7 +195,7 @@ (when (= 0 (length assoc-roles)) (error "~aexpect at least one role but found: ~a" err-pref (length assoc-roles))) - (delete-related-associations assoc-top) + (delete-related-associations assoc-top start-revision) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) (add-to-tm @@ -208,10 +218,11 @@ assoc-roles))) (when found-item (dolist (reifier-topic (getf found-item :reifiers)) - (add-reifier association-role reifier-topic))))) - (roles association)) + (add-reifier association-role reifier-topic + :revision start-revision))))) + (roles association :revision start-revision)) (dolist (reifier-topic reifier-topics) - (add-reifier association reifier-topic)) + (add-reifier association reifier-topic :revision start-revision)) association))))))) @@ -267,7 +278,7 @@ variant-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi *tm2rdf-value-property*))) + (get-item-by-psi *tm2rdf-value-property* :revision start-revision))) (let ((scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value-and-datatype @@ -283,7 +294,7 @@ (reifiers (get-isi-reifiers variant-top start-revision))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) - (delete-related-associations variant-top) + (delete-related-associations variant-top start-revision) (d::delete-construct variant-top) (let ((variant (make-construct 'VariantC @@ -292,9 +303,9 @@ :themes scopes :charvalue (getf value-and-datatype :value) :datatype (getf value-and-datatype :datatype) - :name name))) + :parent name))) (dolist (reifier-topic reifiers) - (add-reifier variant reifier-topic)) + (add-reifier variant reifier-topic :revision start-revision)) variant))))) @@ -312,7 +323,7 @@ name-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi *tm2rdf-value-property*)) + (get-item-by-psi *tm2rdf-value-property* :revision start-revision)) (variant-topics (get-isi-variants name-top start-revision))) (let ((type (let ((fn-types (get-players-by-role-type @@ -335,7 +346,7 @@ (map 'list #'d::delete-construct scope-assocs) (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue value :instance-of type :item-identifiers ids @@ -344,10 +355,10 @@ (map-isi-variant name variant-topic start-revision)) variant-topics) - (delete-related-associations name-top) + (delete-related-associations name-top start-revision) (d::delete-construct name-top) (dolist (reifier-topic reifiers) - (add-reifier name reifier-topic)) + (add-reifier name reifier-topic :revision start-revision)) name))))) @@ -403,19 +414,19 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) - (delete-related-associations occ-top) + (delete-related-associations occ-top start-revision) (d::delete-construct occ-top) (let ((occurrence (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes scopes :item-identifiers ids :instance-of (first types) :charvalue (getf value-and-datatype :value) :datatype (getf value-and-datatype :datatype)))) (dolist (reifier-topic reifiers) - (add-reifier occurrence reifier-topic)) + (add-reifier occurrence reifier-topic :revision start-revision)) occurrence))))) @@ -448,12 +459,15 @@ (let ((topics-in-tm (with-tm (start-revision document-id tm-id) (intersection isi-topics (topics xml-importer::tm))))) - (map 'list #'(lambda(top) - (map 'list - #'(lambda(role) - (when (find (parent role) assocs) - (d::delete-construct (parent role)))) - (player-in-roles top))) + (map 'list + #'(lambda(top) + (map 'list + #'(lambda(role) + (when (find (parent role :revision start-revision) + assocs) + (d::delete-construct + (parent role :revision start-revision)))) + (player-in-roles top :revision start-revision))) topics-in-tm) topics-in-tm)))))) @@ -497,11 +511,13 @@ (map 'list #'(lambda(assoc) (let ((role - (find-if #'(lambda(role) - (eql role-type (instance-of role))) - (roles assoc)))) + (find-if + #'(lambda(role) + (eql role-type (instance-of role + :revision start-revision))) + (roles assoc :revision start-revision)))) (when role - (player role)))) + (player role :revision start-revision)))) associations)))) players))) @@ -517,16 +533,18 @@ (remove-if #'null (map 'list #'(lambda(occurrence) - (let ((type (instance-of occurrence))) + (let ((type + (instance-of occurrence + :revision start-revision))) (let ((type-psi (find-if #'(lambda(psi) (string= occurrence-type-uri (uri psi))) - (psis type)))) + (psis type :revision start-revision)))) (when type-psi occurrence)))) - (occurrences top))))) + (occurrences top :revision start-revision))))) identifier-occs))) @@ -566,11 +584,11 @@ (dolist (id identifiers) (declare (ItemIdentifierC id)) (if (find-if #'(lambda(ii) - (string= (uri ii) (uri id))) - (item-identifiers construct)) + (and (string= (uri ii) (uri id)) + (not (eql ii id)))) + (item-identifiers construct :revision start-revision)) (d::delete-construct id) - (add-item-identifier (identified-construct id :revision start-revision) - construct :revision start-revision))) + (add-item-identifier construct id :revision start-revision))) construct) @@ -580,11 +598,11 @@ (dolist (id identifiers) (declare (PersistentIdC id)) (if (find-if #'(lambda(psi) - (string= (uri psi) (uri id))) - (psis top)) + (and (string= (uri psi) (uri id)) + (not (eql psi id)))) + (psis top :revision start-revision)) (d::delete-construct id) - (add-psi (identified-construct id :revision start-revision) - top :revision start-revision))) + (add-psi top id :revision start-revision))) top) @@ -594,11 +612,11 @@ (dolist (id locators) (declare (SubjectLocatorC id)) (if (find-if #'(lambda(locator) - (string= (uri locator) (uri id))) - (locators top)) + (and (string= (uri locator) (uri id)) + (not (eql locator id)))) + (locators top :revision start-revision)) (d::delete-construct id) - (add-locator (identified-construct id :revision start-revision) - top :revision start-revision))) + (add-locator top id :revision start-revision))) top)