Changeset 234 for branches/new-datamodel
- Timestamp:
- 03/20/10 20:33:55 (15 years ago)
- Location:
- branches/new-datamodel/src
- Files:
-
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
TabularUnified branches/new-datamodel/src/json/json_importer.lisp ¶
r177 r234 33 33 (associations-values (getf fragment-values :associations)) 34 34 (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment 35 (elephant:ensure-transaction (:txn-nosync nil) 36 (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) 37 (loop for topicStub-values in (append topicStubs-values (list topic-values)) 38 do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) 39 (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) 40 (loop for association-values in associations-values 41 do (json-to-association association-values rev :tm xml-importer::tm)))))))) 35 (let ((psi-of-topic 36 (let ((psi-uris (getf topic-values :subjectIdentifiers))) 37 (when psi-uris 38 (first psi-uris))))) 39 (elephant:ensure-transaction (:txn-nosync nil) 40 (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) 41 (loop for topicStub-values in (append topicStubs-values (list topic-values)) 42 do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) 43 (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) 44 (loop for association-values in associations-values 45 do (json-to-association association-values rev :tm xml-importer::tm)))) 46 (when psi-of-topic 47 (create-latest-fragment-of-topic psi-of-topic))))))) 42 48 43 49 -
TabularUnified branches/new-datamodel/src/model/changes.lisp ¶
r188 r234 278 278 279 279 (defun create-latest-fragment-of-topic (topic-psi) 280 " returns the latest fragment of the passed topic-psi"280 "Returns the latest fragment of the passed topic-psi" 281 281 (declare (string topic-psi)) 282 282 (let ((topic … … 301 301 :referenced-topics (find-referenced-topics topic) 302 302 :topic topic))))))) 303 304 305 (defun get-latest-fragment-of-topic (topic-psi) 306 "Returns the latest existing fragment of the passed topic-psi." 307 (declare (string topic-psi)) 308 (let ((topic 309 (get-item-by-psi topic-psi))) 310 (when topic 311 (let ((existing-fragments 312 (elephant:get-instances-by-value 'FragmentC 'topic topic))) 313 (when existing-fragments 314 (first (sort existing-fragments 315 #'(lambda(frg-1 frg-2) 316 (> (revision frg-1) (revision frg-2)))))))))) -
TabularUnified branches/new-datamodel/src/model/datamodel.lisp ¶
r233 r234 93 93 :string-integer-p 94 94 :with-revision 95 :get-latest-fragment-of-topic 96 :create-latest-fragment-of-topic 95 97 :PointerC-p 96 98 :IdentifierC-p … … 123 125 124 126 125 ;;TODO: check merge-constructs in add-topic-identifier, add-item-identifier 126 ;; (can merge the parent construct and the parent's parent construct), 127 ;; add-psi, add-locator 127 ;;TODO: check merge-constructs in add-topic-identifier, 128 ;; add-item-identifier/add-reifier (can merge the parent construct 129 ;; and the parent's parent construct), add-psi, add-locator 130 ;; (--> duplicate-identifier-error) 128 131 ;;TODO: finalize add-reifier 129 132 ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo … … 1008 1011 (defmethod equivalent-construct ((construct TopicC) 1009 1012 &key (start-revision 0) (psis nil) 1010 (locators nil) (item-identifiers nil)) 1013 (locators nil) (item-identifiers nil) 1014 (topic-identifiers nil)) 1011 1015 "Isidorus handles Topic-equality only by the topic's identifiers 1012 1016 'psis', 'subject locators' and 'item identifiers'. Names and occurences … … 1014 1018 all its charactersitics. T is returned if the topic owns one of the given 1015 1019 identifier-URIs." 1016 (declare (integer start-revision) (list psis locators item-identifiers)) 1020 (declare (integer start-revision) (list psis locators item-identifiers 1021 topic-identifiers)) 1017 1022 (when 1018 1023 (intersection 1019 1024 (union (union (psis construct :revision start-revision) 1020 1025 (locators construct :revision start-revision)) 1021 (item-identifiers construct :revision start-revision)) 1022 (union (union psis locators) item-identifiers)) 1026 (union (item-identifiers construct :revision start-revision) 1027 (topic-identifiers construct :revision start-revision))) 1028 (union (union psis locators) (union item-identifiers topic-identifiers))) 1023 1029 t)) 1024 1030 … … 1089 1095 (when (not (eql id-owner construct)) 1090 1096 id-owner)))) 1091 (cond (construct-to-be-merged 1092 (merge-constructs construct construct-to-be-merged :revision revision)) 1093 ((find topic-identifier all-ids) 1094 (let ((ti-assoc (loop for ti-assoc in (slot-p construct 1095 'topic-identifiers) 1096 when (eql (identifier ti-assoc) 1097 topic-identifier) 1098 return ti-assoc))) 1099 (add-to-version-history ti-assoc :start-revision revision))) 1100 (t 1101 (let ((assoc 1102 (make-instance 'TopicIdAssociationC 1103 :parent-construct construct 1104 :identifier topic-identifier))) 1105 (add-to-version-history assoc :start-revision revision)))) 1106 (when (typep construct 'TopicC) 1107 (add-to-version-history construct :start-revision revision)) 1108 construct))) 1097 (let ((merged-construct construct)) 1098 (cond (construct-to-be-merged 1099 (setf merged-construct 1100 (merge-constructs construct construct-to-be-merged 1101 :revision revision))) 1102 ((find topic-identifier all-ids) 1103 (let ((ti-assoc (loop for ti-assoc in (slot-p construct 1104 'topic-identifiers) 1105 when (eql (identifier ti-assoc) 1106 topic-identifier) 1107 return ti-assoc))) 1108 (add-to-version-history ti-assoc :start-revision revision))) 1109 (t 1110 (let ((assoc (make-instance 'TopicIdAssociationC 1111 :parent-construct construct 1112 :identifier topic-identifier))) 1113 (add-to-version-history assoc :start-revision revision)))) 1114 (add-to-version-history merged-construct :start-revision revision) 1115 merged-construct)))) 1109 1116 1110 1117 … … 1145 1152 (when (not (eql id-owner construct)) 1146 1153 id-owner)))) 1147 (cond (construct-to-be-merged 1148 (merge-constructs construct construct-to-be-merged 1149 :revision revision)) 1150 ((find psi all-ids) 1151 (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) 1152 when (eql (identifier psi-assoc) psi) 1153 return psi-assoc))) 1154 (add-to-version-history psi-assoc :start-revision revision))) 1155 (t 1156 (let ((assoc 1157 (make-instance 'PersistentIdAssociationC 1158 :parent-construct construct 1159 :identifier psi))) 1160 (add-to-version-history assoc :start-revision revision)))) 1161 (add-to-version-history construct :start-revision revision) 1162 construct))) 1154 (let ((merged-construct construct)) 1155 (cond (construct-to-be-merged 1156 (setf merged-construct 1157 (merge-constructs construct construct-to-be-merged 1158 :revision revision))) 1159 ((find psi all-ids) 1160 (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) 1161 when (eql (identifier psi-assoc) psi) 1162 return psi-assoc))) 1163 (add-to-version-history psi-assoc :start-revision revision))) 1164 (t 1165 (let ((assoc (make-instance 'PersistentIdAssociationC 1166 :parent-construct construct 1167 :identifier psi))) 1168 (add-to-version-history assoc :start-revision revision)))) 1169 (add-to-version-history merged-construct :start-revision revision) 1170 merged-construct)))) 1163 1171 1164 1172 … … 1199 1207 (when (not (eql id-owner construct)) 1200 1208 id-owner)))) 1201 (cond (construct-to-be-merged 1202 (merge-constructs construct construct-to-be-merged 1203 :revision revision)) 1204 ((find locator all-ids) 1205 (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators) 1206 when (eql (identifier loc-assoc) locator) 1207 return loc-assoc))) 1208 (add-to-version-history loc-assoc :start-revision revision))) 1209 (t 1210 (let ((assoc 1211 (make-instance 'SubjectLocatorAssociationC 1212 :parent-construct construct 1213 :identifier locator))) 1214 (add-to-version-history assoc :start-revision revision)))) 1215 (add-to-version-history construct :start-revision revision) 1216 construct))) 1209 (let ((merged-construct construct)) 1210 (cond (construct-to-be-merged 1211 (setf merged-construct 1212 (merge-constructs construct construct-to-be-merged 1213 :revision revision))) 1214 ((find locator all-ids) 1215 (let ((loc-assoc 1216 (loop for loc-assoc in (slot-p construct 'locators) 1217 when (eql (identifier loc-assoc) locator) 1218 return loc-assoc))) 1219 (add-to-version-history loc-assoc :start-revision revision))) 1220 (t 1221 (let ((assoc 1222 (make-instance 'SubjectLocatorAssociationC 1223 :parent-construct construct 1224 :identifier locator))) 1225 (add-to-version-history assoc :start-revision revision)))) 1226 (add-to-version-history merged-construct :start-revision revision) 1227 merged-construct)))) 1217 1228 1218 1229 … … 1481 1492 1482 1493 (defmethod equivalent-construct ((construct CharacteristicC) 1483 &key (start-revision 0) (reifier nil) 1484 (item-identifiers nil) (charvalue "") 1494 &key (start-revision 0) (charvalue "") 1485 1495 (instance-of nil) (themes nil)) 1486 1496 "Equality rule: Characteristics are equal if charvalue, themes and 1487 1497 instance-of are equal." 1488 (declare (string charvalue) (list themes item-identifiers)1498 (declare (string charvalue) (list themes) 1489 1499 (integer start-revision) 1490 (type (or null TopicC) instance-of reifier))1491 (or (and (string= (charvalue construct) charvalue)1492 (equivalent-scopable-construct construct themes 1493 :start-revision start-revision)1494 (equivalent-typable-construct construct instance-of 1495 :start-revision start-revision))1496 (equivalent-reifiable-construct construct reifier item-identifiers1497 1500 (type (or null TopicC) instance-of)) 1501 ;; item-identifiers and reifers are not checked because the equality have to 1502 ;; be variafied without them 1503 (and (string= (charvalue construct) charvalue) 1504 (equivalent-scopable-construct construct themes 1505 :start-revision start-revision) 1506 (equivalent-typable-construct construct instance-of 1507 :start-revision start-revision))) 1498 1508 1499 1509 … … 1579 1589 1580 1590 (defmethod equivalent-construct ((construct OccurrenceC) 1581 &key (start-revision 0) (reifier nil) 1582 (item-identifiers nil) (charvalue "") 1591 &key (start-revision 0) (charvalue "") 1583 1592 (themes nil) (instance-of nil) 1584 1593 (datatype "")) 1585 1594 "Occurrences are equal if their charvalue, datatype, themes and 1586 1595 instance-of properties are equal." 1587 (declare (type (or null TopicC) instance-of reifier) (string datatype) 1588 (list item-identifiers) 1596 (declare (type (or null TopicC) instance-of) (string datatype) 1589 1597 (ignorable start-revision charvalue themes instance-of)) 1590 1598 (let ((equivalent-characteristic (call-next-method))) 1591 (or (and equivalent-characteristic1592 (string= (datatype construct) datatype)) 1593 (equivalent-reifiable-construct construct reifier item-identifiers 1594 :start-revision start-revision))))1599 ;; item-identifiers and reifers are not checked because the equality have to 1600 ;; be variafied without them 1601 (and equivalent-characteristic 1602 (string= (datatype construct) datatype)))) 1595 1603 1596 1604 … … 1603 1611 1604 1612 (defmethod equivalent-construct ((construct VariantC) 1605 &key (start-revision 0) (reifier nil) 1606 (item-identifiers nil) (charvalue "") 1613 &key (start-revision 0) (charvalue "") 1607 1614 (themes nil) (datatype "")) 1608 1615 "Variants are equal if their charvalue, datatype and themes 1609 1616 properties are equal." 1610 (declare (string datatype) ( list item-identifiers)1611 (ignorable start-revision charvalue themes) 1612 (type (or null TopicC) reifier)) 1617 (declare (string datatype) (ignorable start-revision charvalue themes)) 1618 ;; item-identifiers and reifers are not checked because the equality have to 1619 ;; be variafied without them 1613 1620 (let ((equivalent-characteristic (call-next-method))) 1614 (or (and equivalent-characteristic 1615 (string= (datatype construct) datatype)) 1616 (equivalent-reifiable-construct construct reifier item-identifiers 1617 :start-revision start-revision)))) 1621 (and equivalent-characteristic 1622 (string= (datatype construct) datatype)))) 1618 1623 1619 1624 … … 1631 1636 1632 1637 1638 (defgeneric initialize-name (construct variants &key start-revision) 1639 (:documentation "Adds all given variants to the passed construct.") 1640 (:method ((construct NameC) (variants list) 1641 &key (start-revision *TM-REVISION*)) 1642 (dolist (variant variants) 1643 (add-variant construct variant :revision start-revision)) 1644 construct)) 1645 1646 1633 1647 (defmethod equivalent-construct ((construct NameC) 1634 &key (start-revision 0) (reifier nil) 1635 (item-identifiers nil) (charvalue "") 1648 &key (start-revision 0) (charvalue "") 1636 1649 (themes nil) (instance-of nil)) 1637 1650 "Names are equal if their charvalue, instance-of and themes properties 1638 1651 are equal." 1639 1652 (declare (type (or null TopicC) instance-of) 1640 (ignorable start-revision charvalue instance-of themes 1641 reifier item-identifiers)) 1653 (ignorable start-revision charvalue instance-of themes)) 1642 1654 (call-next-method)) 1643 1655 … … 1710 1722 1711 1723 (defmethod equivalent-construct ((construct AssociationC) 1712 &key (start-revision 0) (reifier nil) 1713 (item-identifiers nil) (roles nil) 1724 &key (start-revision 0) (roles nil) 1714 1725 (instance-of nil) (themes nil)) 1715 1726 "Associations are equal if their themes, instance-of and roles 1716 1727 properties are equal." 1717 (declare (integer start-revision) (list roles themes item-identifiers) 1718 (type (or null TopicC) instance-of reifier)) 1719 (or 1720 (and 1721 (not (set-exclusive-or roles (roles construct :revision start-revision))) 1722 (equivalent-typable-construct construct instance-of 1723 :start-revision start-revision) 1724 (equivalent-scopable-construct construct themes 1725 :start-revision start-revision)) 1726 (equivalent-reifiable-construct construct reifier item-identifiers 1727 :start-revision start-revision))) 1728 (declare (integer start-revision) (list roles themes) 1729 (type (or null TopicC) instance-of)) 1730 ;; item-identifiers and reifers are not checked because the equality have to 1731 ;; be variafied without them 1732 (and 1733 (not (set-exclusive-or roles (roles construct :revision start-revision))) 1734 (equivalent-typable-construct construct instance-of 1735 :start-revision start-revision) 1736 (equivalent-scopable-construct construct themes 1737 :start-revision start-revision))) 1728 1738 1729 1739 … … 1801 1811 1802 1812 (defmethod equivalent-construct ((construct RoleC) 1803 &key (start-revision 0) (reifier nil) 1804 (item-identifiers nil) (player nil) 1813 &key (start-revision 0) (player nil) 1805 1814 (instance-of nil)) 1806 1815 "Roles are equal if their instance-of and player properties are equal." 1807 (declare (integer start-revision) 1808 (type (or null TopicC) player instance-of reifier) 1809 (list item-identifiers)) 1810 (or (and (equivalent-typable-construct construct instance-of 1811 :start-revision start-revision) 1812 (eql player (player construct :revision start-revision))) 1813 (equivalent-reifiable-construct construct reifier item-identifiers 1814 :start-revision start-revision))) 1816 (declare (integer start-revision) (type (or null TopicC) player instance-of)) 1817 ;; item-identifiers and reifers are not checked because the equality have to 1818 ;; be variafied without them 1819 (and (equivalent-typable-construct construct instance-of 1820 :start-revision start-revision) 1821 (eql player (player construct :revision start-revision)))) 1815 1822 1816 1823 … … 1950 1957 1951 1958 1959 (defgeneric initialize-reifiable (construct item-identifiers reifier 1960 &key start-revision) 1961 (:documentation "Adds all item-identifiers and the reifier to the passed 1962 construct.") 1963 (:method ((construct ReifiableConstructC) item-identifiers reifier 1964 &key (start-revision *TM-REVISION*)) 1965 (declare (integer start-revision) (list item-identifiers) 1966 (type (or null TopicC) reifier)) 1967 (let ((merged-construct construct)) 1968 (dolist (ii item-identifiers) 1969 (setf merged-construct 1970 (add-item-identifier merged-construct ii 1971 :revision start-revision))) 1972 (when reifier 1973 (setf merged-construct (add-reifier merged-construct reifier 1974 :revision start-revision))) 1975 merged-construct))) 1976 1977 1952 1978 (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers 1953 1979 &key start-revision) … … 2011 2037 (when (not (eql id-owner construct)) 2012 2038 id-owner)))) 2013 (cond (construct-to-be-merged 2014 (merge-constructs construct construct-to-be-merged 2015 :revision revision)) 2016 ((find item-identifier all-ids) 2017 (let ((ii-assoc (loop for ii-assoc in (slot-p construct 2018 'item-identifiers) 2019 when (eql (identifier ii-assoc) item-identifier) 2020 return ii-assoc))) 2021 (add-to-version-history ii-assoc :start-revision revision))) 2022 (t 2023 (let ((assoc 2024 (make-instance 'ItemIdAssociationC 2025 :parent-construct construct 2026 :identifier item-identifier))) 2027 (add-to-version-history assoc :start-revision revision)))) 2028 (when (or (typep construct 'TopicC) 2029 (typep construct 'AssociationC) 2030 (typep construct 'TopicMapC)) 2031 (add-to-version-history construct :start-revision revision)) 2032 construct))) 2039 (let ((merged-construct construct)) 2040 (cond (construct-to-be-merged 2041 (setf merged-construct 2042 (merge-constructs construct construct-to-be-merged 2043 :revision revision))) 2044 ((find item-identifier all-ids) 2045 (let ((ii-assoc 2046 (loop for ii-assoc in (slot-p construct 'item-identifiers) 2047 when (eql (identifier ii-assoc) item-identifier) 2048 return ii-assoc))) 2049 (add-to-version-history ii-assoc :start-revision revision))) 2050 (t 2051 (let ((assoc (make-instance 'ItemIdAssociationC 2052 :parent-construct construct 2053 :identifier item-identifier))) 2054 (add-to-version-history assoc :start-revision revision)))) 2055 (when (or (typep merged-construct 'TopicC) 2056 (typep merged-construct 'AssociationC) 2057 (typep merged-construct 'TopicMapC)) 2058 (add-to-version-history merged-construct :start-revision revision)) 2059 merged-construct)))) 2033 2060 2034 2061 … … 2063 2090 (when inner-construct 2064 2091 (list inner-construct))))) 2065 ( cond ((find construct all-constructs)2066 (let ((reifier-assoc2067 (loop for reifier-assoc in2068 (slot-p merged-reifier-topic 'reified-construct)2069 when (eql (reifiable-construct reifier-assoc)2070 construct)2071 return reifier-assoc)))2072 (add-to-version-history reifier-assoc :start-revision revision)2073 construct))2074 (all-constructs2075 (merge-constructs (first all-constructs) construct))2076 (t2077 (let ((assoc2078 2079 :reifiable-construct construct2080 :reifier-topic merged-reifier-topic)))2081 (add-to-version-history assoc :start-revision revision))))2082 (when (or (typepconstruct 'TopicC)2083 (typepconstruct 'AssociationC)2084 (typepconstruct 'TopicMapC))2085 (add-to-version-historyconstruct :start-revision revision))2086 construct))))2092 (let ((merged-construct construct)) 2093 (cond ((find construct all-constructs) 2094 (let ((reifier-assoc 2095 (loop for reifier-assoc in 2096 (slot-p merged-reifier-topic 'reified-construct) 2097 when (eql (reifiable-construct reifier-assoc) 2098 construct) 2099 return reifier-assoc))) 2100 (add-to-version-history reifier-assoc 2101 :start-revision revision))) 2102 (all-constructs 2103 (merge-constructs (first all-constructs) construct)) 2104 (t 2105 (let ((assoc (make-instance 'ReifierAssociationC 2106 :reifiable-construct construct 2107 :reifier-topic merged-reifier-topic))) 2108 (add-to-version-history assoc :start-revision revision)))) 2109 (when (or (typep merged-construct 'TopicC) 2110 (typep merged-construct 'AssociationC) 2111 (typep merged-construct 'TopicMapC)) 2112 (add-to-version-history merged-construct :start-revision revision)) 2113 merged-construct))))) 2087 2114 2088 2115 … … 2110 2137 2111 2138 2139 (defgeneric initialize-typable (construct instance-of &key start-revision) 2140 (:documentation "Adds the passed instance-of to the given construct.") 2141 (:method ((construct TypableC) instance-of 2142 &key (start-revision *TM-REVISION*)) 2143 (declare (integer start-revision) (type (or null TopicC) instance-of)) 2144 (when instance-of 2145 (add-type construct instance-of :revision start-revision)) 2146 construct)) 2147 2148 2112 2149 (defgeneric equivalent-typable-construct (construct instance-of 2113 2150 &key start-revision) … … 2128 2165 (AssociationC-p class-symbol) 2129 2166 (CharacteristicC-p class-symbol)))) 2167 2168 2169 (defgeneric initialize-scopable (construct themes &key start-revision) 2170 (:documentation "Adds all passed themes to the given construct.") 2171 (:method ((construct ScopableC) (themes list) 2172 &key (start-revision *TM-REVISION*)) 2173 (declare (integer start-revision)) 2174 (dolist (theme themes) 2175 (add-theme construct theme :revision start-revision)) 2176 construct)) 2130 2177 2131 2178 … … 2325 2372 specific keyword arguments for their purpose." 2326 2373 (declare (symbol class-symbol)) 2327 (let ((start-revision (getf args :start-revision)) 2328 (uri (getf args :uri)) 2329 (xtm-id (getf args :xtm-id)) 2330 (identified-construct (getf args :identified-construct)) 2331 (charvalue (getf args :charvalue)) 2332 (datatype (getf args :datatype)) 2333 (parent-construct (getf args :parent-construct)) 2334 (themes (getf args :themes)) 2335 (variants (getf args :variants)) 2336 (instance-of (getf args :instance-of)) 2337 (reifier-topic (getf args :reifier)) 2338 (item-identifiers (getf args :item-identifiers))) 2339 (let ((construct 2340 (cond 2341 ((PointerC-p class-symbol) 2342 (make-pointer class-symbol uri :start-revision start-revision 2343 :xtm-id xtm-id 2344 :identified-construct identified-construct)) 2345 ((CharacteristicC-p class-symbol) 2346 (make-characteristic class-symbol charvalue 2347 :start-revision start-revision 2348 :datatype datatype :themes themes 2349 :instance-of instance-of :variants variants 2350 :parent-construct parent-construct))))) 2351 2352 (when (typep construct 'ReifiableConstructC) 2353 (when reifier-topic 2354 (add-reifier construct reifier-topic :revision start-revision)) 2355 (dolist (ii item-identifiers) 2356 (add-item-identifier construct ii :revision start-revision))) 2357 construct))) 2358 2359 2360 (defun make-characteristic (class-symbol charvalue 2361 &key (start-revision *TM-REVISION*) 2362 (datatype *xml-string*) (themes nil) 2363 (instance-of nil) (variants nil) 2364 (parent-construct nil)) 2374 (let ((construct 2375 (cond 2376 ((PointerC-p class-symbol) 2377 (make-pointer class-symbol (getf args :uri) args)) 2378 ((CharacteristicC-p class-symbol) 2379 (make-characteristic class-symbol (getf args :charvalue) args)) 2380 ((TopicC-p class-symbol) 2381 (make-topic args))))) 2382 construct)) 2383 2384 2385 (defun merge-all-constructs(constructs-to-be-merged) 2386 "Merges all constructs contained in the given list." 2387 (declare (list constructs-to-be-merged)) 2388 (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1)) 2389 (merged-construct (elt constructs-to-be-merged 0))) 2390 (loop for construct-to-be-merged in constructs-to-be-merged 2391 do (setf merged-construct 2392 (merge-constructs merged-construct construct-to-be-merged))))) 2393 2394 2395 (defun make-tm (&rest args) 2396 "Returns a topic map object. If the topic map has already existed the 2397 existing one is returned otherwise a new one is created. 2398 This function exists only for being used by make-construct!" 2399 (let ((item-identifiers (getf (first args) :item-identifiers)) 2400 (reifier (getf (first args) :reifier)) 2401 (topics (getf (first args) :topics)) 2402 (assocs (getf (first args) :associations)) 2403 (start-revision (getf (first args) :start-revision))) 2404 (let ((tm 2405 (let ((existing-tms 2406 (remove-if 2407 #'null 2408 (map 'list #'(lambda(existing-tm) 2409 (when (equivalent-construct 2410 existing-tm 2411 :item-identifiers item-identifiers 2412 :reifier reifier) 2413 existing-tm)) 2414 (elephant:get-instances-by-class 'TopicMapC))))) 2415 (cond ((and existing-tms (> (length existing-tms) 1)) 2416 (merge-all-constructs existing-tms)) 2417 (existing-tms 2418 (first existing-tms)) 2419 (t 2420 (make-instance 'TopicMapC)))))) 2421 (dolist (top-or-assoc (union topics assocs)) 2422 (add-to-tm tm top-or-assoc)) 2423 (add-to-version-history tm :start-revision start-revision) 2424 tm))) 2425 2426 2427 (defun make-topic (&rest args) 2428 "Returns a topic object. If the topic has already existed the existing one is 2429 returned otherwise a new one is created. 2430 This function exists only for being used by make-construct!" 2431 (let ((start-revision (getf (first args) :start-revision)) 2432 (psis (getf (first args) :psis)) 2433 (locators (getf (first args) :locators)) 2434 (item-identifiers (getf (first args) :item-identifiers)) 2435 (topic-identifiers (getf (first args) :topic-identifiers)) 2436 (names (getf (first args) :names)) 2437 (occurrences (getf (first args) :occurrences))) 2438 (let ((topic 2439 (let ((existing-topics 2440 (remove-if 2441 #'null 2442 (map 'list #'(lambda(existing-topic) 2443 (when (equivalent-construct 2444 existing-topic 2445 :start-revision start-revision 2446 :psis psis :locators locators 2447 :item-identifiers item-identifiers 2448 :topic-identifiers topic-identifiers) 2449 existing-topic)) 2450 (elephant:get-instances-by-class 'TopicC))))) 2451 (cond ((and existing-topics (> (length existing-topics) 1)) 2452 (merge-all-constructs existing-topics)) 2453 (existing-topics 2454 (first existing-topics)) 2455 (t 2456 (make-instance 'TopicC)))))) 2457 (initialize-reifiable topic item-identifiers nil 2458 :start-revision start-revision) 2459 (let ((merged-topic topic)) 2460 (dolist (psi psis) 2461 (setf merged-topic (add-psi merged-topic psi 2462 :revision start-revision))) 2463 (dolist (locator locators) 2464 (setf merged-topic (add-locator merged-topic locator 2465 :revision start-revision))) 2466 (dolist (name names) 2467 (setf merged-topic (add-name topic name :revision start-revision))) 2468 (dolist (occ occurrences) 2469 (add-occurrence merged-topic occ :revision start-revision)) 2470 (add-to-version-history merged-topic :start-revision start-revision) 2471 merged-topic)))) 2472 2473 2474 (defun make-characteristic (class-symbol &rest args) 2365 2475 "Returns a characteristic object with the passed parameters. 2366 2476 If an equivalent construct has already existed this one is returned. 2367 2477 To check if there is existing an equivalent construct the parameter 2368 parent-construct must be set." 2369 (declare (symbol class-symbol) (string charvalue) (integer start-revision) 2370 (list themes variants) 2371 (type (or null string) datatype) 2372 (type (or null TopicC) instance-of) 2373 (type (or null TopicC NameC) parent-construct)) 2374 (let ((characteristic 2375 (let ((existing-characteristic 2376 (when parent-construct 2478 parent-construct must be set. 2479 This function only exists for being used by make-construct!" 2480 (let ((charvalue (getf (first args) :charvalue)) 2481 (start-revision (getf (first args) :start-revision)) 2482 (datatype (getf (first args) :datatype)) 2483 (instance-of (getf (first args) :instance-of)) 2484 (themes (getf (first args) :themes)) 2485 (variants (getf (first args) :variants)) 2486 (reifier (getf (first args) :reifier)) 2487 (parent-construct (getf (first args) :parent-construct)) 2488 (item-identifiers (getf (first args) :item-identifiers))) 2489 (let ((characteristic 2490 (let ((existing-characteristic 2491 (when parent-construct 2492 (remove-if 2493 #'null 2494 (map 'list #'(lambda(existing-characteristic) 2495 (when (equivalent-construct 2496 existing-characteristic 2497 :start-revision start-revision 2498 :datatype datatype :variants variants 2499 :charvalue charvalue :themes themes 2500 :instance-of instance-of) 2501 existing-characteristic)) 2502 (get-all-characteristics parent-construct 2503 class-symbol)))))) 2504 (if existing-characteristic 2505 existing-characteristic 2506 (make-instance class-symbol :charvalue charvalue 2507 :datatype datatype))))) 2508 (let ((merged-characteristic characteristic)) 2509 (setf merged-characteristic 2510 (initialize-reifiable merged-characteristic item-identifiers 2511 reifier :start-revision start-revision)) 2512 (initialize-scopable merged-characteristic themes 2513 :start-revision start-revision) 2514 (initialize-typable merged-characteristic instance-of 2515 :start-revision start-revision) 2516 (initialize-name merged-characteristic variants 2517 :start-revision start-revision) 2518 (when parent-construct 2519 (add-parent merged-characteristic parent-construct 2520 :revision start-revision)) 2521 merged-characteristic)))) 2522 2523 2524 (defun make-pointer (class-symbol &rest args) 2525 "Returns a pointer object with the specified parameters. 2526 If an equivalen construct has already existed this one is returned. 2527 This function only exists for beoing used by make-construct!" 2528 (let ((uri (getf (first args) :uri)) 2529 (xtm-id (getf (first args) :xtm-id)) 2530 (start-revision (getf (first args) :start-revision)) 2531 (identified-construct (getf (first args) :identified-construct))) 2532 (let ((identifier 2533 (let ((existing-pointer 2377 2534 (remove-if 2378 2535 #'null 2379 (map 'list #'(lambda(existing-characteristic) 2380 (when (equivalent-construct 2381 existing-characteristic 2382 :start-revision start-revision 2383 :datatype datatype :themes themes 2384 :instance-of instance-of) 2385 existing-characteristic)) 2386 (get-all-characteristics parent-construct 2387 class-symbol)))))) 2388 (if existing-characteristic 2389 existing-characteristic 2390 (make-instance class-symbol :charvalue charvalue 2391 :datatype datatype))))) 2392 (dolist (theme themes) 2393 (add-theme characteristic theme :revision start-revision)) 2394 (when instance-of 2395 (add-type characteristic instance-of :revision start-revision)) 2396 (dolist (variant variants) 2397 (add-variant characteristic variant :revision start-revision)) 2398 (when parent-construct 2399 (add-parent characteristic parent-construct :revision start-revision)))) 2400 2401 2402 (defun make-pointer (class-symbol uri 2403 &key (start-revision *TM-REVISION*) (xtm-id nil) 2404 (identified-construct nil)) 2405 "Returns a pointer object with the specified parameters. 2406 If an equivalen construct has already existed this one is returned." 2407 (declare (symbol class-symbol) (string uri) (integer start-revision) 2408 (type (or null string) xtm-id) 2409 (type (or null ReifiableconstructC))) 2410 (let ((identifier 2411 (let ((existing-pointer 2412 (remove-if 2413 #'null 2414 (map 'list 2415 #'(lambda(existing-pointer) 2416 (when (equivalent-construct existing-pointer :uri uri 2417 :xtm-id xtm-id) 2418 existing-pointer)) 2419 (elephant:get-instances-by-value class-symbol 'd::uri uri))))) 2420 (if existing-pointer existing-pointer 2421 (make-instance class-symbol :uri uri :xtm-id xtm-id))))) 2422 (when identified-construct 2423 (cond ((TopicIdentificationC-p class-symbol) 2424 (add-topic-identifier identified-construct identifier 2425 :revision start-revision)) 2426 ((PersistentIdC-p class-symbol) 2427 (add-psi identified-construct identifier :revision start-revision)) 2428 ((ItemIdentifierC-p class-symbol) 2429 (add-item-identifier identified-construct identifier 2430 :revision start-revision)) 2431 ((SubjectLocatorC-p class-symbol) 2432 (add-locator identified-construct identifier 2433 :revision start-revision)))) 2434 identifier)) 2536 (map 'list 2537 #'(lambda(existing-pointer) 2538 (when (equivalent-construct existing-pointer uri 2539 xtm-id) 2540 existing-pointer)) 2541 (elephant:get-instances-by-value class-symbol 'd::uri uri))))) 2542 (if existing-pointer existing-pointer 2543 (make-instance class-symbol :uri uri :xtm-id xtm-id))))) 2544 (when identified-construct 2545 (cond ((TopicIdentificationC-p class-symbol) 2546 (add-topic-identifier identified-construct identifier 2547 :revision start-revision)) 2548 ((PersistentIdC-p class-symbol) 2549 (add-psi identified-construct identifier :revision start-revision)) 2550 ((ItemIdentifierC-p class-symbol) 2551 (add-item-identifier identified-construct identifier 2552 :revision start-revision)) 2553 ((SubjectLocatorC-p class-symbol) 2554 (add-locator identified-construct identifier 2555 :revision start-revision)))) 2556 identifier))) 2435 2557 2436 2558 -
TabularUnified branches/new-datamodel/src/rest_interface/rest-interface.lisp ¶
r176 r234 72 72 (flex:make-external-format :utf-8 :eol-style :lf)) 73 73 (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) 74 (elephant:open-store 75 (xml-importer:get-store-spec repository-path)) 74 (unless elephant:*store-controller* 75 (elephant:open-store 76 (xml-importer:get-store-spec repository-path))) 76 77 (load conffile) 77 78 (publish-feed atom:*tm-feed*) -
TabularUnified branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ¶
r208 r234 227 227 (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 228 228 (let ((fragment 229 (with- writer-lock230 ( create-latest-fragment-of-topic identifier))))229 (with-reader-lock 230 (get-latest-fragment-of-topic identifier)))) 231 231 (if fragment 232 232 (handler-case (with-reader-lock … … 252 252 (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 253 253 (let ((fragment 254 (with- writer-lock255 ( create-latest-fragment-of-topic identifier))))254 (with-reader-lock 255 (get-latest-fragment-of-topic identifier)))) 256 256 (if fragment 257 257 (handler-case (with-reader-lock -
TabularUnified branches/new-datamodel/src/unit_tests/datamodel_test.lisp ¶
r231 r234 1376 1376 (scope-2 (make-instance 'd:TopicC)) 1377 1377 (scope-3 (make-instance 'd:TopicC)) 1378 (reifier-1 (make-instance 'd:TopicC))1379 (reifier-2 (make-instance 'd:TopicC))1380 (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))1381 (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))1382 1378 (revision-0-5 50) 1383 1379 (version-1 100)) … … 1404 1400 (is-false (d::equivalent-construct 1405 1401 occ-1 :charvalue "occ-2" :datatype constants:*xml-string* 1406 :instance-of type-1 :themes (list scope-2 scope-1))) 1407 (add-item-identifier occ-1 ii-1) 1408 (is-true (d::equivalent-construct occ-1 :item-identifiers (list ii-1))) 1409 (is-false (d::equivalent-construct occ-1 :item-identifiers (list ii-2))) 1410 (add-reifier occ-1 reifier-1) 1411 (is-true (d::equivalent-construct occ-1 :reifier reifier-1)) 1412 (is-false (d::equivalent-construct occ-1 :reifier reifier-2))))) 1402 :instance-of type-1 :themes (list scope-2 scope-1)))))) 1413 1403 1414 1404 … … 1422 1412 (scope-2 (make-instance 'd:TopicC)) 1423 1413 (scope-3 (make-instance 'd:TopicC)) 1424 (reifier-1 (make-instance 'd:TopicC))1425 (reifier-2 (make-instance 'd:TopicC))1426 (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))1427 (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))1428 1414 (revision-0-5 50) 1429 1415 (version-1 100)) … … 1447 1433 (is-false (d::equivalent-construct 1448 1434 nam-1 :charvalue "nam-2" :instance-of type-1 1449 :themes (list scope-2 scope-1))) 1450 (add-item-identifier nam-1 ii-1) 1451 (is-true (d::equivalent-construct nam-1 :item-identifiers (list ii-1))) 1452 (is-false (d::equivalent-construct nam-1 :item-identifiers (list ii-2))) 1453 (add-reifier nam-1 reifier-1) 1454 (is-true (d::equivalent-construct nam-1 :reifier reifier-1)) 1455 (is-false (d::equivalent-construct nam-1 :reifier reifier-2))))) 1435 :themes (list scope-2 scope-1)))))) 1456 1436 1457 1437 … … 1463 1443 (scope-2 (make-instance 'd:TopicC)) 1464 1444 (scope-3 (make-instance 'd:TopicC)) 1465 (reifier-1 (make-instance 'd:TopicC))1466 (reifier-2 (make-instance 'd:TopicC))1467 (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))1468 (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))1469 1445 (revision-0-5 50) 1470 1446 (version-1 100)) … … 1487 1463 (is-false (d::equivalent-construct 1488 1464 var-1 :charvalue "var-2" :datatype constants:*xml-string* 1489 :themes (list scope-2 scope-1))) 1490 (add-item-identifier var-1 ii-1) 1491 (is-true (d::equivalent-construct var-1 :item-identifiers (list ii-1))) 1492 (is-false (d::equivalent-construct var-1 :item-identifiers (list ii-2))) 1493 (add-reifier var-1 reifier-1) 1494 (is-true (d::equivalent-construct var-1 :reifier reifier-1)) 1495 (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) 1465 :themes (list scope-2 scope-1)))))) 1496 1466 1497 1467 … … 1504 1474 (player-1 (make-instance 'd:TopicC)) 1505 1475 (player-2 (make-instance 'd:TopicC)) 1506 (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))1507 (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))1508 (ii-3 (make-instance 'd:ItemIdentifierC :uri "ii-3"))1509 (reifier-1 (make-instance 'd:TopicC))1510 (reifier-2 (make-instance 'd:TopicC))1511 1476 (revision-1 100) 1512 1477 (revision-2 200)) … … 1514 1479 (add-type role-1 type-1) 1515 1480 (add-player role-1 player-1) 1516 (add-item-identifier role-1 ii-1)1517 (add-item-identifier role-1 ii-2)1518 (add-reifier role-1 reifier-1)1519 1481 (is-true (d::equivalent-construct role-1 :player player-1 1520 1482 :instance-of type-1)) 1521 (is-true (d::equivalent-construct role-11522 :item-identifiers (list ii-1 ii-3)))1523 (is-true (d::equivalent-construct role-1 :reifier reifier-1))1524 1483 (is-false (d::equivalent-construct role-1 :player player-2 1525 1484 :instance-of type-1)) 1526 1485 (is-false (d::equivalent-construct role-1 :player player-1 1527 1486 :instance-of type-2)) 1528 (is-false (d::equivalent-construct role-11529 :item-identifiers (list ii-3)))1530 (is-false (d::equivalent-construct role-1 :reifier reifier-2))1531 1487 (setf *TM-REVISION* revision-2) 1532 (delete-item-identifier role-1 ii-1 :revision revision-2)1533 1488 (delete-player role-1 player-1 :revision revision-2) 1534 1489 (add-player role-1 player-2) 1535 1490 (delete-type role-1 type-1 :revision revision-2) 1536 1491 (add-type role-1 type-2) 1537 (delete-reifier role-1 reifier-1 :revision revision-2)1538 (add-reifier role-1 reifier-2)1539 1492 (is-true (d::equivalent-construct role-1 :player player-2 1540 1493 :instance-of type-2)) 1541 (is-true (d::equivalent-construct role-11542 :item-identifiers (list ii-2)))1543 (is-true (d::equivalent-construct role-1 :reifier reifier-2))1544 1494 (is-false (d::equivalent-construct role-1 :player player-1 1545 1495 :instance-of type-2)) 1546 1496 (is-false (d::equivalent-construct role-1 :player player-2 1547 :instance-of type-1)) 1548 (is-false (d::equivalent-construct role-1 1549 :item-identifiers (list ii-1))) 1550 (is-false (d::equivalent-construct role-1 :reifier reifier-1)) 1551 (is-true (d::equivalent-construct role-1 :start-revision revision-1 1552 :item-identifiers (list ii-1))) 1553 (is-true (d::equivalent-construct role-1 :reifier reifier-1 1554 :start-revision revision-1))))) 1497 :instance-of type-1))))) 1555 1498 1556 1499 … … 1567 1510 (scope-2 (make-instance 'd:TopicC)) 1568 1511 (scope-3 (make-instance 'd:TopicC)) 1569 (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))1570 (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))1571 (reifier-1 (make-instance 'd:TopicC))1572 (reifier-2 (make-instance 'd:TopicC))1573 1512 (revision-1 100)) 1574 1513 (setf *TM-REVISION* revision-1) … … 1578 1517 (d:add-theme assoc-1 scope-1) 1579 1518 (d:add-theme assoc-1 scope-2) 1580 (d:add-item-identifier assoc-1 ii-1)1581 (d:add-reifier assoc-1 reifier-1)1582 1519 (is-true (d::equivalent-construct 1583 1520 assoc-1 :roles (list role-1 role-2) :instance-of type-1 1584 1521 :themes (list scope-1 scope-2))) 1585 (is-true (d::equivalent-construct assoc-11586 :item-identifiers (list ii-1 ii-2)))1587 (is-true (d::equivalent-construct assoc-1 :reifier reifier-1))1588 1522 (is-false (d::equivalent-construct 1589 1523 assoc-1 :roles (list role-1 role-2 role-3) :instance-of type-1 … … 1594 1528 (is-false (d::equivalent-construct 1595 1529 assoc-1 :roles (list role-1 role-2) :instance-of type-1 1596 :themes (list scope-1 scope-3 scope-2))) 1597 (is-false (d::equivalent-construct assoc-1 :item-identifiers (list ii-2))) 1598 (is-false (d::equivalent-construct assoc-1 :reifeir reifier-2))))) 1530 :themes (list scope-1 scope-3 scope-2)))))) 1599 1531 1600 1532 … … 1609 1541 (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")) 1610 1542 (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2")) 1543 (tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1" 1544 :xtm-id "xtm-id-1")) 1545 (tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2" 1546 :xtm-id "xtm-id-2")) 1611 1547 (revision-1 100)) 1612 1548 (setf *TM-REVISION* revision-1) … … 1614 1550 (d:add-locator top-1 sl-1) 1615 1551 (d:add-psi top-1 psi-1) 1552 (d:add-topic-identifier top-1 tid-1) 1616 1553 (is-true (d::equivalent-construct top-1 1617 1554 :item-identifiers (list ii-1 ii-2))) … … 1621 1558 (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) 1622 1559 (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) 1560 (is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1))) 1561 (is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2))) 1623 1562 (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) 1624 1563 :psis (list psi-2) -
TabularUnified branches/new-datamodel/src/xml/rdf/importer.lisp ¶
r172 r234 21 21 (init-rdf-module) 22 22 (rdf-importer rdf-xml-path repository-path :tm-id tm-id 23 :document-id document-id) 24 (when elephant:*store-controller*25 (elephant:close-store)))23 :document-id document-id)) 24 ; (when elephant:*store-controller* 25 ; (elephant:close-store))) 26 26 27 27 … … 47 47 (length (elephant:get-instances-by-class 'TopicC)) 48 48 (length (elephant:get-instances-by-class 'AssociationC))) 49 (elephant:close-store)49 ; (elephant:close-store) 50 50 (setf *_n-map* nil))) 51 51 -
TabularUnified branches/new-datamodel/src/xml/xtm/setup.lisp ¶
r95 r234 51 51 (get-store-spec repository-path))) 52 52 (init-isidorus) 53 (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) 54 (when elephant:*store-controller*55 (elephant:close-store)))53 (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)) 54 ; (when elephant:*store-controller* 55 ; (elephant:close-store)))
Note: See TracChangeset
for help on using the changeset viewer.