Changeset 30 for trunk/src/json
- Timestamp:
- 05/05/09 19:18:11 (16 years ago)
- Location:
- trunk/src/json
- Files:
-
- 1 added
- 1 edited
-
json_tmcl.lisp (modified) (5 diffs)
-
json_tmcl_validation.lisp (added)
Legend:
- Unmodified
- Added
- Removed
-
TabularUnified trunk/src/json/json_tmcl.lisp ¶
r29 r30 7 7 ;;+----------------------------------------------------------------------------- 8 8 9 10 (defpackage :json-tmcl11 (:use :cl :datamodel :constants :json-tmcl-constants)12 (:export :get-constraints-of-fragment13 :topictype-p14 :abstract-p15 :list-subtypes))16 9 17 10 (in-package :json-tmcl) … … 526 519 (defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics) 527 520 "Returns all topicoccurrence constraints as a list of the following form: 528 ( ( :type <occurrencetype-topic> 529 :constraints ( ( :regexp <string> :card-min <string> :card-max <string>) 530 <...>) 531 :scopes ( ( :scope <scope-topic> :regexp <string> :card-min <string> :card-max <string>) 532 <...>) 533 :datatype <string> 534 :uniqe ( ( :regexp <string> :dard-min <string> :card-max <string> ) ) 535 <...>)." 521 [{occurrenceTypes:[{occurrenceType:[psi-1,psi-2], 522 scopeConstraints:[<scopeConstraints>], 523 datatypeConstraint:datatype}, 524 <...>], 525 constraints:[<simpleConstraints>, <...>], 526 uniqueConstraint:[<uniqueConstraints>, <...> ]} 527 <...>]." 536 528 (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) 537 529 (applies-to (get-item-by-psi *applies-to-psi*)) … … 856 848 857 849 858 ;; --- checks if the given topic is a valid topictype --------------------------859 (defun get-direct-types-of-topic(topic-instance)860 "Returns the direct types of the topic as a list passed to this function.861 This function only returns the types of the type-instance-relationship -> TMDM 7.2"862 (let ((type-instance (get-item-by-psi *type-instance-psi*))863 (instance (get-item-by-psi *instance-psi*))864 (type (get-item-by-psi *type-psi*)))865 (let ((topic-types866 (loop for role in (player-in-roles topic-instance)867 when (eq instance (instance-of role))868 collect (loop for other-role in (roles (parent role))869 when (and (not (eq role other-role))870 (eq type-instance (instance-of (parent role)))871 (eq type (instance-of other-role)))872 return (player other-role)))))873 (when topic-types874 (remove-if #'null topic-types)))))875 876 877 (defun get-direct-supertypes-of-topic(topic-instance)878 "Returns the direct supertypes of the topic as a list passed to this function.879 This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3"880 (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*))881 (supertype (get-item-by-psi *supertype-psi*))882 (subtype (get-item-by-psi *subtype-psi*)))883 (let ((supertypes884 (loop for role in (player-in-roles topic-instance)885 when (eq subtype (instance-of role))886 append (loop for other-role in (roles (parent role))887 when (and (not (eq role other-role))888 (eq supertype-subtype (instance-of (parent role)))889 (eq supertype (instance-of other-role)))890 collect (player other-role)))))891 (remove-if #'null supertypes))))892 893 894 (defun subtype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) (checked-topics nil))895 "Returns a list of all supertypes of the passed topic if the passed topic896 is not an instanceOf any other topic but a subtype of some supertypes897 of topictype or it is the topictype-topic itself."898 ;(format t "~%~%subtype-p ~a~%" (uri (first (psis topic-instance))))899 (let ((current-checked-topics (remove-duplicates (append checked-topics (list topic-instance)))))900 901 (when (eq topictype topic-instance)902 (return-from subtype-p current-checked-topics))903 904 (when (get-direct-types-of-topic topic-instance)905 (return-from subtype-p nil))906 907 (let ((supertypes-of-this (get-direct-supertypes-of-topic topic-instance)))908 (when (not supertypes-of-this)909 (return-from subtype-p nil))910 (when supertypes-of-this911 (loop for supertype-of-this in supertypes-of-this912 when (not (find supertype-of-this current-checked-topics :test #'eq))913 do (let ((further-supertypes (subtype-p topictype supertype-of-this current-checked-topics)))914 (when (not further-supertypes)915 (return-from subtype-p nil))916 917 (dolist (item further-supertypes)918 (pushnew item current-checked-topics))))))919 920 current-checked-topics))921 922 923 (defun topictype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))924 (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))925 (checked-topics nil))926 "Returns a list of all instanceOf-topics and all Supertypes of this topic927 if this topic is a valid topic (-type). I.e. the passed topic is the928 topictype or it is an instanceOf of the topictype or it is a subtype of929 the topictype. TMDM 7.2 + TMDM 7.3"930 ;(format t "~%~%topictype-p ~a~%" (uri (first (psis topic-instance))))931 (let ((current-checked-topics (append checked-topics (list topic-instance)))932 (akos-of-this (get-direct-supertypes-of-topic topic-instance))933 (isas-of-this (get-direct-types-of-topic topic-instance)))934 935 (when (eq topictype topic-instance)936 (return-from topictype-p current-checked-topics))937 938 (when (not (union akos-of-this isas-of-this :test #'eq))939 (when topictype-constraint940 ;(return-from topictype-p nil))941 (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))942 (return-from topictype-p current-checked-topics))943 944 (let ((akos-are-topictype nil))945 (loop for ako-of-this in akos-of-this946 when (not (find ako-of-this current-checked-topics))947 do (let ((further-topics (topictype-p ako-of-this topictype topictype-constraint)))948 (if further-topics949 (progn950 (dolist (item further-topics)951 (pushnew item current-checked-topics))952 (pushnew ako-of-this akos-are-topictype))953 (when topictype-constraint954 ;(return-from topictype-p nil)))))955 (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype))))))))956 957 (when isas-of-this958 (let ((topictype-topics-of-isas nil))959 (loop for isa-of-this in isas-of-this960 do (let ((topic-akos (subtype-p isa-of-this topictype)))961 (when topic-akos962 (pushnew isa-of-this topictype-topics-of-isas)963 (pushnew isa-of-this current-checked-topics)964 (dolist (item topic-akos)965 (pushnew item current-checked-topics)))))966 967 (when (and (not topictype-topics-of-isas)968 (not akos-are-topictype)969 topictype-constraint)970 ;(return-from topictype-p nil))971 (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))972 973 (loop for isa-of-this in isas-of-this974 when (and (not (find isa-of-this current-checked-topics :test #'eq))975 (not (find isa-of-this topictype-topics-of-isas :test #'eq)))976 do (let ((further-topic-types (topictype-p isa-of-this topictype topictype-constraint current-checked-topics)))977 (if further-topic-types978 (dolist (item further-topic-types)979 (pushnew item current-checked-topics))980 (when topictype-constraint981 ;(return-from topictype-p nil))))))))982 (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))))))))983 current-checked-topics))984 985 986 (defun topictype-of-p (topic-instance type-instance &optional (topictype (get-item-by-psi *topictype-psi*))987 (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))988 checked-topics)989 "Returns a list of all types and supertypes of this topic if this topic is a990 valid instance-topic of the type-topic called type-instance. TMCL 4.4.2.991 When the type-instance is set to nil there will be checked only if the992 topic-instance is a valid instance."993 (let ((current-checked-topics (append checked-topics (list topic-instance)))994 (isas-of-this (get-direct-types-of-topic topic-instance))995 (akos-of-this (get-direct-supertypes-of-topic topic-instance)))996 997 (when (eq topic-instance topictype)998 t)999 1000 (when (and (not isas-of-this)1001 (not akos-of-this))1002 (return-from topictype-of-p nil))1003 1004 (loop for isa-of-this in isas-of-this1005 do (let ((found-topics (topictype-p isa-of-this topictype topictype-constraint)))1006 (when (not found-topics)1007 (return-from topictype-of-p nil))1008 (dolist (item found-topics)1009 (pushnew item current-checked-topics))))1010 1011 (loop for ako-of-this in akos-of-this1012 when (not (find ako-of-this current-checked-topics :test #'eq))1013 do (let ((found-topics (topictype-of-p ako-of-this type-instance topictype topictype-constraint current-checked-topics)))1014 (when (not found-topics)1015 (return-from topictype-of-p nil))1016 (dolist (item found-topics)1017 (pushnew item current-checked-topics))))1018 1019 (if type-instance1020 (when (find type-instance current-checked-topics)1021 current-checked-topics)1022 current-checked-topics)))1023 1024 1025 850 ;; --- gets all constraint topics ---------------------------------------------- 1026 851 (defun get-direct-constraint-topics-of-topic (topic-instance) … … 1130 955 1131 956 1132 (defun abstract-p (topic-instance)1133 "Returns t if this topic type is an abstract topic type."1134 (let ((constraint-role (get-item-by-psi *constraint-role-psi*))1135 (topictype-role (get-item-by-psi *topictype-role-psi*))1136 (applies-to (get-item-by-psi *applies-to-psi*))1137 (abstract-topictype-constraint (get-item-by-psi *abstract-topictype-constraint-psi*)))1138 1139 (loop for role in (player-in-roles topic-instance)1140 when (and (eq topictype-role (instance-of role))1141 (eq applies-to (instance-of (parent role))))1142 return (loop for other-role in (roles (parent role))1143 when (and (eq constraint-role (instance-of other-role))1144 (eq abstract-topictype-constraint (player other-role)))1145 return t))))1146 1147 1148 957 (defun get-direct-constraint-topics-of-association(associationtype-topic) 1149 958 "Returns all direct constraint topics defined for associations if … … 1246 1055 1247 1056 1248 (defun list-subtypes (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))1249 (topictype-constraint (get-item-by-psi *topictype-constraint-psi*))1250 (checked-topics nil) (valid-subtypes nil))1251 "Returns all valid subtypes of a topic, e.g.:1252 nametype-constraint ako constraint .1253 first-name isa nametype .1254 first-name-1 ako first-name .1255 // ...1256 The return value is a named list of the form (:subtypes (<topic> <...>) :checked-topics (<topic> <...>)"1257 (let ((current-checked-topics (append checked-topics (list topic-instance))))1258 1259 (handler-case (topictype-p topic-instance topictype topictype-constraint)1260 (condition () (return-from list-subtypes (list :subtypes nil :checked-topics current-checked-topics))))1261 1262 (let ((subtype (get-item-by-psi *subtype-psi*))1263 (supertype (get-item-by-psi *supertype-psi*))1264 (supertype-subtype (get-item-by-psi *supertype-subtype-psi*))1265 (current-valid-subtypes (append valid-subtypes (list topic-instance))))1266 (loop for role in (player-in-roles topic-instance)1267 when (and (eq supertype (instance-of role))1268 (eq supertype-subtype (instance-of (parent role))))1269 do (loop for other-role in (roles (parent role))1270 do (when (and (eq subtype (instance-of other-role))1271 (not (find (player other-role) current-checked-topics)))1272 (let ((new-values1273 (list-subtypes (player other-role) topictype topictype-constraint current-checked-topics current-valid-subtypes)))1274 (dolist (item (getf new-values :subtypes))1275 (pushnew item current-valid-subtypes))1276 (dolist (item (getf new-values :checked-topics))1277 (pushnew item current-checked-topics))))))1278 (list :subtypes current-valid-subtypes :checked-topics current-checked-topics))))1279 1280 1281 (defun list-instances (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*))1282 (topictype-constraint (get-item-by-psi *topictype-constraint-psi*)))1283 "Returns the topic-instance, all subtypes found by the function lis-subtypes and all direct1284 instances for the found subtypes."1285 (let ((all-subtypes-of-this1286 (getf (list-subtypes topic-instance topictype topictype-constraint) :subtypes))1287 (type (get-item-by-psi *type-psi*))1288 (instance (get-item-by-psi *instance-psi*))1289 (type-instance (get-item-by-psi *type-instance-psi*)))1290 (let ((all-instances-of-this1291 (remove-duplicates1292 (loop for subtype-of-this in all-subtypes-of-this1293 append (loop for role in (player-in-roles subtype-of-this)1294 when (and (eq type (instance-of role))1295 (eq type-instance (instance-of (parent role))))1296 append (loop for other-role in (roles (parent role))1297 when (eq instance (instance-of other-role))1298 collect (player other-role)))))))1299 (let ((all-subtypes-of-all-instances1300 (remove-if #'null1301 (remove-duplicates1302 (loop for subtype in all-instances-of-this1303 append (getf (list-subtypes subtype nil nil) :subtypes))))))1304 (remove-if #'null1305 (map 'list #'(lambda(x)1306 (handler-case (progn1307 (topictype-of-p x nil)1308 x)1309 (condition () nil)))1310 all-subtypes-of-all-instances))))))1311 1312 1313 1057 (defun topics-to-json-list (topics) 1314 1058 "Returns a json list of psi-lists."
Note: See TracChangeset
for help on using the changeset viewer.
