| 1 | ;;+----------------------------------------------------------------------------- |
|---|
| 2 | ;;+ Isidorus |
|---|
| 3 | ;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff |
|---|
| 4 | ;;+ |
|---|
| 5 | ;;+ Isidorus is freely distributable under the LLGPL license. |
|---|
| 6 | ;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and |
|---|
| 7 | ;;+ trunk/docs/LGPL-LICENSE.txt. |
|---|
| 8 | ;;+----------------------------------------------------------------------------- |
|---|
| 9 | |
|---|
| 10 | (in-package :json-tmcl) |
|---|
| 11 | |
|---|
| 12 | |
|---|
| 13 | ;; ============================================================================= |
|---|
| 14 | ;; --- all fragment constraints ------------------------------------------------ |
|---|
| 15 | ;; ============================================================================= |
|---|
| 16 | (defun get-constraints-of-fragment(topic-psis &key |
|---|
| 17 | (treat-as 'type) (revision *TM-REVISION*)) |
|---|
| 18 | "Returns a json string with all constraints of this topic-psis. |
|---|
| 19 | topic-psis must contain one item if it is treated as instance otherwise# |
|---|
| 20 | there can be more psis then the fragment will be treated as an instanceOf |
|---|
| 21 | all passed psis." |
|---|
| 22 | (declare (type (or integer null) revision) |
|---|
| 23 | (symbol treat-as) |
|---|
| 24 | (list topic-psis)) |
|---|
| 25 | (let ((associationtype (get-item-by-psi *associationtype-psi* :revision revision)) |
|---|
| 26 | (associationtype-constraint (is-type-constrained |
|---|
| 27 | :what *associationtype-constraint-psi* |
|---|
| 28 | :revision revision)) |
|---|
| 29 | (topics nil)) |
|---|
| 30 | (when (and (not (eql treat-as 'type)) |
|---|
| 31 | (> (length topic-psis) 1)) |
|---|
| 32 | (error "From get-constraints-of-fragment: when treat-as is set ot instance there must be exactly one item in topic-psis!")) |
|---|
| 33 | (loop for topic-psi in topic-psis |
|---|
| 34 | do (let ((psi |
|---|
| 35 | (elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi))) |
|---|
| 36 | (if psi |
|---|
| 37 | (pushnew (identified-construct psi) topics) |
|---|
| 38 | (error "Topic \"~a\" not found!" topic-psi)))) |
|---|
| 39 | (when topics |
|---|
| 40 | (let ((topic-constraints |
|---|
| 41 | (let ((value |
|---|
| 42 | (get-constraints-of-topic topics :treat-as treat-as |
|---|
| 43 | :revision revision))) |
|---|
| 44 | (concat "\"topicConstraints\":" value)))) |
|---|
| 45 | (let ((available-associations |
|---|
| 46 | (remove-duplicates |
|---|
| 47 | (loop for topic in topics |
|---|
| 48 | append (get-available-associations-of-topic |
|---|
| 49 | topic :treat-as treat-as :revision revision))))) |
|---|
| 50 | (dolist (item available-associations) |
|---|
| 51 | (topictype-p item associationtype associationtype-constraint |
|---|
| 52 | nil revision)) |
|---|
| 53 | (let ((associations-constraints |
|---|
| 54 | (concat "\"associationsConstraints\":" |
|---|
| 55 | (let ((inner-associations-constraints "[")) |
|---|
| 56 | (loop for available-association in available-associations |
|---|
| 57 | do (let ((value |
|---|
| 58 | (get-constraints-of-association |
|---|
| 59 | available-association :revision revision))) |
|---|
| 60 | (push-string (concat value ",") |
|---|
| 61 | inner-associations-constraints))) |
|---|
| 62 | (if (string= inner-associations-constraints "[") |
|---|
| 63 | (setf inner-associations-constraints "null") |
|---|
| 64 | (setf inner-associations-constraints |
|---|
| 65 | (concat |
|---|
| 66 | (subseq inner-associations-constraints 0 |
|---|
| 67 | (- (length inner-associations-constraints) 1)) |
|---|
| 68 | "]"))))))) |
|---|
| 69 | (concat "{" topic-constraints "," associations-constraints "}"))))))) |
|---|
| 70 | |
|---|
| 71 | |
|---|
| 72 | ;; ============================================================================= |
|---|
| 73 | ;; --- all association constraints --------------------------------------------- |
|---|
| 74 | ;; ============================================================================= |
|---|
| 75 | (defun get-constraints-of-association (associationtype-topic &key |
|---|
| 76 | (revision *TM-REVISION*)) |
|---|
| 77 | "Returns a list of constraints which are describing associations of the |
|---|
| 78 | passed associationtype-topic." |
|---|
| 79 | (declare (TopicC associationtype-topic) |
|---|
| 80 | (type (or integer null) revision)) |
|---|
| 81 | (let ((constraint-topics |
|---|
| 82 | (get-all-constraint-topics-of-association associationtype-topic |
|---|
| 83 | :revision revision))) |
|---|
| 84 | (let ((associationtype |
|---|
| 85 | (concat "\"associationType\":" |
|---|
| 86 | (json-exporter::identifiers-to-json-string |
|---|
| 87 | associationtype-topic :revision revision))) |
|---|
| 88 | (associationtypescope-constraints |
|---|
| 89 | (let ((value (get-typescope-constraints associationtype-topic |
|---|
| 90 | :what 'association |
|---|
| 91 | :revision revision))) |
|---|
| 92 | (concat "\"scopeConstraints\":" value))) |
|---|
| 93 | (associationrole-constraints |
|---|
| 94 | (let ((value |
|---|
| 95 | (get-associationrole-constraints |
|---|
| 96 | (getf constraint-topics :associationrole-constraints) |
|---|
| 97 | :revision revision))) |
|---|
| 98 | (concat "\"associationRoleConstraints\":" value))) |
|---|
| 99 | (roleplayer-constraints |
|---|
| 100 | (let ((value |
|---|
| 101 | (get-roleplayer-constraints |
|---|
| 102 | (getf constraint-topics :roleplayer-constraints) |
|---|
| 103 | :revision revision))) |
|---|
| 104 | (concat "\"rolePlayerConstraints\":" value))) |
|---|
| 105 | (otherrole-constraints |
|---|
| 106 | (let ((value |
|---|
| 107 | (handler-case |
|---|
| 108 | (get-otherrole-constraints |
|---|
| 109 | (getf constraint-topics :otherrole-constraints) |
|---|
| 110 | :revision revision) |
|---|
| 111 | (condition () "null")))) |
|---|
| 112 | (concat "\"otherRoleConstraints\":" value)))) |
|---|
| 113 | (concat "{" associationtype "," associationrole-constraints |
|---|
| 114 | "," roleplayer-constraints "," otherrole-constraints "," |
|---|
| 115 | associationtypescope-constraints "}")))) |
|---|
| 116 | |
|---|
| 117 | |
|---|
| 118 | (defun get-otherrole-constraints (constraint-topics &key (revision *TM-REVISION*)) |
|---|
| 119 | "Returns a list of the form |
|---|
| 120 | ((::role <topic> :player <topic> :otherrole <topic> :othertopic <topic> |
|---|
| 121 | :card-min <string> :card-max <string>) <...>) |
|---|
| 122 | which describes an otherrole constraint for the parent-association of a give type." |
|---|
| 123 | (declare (list constraint-topics) |
|---|
| 124 | (type (or integer null) revision)) |
|---|
| 125 | (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 126 | (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 127 | (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) |
|---|
| 128 | (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision)) |
|---|
| 129 | (othertopictype-role (get-item-by-psi *othertopictype-role-psi* |
|---|
| 130 | :revision revision)) |
|---|
| 131 | (otherroletype-role (get-item-by-psi *otherroletype-role-psi* |
|---|
| 132 | :revision revision)) |
|---|
| 133 | (roletype (get-item-by-psi *roletype-psi* :revision revision)) |
|---|
| 134 | (roletype-constraint (is-type-constrained :what *roletype-constraint-psi* |
|---|
| 135 | :revision revision)) |
|---|
| 136 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 137 | (topictype-constraint (is-type-constrained :revision revision))) |
|---|
| 138 | (let ((otherrole-constraints |
|---|
| 139 | (loop for constraint-topic in constraint-topics |
|---|
| 140 | append (let ((players nil) |
|---|
| 141 | (roletypes nil) |
|---|
| 142 | (otherplayers nil) |
|---|
| 143 | (otherroletypes nil) |
|---|
| 144 | (constraint-list |
|---|
| 145 | (get-constraint-topic-values constraint-topic |
|---|
| 146 | :revision revision))) |
|---|
| 147 | (loop for role in (player-in-roles constraint-topic |
|---|
| 148 | :revision revision) |
|---|
| 149 | when (and (parent role :revision revision) |
|---|
| 150 | (eq constraint-role |
|---|
| 151 | (instance-of role :revision revision)) |
|---|
| 152 | (eq applies-to (instance-of |
|---|
| 153 | (parent role :revision revision) |
|---|
| 154 | :revision revision))) |
|---|
| 155 | do (loop for other-role in (roles |
|---|
| 156 | (parent role :revision revision) |
|---|
| 157 | :revision revision) |
|---|
| 158 | do (let ((current-player |
|---|
| 159 | (player other-role :revision revision)) |
|---|
| 160 | (current-role |
|---|
| 161 | (instance-of other-role :revision revision))) |
|---|
| 162 | (cond |
|---|
| 163 | ((eq topictype-role current-role) |
|---|
| 164 | (push current-player players)) |
|---|
| 165 | ((eq roletype-role current-role) |
|---|
| 166 | (push current-player roletypes)) |
|---|
| 167 | ((eq othertopictype-role current-role) |
|---|
| 168 | (push current-player otherplayers)) |
|---|
| 169 | ((eq otherroletype-role current-role) |
|---|
| 170 | (push current-player otherroletypes)))))) |
|---|
| 171 | (when (and (append |
|---|
| 172 | players roletypes otherplayers otherroletypes) |
|---|
| 173 | (or (not players) (not roletypes) |
|---|
| 174 | (not otherplayers) (not otherroletypes))) |
|---|
| 175 | (error "otherroletype-constraint ~a is not complete:~%players: ~a~%roletypes: ~a~%otherplayers: ~a~%otherroletypes: ~a~%" |
|---|
| 176 | (uri (first (psis constraint-topic))) |
|---|
| 177 | (map 'list |
|---|
| 178 | #'(lambda(x) |
|---|
| 179 | (uri (first (psis x :revision revision)))) |
|---|
| 180 | players) |
|---|
| 181 | (map 'list |
|---|
| 182 | #'(lambda(x) |
|---|
| 183 | (uri (first (psis x :revision revision)))) |
|---|
| 184 | roletypes) |
|---|
| 185 | (map 'list |
|---|
| 186 | #'(lambda(x) |
|---|
| 187 | (uri (first (psis x :revision revision)))) |
|---|
| 188 | otherplayers) |
|---|
| 189 | (map 'list |
|---|
| 190 | #'(lambda(x) |
|---|
| 191 | (uri (first (psis x :revision revision)))) |
|---|
| 192 | otherroletypes))) |
|---|
| 193 | (let ((cross-product-1 |
|---|
| 194 | (loop for player in players |
|---|
| 195 | append (loop for roletype in roletypes |
|---|
| 196 | collect (list :player player |
|---|
| 197 | :role roletype)))) |
|---|
| 198 | (cross-product-2 |
|---|
| 199 | (loop for otherplayer in otherplayers |
|---|
| 200 | append (loop for otherroletype in otherroletypes |
|---|
| 201 | collect |
|---|
| 202 | (list :otherplayer otherplayer |
|---|
| 203 | :otherrole otherroletype))))) |
|---|
| 204 | (let ((cross-product |
|---|
| 205 | (loop for tupple-1 in cross-product-1 |
|---|
| 206 | append |
|---|
| 207 | (loop for tupple-2 in cross-product-2 |
|---|
| 208 | collect |
|---|
| 209 | (append |
|---|
| 210 | tupple-1 tupple-2 |
|---|
| 211 | (list :constraint constraint-list)))))) |
|---|
| 212 | cross-product)))))) |
|---|
| 213 | (let ((involved-topic-tupples |
|---|
| 214 | (remove-duplicates |
|---|
| 215 | (loop for otherrole-constraint in otherrole-constraints |
|---|
| 216 | collect (let ((player (getf otherrole-constraint :player)) |
|---|
| 217 | (role-type (getf otherrole-constraint :role)) |
|---|
| 218 | (otherplayer (getf otherrole-constraint :otherplayer)) |
|---|
| 219 | (otherrole-type (getf otherrole-constraint :otherrole))) |
|---|
| 220 | (topictype-p player topictype topictype-constraint |
|---|
| 221 | nil revision) |
|---|
| 222 | (topictype-p role-type roletype roletype-constraint |
|---|
| 223 | nil revision) |
|---|
| 224 | (topictype-p otherplayer topictype topictype-constraint |
|---|
| 225 | nil revision) |
|---|
| 226 | (topictype-p otherrole-type roletype roletype-constraint |
|---|
| 227 | nil revision) |
|---|
| 228 | (list :player player |
|---|
| 229 | :role role-type |
|---|
| 230 | :otherplayer otherplayer |
|---|
| 231 | :otherrole otherrole-type))) |
|---|
| 232 | :test #'(lambda(x y) |
|---|
| 233 | (and (eq (getf x :player) (getf y :player)) |
|---|
| 234 | (eq (getf x :role) (getf y :role)) |
|---|
| 235 | (eq (getf x :otherplayer) (getf y :otherplayer)) |
|---|
| 236 | (eq (getf x :otherrole) (getf y :otherrole))))))) |
|---|
| 237 | (let ((cleaned-otherrole-constraints "[")) |
|---|
| 238 | (loop for involved-topic-tupple in involved-topic-tupples |
|---|
| 239 | do (let ((constraint-lists |
|---|
| 240 | (remove-duplicate-constraints |
|---|
| 241 | (loop for otherrole-constraint in otherrole-constraints |
|---|
| 242 | when (and (eq (getf otherrole-constraint :player) |
|---|
| 243 | (getf involved-topic-tupple :player)) |
|---|
| 244 | (eq (getf otherrole-constraint :role) |
|---|
| 245 | (getf involved-topic-tupple :role)) |
|---|
| 246 | (eq (getf otherrole-constraint :otherplayer) |
|---|
| 247 | (getf involved-topic-tupple :otherplayer)) |
|---|
| 248 | (eq (getf otherrole-constraint :otherrole) |
|---|
| 249 | (getf involved-topic-tupple :otherrole))) |
|---|
| 250 | collect (getf otherrole-constraint :constraint))))) |
|---|
| 251 | (when (> (length constraint-lists) 1) |
|---|
| 252 | (error "found contrary otherrole-constraints:~%player: ~a~%role: ~a~%otherplayer: ~a~%otherrole: ~a~% ~a~%" |
|---|
| 253 | (uri (first (psis (getf involved-topic-tupple :player) |
|---|
| 254 | :revision revision))) |
|---|
| 255 | (uri (first (psis (getf involved-topic-tupple :role) |
|---|
| 256 | :revision revision))) |
|---|
| 257 | (uri (first (psis (getf involved-topic-tupple :otherplayer) |
|---|
| 258 | :revision revision))) |
|---|
| 259 | (uri (first (psis (getf involved-topic-tupple :otherrole) |
|---|
| 260 | :revision revision))) |
|---|
| 261 | constraint-lists)) |
|---|
| 262 | |
|---|
| 263 | (let ((json-player-type |
|---|
| 264 | (concat "\"playerType\":" |
|---|
| 265 | (topics-to-json-list |
|---|
| 266 | (getf (list-subtypes |
|---|
| 267 | (getf involved-topic-tupple :player) |
|---|
| 268 | nil nil nil nil revision) |
|---|
| 269 | :subtypes) :revision revision))) |
|---|
| 270 | (json-player |
|---|
| 271 | (concat "\"players\":" |
|---|
| 272 | (topics-to-json-list |
|---|
| 273 | (list-instances |
|---|
| 274 | (getf involved-topic-tupple :player) |
|---|
| 275 | topictype topictype-constraint revision) |
|---|
| 276 | :revision revision))) |
|---|
| 277 | (json-role |
|---|
| 278 | (concat "\"roleType\":" |
|---|
| 279 | (topics-to-json-list |
|---|
| 280 | (getf (list-subtypes |
|---|
| 281 | (getf involved-topic-tupple :role) |
|---|
| 282 | roletype roletype-constraint nil |
|---|
| 283 | nil revision) |
|---|
| 284 | :subtypes) :revision revision))) |
|---|
| 285 | (json-otherplayer-type |
|---|
| 286 | (concat "\"otherPlayerType\":" |
|---|
| 287 | (topics-to-json-list |
|---|
| 288 | (getf (list-subtypes |
|---|
| 289 | (getf involved-topic-tupple :otherplayer) |
|---|
| 290 | nil nil nil nil revision) :subtypes) |
|---|
| 291 | :revision revision))) |
|---|
| 292 | (json-otherplayer |
|---|
| 293 | (concat "\"otherPlayers\":" |
|---|
| 294 | (topics-to-json-list |
|---|
| 295 | (list-instances |
|---|
| 296 | (getf involved-topic-tupple :otherplayer) |
|---|
| 297 | topictype topictype-constraint revision) |
|---|
| 298 | :revision revision))) |
|---|
| 299 | (json-otherrole |
|---|
| 300 | (concat "\"otherRoleType\":" |
|---|
| 301 | (topics-to-json-list |
|---|
| 302 | (getf (list-subtypes |
|---|
| 303 | (getf involved-topic-tupple :otherrole) |
|---|
| 304 | roletype roletype-constraint nil nil revision) |
|---|
| 305 | :subtypes) :revision revision))) |
|---|
| 306 | (card-min |
|---|
| 307 | (concat "\"cardMin\":" |
|---|
| 308 | (getf (first constraint-lists) :card-min))) |
|---|
| 309 | (card-max |
|---|
| 310 | (concat "\"cardMax\":" |
|---|
| 311 | (getf (first constraint-lists) :card-max)))) |
|---|
| 312 | (setf cleaned-otherrole-constraints |
|---|
| 313 | (concat cleaned-otherrole-constraints |
|---|
| 314 | "{" json-player-type "," json-player "," |
|---|
| 315 | json-role "," json-otherplayer-type "," |
|---|
| 316 | json-otherplayer "," json-otherrole "," |
|---|
| 317 | card-min "," card-max "},"))))) |
|---|
| 318 | (if (string= cleaned-otherrole-constraints "[") |
|---|
| 319 | (setf cleaned-otherrole-constraints "null") |
|---|
| 320 | (setf cleaned-otherrole-constraints |
|---|
| 321 | (concat (subseq cleaned-otherrole-constraints 0 |
|---|
| 322 | (- (length cleaned-otherrole-constraints) 1)) |
|---|
| 323 | "]"))) |
|---|
| 324 | cleaned-otherrole-constraints))))) |
|---|
| 325 | |
|---|
| 326 | |
|---|
| 327 | (defun get-roleplayer-constraints (constraint-topics &key (revision *TM-REVISION*)) |
|---|
| 328 | "Returns a list of the form |
|---|
| 329 | ((:role <topic> :player <topic> :card-min <string> :card-max <string>) <...>) |
|---|
| 330 | which describes the cardinality of topctypes used as players in roles of given |
|---|
| 331 | types in an association of a given type which is also the parent if this list." |
|---|
| 332 | (declare (type (or integer null) revision) |
|---|
| 333 | (list constraint-topics)) |
|---|
| 334 | (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 335 | (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 336 | (topictype-role (get-item-by-psI *topictype-role-psi* :revision revision)) |
|---|
| 337 | (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision)) |
|---|
| 338 | (roletype (get-item-by-psi *roletype-psi* :revision revision)) |
|---|
| 339 | (roletype-constraint (is-type-constrained :what *roletype-constraint-psi* |
|---|
| 340 | :revision revision)) |
|---|
| 341 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 342 | (topictype-constraint (is-type-constrained :revision revision))) |
|---|
| 343 | (let ((roleplayer-constraints |
|---|
| 344 | (loop for constraint-topic in constraint-topics |
|---|
| 345 | append (let ((constraint-list |
|---|
| 346 | (get-constraint-topic-values constraint-topic |
|---|
| 347 | :revision revision))) |
|---|
| 348 | (let ((players |
|---|
| 349 | (loop for role in (player-in-roles constraint-topic |
|---|
| 350 | :revision revision) |
|---|
| 351 | when (and (eq constraint-role |
|---|
| 352 | (instance-of role :revision revision)) |
|---|
| 353 | (eq applies-to |
|---|
| 354 | (instance-of |
|---|
| 355 | (parent role :revision revision) |
|---|
| 356 | :revision revision))) |
|---|
| 357 | append (loop for other-role in |
|---|
| 358 | (roles (parent role :revision revision) |
|---|
| 359 | :revision revision) |
|---|
| 360 | when (eq topictype-role |
|---|
| 361 | (instance-of other-role |
|---|
| 362 | :revision revision)) |
|---|
| 363 | collect (player other-role |
|---|
| 364 | :revision revision)))) |
|---|
| 365 | (roles |
|---|
| 366 | (loop for role in (player-in-roles constraint-topic |
|---|
| 367 | :revision revision) |
|---|
| 368 | when (and (eq constraint-role |
|---|
| 369 | (instance-of role :revision revision)) |
|---|
| 370 | (eq applies-to |
|---|
| 371 | (instance-of |
|---|
| 372 | (parent role :revision revision) |
|---|
| 373 | :revision revision))) |
|---|
| 374 | append (loop for other-role in (roles (parent role)) |
|---|
| 375 | when (eq roletype-role |
|---|
| 376 | (instance-of other-role |
|---|
| 377 | :revision revision)) |
|---|
| 378 | collect (player other-role))))) |
|---|
| 379 | (when (or (and players (not roles)) |
|---|
| 380 | (and roles (not players))) |
|---|
| 381 | (error "roleplayer-constraint ~a is not complete:~%players: ~a~%roles: ~a~%" |
|---|
| 382 | (uri (first (psis constraint-topic |
|---|
| 383 | :revision revision))) |
|---|
| 384 | (map 'list |
|---|
| 385 | #'(lambda(x) |
|---|
| 386 | (uri (first (psis x :revision revision)))) |
|---|
| 387 | players) |
|---|
| 388 | (map 'list |
|---|
| 389 | #'(lambda(x) |
|---|
| 390 | (uri (first (psis x :revision revision)))) |
|---|
| 391 | roles))) |
|---|
| 392 | (let ((cross-product |
|---|
| 393 | (loop for player in players |
|---|
| 394 | append (loop for role in roles |
|---|
| 395 | collect |
|---|
| 396 | (list :player player |
|---|
| 397 | :role role |
|---|
| 398 | :constraint constraint-list))))) |
|---|
| 399 | cross-product)))))) |
|---|
| 400 | (let ((role-player-tupples |
|---|
| 401 | (remove-duplicates |
|---|
| 402 | (loop for roleplayer-constraint in roleplayer-constraints |
|---|
| 403 | collect (let ((current-player (getf roleplayer-constraint :player)) |
|---|
| 404 | (current-role (getf roleplayer-constraint :role))) |
|---|
| 405 | (topictype-p current-player topictype topictype-constraint |
|---|
| 406 | nil revision) |
|---|
| 407 | (topictype-p current-role roletype roletype-constraint |
|---|
| 408 | nil revision) |
|---|
| 409 | (list :player current-player |
|---|
| 410 | :role current-role))) |
|---|
| 411 | :test #'(lambda(x y) |
|---|
| 412 | (and (eq (getf x :player) (getf y :player)) |
|---|
| 413 | (eq (getf x :role) (getf y :role))))))) |
|---|
| 414 | (let ((cleaned-roleplayer-constraints "[")) |
|---|
| 415 | (loop for role-player-tupple in role-player-tupples |
|---|
| 416 | do (let ((constraint-lists |
|---|
| 417 | (remove-duplicate-constraints |
|---|
| 418 | (loop for roleplayer-constraint in roleplayer-constraints |
|---|
| 419 | when (and (eq (getf roleplayer-constraint :player) |
|---|
| 420 | (getf role-player-tupple :player)) |
|---|
| 421 | (eq (getf roleplayer-constraint :role) |
|---|
| 422 | (getf role-player-tupple :role))) |
|---|
| 423 | collect (getf roleplayer-constraint :constraint))))) |
|---|
| 424 | (when (> (length constraint-lists) 1) |
|---|
| 425 | (error "found contrary roleplayer-constraints:~%role: ~a~%player: ~a~% ~a ~%" |
|---|
| 426 | (uri (first (psis (getf role-player-tupple :role) |
|---|
| 427 | :revision revision))) |
|---|
| 428 | (uri (first (psis (getf role-player-tupple :player) |
|---|
| 429 | :revision revision))) |
|---|
| 430 | constraint-lists)) |
|---|
| 431 | (let ((json-player-type |
|---|
| 432 | (concat "\"playerType\":" |
|---|
| 433 | (topics-to-json-list |
|---|
| 434 | (getf (list-subtypes |
|---|
| 435 | (getf role-player-tupple :player) |
|---|
| 436 | nil nil nil nil revision) :subtypes) |
|---|
| 437 | :revision revision))) |
|---|
| 438 | (json-players |
|---|
| 439 | (concat "\"players\":" |
|---|
| 440 | (topics-to-json-list |
|---|
| 441 | (list-instances |
|---|
| 442 | (getf role-player-tupple :player) |
|---|
| 443 | topictype topictype-constraint revision) |
|---|
| 444 | :revision revision))) |
|---|
| 445 | (json-role |
|---|
| 446 | (concat "\"roleType\":" |
|---|
| 447 | (topics-to-json-list |
|---|
| 448 | (getf (list-subtypes |
|---|
| 449 | (getf role-player-tupple :role) |
|---|
| 450 | roletype roletype-constraint nil |
|---|
| 451 | nil revision) |
|---|
| 452 | :subtypes) |
|---|
| 453 | :revision revision))) |
|---|
| 454 | (card-min |
|---|
| 455 | (concat "\"cardMin\":" |
|---|
| 456 | (getf (first constraint-lists) :card-min))) |
|---|
| 457 | (card-max |
|---|
| 458 | (concat "\"cardMax\":" |
|---|
| 459 | (getf (first constraint-lists) :card-max)))) |
|---|
| 460 | (setf cleaned-roleplayer-constraints |
|---|
| 461 | (concat cleaned-roleplayer-constraints |
|---|
| 462 | "{" json-player-type "," json-players "," |
|---|
| 463 | json-role "," card-min "," card-max "},"))))) |
|---|
| 464 | (if (string= cleaned-roleplayer-constraints "[") |
|---|
| 465 | (setf cleaned-roleplayer-constraints "null") |
|---|
| 466 | (setf cleaned-roleplayer-constraints |
|---|
| 467 | (concat (subseq cleaned-roleplayer-constraints 0 |
|---|
| 468 | (- (length cleaned-roleplayer-constraints) 1)) |
|---|
| 469 | "]"))) |
|---|
| 470 | cleaned-roleplayer-constraints))))) |
|---|
| 471 | |
|---|
| 472 | |
|---|
| 473 | (defun get-associationrole-constraints (constraint-topics &key |
|---|
| 474 | (revision *TM-REVISION*)) |
|---|
| 475 | "Returns a list of the form |
|---|
| 476 | ((:associationroletype <topic> :card-min <string> :card-max <string>), <...>) |
|---|
| 477 | which describes all associationrole-constraints of the passed |
|---|
| 478 | constraint-topics. |
|---|
| 479 | If as-json is set to t the return value of this function is a |
|---|
| 480 | json-string otherwise a list of lists of the following form |
|---|
| 481 | (:roletype <topic, topic, ...> :cardMin <min> :cardMax <max>)" |
|---|
| 482 | (declare (type (or integer null) revision) |
|---|
| 483 | (list constraint-topics)) |
|---|
| 484 | (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 485 | (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision)) |
|---|
| 486 | (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 487 | (roletype (get-item-by-psi *roletype-psi* :revision revision)) |
|---|
| 488 | (roletype-constraint (is-type-constrained :what *roletype-constraint-psi* |
|---|
| 489 | :revision revision))) |
|---|
| 490 | (let ((associationrole-constraints |
|---|
| 491 | (loop for constraint-topic in constraint-topics |
|---|
| 492 | append (let ((constraint-list |
|---|
| 493 | (get-constraint-topic-values constraint-topic |
|---|
| 494 | :revision revision))) |
|---|
| 495 | (loop for role in (player-in-roles constraint-topic |
|---|
| 496 | :revision revision) |
|---|
| 497 | when (and (eq constraint-role |
|---|
| 498 | (instance-of role :revision revision)) |
|---|
| 499 | (eq applies-to |
|---|
| 500 | (instance-of (parent role :revision revision) |
|---|
| 501 | :revision revision))) |
|---|
| 502 | append (loop for other-role in |
|---|
| 503 | (roles (parent role :revision revision) |
|---|
| 504 | :revision revision) |
|---|
| 505 | when (eq roletype-role |
|---|
| 506 | (instance-of other-role |
|---|
| 507 | :revision revision)) |
|---|
| 508 | collect |
|---|
| 509 | (list :associationroletype |
|---|
| 510 | (player other-role :revision revision) |
|---|
| 511 | :constraint constraint-list))))))) |
|---|
| 512 | (let ((associationroletype-topics |
|---|
| 513 | (remove-duplicates |
|---|
| 514 | (map 'list #'(lambda(x) |
|---|
| 515 | (let ((associationroletype (getf x :associationroletype))) |
|---|
| 516 | (topictype-p associationroletype roletype |
|---|
| 517 | roletype-constraint nil revision) |
|---|
| 518 | associationroletype)) |
|---|
| 519 | associationrole-constraints)))) |
|---|
| 520 | (let ((cleaned-associationrole-constraints "[")) |
|---|
| 521 | (loop for associationroletype-topic in associationroletype-topics |
|---|
| 522 | do |
|---|
| 523 | (let ((constraint-lists |
|---|
| 524 | (remove-duplicate-constraints |
|---|
| 525 | (loop for associationrole-constraint in |
|---|
| 526 | associationrole-constraints |
|---|
| 527 | when (eq associationroletype-topic |
|---|
| 528 | (getf associationrole-constraint |
|---|
| 529 | :associationroletype)) |
|---|
| 530 | collect (getf associationrole-constraint :constraint))))) |
|---|
| 531 | (when (> (length constraint-lists) 1) |
|---|
| 532 | (error "found contrary associationrole-constraints: ~a ~a~%" (uri (first (psis associationroletype-topic :revision revision))) constraint-lists)) |
|---|
| 533 | (let ((roletype-with-subtypes |
|---|
| 534 | (json:encode-json-to-string |
|---|
| 535 | (map 'list #'(lambda(topic) |
|---|
| 536 | (map 'list #'uri |
|---|
| 537 | (psis topic :revision revision))) |
|---|
| 538 | (getf (list-subtypes associationroletype-topic |
|---|
| 539 | roletype roletype-constraint |
|---|
| 540 | nil nil revision) :subtypes))))) |
|---|
| 541 | (setf cleaned-associationrole-constraints |
|---|
| 542 | (concat cleaned-associationrole-constraints |
|---|
| 543 | "{\"roleType\":" roletype-with-subtypes |
|---|
| 544 | ",\"cardMin\":" (getf (first constraint-lists) |
|---|
| 545 | :card-min) |
|---|
| 546 | ",\"cardMax\":" (getf (first constraint-lists) |
|---|
| 547 | :card-max) "},"))))) |
|---|
| 548 | (if (string= cleaned-associationrole-constraints "[") |
|---|
| 549 | (setf cleaned-associationrole-constraints "null") |
|---|
| 550 | (setf cleaned-associationrole-constraints |
|---|
| 551 | (concat (subseq cleaned-associationrole-constraints 0 |
|---|
| 552 | (- (length cleaned-associationrole-constraints) |
|---|
| 553 | 1)) "]"))) |
|---|
| 554 | cleaned-associationrole-constraints))))) |
|---|
| 555 | |
|---|
| 556 | |
|---|
| 557 | ;; ============================================================================= |
|---|
| 558 | ;; --- all topic constraints --------------------------------------------------- |
|---|
| 559 | ;; ============================================================================= |
|---|
| 560 | (defun get-constraints-of-topic (topic-instances &key(treat-as 'type) |
|---|
| 561 | (revision *TM-REVISION*)) |
|---|
| 562 | "Returns a constraint list with the constraints: |
|---|
| 563 | subjectidentifier-constraints, subjectlocator-constraints, |
|---|
| 564 | topicname-constraints, topicoccurrence-constraints and |
|---|
| 565 | uniqueoccurrence-constraints. |
|---|
| 566 | topic-instances should be a list with exactly one item if trea-as is set to type |
|---|
| 567 | otherwise it can constain more items." |
|---|
| 568 | (declare (list topic-instances) |
|---|
| 569 | (symbol treat-as) |
|---|
| 570 | (type (or integer null) revision)) |
|---|
| 571 | (when (and (> (length topic-instances) 1) |
|---|
| 572 | (not (eql treat-as 'type))) |
|---|
| 573 | (error "From get-constraints-of-topic: topic-instances must contain exactly one item when treated as instance!")) |
|---|
| 574 | (let ((abstract-topictype-constraints nil) |
|---|
| 575 | (exclusive-instance-constraints nil) |
|---|
| 576 | (subjectidentifier-constraints nil) |
|---|
| 577 | (subjectlocator-constraints nil) |
|---|
| 578 | (topicname-constraints nil) |
|---|
| 579 | (topicoccurrence-constraints nil) |
|---|
| 580 | (uniqueoccurrence-constraints nil)) |
|---|
| 581 | (loop for topic-instance in topic-instances |
|---|
| 582 | do (let ((current-constraints |
|---|
| 583 | (get-all-constraint-topics-of-topic topic-instance |
|---|
| 584 | :treat-as treat-as |
|---|
| 585 | :revision revision))) |
|---|
| 586 | (dolist (item (getf current-constraints :abstract-topictype-constraints)) |
|---|
| 587 | (pushnew item abstract-topictype-constraints)) |
|---|
| 588 | (dolist (item (getf current-constraints :exclusive-instance-constraints)) |
|---|
| 589 | (let ((current-list |
|---|
| 590 | (list topic-instance (list item)))) |
|---|
| 591 | (let ((found-item |
|---|
| 592 | (find current-list exclusive-instance-constraints |
|---|
| 593 | :key #'first))) |
|---|
| 594 | (if found-item |
|---|
| 595 | (dolist (inner-item (second current-list)) |
|---|
| 596 | (pushnew inner-item (second found-item))) |
|---|
| 597 | (push current-list exclusive-instance-constraints))))) |
|---|
| 598 | (dolist (item (getf current-constraints :subjectidentifier-constraints)) |
|---|
| 599 | (pushnew item subjectidentifier-constraints)) |
|---|
| 600 | (dolist (item (getf current-constraints :subjectlocator-constraints)) |
|---|
| 601 | (pushnew item subjectlocator-constraints)) |
|---|
| 602 | (dolist (item (getf current-constraints :topicname-constraints)) |
|---|
| 603 | (pushnew item topicname-constraints)) |
|---|
| 604 | (dolist (item (getf current-constraints :topicoccurrence-constraints)) |
|---|
| 605 | (pushnew item topicoccurrence-constraints)) |
|---|
| 606 | (dolist (item (getf current-constraints :uniqueoccurrence-constraints)) |
|---|
| 607 | (pushnew item uniqueoccurrence-constraints)))) |
|---|
| 608 | (let ((exclusive-instance-constraints |
|---|
| 609 | (let ((value "[")) |
|---|
| 610 | (loop for exclusive-instance-constraint in exclusive-instance-constraints |
|---|
| 611 | do (setf value |
|---|
| 612 | (concat value (get-exclusive-instance-constraints |
|---|
| 613 | (first exclusive-instance-constraint) |
|---|
| 614 | (second exclusive-instance-constraint) |
|---|
| 615 | :revision revision) ","))) |
|---|
| 616 | (if (string= value "[") |
|---|
| 617 | (setf value "null") |
|---|
| 618 | (setf value (concat (subseq value 0 (- (length value) 1)) "]"))) |
|---|
| 619 | (concat "\"exclusiveInstances\":" value))) |
|---|
| 620 | (subjectidentifier-constraints |
|---|
| 621 | (let ((value |
|---|
| 622 | (get-simple-constraints |
|---|
| 623 | subjectidentifier-constraints |
|---|
| 624 | :error-msg-constraint-name "subjectidentifier" |
|---|
| 625 | :revision revision))) |
|---|
| 626 | (concat "\"subjectIdentifierConstraints\":" value))) |
|---|
| 627 | (subjectlocator-constraints |
|---|
| 628 | (let ((value |
|---|
| 629 | (get-simple-constraints |
|---|
| 630 | subjectlocator-constraints |
|---|
| 631 | :error-msg-constraint-name "subjectlocator" |
|---|
| 632 | :revision revision))) |
|---|
| 633 | (concat "\"subjectLocatorConstraints\":" value))) |
|---|
| 634 | (topicname-constraints |
|---|
| 635 | (let ((value |
|---|
| 636 | (get-topicname-constraints topicname-constraints |
|---|
| 637 | :revision revision))) |
|---|
| 638 | (concat "\"topicNameConstraints\":" value))) |
|---|
| 639 | (topicoccurrence-constraints |
|---|
| 640 | (let ((value |
|---|
| 641 | (get-topicoccurrence-constraints topicoccurrence-constraints |
|---|
| 642 | uniqueoccurrence-constraints |
|---|
| 643 | :revision revision))) |
|---|
| 644 | (concat "\"topicOccurrenceConstraints\":" value))) |
|---|
| 645 | (abstract-constraint |
|---|
| 646 | (concat "\"abstractConstraint\":" |
|---|
| 647 | (if abstract-topictype-constraints |
|---|
| 648 | "true" |
|---|
| 649 | "false")))) |
|---|
| 650 | (let ((json-string |
|---|
| 651 | (concat "{" exclusive-instance-constraints "," |
|---|
| 652 | subjectidentifier-constraints "," subjectlocator-constraints |
|---|
| 653 | "," topicname-constraints "," topicoccurrence-constraints |
|---|
| 654 | "," abstract-constraint "}"))) |
|---|
| 655 | json-string)))) |
|---|
| 656 | |
|---|
| 657 | |
|---|
| 658 | (defun get-exclusive-instance-constraints(owner exclusive-instances-lists |
|---|
| 659 | &key (revision *TM-REVISION*)) |
|---|
| 660 | "Returns a JSON-obejct of the following form: |
|---|
| 661 | {owner: [psi-1, psi-2], exclusives: [[psi-1-1, psi-1-2], [psi-2-1, <...>], <...>]}." |
|---|
| 662 | (declare (type (or integer null) revision)) |
|---|
| 663 | (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 664 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 665 | (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) |
|---|
| 666 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 667 | (topictype-constraint (is-type-constrained :revision revision))) |
|---|
| 668 | (let ((topics |
|---|
| 669 | (remove-duplicates |
|---|
| 670 | (loop for exclusive-instances-list in exclusive-instances-lists |
|---|
| 671 | append |
|---|
| 672 | (let ((owner (getf exclusive-instances-list :owner)) |
|---|
| 673 | (exclusive-constraints |
|---|
| 674 | (getf exclusive-instances-list :exclusive-constraints))) |
|---|
| 675 | (loop for exclusive-constraint in exclusive-constraints |
|---|
| 676 | append |
|---|
| 677 | (loop for role in |
|---|
| 678 | (player-in-roles exclusive-constraint |
|---|
| 679 | :revision revision) |
|---|
| 680 | when (and (eq constraint-role |
|---|
| 681 | (instance-of role |
|---|
| 682 | :revision revision)) |
|---|
| 683 | (parent role :revision revision) |
|---|
| 684 | (eq applies-to (instance-of |
|---|
| 685 | (parent role :revision revision) |
|---|
| 686 | :revision revision))) |
|---|
| 687 | append |
|---|
| 688 | (loop for other-role in |
|---|
| 689 | (roles |
|---|
| 690 | (parent role :revision revision) |
|---|
| 691 | :revision revision) |
|---|
| 692 | when (and (eq topictype-role |
|---|
| 693 | (instance-of other-role |
|---|
| 694 | :revision revision)) |
|---|
| 695 | (not |
|---|
| 696 | (eq owner (player other-role |
|---|
| 697 | :revision revision)))) |
|---|
| 698 | append |
|---|
| 699 | (getf |
|---|
| 700 | (list-subtypes |
|---|
| 701 | (player other-role :revision revision) |
|---|
| 702 | topictype topictype-constraint nil |
|---|
| 703 | nil revision) :subtypes))))))))) |
|---|
| 704 | (concat "{\"owner\":" (json-exporter::identifiers-to-json-string |
|---|
| 705 | owner :revision revision) |
|---|
| 706 | ",\"exclusives\":" |
|---|
| 707 | (json:encode-json-to-string |
|---|
| 708 | (map 'list #'(lambda(y) |
|---|
| 709 | (map 'list #'uri y)) |
|---|
| 710 | (map 'list #'(lambda(z) |
|---|
| 711 | (psis z :revision revision)) |
|---|
| 712 | topics))) "}")))) |
|---|
| 713 | |
|---|
| 714 | |
|---|
| 715 | (defun get-simple-constraints(constraint-topics &key |
|---|
| 716 | (error-msg-constraint-name "uniqueoccurrence") |
|---|
| 717 | (revision *TM-REVISION*)) |
|---|
| 718 | "Returns a list of the form |
|---|
| 719 | ((:regexp <string> :card-min <string> :card-max <string>)) |
|---|
| 720 | which contains the subjectidentifier, subjectlocator or |
|---|
| 721 | unique-occurrence constraints. This depends on the passed |
|---|
| 722 | constraint-topics." |
|---|
| 723 | (declare (list constraint-topics) |
|---|
| 724 | (string error-msg-constraint-name) |
|---|
| 725 | (type (or integer null) revision)) |
|---|
| 726 | (let ((all-values |
|---|
| 727 | (remove-duplicate-constraints |
|---|
| 728 | (loop for constraint-topic in constraint-topics |
|---|
| 729 | collect (get-constraint-topic-values constraint-topic |
|---|
| 730 | :revision revision))))) |
|---|
| 731 | (let ((contrary-constraints (find-contrary-constraints all-values))) |
|---|
| 732 | (when contrary-constraints |
|---|
| 733 | (error "found contrary ~a-constraints: ~a~%" |
|---|
| 734 | error-msg-constraint-name contrary-constraints))) |
|---|
| 735 | (simple-constraints-to-json all-values))) |
|---|
| 736 | |
|---|
| 737 | |
|---|
| 738 | (defun simple-constraints-to-json(simple-constraints) |
|---|
| 739 | "Transforms a list of simple constraint lists of the form |
|---|
| 740 | ((:regexp <string> :card-min <string> :card-max <string>) <...>) |
|---|
| 741 | to a valid json list of the form |
|---|
| 742 | [{regexp: expr, cardMin: 123, cardMax: 456}, <...>]." |
|---|
| 743 | (let ((constraints "[")) |
|---|
| 744 | (loop for constraint in simple-constraints |
|---|
| 745 | do (let ((constraint |
|---|
| 746 | (concat "{\"regexp\":" |
|---|
| 747 | (json:encode-json-to-string (getf constraint :regexp)) |
|---|
| 748 | ",\"cardMin\":" |
|---|
| 749 | (json:encode-json-to-string (getf constraint :card-min)) |
|---|
| 750 | ",\"cardMax\":" |
|---|
| 751 | (json:encode-json-to-string (getf constraint :card-max)) |
|---|
| 752 | "}"))) |
|---|
| 753 | (if (string= constraints "[") |
|---|
| 754 | (push-string constraint constraints) |
|---|
| 755 | (push-string (concat "," constraint) constraints)))) |
|---|
| 756 | (if (string= constraints "[") |
|---|
| 757 | "null" |
|---|
| 758 | (concat constraints "]")))) |
|---|
| 759 | |
|---|
| 760 | |
|---|
| 761 | (defun get-topicname-constraints(constraint-topics &key (revision *TM-REVISION*)) |
|---|
| 762 | "Returns all topicname constraints as a list of the following form: |
|---|
| 763 | [{nametypescopes:[{nameType: [psi-1, psi-2], scopeConstraints: [<scopeConstraint>]}, |
|---|
| 764 | {nameType: [subtype-1-psi-1], scopeConstraints: [<scopeConstraints>]}, |
|---|
| 765 | constraints: [<simpleConstraint>, <...>]}, |
|---|
| 766 | <...>]." |
|---|
| 767 | (declare (type (or integer null) revision) |
|---|
| 768 | (list constraint-topics)) |
|---|
| 769 | (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 770 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 771 | (nametype-role (get-item-by-psi *nametype-role-psi* :revision revision)) |
|---|
| 772 | (nametype (get-item-by-psi *nametype-psi* :revision revision)) |
|---|
| 773 | (nametype-constraint (is-type-constrained :what *nametype-constraint-psi* |
|---|
| 774 | :revision revision))) |
|---|
| 775 | (let ((topicname-constraints |
|---|
| 776 | (remove-if |
|---|
| 777 | #'null |
|---|
| 778 | (loop for constraint-topic in constraint-topics |
|---|
| 779 | append |
|---|
| 780 | (loop for role in (player-in-roles constraint-topic |
|---|
| 781 | :revision revision) |
|---|
| 782 | when (and (eq constraint-role |
|---|
| 783 | (instance-of role :revision revision)) |
|---|
| 784 | (eq applies-to |
|---|
| 785 | (instance-of (parent role :revision revision) |
|---|
| 786 | :revision revision))) |
|---|
| 787 | append |
|---|
| 788 | (loop for other-role in |
|---|
| 789 | (roles (parent role :revision revision) |
|---|
| 790 | :revision revision) |
|---|
| 791 | when (eq nametype-role |
|---|
| 792 | (instance-of other-role :revision revision)) |
|---|
| 793 | collect |
|---|
| 794 | (let ((nametype-topic |
|---|
| 795 | (player other-role :revision revision)) |
|---|
| 796 | (constraint-list |
|---|
| 797 | (get-constraint-topic-values constraint-topic |
|---|
| 798 | :revision revision))) |
|---|
| 799 | (list :type nametype-topic |
|---|
| 800 | :constraint constraint-list)))))))) |
|---|
| 801 | (let ((nametype-topics |
|---|
| 802 | (remove-duplicates |
|---|
| 803 | (map 'list #'(lambda(x) |
|---|
| 804 | (let ((topicname-type |
|---|
| 805 | (getf x :type))) |
|---|
| 806 | (topictype-p topicname-type nametype |
|---|
| 807 | nametype-constraint nil revision) |
|---|
| 808 | topicname-type)) |
|---|
| 809 | topicname-constraints)))) |
|---|
| 810 | (let ((cleaned-topicname-constraints "[")) |
|---|
| 811 | (loop for nametype-topic in nametype-topics |
|---|
| 812 | do (let ((constraint-lists |
|---|
| 813 | (remove-duplicate-constraints |
|---|
| 814 | (loop for topicname-constraint in topicname-constraints |
|---|
| 815 | when (eq nametype-topic (getf topicname-constraint :type)) |
|---|
| 816 | collect (getf topicname-constraint :constraint))))) |
|---|
| 817 | (let ((contrary-constraints |
|---|
| 818 | (find-contrary-constraints constraint-lists))) |
|---|
| 819 | (when contrary-constraints |
|---|
| 820 | (error "found contrary topicname-constraints: ~a~%" |
|---|
| 821 | contrary-constraints))) |
|---|
| 822 | (let ((nametype-with-subtypes |
|---|
| 823 | (remove-if |
|---|
| 824 | #'null |
|---|
| 825 | (getf (list-subtypes nametype-topic nametype |
|---|
| 826 | nametype-constraint nil nil revision) |
|---|
| 827 | :subtypes)))) |
|---|
| 828 | (let ((nametypescopes "\"nametypescopes\":[")) |
|---|
| 829 | (loop for current-topic in nametype-with-subtypes |
|---|
| 830 | do (let ((current-json-string |
|---|
| 831 | (concat |
|---|
| 832 | "{\"nameType\":" |
|---|
| 833 | (json-exporter::identifiers-to-json-string |
|---|
| 834 | current-topic :revision revision) |
|---|
| 835 | ",\"scopeConstraints\":" |
|---|
| 836 | (get-typescope-constraints current-topic |
|---|
| 837 | :what 'topicname |
|---|
| 838 | :revision revision) |
|---|
| 839 | "}"))) |
|---|
| 840 | (push-string (concat current-json-string ",") |
|---|
| 841 | nametypescopes))) |
|---|
| 842 | (if (string= nametypescopes "\"nametypescopes\"[") |
|---|
| 843 | (setf nametypescopes "null") |
|---|
| 844 | (setf nametypescopes |
|---|
| 845 | (concat (subseq nametypescopes 0 |
|---|
| 846 | (- (length nametypescopes) 1)) "]"))) |
|---|
| 847 | (let ((json-constraint-lists |
|---|
| 848 | (concat "\"constraints\":" |
|---|
| 849 | (simple-constraints-to-json constraint-lists)))) |
|---|
| 850 | (setf cleaned-topicname-constraints |
|---|
| 851 | (concat cleaned-topicname-constraints "{" |
|---|
| 852 | nametypescopes "," json-constraint-lists "},"))))))) |
|---|
| 853 | (if (string= cleaned-topicname-constraints "[") |
|---|
| 854 | (setf cleaned-topicname-constraints "null") |
|---|
| 855 | (setf cleaned-topicname-constraints |
|---|
| 856 | (concat (subseq cleaned-topicname-constraints 0 |
|---|
| 857 | (- (length cleaned-topicname-constraints) 1)) |
|---|
| 858 | "]"))) |
|---|
| 859 | cleaned-topicname-constraints))))) |
|---|
| 860 | |
|---|
| 861 | |
|---|
| 862 | (defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics |
|---|
| 863 | &key (revision *TM-REVISION*)) |
|---|
| 864 | "Returns all topicoccurrence constraints as a list of the following form: |
|---|
| 865 | [{occurrenceTypes:[{occurrenceType:[psi-1,psi-2], |
|---|
| 866 | scopeConstraints:[<scopeConstraints>], |
|---|
| 867 | datatypeConstraint:datatype}, |
|---|
| 868 | <...>], |
|---|
| 869 | constraints:[<simpleConstraints>, <...>], |
|---|
| 870 | uniqueConstraint:[<uniqueConstraints>, <...> ]} |
|---|
| 871 | <...>]." |
|---|
| 872 | (declare (type (or integer null) revision) |
|---|
| 873 | (list constraint-topics unique-constraint-topics)) |
|---|
| 874 | (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 875 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 876 | (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi* |
|---|
| 877 | :revision revision)) |
|---|
| 878 | (occurrencetype (get-item-by-psi *occurrencetype-psi* |
|---|
| 879 | :revision revision)) |
|---|
| 880 | (occurrencetype-constraint |
|---|
| 881 | (is-type-constrained :what *occurrencetype-constraint-psi* |
|---|
| 882 | :revision revision))) |
|---|
| 883 | (let ((topicoccurrence-constraints |
|---|
| 884 | (remove-if |
|---|
| 885 | #'null |
|---|
| 886 | (loop for constraint-topic in constraint-topics |
|---|
| 887 | append |
|---|
| 888 | (loop for role in (player-in-roles constraint-topic |
|---|
| 889 | :revision revision) |
|---|
| 890 | when (and (eq constraint-role |
|---|
| 891 | (instance-of role :revision revision)) |
|---|
| 892 | (eq applies-to |
|---|
| 893 | (instance-of (parent role :revision revision) |
|---|
| 894 | :revision revision))) |
|---|
| 895 | append |
|---|
| 896 | (loop for other-role in (roles (parent role :revision revision) |
|---|
| 897 | :revision revision) |
|---|
| 898 | when (eq occurrencetype-role |
|---|
| 899 | (instance-of other-role :revision revision)) |
|---|
| 900 | collect |
|---|
| 901 | (let ((occurrencetype-topic |
|---|
| 902 | (player other-role :revision revision)) |
|---|
| 903 | (constraint-list |
|---|
| 904 | (get-constraint-topic-values constraint-topic |
|---|
| 905 | :revision revision))) |
|---|
| 906 | (list :type occurrencetype-topic |
|---|
| 907 | :constraint constraint-list)))))))) |
|---|
| 908 | (let ((occurrencetype-topics |
|---|
| 909 | (remove-duplicates |
|---|
| 910 | (map 'list |
|---|
| 911 | #'(lambda(x) |
|---|
| 912 | (let ((occurrence-type (getf x :type))) |
|---|
| 913 | (topictype-p occurrence-type occurrencetype |
|---|
| 914 | occurrencetype-constraint nil revision) |
|---|
| 915 | occurrence-type)) |
|---|
| 916 | topicoccurrence-constraints)))) |
|---|
| 917 | (let ((cleaned-topicoccurrence-constraints "[")) |
|---|
| 918 | (loop for occurrencetype-topic in occurrencetype-topics |
|---|
| 919 | do (let ((constraint-lists |
|---|
| 920 | (remove-duplicate-constraints |
|---|
| 921 | (loop for topicoccurrence-constraint in |
|---|
| 922 | topicoccurrence-constraints |
|---|
| 923 | when (eq occurrencetype-topic |
|---|
| 924 | (getf topicoccurrence-constraint :type)) |
|---|
| 925 | collect (getf topicoccurrence-constraint :constraint))))) |
|---|
| 926 | (let ((contrary-constraints |
|---|
| 927 | (find-contrary-constraints constraint-lists))) |
|---|
| 928 | (when contrary-constraints |
|---|
| 929 | (error "found contrary topicname-constraints: ~a~%" |
|---|
| 930 | contrary-constraints))) |
|---|
| 931 | (let ((occurrencetype-with-subtypes |
|---|
| 932 | (getf |
|---|
| 933 | (list-subtypes occurrencetype-topic |
|---|
| 934 | occurrencetype occurrencetype-constraint |
|---|
| 935 | nil nil revision) :subtypes))) |
|---|
| 936 | (let ((occurrencetypes-json-string "\"occurrenceTypes\":[")) |
|---|
| 937 | (loop for current-topic in occurrencetype-with-subtypes |
|---|
| 938 | do (let ((current-json-string |
|---|
| 939 | (concat "{\"occurrenceType\":" |
|---|
| 940 | (json-exporter::identifiers-to-json-string |
|---|
| 941 | current-topic :revision revision) |
|---|
| 942 | ",\"scopeConstraints\":" |
|---|
| 943 | (get-typescope-constraints |
|---|
| 944 | current-topic :what 'topicoccurrence |
|---|
| 945 | :revision revision) |
|---|
| 946 | ",\"datatypeConstraint\":" |
|---|
| 947 | (get-occurrence-datatype-constraint |
|---|
| 948 | current-topic :revision revision) |
|---|
| 949 | "}"))) |
|---|
| 950 | (push-string (concat current-json-string ",") |
|---|
| 951 | occurrencetypes-json-string))) |
|---|
| 952 | (if (string= occurrencetypes-json-string "\"occurrenceTypes\"[") |
|---|
| 953 | (setf occurrencetypes-json-string "null") |
|---|
| 954 | (setf occurrencetypes-json-string |
|---|
| 955 | (concat (subseq occurrencetypes-json-string 0 |
|---|
| 956 | (- (length |
|---|
| 957 | occurrencetypes-json-string) 1)) |
|---|
| 958 | "]"))) |
|---|
| 959 | (let ((unique-constraints |
|---|
| 960 | (concat "\"uniqueConstraints\":" |
|---|
| 961 | (get-simple-constraints unique-constraint-topics |
|---|
| 962 | :revision revision))) |
|---|
| 963 | (json-constraint-lists |
|---|
| 964 | (concat "\"constraints\":" |
|---|
| 965 | (simple-constraints-to-json constraint-lists)))) |
|---|
| 966 | (let ((current-json-string |
|---|
| 967 | (concat "{" occurrencetypes-json-string "," |
|---|
| 968 | json-constraint-lists "," |
|---|
| 969 | unique-constraints "}"))) |
|---|
| 970 | (push-string (concat current-json-string ",") |
|---|
| 971 | cleaned-topicoccurrence-constraints))))))) |
|---|
| 972 | (if (string= cleaned-topicoccurrence-constraints "[") |
|---|
| 973 | (setf cleaned-topicoccurrence-constraints "null") |
|---|
| 974 | (setf cleaned-topicoccurrence-constraints |
|---|
| 975 | (concat |
|---|
| 976 | (subseq |
|---|
| 977 | cleaned-topicoccurrence-constraints 0 |
|---|
| 978 | (- (length cleaned-topicoccurrence-constraints) 1)) "]"))) |
|---|
| 979 | cleaned-topicoccurrence-constraints))))) |
|---|
| 980 | |
|---|
| 981 | |
|---|
| 982 | (defun get-occurrence-datatype-constraint(occurrencetype-topic |
|---|
| 983 | &key (revision *TM-REVISION*)) |
|---|
| 984 | "Return a datatype qualifier as a string." |
|---|
| 985 | (declare (TopicC occurrencetype-topic) |
|---|
| 986 | (type (or integer null) revision)) |
|---|
| 987 | (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 988 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 989 | (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi* |
|---|
| 990 | :revision revision)) |
|---|
| 991 | (datatype (get-item-by-psi *datatype-psi* :revision revision)) |
|---|
| 992 | (occurrencedatatype-constraint |
|---|
| 993 | (get-item-by-psi *occurrencedatatype-constraint-psi* |
|---|
| 994 | :revision revision)) |
|---|
| 995 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 996 | (topictype-constraint (get-item-by-psi *topictype-constraint-psi* |
|---|
| 997 | :revision revision))) |
|---|
| 998 | (let ((datatype-constraints |
|---|
| 999 | (remove-duplicates |
|---|
| 1000 | (loop for role in (player-in-roles occurrencetype-topic :revision revision) |
|---|
| 1001 | when (and (eq occurrencetype-role (instance-of role :revision revision)) |
|---|
| 1002 | (eq applies-to (instance-of (parent role :revision revision) |
|---|
| 1003 | :revision revision))) |
|---|
| 1004 | append (loop for other-role in (roles (parent role :revision revision) |
|---|
| 1005 | :revision revision) |
|---|
| 1006 | when (and (eq constraint-role |
|---|
| 1007 | (instance-of other-role :revision revision)) |
|---|
| 1008 | (topictype-of-p |
|---|
| 1009 | (player other-role :revision revision) |
|---|
| 1010 | occurrencedatatype-constraint topictype |
|---|
| 1011 | topictype-constraint nil revision)) |
|---|
| 1012 | collect (player other-role :revision revision)))))) |
|---|
| 1013 | (let ((datatype-constraint |
|---|
| 1014 | (remove-duplicates |
|---|
| 1015 | (map |
|---|
| 1016 | 'list |
|---|
| 1017 | #'(lambda(constraint-topic) |
|---|
| 1018 | (loop for occurrence in |
|---|
| 1019 | (occurrences constraint-topic :revision revision) |
|---|
| 1020 | when (and (eq (instance-of occurrence :revision revision) |
|---|
| 1021 | datatype) |
|---|
| 1022 | (slot-boundp occurrence 'charvalue)) |
|---|
| 1023 | return (charvalue occurrence))) |
|---|
| 1024 | datatype-constraints)))) |
|---|
| 1025 | (when (> (length datatype-constraint) 1) |
|---|
| 1026 | (error "found contrary occurrence-datatype-constraints: ~a~%" |
|---|
| 1027 | datatype-constraints)) |
|---|
| 1028 | (if datatype-constraint |
|---|
| 1029 | (json:encode-json-to-string (first datatype-constraint)) |
|---|
| 1030 | "null"))))) |
|---|
| 1031 | |
|---|
| 1032 | |
|---|
| 1033 | (defun get-typescope-constraints(element-type-topic &key (what 'topicname) |
|---|
| 1034 | (revision *TM-REVISION*)) |
|---|
| 1035 | "Returns a list of scopes for the element-typetopic which is the type topic of |
|---|
| 1036 | a topicname, a topicoccurrence or an association. To specifiy of what kind |
|---|
| 1037 | of element the scopes should be there is the key-variable what. |
|---|
| 1038 | It can be set to 'topicname, 'topicoccurrence or 'association. |
|---|
| 1039 | The return value is of the form: |
|---|
| 1040 | [{scopeTypes:[[[psi-1-1, psi-1-2], [subtype-1-psi-1, subtype-1-psi-2]], [[psi-2-1], |
|---|
| 1041 | [subtype-1-psi-1], [subtype-2-psi-1]]], cardMin: <int-as-string>, |
|---|
| 1042 | cardMax <int-as-string | MAX_INT>}, <...>]." |
|---|
| 1043 | (declare (TopicC element-type-topic) |
|---|
| 1044 | (symbol what) |
|---|
| 1045 | (type (or integer null) revision)) |
|---|
| 1046 | (let ((element-type-role-and-scope-constraint |
|---|
| 1047 | (cond |
|---|
| 1048 | ((eq what 'topicname) |
|---|
| 1049 | (list (get-item-by-psi *nametype-role-psi* :revision revision) |
|---|
| 1050 | (get-item-by-psi *nametypescope-constraint-psi* |
|---|
| 1051 | :revision revision))) |
|---|
| 1052 | ((eq what 'topicoccurrence) |
|---|
| 1053 | (list |
|---|
| 1054 | (get-item-by-psi *occurrencetype-role-psi* :revision revision) |
|---|
| 1055 | (get-item-by-psi *occurrencetypescope-constraint-psi* |
|---|
| 1056 | :revision revision))) |
|---|
| 1057 | ((eq what 'association) |
|---|
| 1058 | (list |
|---|
| 1059 | (get-item-by-psi *associationtype-role-psi* :revision revision) |
|---|
| 1060 | (get-item-by-psi *associationtypescope-constraint-psi* |
|---|
| 1061 | :revision revision))))) |
|---|
| 1062 | (scopetype-role (get-item-by-psi *scopetype-role-psi* :revision revision)) |
|---|
| 1063 | (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 1064 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 1065 | (scopetype (get-item-by-psi *scopetype-psi* :revision revision)) |
|---|
| 1066 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1067 | (topictype-constraint (get-item-by-psi *topictype-constraint-psi* |
|---|
| 1068 | :revision revision))) |
|---|
| 1069 | (when (and (= (length element-type-role-and-scope-constraint) 2) |
|---|
| 1070 | (first element-type-role-and-scope-constraint) |
|---|
| 1071 | (second element-type-role-and-scope-constraint)) |
|---|
| 1072 | (let ((type-role (first element-type-role-and-scope-constraint)) |
|---|
| 1073 | (typescope-constraint (second element-type-role-and-scope-constraint))) |
|---|
| 1074 | (let ((typescope-constraints |
|---|
| 1075 | (loop for role in |
|---|
| 1076 | (player-in-roles element-type-topic :revision revision) |
|---|
| 1077 | when (and (eq type-role (instance-of role :revision revision)) |
|---|
| 1078 | (eq applies-to |
|---|
| 1079 | (instance-of (parent role :revision revision) |
|---|
| 1080 | :revision revision))) |
|---|
| 1081 | append |
|---|
| 1082 | (loop for other-role in |
|---|
| 1083 | (roles (parent role :revision revision) |
|---|
| 1084 | :revision revision) |
|---|
| 1085 | when (and (eq constraint-role |
|---|
| 1086 | (instance-of other-role :revision revision)) |
|---|
| 1087 | (topictype-of-p |
|---|
| 1088 | (player other-role :revision revision) |
|---|
| 1089 | typescope-constraint topictype |
|---|
| 1090 | topictype-constraint nil revision)) |
|---|
| 1091 | collect |
|---|
| 1092 | (let ((scopes nil) |
|---|
| 1093 | (constraint nil)) |
|---|
| 1094 | (loop for c-role in |
|---|
| 1095 | (player-in-roles |
|---|
| 1096 | (player other-role :revision revision) |
|---|
| 1097 | :revision revision) |
|---|
| 1098 | when (and (eq constraint-role |
|---|
| 1099 | (instance-of c-role :revision revision)) |
|---|
| 1100 | (eq applies-to |
|---|
| 1101 | (instance-of |
|---|
| 1102 | (parent c-role :revision revision) |
|---|
| 1103 | :revision revision))) |
|---|
| 1104 | do (progn |
|---|
| 1105 | (setf constraint |
|---|
| 1106 | (get-constraint-topic-values |
|---|
| 1107 | (player c-role :revision revision) |
|---|
| 1108 | :revision revision)) |
|---|
| 1109 | (loop for c-other-role in |
|---|
| 1110 | (roles (parent c-role :revision revision) |
|---|
| 1111 | :revision revision) |
|---|
| 1112 | when (eq scopetype-role |
|---|
| 1113 | (instance-of c-other-role |
|---|
| 1114 | :revision revision)) |
|---|
| 1115 | do (push |
|---|
| 1116 | (player c-other-role :revision revision) |
|---|
| 1117 | scopes)))) |
|---|
| 1118 | (list :scopes scopes :constraint constraint)))))) |
|---|
| 1119 | (let ((scopetype-groups |
|---|
| 1120 | (remove-duplicates |
|---|
| 1121 | (map 'list #'(lambda(x) |
|---|
| 1122 | (let ((scopes (getf x :scopes))) |
|---|
| 1123 | (when scopes |
|---|
| 1124 | scopes))) |
|---|
| 1125 | typescope-constraints) |
|---|
| 1126 | :test #'(lambda(x y) |
|---|
| 1127 | (when (and (= (length x) (length y)) |
|---|
| 1128 | (= (length x) (length (intersection x y)))) |
|---|
| 1129 | t))))) |
|---|
| 1130 | (let ((cleaned-typescope-constraints "[")) |
|---|
| 1131 | (loop for scopetype-group in scopetype-groups |
|---|
| 1132 | do (let ((constraint-lists |
|---|
| 1133 | (remove-duplicate-constraints |
|---|
| 1134 | (loop for typescope-constraint in typescope-constraints |
|---|
| 1135 | when |
|---|
| 1136 | (and (= (length (getf typescope-constraint :scopes)) |
|---|
| 1137 | (length scopetype-group)) |
|---|
| 1138 | (= (length (getf typescope-constraint :scopes)) |
|---|
| 1139 | (length (intersection |
|---|
| 1140 | (getf typescope-constraint :scopes) |
|---|
| 1141 | scopetype-group)))) |
|---|
| 1142 | collect (getf typescope-constraint :constraint))))) |
|---|
| 1143 | (when (> (length constraint-lists) 1) |
|---|
| 1144 | (error "found contrary scopetype-constraints for ~a: ~a~%" |
|---|
| 1145 | (map 'list |
|---|
| 1146 | #'(lambda(x) |
|---|
| 1147 | (uri (first (psis x :revision revision)))) |
|---|
| 1148 | scopetype-group) |
|---|
| 1149 | constraint-lists)) |
|---|
| 1150 | (let ((card-min (getf (first constraint-lists) :card-min)) |
|---|
| 1151 | (card-max (getf (first constraint-lists) :card-max))) |
|---|
| 1152 | (let ((json-scopes |
|---|
| 1153 | (concat |
|---|
| 1154 | "\"scopeTypes\":" |
|---|
| 1155 | (let ((scopetypes-with-subtypes |
|---|
| 1156 | (remove-if |
|---|
| 1157 | #'null |
|---|
| 1158 | (loop for current-scopetype in scopetype-group |
|---|
| 1159 | collect (getf |
|---|
| 1160 | (list-subtypes current-scopetype |
|---|
| 1161 | scopetype nil nil |
|---|
| 1162 | nil revision) |
|---|
| 1163 | :subtypes))))) |
|---|
| 1164 | (json:encode-json-to-string |
|---|
| 1165 | (map |
|---|
| 1166 | 'list |
|---|
| 1167 | #'(lambda(topic-group) |
|---|
| 1168 | (map 'list |
|---|
| 1169 | #'(lambda(topic) |
|---|
| 1170 | (map 'list #'uri |
|---|
| 1171 | (psis topic :revision revision))) |
|---|
| 1172 | topic-group)) |
|---|
| 1173 | scopetypes-with-subtypes)))))) |
|---|
| 1174 | (let ((current-json-string |
|---|
| 1175 | (concat "{" json-scopes |
|---|
| 1176 | ",\"cardMin\":\"" card-min |
|---|
| 1177 | "\",\"cardMax\":\"" card-max "\"}"))) |
|---|
| 1178 | (push-string (concat current-json-string ",") |
|---|
| 1179 | cleaned-typescope-constraints)))))) |
|---|
| 1180 | (if (string= cleaned-typescope-constraints "[") |
|---|
| 1181 | (setf cleaned-typescope-constraints "null") |
|---|
| 1182 | (setf cleaned-typescope-constraints |
|---|
| 1183 | (concat |
|---|
| 1184 | (subseq cleaned-typescope-constraints 0 |
|---|
| 1185 | (- (length cleaned-typescope-constraints) 1)) "]"))) |
|---|
| 1186 | cleaned-typescope-constraints))))))) |
|---|
| 1187 | |
|---|
| 1188 | |
|---|
| 1189 | ;; ============================================================================= |
|---|
| 1190 | ;; --- some basic helpers ------------------------------------------------------ |
|---|
| 1191 | ;; ============================================================================= |
|---|
| 1192 | (defun get-constraint-topic-values(topic &key (revision *TM-REVISION*)) |
|---|
| 1193 | "Returns all constraint values of the passed topic in the |
|---|
| 1194 | following form (list :regexp regexp :card-min card-min :card-max card-max)" |
|---|
| 1195 | (declare (type (or integer null) revision)) |
|---|
| 1196 | (let ((regexp |
|---|
| 1197 | (get-constraint-occurrence-value topic :revision revision)) |
|---|
| 1198 | (card-min |
|---|
| 1199 | (get-constraint-occurrence-value topic :what 'card-min :revision revision)) |
|---|
| 1200 | (card-max |
|---|
| 1201 | (get-constraint-occurrence-value topic :what 'card-max :revision revision))) |
|---|
| 1202 | (when (and (string/= "MAX_INT" card-max) |
|---|
| 1203 | (> (parse-integer card-min) (parse-integer card-max))) |
|---|
| 1204 | (error "card-min (~a) must be < card-max (~a)" card-min card-max)) |
|---|
| 1205 | (list :regexp regexp :card-min card-min :card-max card-max))) |
|---|
| 1206 | |
|---|
| 1207 | |
|---|
| 1208 | (defun get-constraint-occurrence-value(topic &key (what 'regexp) |
|---|
| 1209 | (revision *TM-REVISION*)) |
|---|
| 1210 | "Checks the occurrence-value of a regexp, card-min or card-max |
|---|
| 1211 | constraint-occurrence. |
|---|
| 1212 | If what = 'regexp and the occurrence-value is empty there will be returned |
|---|
| 1213 | the value '.*!'. |
|---|
| 1214 | If what = 'card-min and the occurrence-value is empty there will be returned |
|---|
| 1215 | the value '0'. |
|---|
| 1216 | If what = 'card-max and the occurrence-value is empty there will be returned |
|---|
| 1217 | the value 'MAX_INT'" |
|---|
| 1218 | (declare (type (or integer null) revision) |
|---|
| 1219 | (TopicC topic) |
|---|
| 1220 | (symbol what)) |
|---|
| 1221 | (let ((occurrence-type |
|---|
| 1222 | (get-item-by-psi |
|---|
| 1223 | (cond |
|---|
| 1224 | ((eq what 'regexp) |
|---|
| 1225 | *regexp-psi*) |
|---|
| 1226 | ((eq what 'card-min) |
|---|
| 1227 | *card-min-psi*) |
|---|
| 1228 | ((eq what 'card-max) |
|---|
| 1229 | *card-max-psi*) |
|---|
| 1230 | (t |
|---|
| 1231 | "")) |
|---|
| 1232 | :revision revision))) |
|---|
| 1233 | (when occurrence-type |
|---|
| 1234 | (let ((occurrence-value |
|---|
| 1235 | (let ((occurrence |
|---|
| 1236 | (find occurrence-type (occurrences topic :revision revision) |
|---|
| 1237 | :key #'(lambda(occ) |
|---|
| 1238 | (instance-of occ :revision revision))))) |
|---|
| 1239 | (if (and occurrence |
|---|
| 1240 | (slot-boundp occurrence 'charvalue) |
|---|
| 1241 | (> (length (charvalue occurrence)) 0)) |
|---|
| 1242 | (charvalue occurrence) |
|---|
| 1243 | (cond |
|---|
| 1244 | ((eq what 'regexp) |
|---|
| 1245 | ".*") |
|---|
| 1246 | ((eq what 'card-min) |
|---|
| 1247 | "0") |
|---|
| 1248 | ((eq what 'card-max) |
|---|
| 1249 | "MAX_INT")))))) |
|---|
| 1250 | (cond |
|---|
| 1251 | ((eq what 'card-min) |
|---|
| 1252 | (let ((is-valid |
|---|
| 1253 | (handler-case (let ((card-min |
|---|
| 1254 | (parse-integer occurrence-value))) |
|---|
| 1255 | (when (>= card-min 0) |
|---|
| 1256 | t)) |
|---|
| 1257 | (condition () nil)))) |
|---|
| 1258 | (unless is-valid |
|---|
| 1259 | (error "card-min in ~a is \"~a\" but should be >= 0" |
|---|
| 1260 | (uri (first (psis topic :revision revision))) |
|---|
| 1261 | occurrence-value)))) |
|---|
| 1262 | ((eq what 'card-max) |
|---|
| 1263 | (let ((is-valid |
|---|
| 1264 | (handler-case (let ((card-max |
|---|
| 1265 | (parse-integer occurrence-value))) |
|---|
| 1266 | (when (>= card-max 0) |
|---|
| 1267 | t)) |
|---|
| 1268 | (condition () (when (string= occurrence-value "MAX_INT") |
|---|
| 1269 | t))))) |
|---|
| 1270 | (unless is-valid |
|---|
| 1271 | (error "card-max in ~a is \"~a\" but should be >= 0 or \"MAX_INT\"" |
|---|
| 1272 | (uri (first (psis topic))) |
|---|
| 1273 | occurrence-value))))) |
|---|
| 1274 | occurrence-value)))) |
|---|
| 1275 | |
|---|
| 1276 | |
|---|
| 1277 | (defun find-contrary-constraints(constraint-lists) |
|---|
| 1278 | "Returns a list which contains a list of minimum two contrary constraints |
|---|
| 1279 | or nil if there are no contrary constraints. |
|---|
| 1280 | The list is of the form |
|---|
| 1281 | (list (list :regexp <regexp> :card-min <card-min> :card-max <card-max>) (list ...))." |
|---|
| 1282 | (let ((current-constraint nil)) |
|---|
| 1283 | (loop for constraint-list in constraint-lists |
|---|
| 1284 | do (progn |
|---|
| 1285 | (when (> (length current-constraint) 0) |
|---|
| 1286 | (return-from find-contrary-constraints current-constraint)) |
|---|
| 1287 | (setf current-constraint |
|---|
| 1288 | (remove-if |
|---|
| 1289 | #'null |
|---|
| 1290 | (map 'list |
|---|
| 1291 | #'(lambda(x) |
|---|
| 1292 | (contrary-constraint-list x constraint-list)) |
|---|
| 1293 | constraint-lists))))))) |
|---|
| 1294 | |
|---|
| 1295 | |
|---|
| 1296 | (defun contrary-constraint-list (lst-1 lst-2) |
|---|
| 1297 | "Returns both passed lists when they have the same |
|---|
| 1298 | regular expression but different card-min or card-max values." |
|---|
| 1299 | (when (and (typep lst-1 'list) (typep lst-2 'list) |
|---|
| 1300 | (= 6 (length lst-1) (length lst-2))) |
|---|
| 1301 | (when (and (string= (getf lst-1 :regexp) (getf lst-2 :regexp)) |
|---|
| 1302 | (or (string/= (getf lst-1 :card-min) (getf lst-2 :card-min)) |
|---|
| 1303 | (string/= (getf lst-1 :card-max) (getf lst-2 :card-max)))) |
|---|
| 1304 | (list lst-1 lst-2)))) |
|---|
| 1305 | |
|---|
| 1306 | |
|---|
| 1307 | (defun remove-duplicate-constraints(constraint-lists) |
|---|
| 1308 | "Removes duplicate constraints of the passed constraint list. |
|---|
| 1309 | This list should have the form |
|---|
| 1310 | (list (list :regexp <regexp> :card-min <card-min> :card-max <card-max>) (list ...)). |
|---|
| 1311 | A constraint is defined as equal whan all three value (regexp, card-min and card-max |
|---|
| 1312 | are equal." |
|---|
| 1313 | (remove-duplicates constraint-lists :test #'eql-constraint-list)) |
|---|
| 1314 | |
|---|
| 1315 | |
|---|
| 1316 | (defun eql-constraint-list (lst-1 lst-2) |
|---|
| 1317 | "Compares two constraint lists of the form (list <string> <string> string>) |
|---|
| 1318 | or (list <topic> <string> <string> <string>." |
|---|
| 1319 | (when (and (typep lst-1 'list) (typep lst-2 'list) |
|---|
| 1320 | (= 6 (length lst-1) (length lst-2))) |
|---|
| 1321 | (and (string= (getf lst-1 :regexp) (getf lst-2 :regexp)) |
|---|
| 1322 | (string= (getf lst-1 :card-min) (getf lst-2 :card-min)) |
|---|
| 1323 | (string= (getf lst-1 :card-max) (getf lst-2 :card-max))))) |
|---|
| 1324 | |
|---|
| 1325 | |
|---|
| 1326 | ;; --- gets all constraint topics ---------------------------------------------- |
|---|
| 1327 | (defun get-direct-constraint-topics-of-topic (topic-instance &key |
|---|
| 1328 | (revision *TM-REVISION*)) |
|---|
| 1329 | "Returns all constraint topics defined for the passed topic-instance" |
|---|
| 1330 | (declare (type (or integer null) revision) |
|---|
| 1331 | (TopicC topic-instance)) |
|---|
| 1332 | (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 1333 | (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) |
|---|
| 1334 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 1335 | (abstract-topictype-constraint |
|---|
| 1336 | (get-item-by-psi *abstract-topictype-constraint-psi* :revision revision)) |
|---|
| 1337 | (exclusive-instance-constraint |
|---|
| 1338 | (get-item-by-psi *exclusive-instance-psi* :revision revision)) |
|---|
| 1339 | (subjectidentifier-constraint |
|---|
| 1340 | (get-item-by-psi *subjectidentifier-constraint-psi* :revision revision)) |
|---|
| 1341 | (subjectlocator-constraint |
|---|
| 1342 | (get-item-by-psi *subjectlocator-constraint-psi* :revision revision)) |
|---|
| 1343 | (topicname-constraint |
|---|
| 1344 | (get-item-by-psi *topicname-constraint-psi* :revision revision)) |
|---|
| 1345 | (topicoccurrence-constraint |
|---|
| 1346 | (get-item-by-psi *topicoccurrence-constraint-psi* :revision revision)) |
|---|
| 1347 | (uniqueoccurrence-constraint |
|---|
| 1348 | (get-item-by-psi *uniqueoccurrence-constraint-psi* :revision revision)) |
|---|
| 1349 | (roleplayer-constraint |
|---|
| 1350 | (get-item-by-psi *roleplayer-constraint-psi* :revision revision)) |
|---|
| 1351 | (otherrole-constraint |
|---|
| 1352 | (get-item-by-psi *otherrole-constraint-psi* :revision revision)) |
|---|
| 1353 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1354 | (topictype-constraint (get-item-by-psi *topictype-constraint-psi* |
|---|
| 1355 | :revision revision)) |
|---|
| 1356 | (abstract-topictype-constraints nil) |
|---|
| 1357 | (exclusive-instance-constraints nil) |
|---|
| 1358 | (subjectidentifier-constraints nil) |
|---|
| 1359 | (subjectlocator-constraints nil) |
|---|
| 1360 | (topicname-constraints nil) |
|---|
| 1361 | (topicoccurrence-constraints nil) |
|---|
| 1362 | (uniqueoccurrence-constraints nil)) |
|---|
| 1363 | (loop for role in (player-in-roles topic-instance :revision revision) |
|---|
| 1364 | when (and (eq topictype-role (instance-of role :revision revision)) |
|---|
| 1365 | (eq applies-to (instance-of (parent role :revision revision) |
|---|
| 1366 | :revision revision))) |
|---|
| 1367 | do (loop for other-role in (roles (parent role :revision revision) |
|---|
| 1368 | :revision revision) |
|---|
| 1369 | when (eq constraint-role (instance-of other-role :revision revision)) |
|---|
| 1370 | do (let ((constraint-topic (player other-role :revision revision))) |
|---|
| 1371 | (cond |
|---|
| 1372 | ((topictype-of-p constraint-topic abstract-topictype-constraint |
|---|
| 1373 | topictype topictype-constraint nil revision) |
|---|
| 1374 | (pushnew constraint-topic abstract-topictype-constraints)) |
|---|
| 1375 | ((topictype-of-p constraint-topic exclusive-instance-constraint |
|---|
| 1376 | topictype topictype-constraint nil revision) |
|---|
| 1377 | (pushnew constraint-topic exclusive-instance-constraints)) |
|---|
| 1378 | ((topictype-of-p constraint-topic subjectidentifier-constraint |
|---|
| 1379 | topictype topictype-constraint nil revision) |
|---|
| 1380 | (pushnew constraint-topic subjectidentifier-constraints)) |
|---|
| 1381 | ((topictype-of-p constraint-topic subjectlocator-constraint |
|---|
| 1382 | topictype topictype-constraint nil revision) |
|---|
| 1383 | (pushnew constraint-topic subjectlocator-constraints)) |
|---|
| 1384 | ((topictype-of-p constraint-topic topicname-constraint |
|---|
| 1385 | topictype topictype-constraint nil revision) |
|---|
| 1386 | (pushnew constraint-topic topicname-constraints)) |
|---|
| 1387 | ((topictype-of-p constraint-topic topicoccurrence-constraint |
|---|
| 1388 | topictype topictype-constraint nil revision) |
|---|
| 1389 | (pushnew constraint-topic topicoccurrence-constraints)) |
|---|
| 1390 | ((topictype-of-p constraint-topic uniqueoccurrence-constraint |
|---|
| 1391 | topictype topictype-constraint nil revision) |
|---|
| 1392 | (pushnew constraint-topic uniqueoccurrence-constraints)) |
|---|
| 1393 | (t |
|---|
| 1394 | (unless (or |
|---|
| 1395 | (topictype-of-p constraint-topic roleplayer-constraint |
|---|
| 1396 | topictype topictype-constraint |
|---|
| 1397 | nil revision) |
|---|
| 1398 | (topictype-of-p constraint-topic otherrole-constraint |
|---|
| 1399 | topictype topictype-constraint |
|---|
| 1400 | nil revision)) |
|---|
| 1401 | (error "Constraint-Topic \"~a\" could not be handled" |
|---|
| 1402 | (uri (first (psis constraint-topic |
|---|
| 1403 | :revision revision)))))))))) |
|---|
| 1404 | (list :abstract-topictype-constraints abstract-topictype-constraints |
|---|
| 1405 | :exclusive-instance-constraints |
|---|
| 1406 | (list :exclusive-constraints exclusive-instance-constraints |
|---|
| 1407 | :owner topic-instance) |
|---|
| 1408 | :subjectidentifier-constraints subjectidentifier-constraints |
|---|
| 1409 | :subjectlocator-constraints subjectlocator-constraints |
|---|
| 1410 | :topicname-constraints topicname-constraints |
|---|
| 1411 | :topicoccurrence-constraints topicoccurrence-constraints |
|---|
| 1412 | :uniqueoccurrence-constraints uniqueoccurrence-constraints))) |
|---|
| 1413 | |
|---|
| 1414 | |
|---|
| 1415 | (defun get-all-constraint-topics-of-topic (topic-instance &key (treat-as 'type) |
|---|
| 1416 | (revision *TM-REVISION*)) |
|---|
| 1417 | "Returns a list of constraint-topics of the topics-instance's base type(s). |
|---|
| 1418 | If topic c is instanceOf a and b, there will be returned all |
|---|
| 1419 | constraint-topics of the topic types a and b. |
|---|
| 1420 | If treat-as is set to instance there will be only the constraints collected |
|---|
| 1421 | defined for the supertypes or the types of the passed topic - all constraints |
|---|
| 1422 | defined directly for the passed topic are ignored, unless the passed topic is |
|---|
| 1423 | an instance of itself." |
|---|
| 1424 | (declare (type (or integer null) revision) |
|---|
| 1425 | (TopicC topic-instance) |
|---|
| 1426 | (symbol treat-as)) |
|---|
| 1427 | (let ((topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1428 | (topictype-constraint (get-item-by-psi *topictype-constraint-psi* |
|---|
| 1429 | :revision revision))) |
|---|
| 1430 | (let ((akos-and-isas-of-this |
|---|
| 1431 | (remove-duplicates |
|---|
| 1432 | (if (eql treat-as 'type) |
|---|
| 1433 | (progn |
|---|
| 1434 | (topictype-p topic-instance topictype topictype-constraint |
|---|
| 1435 | nil revision) |
|---|
| 1436 | (get-all-upper-constrainted-topics topic-instance |
|---|
| 1437 | :revision revision)) |
|---|
| 1438 | (progn |
|---|
| 1439 | (valid-instance-p topic-instance nil nil revision) |
|---|
| 1440 | (let ((topictypes |
|---|
| 1441 | (get-direct-types-of-topic topic-instance |
|---|
| 1442 | :revision revision)) |
|---|
| 1443 | (all-constraints nil)) |
|---|
| 1444 | (dolist (tt topictypes) |
|---|
| 1445 | (let ((upts |
|---|
| 1446 | (get-all-upper-constrainted-topics tt |
|---|
| 1447 | :revision revision))) |
|---|
| 1448 | (dolist (upt upts) |
|---|
| 1449 | (pushnew upt all-constraints)))) |
|---|
| 1450 | (remove-if #'(lambda(x) |
|---|
| 1451 | (when (eql x topic-instance) |
|---|
| 1452 | t)) |
|---|
| 1453 | all-constraints))))))) |
|---|
| 1454 | (let ((all-abstract-topictype-constraints nil) |
|---|
| 1455 | (all-exclusive-instance-constraints nil) |
|---|
| 1456 | (all-subjectidentifier-constraints nil) |
|---|
| 1457 | (all-subjectlocator-constraints nil) |
|---|
| 1458 | (all-topicname-constraints nil) |
|---|
| 1459 | (all-topicoccurrence-constraints nil) |
|---|
| 1460 | (all-uniqueoccurrence-constraints nil)) |
|---|
| 1461 | (loop for topic in akos-and-isas-of-this |
|---|
| 1462 | do (let ((constraint-topics-of-topic |
|---|
| 1463 | (get-direct-constraint-topics-of-topic topic |
|---|
| 1464 | :revision revision))) |
|---|
| 1465 | (when (eq topic topic-instance) |
|---|
| 1466 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1467 | :abstract-topictype-constraints)) |
|---|
| 1468 | (pushnew item all-abstract-topictype-constraints))) |
|---|
| 1469 | (let ((exclusive-instance-constraints |
|---|
| 1470 | (getf constraint-topics-of-topic |
|---|
| 1471 | :exclusive-instance-constraints))) |
|---|
| 1472 | (when (getf exclusive-instance-constraints :exclusive-constraints) |
|---|
| 1473 | (push exclusive-instance-constraints |
|---|
| 1474 | all-exclusive-instance-constraints))) |
|---|
| 1475 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1476 | :subjectidentifier-constraints)) |
|---|
| 1477 | (pushnew item all-subjectidentifier-constraints)) |
|---|
| 1478 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1479 | :subjectlocator-constraints)) |
|---|
| 1480 | (pushnew item all-subjectlocator-constraints)) |
|---|
| 1481 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1482 | :topicname-constraints)) |
|---|
| 1483 | (pushnew item all-topicname-constraints)) |
|---|
| 1484 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1485 | :topicoccurrence-constraints)) |
|---|
| 1486 | (pushnew item all-topicoccurrence-constraints)) |
|---|
| 1487 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1488 | :uniqueoccurrence-constraints)) |
|---|
| 1489 | (pushnew item all-uniqueoccurrence-constraints)))) |
|---|
| 1490 | (list :abstract-topictype-constraints all-abstract-topictype-constraints |
|---|
| 1491 | :exclusive-instance-constraints all-exclusive-instance-constraints |
|---|
| 1492 | :subjectidentifier-constraints all-subjectidentifier-constraints |
|---|
| 1493 | :subjectlocator-constraints all-subjectlocator-constraints |
|---|
| 1494 | :topicname-constraints all-topicname-constraints |
|---|
| 1495 | :topicoccurrence-constraints all-topicoccurrence-constraints |
|---|
| 1496 | :uniqueoccurrence-constraints all-uniqueoccurrence-constraints))))) |
|---|
| 1497 | |
|---|
| 1498 | |
|---|
| 1499 | (defun get-direct-constraint-topics-of-association(associationtype-topic |
|---|
| 1500 | &key (revision *TM-REVISION*)) |
|---|
| 1501 | "Returns all direct constraint topics defined for associations if |
|---|
| 1502 | the passed associationtype-topic" |
|---|
| 1503 | (declare (type (or integer null) revision) |
|---|
| 1504 | (TopicC associationtype-topic)) |
|---|
| 1505 | (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 1506 | (associationtype-role (get-item-by-psi *associationtype-role-psi* |
|---|
| 1507 | :revision revision)) |
|---|
| 1508 | (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 1509 | (associationtypescope-constraint |
|---|
| 1510 | (get-item-by-psi *associationtypescope-constraint-psi* :revision revision)) |
|---|
| 1511 | (associationrole-constraint (get-item-by-psi *associationrole-constraint-psi* |
|---|
| 1512 | :revision revision)) |
|---|
| 1513 | (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi* |
|---|
| 1514 | :revision revision)) |
|---|
| 1515 | (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi* |
|---|
| 1516 | :revision revision)) |
|---|
| 1517 | (topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1518 | (topictype-constraint (get-item-by-psi *topictype-constraint-psi* |
|---|
| 1519 | :revision revision)) |
|---|
| 1520 | (associationrole-constraints nil) |
|---|
| 1521 | (roleplayer-constraints nil) |
|---|
| 1522 | (otherrole-constraints nil)) |
|---|
| 1523 | (loop for role in (player-in-roles associationtype-topic :revision revision) |
|---|
| 1524 | when (and (eq associationtype-role (instance-of role :revision revision)) |
|---|
| 1525 | (eq applies-to (instance-of (parent role :revision revision) |
|---|
| 1526 | :revision revision))) |
|---|
| 1527 | do (loop for other-role in (roles (parent role :revision revision) |
|---|
| 1528 | :revision revision) |
|---|
| 1529 | when (eq constraint-role (instance-of other-role :revision revision)) |
|---|
| 1530 | do (let ((constraint-topic (player other-role :revision revision))) |
|---|
| 1531 | (cond |
|---|
| 1532 | ((topictype-of-p constraint-topic associationtypescope-constraint |
|---|
| 1533 | topictype topictype-constraint nil revision) |
|---|
| 1534 | t) ;do nothing |
|---|
| 1535 | ((topictype-of-p constraint-topic associationrole-constraint |
|---|
| 1536 | topictype topictype-constraint nil revision) |
|---|
| 1537 | (pushnew constraint-topic associationrole-constraints)) |
|---|
| 1538 | ((topictype-of-p constraint-topic roleplayer-constraint |
|---|
| 1539 | topictype topictype-constraint nil revision) |
|---|
| 1540 | (pushnew constraint-topic roleplayer-constraints)) |
|---|
| 1541 | ((topictype-of-p constraint-topic otherrole-constraint |
|---|
| 1542 | topictype topictype-constraint nil revision) |
|---|
| 1543 | (pushnew constraint-topic otherrole-constraints)) |
|---|
| 1544 | (t |
|---|
| 1545 | (error "Constraint-Topic \"~a\" could not be handled" |
|---|
| 1546 | (uri (first (psis constraint-topic |
|---|
| 1547 | :revision revision))))))))) |
|---|
| 1548 | (list :associationrole-constraints associationrole-constraints |
|---|
| 1549 | :roleplayer-constraints roleplayer-constraints |
|---|
| 1550 | :otherrole-constraints otherrole-constraints))) |
|---|
| 1551 | |
|---|
| 1552 | |
|---|
| 1553 | (defun get-all-constraint-topics-of-association(associationtype-topic &key |
|---|
| 1554 | (revision *TM-REVISION*)) |
|---|
| 1555 | "Returns all constraint topics defined for associations if |
|---|
| 1556 | the passed associationtype-topic." |
|---|
| 1557 | (declare (type (or integer null) revision) |
|---|
| 1558 | (TopicC associationtype-topic)) |
|---|
| 1559 | (topictype-p associationtype-topic |
|---|
| 1560 | (get-item-by-psi *associationtype-psi* :revision revision) |
|---|
| 1561 | (is-type-constrained :what *associationtype-constraint-psi* |
|---|
| 1562 | :revision revision) nil revision) |
|---|
| 1563 | (let ((akos-and-isas-of-this |
|---|
| 1564 | (get-all-upper-constrainted-topics associationtype-topic |
|---|
| 1565 | :revision revision))) |
|---|
| 1566 | (let ((all-associationrole-constraints nil) |
|---|
| 1567 | (all-roleplayer-constraints nil) |
|---|
| 1568 | (all-otherrole-constraints nil)) |
|---|
| 1569 | (loop for topic in akos-and-isas-of-this |
|---|
| 1570 | do (let ((constraint-topics-of-topic |
|---|
| 1571 | (get-direct-constraint-topics-of-association topic |
|---|
| 1572 | :revision revision))) |
|---|
| 1573 | (dolist (item (getf constraint-topics-of-topic |
|---|
| 1574 | :associationrole-constraints)) |
|---|
| 1575 | (pushnew item all-associationrole-constraints)) |
|---|
| 1576 | (dolist (item (getf constraint-topics-of-topic :roleplayer-constraints)) |
|---|
| 1577 | (pushnew item all-roleplayer-constraints)) |
|---|
| 1578 | (dolist (item (getf constraint-topics-of-topic :otherrole-constraints)) |
|---|
| 1579 | (pushnew item all-otherrole-constraints)))) |
|---|
| 1580 | (list :associationrole-constraints all-associationrole-constraints |
|---|
| 1581 | :roleplayer-constraints all-roleplayer-constraints |
|---|
| 1582 | :otherrole-constraints all-otherrole-constraints)))) |
|---|
| 1583 | |
|---|
| 1584 | |
|---|
| 1585 | (defun get-available-associations-of-topic(topic-instance &key (treat-as 'type) |
|---|
| 1586 | (revision *TM-REVISION*)) |
|---|
| 1587 | "Returns a list of topics decribing the available associationtype for the |
|---|
| 1588 | passed topic." |
|---|
| 1589 | (declare (type (or integer null) revision) |
|---|
| 1590 | (TopicC topic-instance) |
|---|
| 1591 | (symbol treat-as)) |
|---|
| 1592 | (let ((topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1593 | (topictype-constraint (get-item-by-psi *topictype-constraint-psi* |
|---|
| 1594 | :revision revision))) |
|---|
| 1595 | (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) |
|---|
| 1596 | (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) |
|---|
| 1597 | (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) |
|---|
| 1598 | (othertopictype-role (get-item-by-psi *othertopictype-role-psi* |
|---|
| 1599 | :revision revision)) |
|---|
| 1600 | (associationtype-role (get-item-by-psi *associationtype-role-psi* |
|---|
| 1601 | :revision revision)) |
|---|
| 1602 | (associationtype (get-item-by-psi *associationtype-psi* :revision revision)) |
|---|
| 1603 | (associationtype-constraint |
|---|
| 1604 | (get-item-by-psi *associationtype-constraint-psi* :revision revision)) |
|---|
| 1605 | (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi* |
|---|
| 1606 | :revision revision)) |
|---|
| 1607 | (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi* |
|---|
| 1608 | :revision revision)) |
|---|
| 1609 | (all-possible-player-topics |
|---|
| 1610 | (remove-duplicates |
|---|
| 1611 | (if (eql treat-as 'type) |
|---|
| 1612 | (topictype-p topic-instance topictype topictype-constraint nil |
|---|
| 1613 | revision) |
|---|
| 1614 | (valid-instance-p topic-instance nil nil revision))))) |
|---|
| 1615 | (let ((all-available-associationtypes |
|---|
| 1616 | (remove-duplicates |
|---|
| 1617 | (loop for possible-player-topic in all-possible-player-topics |
|---|
| 1618 | append |
|---|
| 1619 | (loop for role in (player-in-roles possible-player-topic |
|---|
| 1620 | :revision revision) |
|---|
| 1621 | when (and (or (eq topictype-role |
|---|
| 1622 | (instance-of role :revision revision)) |
|---|
| 1623 | (eq othertopictype-role |
|---|
| 1624 | (instance-of role :revision revision))) |
|---|
| 1625 | (parent role :revision revision) |
|---|
| 1626 | (eq applies-to |
|---|
| 1627 | (instance-of (parent role :revision revision) |
|---|
| 1628 | :revision revision))) |
|---|
| 1629 | append |
|---|
| 1630 | (loop for other-role in |
|---|
| 1631 | (roles (parent role :revision revision) |
|---|
| 1632 | :revision revision) |
|---|
| 1633 | when (and (eq constraint-role |
|---|
| 1634 | (instance-of other-role :revision revision)) |
|---|
| 1635 | (or (topictype-of-p |
|---|
| 1636 | (player other-role :revision revision) |
|---|
| 1637 | roleplayer-constraint topictype |
|---|
| 1638 | topictype-constraint nil revision) |
|---|
| 1639 | (topictype-of-p |
|---|
| 1640 | (player other-role :revision revision) |
|---|
| 1641 | otherrole-constraint topictype |
|---|
| 1642 | topictype-constraint nil revision))) |
|---|
| 1643 | append |
|---|
| 1644 | (loop for c-role in |
|---|
| 1645 | (player-in-roles |
|---|
| 1646 | (player other-role :revision revision) |
|---|
| 1647 | :revision revision) |
|---|
| 1648 | when (and (eq constraint-role |
|---|
| 1649 | (instance-of c-role :revision revision)) |
|---|
| 1650 | (parent c-role :revision revision) |
|---|
| 1651 | (eq applies-to |
|---|
| 1652 | (instance-of (parent c-role |
|---|
| 1653 | :revision revision) |
|---|
| 1654 | :revision revision))) |
|---|
| 1655 | append |
|---|
| 1656 | (loop for type-role in |
|---|
| 1657 | (roles (parent c-role :revision revision) |
|---|
| 1658 | :revision revision) |
|---|
| 1659 | when (eq associationtype-role |
|---|
| 1660 | (instance-of type-role |
|---|
| 1661 | :revision revision)) |
|---|
| 1662 | append |
|---|
| 1663 | (map |
|---|
| 1664 | 'list |
|---|
| 1665 | #'(lambda(x) |
|---|
| 1666 | (topictype-p x associationtype |
|---|
| 1667 | associationtype-constraint |
|---|
| 1668 | nil revision) |
|---|
| 1669 | x) |
|---|
| 1670 | (getf (list-subtypes |
|---|
| 1671 | (player type-role :revision revision) |
|---|
| 1672 | associationtype |
|---|
| 1673 | associationtype-constraint nil |
|---|
| 1674 | nil revision) :subtypes)))))))))) |
|---|
| 1675 | all-available-associationtypes)))) |
|---|
| 1676 | |
|---|
| 1677 | |
|---|
| 1678 | (defun topics-to-json-list (topics &key (revision *TM-REVISION*)) |
|---|
| 1679 | "Returns a json list of psi-lists." |
|---|
| 1680 | (declare (list topics) |
|---|
| 1681 | (type (or integer null) revision)) |
|---|
| 1682 | (json:encode-json-to-string |
|---|
| 1683 | (map 'list #'(lambda(topic) |
|---|
| 1684 | (map 'list #'uri (psis topic :revision revision))) |
|---|
| 1685 | topics))) |
|---|
| 1686 | |
|---|
| 1687 | |
|---|
| 1688 | (defun tree-view-to-json-string (tree-views) |
|---|
| 1689 | "Returns a full tree-view as json-string." |
|---|
| 1690 | (let ((json-string |
|---|
| 1691 | (concat |
|---|
| 1692 | "[" |
|---|
| 1693 | (if tree-views |
|---|
| 1694 | (let ((inner-string "")) |
|---|
| 1695 | (loop for tree-view in tree-views |
|---|
| 1696 | do (push-string (concat (node-to-json-string tree-view) ",") |
|---|
| 1697 | inner-string)) |
|---|
| 1698 | (concat (subseq inner-string 0 (- (length inner-string) 1)) "]")) |
|---|
| 1699 | "null")))) |
|---|
| 1700 | json-string)) |
|---|
| 1701 | |
|---|
| 1702 | |
|---|
| 1703 | (defun make-tree-view (&key (revision *TM-REVISION*)) |
|---|
| 1704 | "Returns a list of the form: |
|---|
| 1705 | ((<topictype> (direct-instances) (direc-subtypes)) (<...>)); |
|---|
| 1706 | -> direct-instances: (<any-topic> (direct-instances) (direct-subtypes)) |
|---|
| 1707 | -> direct-subtypes: (<any-topic> (direct-instances) (direct-subtypes))" |
|---|
| 1708 | (declare (type (or integer null) revision)) |
|---|
| 1709 | (let ((topictype |
|---|
| 1710 | (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1711 | (topictype-constraint (is-type-constrained :revision revision))) |
|---|
| 1712 | (if topictype-constraint |
|---|
| 1713 | (progn |
|---|
| 1714 | (unless topictype |
|---|
| 1715 | (error "From make-tree-view(): The topictype-constraint \"~a\" exists but the topictype \"~a\" is missing!" |
|---|
| 1716 | *topictype-constraint-psi* |
|---|
| 1717 | *topictype-psi*)) |
|---|
| 1718 | (list (make-nodes topictype t t :revision revision))) |
|---|
| 1719 | (let ((tree-roots |
|---|
| 1720 | (get-all-tree-roots :revision revision))) |
|---|
| 1721 | (let ((tree-list |
|---|
| 1722 | (loop for root in tree-roots |
|---|
| 1723 | collect |
|---|
| 1724 | (let ((l-is-type |
|---|
| 1725 | (handler-case |
|---|
| 1726 | (progn |
|---|
| 1727 | (topictype-p root topictype topictype-constraint |
|---|
| 1728 | nil revision) |
|---|
| 1729 | t) |
|---|
| 1730 | (Condition () nil))) |
|---|
| 1731 | (l-is-instance |
|---|
| 1732 | (handler-case (progn |
|---|
| 1733 | (valid-instance-p root nil nil revision) |
|---|
| 1734 | t) |
|---|
| 1735 | (Condition () nil)))) |
|---|
| 1736 | (make-nodes root l-is-type l-is-instance |
|---|
| 1737 | :revision revision))))) |
|---|
| 1738 | tree-list))))) |
|---|
| 1739 | |
|---|
| 1740 | |
|---|
| 1741 | (defun node-to-json-string(node &key (revision *TM-REVISION*)) |
|---|
| 1742 | "Returns a json-object of the form |
|---|
| 1743 | {topic: [<psis>], isType: <bool>, isInstance: <bool>, |
|---|
| 1744 | instances: [<nodes>], subtypes: [<nodes>]}." |
|---|
| 1745 | (declare (type (or integer null) revision) |
|---|
| 1746 | (list node)) |
|---|
| 1747 | (let ((topic-psis |
|---|
| 1748 | (concat |
|---|
| 1749 | "\"topic\":" |
|---|
| 1750 | (json:encode-json-to-string |
|---|
| 1751 | (map 'list #'d:uri (d:psis (getf node :topic) :revision revision))))) |
|---|
| 1752 | (is-type |
|---|
| 1753 | (concat "\"isType\":" (if (getf node :is-type) |
|---|
| 1754 | "true" |
|---|
| 1755 | "false"))) |
|---|
| 1756 | (is-instance |
|---|
| 1757 | (concat "\"isInstance\":" (if (getf node :is-instance) |
|---|
| 1758 | "true" |
|---|
| 1759 | "false"))) |
|---|
| 1760 | (instances |
|---|
| 1761 | (concat |
|---|
| 1762 | "\"instances\":" |
|---|
| 1763 | (if (getf node :instances) |
|---|
| 1764 | (let ((inner-string "[")) |
|---|
| 1765 | (loop for instance-node in (getf node :instances) |
|---|
| 1766 | do (setf inner-string |
|---|
| 1767 | (concat |
|---|
| 1768 | inner-string |
|---|
| 1769 | (node-to-json-string instance-node :revision revision) |
|---|
| 1770 | ","))) |
|---|
| 1771 | (concat (subseq inner-string 0 (- (length inner-string) 1)) "]")) |
|---|
| 1772 | "null"))) |
|---|
| 1773 | (subtypes |
|---|
| 1774 | (concat |
|---|
| 1775 | "\"subtypes\":" |
|---|
| 1776 | (if (getf node :subtypes) |
|---|
| 1777 | (let ((inner-string "[")) |
|---|
| 1778 | (loop for instance-node in (getf node :subtypes) |
|---|
| 1779 | do (push-string (concat |
|---|
| 1780 | (node-to-json-string instance-node |
|---|
| 1781 | :revision revision) |
|---|
| 1782 | ",") |
|---|
| 1783 | inner-string)) |
|---|
| 1784 | (concat (subseq inner-string 0 (- (length inner-string) 1)) "]")) |
|---|
| 1785 | "null")))) |
|---|
| 1786 | (concat "{" topic-psis "," is-type "," is-instance "," instances |
|---|
| 1787 | "," subtypes"}"))) |
|---|
| 1788 | |
|---|
| 1789 | |
|---|
| 1790 | (defun make-nodes (topic-instance is-type is-instance &key (revision *TM-REVISION*)) |
|---|
| 1791 | "Creates a li of nodes. |
|---|
| 1792 | A node looks like |
|---|
| 1793 | (:topic <topic> :is-type <bool> :is-instance <bool> :instances <node> |
|---|
| 1794 | :subtypes <nodes>)." |
|---|
| 1795 | (declare (TopicC topic-instance) |
|---|
| 1796 | (type (or integer null) revision)) |
|---|
| 1797 | (let ((topictype (get-item-by-psi *topictype-psi* :revision revision)) |
|---|
| 1798 | (topictype-constraint (is-type-constrained :revision revision))) |
|---|
| 1799 | (let ((isas-of-this |
|---|
| 1800 | (map |
|---|
| 1801 | 'list |
|---|
| 1802 | #'(lambda(z) |
|---|
| 1803 | (let ((l-is-type |
|---|
| 1804 | (handler-case |
|---|
| 1805 | (progn |
|---|
| 1806 | (topictype-p z topictype topictype-constraint |
|---|
| 1807 | nil revision) |
|---|
| 1808 | t) |
|---|
| 1809 | (Condition () nil))) |
|---|
| 1810 | (l-is-instance |
|---|
| 1811 | (handler-case (progn |
|---|
| 1812 | (valid-instance-p z nil nil revision) |
|---|
| 1813 | t) |
|---|
| 1814 | (Condition () nil)))) |
|---|
| 1815 | (list :topic z :is-type l-is-type :is-instance l-is-instance))) |
|---|
| 1816 | (remove-duplicates |
|---|
| 1817 | (remove-if #'null |
|---|
| 1818 | (remove-if |
|---|
| 1819 | #'(lambda(x) (when (eql topic-instance x) |
|---|
| 1820 | t)) |
|---|
| 1821 | (get-direct-instances-of-topic topic-instance |
|---|
| 1822 | :revision revision)))))) |
|---|
| 1823 | (akos-of-this |
|---|
| 1824 | (map 'list |
|---|
| 1825 | #'(lambda(z) |
|---|
| 1826 | (let ((l-is-type |
|---|
| 1827 | (handler-case |
|---|
| 1828 | (progn |
|---|
| 1829 | (topictype-p z topictype topictype-constraint |
|---|
| 1830 | nil revision) |
|---|
| 1831 | t) |
|---|
| 1832 | (Condition () nil))) |
|---|
| 1833 | (l-is-instance |
|---|
| 1834 | (handler-case (progn |
|---|
| 1835 | (valid-instance-p z nil nil revision) |
|---|
| 1836 | t) |
|---|
| 1837 | (Condition () nil)))) |
|---|
| 1838 | (list :topic z :is-type l-is-type :is-instance l-is-instance))) |
|---|
| 1839 | (remove-duplicates |
|---|
| 1840 | (remove-if |
|---|
| 1841 | #'null |
|---|
| 1842 | (remove-if #'(lambda(x) (when (eql topic-instance x) |
|---|
| 1843 | t)) |
|---|
| 1844 | (get-direct-subtypes-of-topic topic-instance |
|---|
| 1845 | :revision revision))))))) |
|---|
| 1846 | (let ((cleaned-isas ;;all constraint topics are removed |
|---|
| 1847 | (clean-topic-entries isas-of-this :revision revision)) |
|---|
| 1848 | (cleaned-akos ;;all constraint topics are removed |
|---|
| 1849 | (clean-topic-entries akos-of-this :revision revision))) |
|---|
| 1850 | (list :topic topic-instance |
|---|
| 1851 | :is-type is-type |
|---|
| 1852 | :is-instance is-instance |
|---|
| 1853 | :instances (map 'list #'(lambda(x) |
|---|
| 1854 | (make-nodes (getf x :topic) |
|---|
| 1855 | (getf x :is-type) |
|---|
| 1856 | (getf x :is-instance) |
|---|
| 1857 | :revision revision)) |
|---|
| 1858 | cleaned-isas) |
|---|
| 1859 | :subtypes (map 'list #'(lambda(x) |
|---|
| 1860 | (make-nodes (getf x :topic) |
|---|
| 1861 | (getf x :is-type) |
|---|
| 1862 | (getf x :is-instance) |
|---|
| 1863 | :revision revision)) |
|---|
| 1864 | cleaned-akos)))))) |
|---|
| 1865 | |
|---|
| 1866 | |
|---|
| 1867 | (defun clean-topic-entries(isas-or-akos &key (revision *TM-REVISION*)) |
|---|
| 1868 | "Removes all TMCL-topics from the passed topic-list." |
|---|
| 1869 | (remove-if |
|---|
| 1870 | #'null |
|---|
| 1871 | (map 'list |
|---|
| 1872 | #'(lambda(top-entry) |
|---|
| 1873 | (when (and (d:find-item-by-revision (getf top-entry :topic) 0) |
|---|
| 1874 | (find-if |
|---|
| 1875 | #'(lambda(psi) |
|---|
| 1876 | (unless (or (string= (uri psi) *constraint-psi*) |
|---|
| 1877 | (string= (uri psi) *occurrencetype-psi*) |
|---|
| 1878 | (string= (uri psi) *nametype-psi*) |
|---|
| 1879 | (string= (uri psi) *associationtype-psi*) |
|---|
| 1880 | (string= (uri psi) *roletype-psi*) |
|---|
| 1881 | (string= (uri psi) *scopetype-psi*) |
|---|
| 1882 | (string= (uri psi) *schema-psi*)) |
|---|
| 1883 | top-entry)) |
|---|
| 1884 | (psis (getf top-entry :topic) :revision revision))) |
|---|
| 1885 | top-entry)) |
|---|
| 1886 | isas-or-akos))) |
|---|
| 1887 | |
|---|
| 1888 | |
|---|
| 1889 | (defun get-all-tree-roots (&key (revision *TM-REVISION*)) |
|---|
| 1890 | "Returns all topics that are no instanceOf and no subtype |
|---|
| 1891 | of any other topic." |
|---|
| 1892 | (declare (type (or integer null) revision)) |
|---|
| 1893 | (let ((all-topics (get-all-topics revision))) |
|---|
| 1894 | (remove-if |
|---|
| 1895 | #'null |
|---|
| 1896 | (map 'list |
|---|
| 1897 | #'(lambda(x) |
|---|
| 1898 | (let ((isas-of-x |
|---|
| 1899 | (remove-if #'(lambda(y) |
|---|
| 1900 | (when (eql y x) |
|---|
| 1901 | t)) |
|---|
| 1902 | (get-direct-types-of-topic x :revision revision))) |
|---|
| 1903 | (akos-of-x |
|---|
| 1904 | (remove-if |
|---|
| 1905 | #'(lambda(y) |
|---|
| 1906 | (when (eql y x) |
|---|
| 1907 | t)) |
|---|
| 1908 | (get-direct-supertypes-of-topic x :revision revision)))) |
|---|
| 1909 | (unless (or isas-of-x akos-of-x) |
|---|
| 1910 | x))) |
|---|
| 1911 | all-topics)))) |
|---|
