Changeset 337

Timestamp:

11/11/10 08:47:23 (14 years ago)

Author:

lgiessmann

Message:

fixed ticket #90 => added unit-tests for the trivial-query part of the datamodel; added some functionality and fixed some bugs in the trivial-query part.

Location:

trunk/src

Files:

• base-tools/base-tools.lisp (modified) (2 diffs)
• isidorus.asd (modified) (2 diffs)
• model/datamodel.lisp (modified) (1 diff)
• model/trivial-queries.lisp (modified) (13 diffs)
• unit_tests/fixtures.lisp (modified) (3 diffs)
• unit_tests/poems.xtm (modified) (1 diff)
• unit_tests/trivial_queries_test.lisp (modified) (2 diffs)
• unit_tests/unittests-constants.lisp (modified) (2 diffs)

trunk/src/base-tools/base-tools.lisp ¶

@@ -12 +12 @@
   (:nicknames :tools)
   (:export :push-string
-           :when-do))
+           :when-do
+           :remove-null
+           :full-path))
 
 (in-package :base-tools)
@@ -32 +34 @@
          nil)))
 
+
+(defun remove-null (lst)
+  "Removes all null values from the passed list."
+  (remove-if #'null lst))
+
+
+(defun full-path (pathname)
+  "Returns a string that represents the full path of the passed
+   CL:Pathname construct."
+  (declare (CL:Pathname pathname))
+  (let ((segments
+         (remove-if #'null
+                    (map 'list #'(lambda(item)
+                                   (when (stringp item)
+                                     (concatenate 'string "/" item)))
+                         (pathname-directory pathname))))
+        (full-path-string ""))
+    (dolist (segment segments)
+      (push-string segment full-path-string))
+    (concatenate 'string full-path-string "/" (pathname-name pathname))))

trunk/src/isidorus.asd ¶

@@ -40 +40 @@
                                      (:file "model_tools"
                                             :depends-on ("exceptions")))
-                        :depends-on ("constants"))
+                        :depends-on ("constants" "base-tools"))
                (:module "TM-SPARQL"
                         :components ((:file "sparql"
@@ -178 +178 @@
                                      "xml"
                                      "json"
-                                     "threading"))
+                                     "threading"
+                                     "base-tools"
+                                     "TM-SPARQL"))
                (:module "json"
                         :components ((:file "json_exporter"

trunk/src/model/datamodel.lisp ¶

@@ -171 +171 @@
            :invoke-on
            :names-by-type
-           :occurrencs-by-type
+           :occurrences-by-type
            :characteristics-by-type
            :occurrences-by-value
            :names-by-value
-           :characteristics-by-value))
+           :characteristics-by-value
+           :isa
+           :aka))
 
 (in-package :datamodel)

trunk/src/model/trivial-queries.lisp ¶

@@ -22 +22 @@
            (type (or Null TopicC) role-type))
   (if role-type
-      (remove-if #'null
-                 (map 'list #'(lambda(role)
-                                (when (eql (instance-of role :revision revision)
-                                           role-type)
-                                  role))
-                      (player-in-roles construct :revision revision)))
+      (remove-null
+       (map 'list #'(lambda(role)
+                      (when (eql (instance-of role :revision revision)
+                                 role-type)
+                        role))
+            (player-in-roles construct :revision revision)))
       (player-in-roles construct :revision revision)))
 
@@ -36 +36 @@
            (type (or Null TopicC) role-type))
   (if role-type
-      (remove-if #'null
-                 (map 'list #'(lambda(role)
-                                (when (eql (instance-of role :revision revision)
-                                           role-type)
-                                  role))
-                      (roles construct :revision revision)))
+      (remove-null
+       (map 'list #'(lambda(role)
+                      (when (eql (instance-of role :revision revision)
+                                 role-type)
+                        role))
+            (roles construct :revision revision)))
       (roles construct :revision revision)))
 
 
-(defgeneric roles-by-player (construct role-player &key revision)
+(defgeneric roles-by-player (construct role-player
+                                       &key role-player-is-type revision)
   (:documentation "Returns all roles that contains the corresponding player.
                    If the player is set to nil all roles are returned.")
-  (:method ((construct AssociationC) role-player &key (revision *TM-REVISION*))
+  (:method ((construct AssociationC) role-player
+            &key role-player-is-type (revision *TM-REVISION*))
     (declare (integer revision)
-             (type (or Null TopicC) role-player))
+             (type (or Null TopicC) role-player)
+             (boolean role-player-is-type))
     (if role-player
-        (remove-if #'null
-                   (map 'list #'(lambda(role)
-                                  (when (eql (player role :revision revision)
-                                             role-player)
-                                    role))
-                        (roles construct :revision revision)))
+        (remove-null
+         (map 'list #'(lambda(role)
+                        (if role-player-is-type
+                            (when (isa (player role :revision revision)
+                                       role-player)
+                              role)
+                            (when (eql (player role :revision revision)
+                                       role-player)
+                              role)))
+              (roles construct :revision revision)))
         (roles construct :revision revision))))
 
@@ -78 +85 @@
 
 (defun filter-associations-by-role (associations role-type role-player
-                                 &key (revision *TM-REVISION*))
+                                 &key role-player-is-type (revision *TM-REVISION*))
   "Returns associations that have a role corresponding to the passed
    values. If any of the passed role-values is set to nil, it won't be used
    for the evaluation of the result."
   (declare (List associations)
-           (type (or Null TopicC) role-type role-player))
-  (remove-if #'null
-             (intersection
-              (map 'list #'(lambda(assoc)
-                             (when (roles-by-type assoc role-type
-                                                  :revision revision)
-                               assoc))
-                   associations)
-              (map 'list #'(lambda(assoc)
-                             (when (roles-by-player assoc role-player
-                                                    :revision revision)
-                               assoc))
-                   associations))))
+           (type (or Null TopicC) role-type role-player)
+           (boolean role-player-is-type))
+  (remove-null
+   (intersection
+    (map 'list #'(lambda(assoc)
+                   (when (roles-by-type assoc role-type
+                                        :revision revision)
+                     assoc))
+         associations)
+    (map 'list #'(lambda(assoc)
+                   (when (roles-by-player
+                          assoc role-player
+                          :role-player-is-type role-player-is-type
+                          :revision revision)
+                     assoc))
+         associations))))
 
 
 (defgeneric associations-of (construct role-type association-type
                                        other-role-type other-player
-                                       &key revision)
+                                       &key other-role-player-is-type
+                                       revision)
   (:documentation "Returns all associations of the passed topic (construct)
                    that corresponds to the given values.
@@ -106 +117 @@
                    used to evaluate the result.")
   (:method ((construct TopicC) role-type association-type other-role-type
-            other-player &key (revision *TM-REVISION*))
+            other-player &key other-role-player-is-type
+            (revision *TM-REVISION*))
     (declare (integer revision)
              (type (or Null TopicC) role-type association-type
-                   other-role-type other-player))
+                   other-role-type other-player)
+             (boolean other-role-player-is-type))
     (let ((assocs-by-role (map 'list #'(lambda(role)
                                          (parent role :revision revision))
@@ -117 +130 @@
              (filter-associations-by-type assocs-by-role association-type
                                           :revision revision)))
-        (filter-associations-by-role assocs-by-type other-role-type
-                                     other-player :revision revision)))))
+        (filter-associations-by-role
+         assocs-by-type other-role-type other-player
+         :role-player-is-type other-role-player-is-type
+         :revision revision)))))
 
 
@@ -173 +188 @@
     (declare (integer revision))
     (let ((assocs (supertype-associations construct :revision revision)))
-      (remove-if #'null
-                 (map 'list #'(lambda(assoc)
-                                (find-if-not
-                                 #'(lambda(role)
-                                     (eql (player role :revision revision)
-                                          construct))
-                                 (roles assoc :revision revision)))
-                      assocs)))))
+      (let ((other-roles
+             (remove-null
+              (map 'list
+                   #'(lambda(assoc)
+                       (find-if-not #'(lambda(role)
+                                        (eql (player role :revision revision)
+                                             construct))
+                                    (roles assoc :revision revision)))
+                   assocs))))
+        (remove-null (map 'list #'(lambda(role)
+                                    (player role :revision revision))
+                          other-roles))))))
 
 
@@ -197 +216 @@
                           :valid-supertypes current-valid-super-types))))
           (remove-duplicates
-           (remove-if #'null recursive-super-types)))))))
+           (remove-null (union recursive-super-types
+                               current-valid-super-types))))))))
 
 
@@ -205 +225 @@
     (declare (integer revision))
     (let ((assocs (instance-of-associations construct :revision revision)))
-      (remove-if #'null
-                 (map 'list #'(lambda(assoc)
-                                (find-if-not
-                                 #'(lambda(role)
-                                     (eql (player role :revision revision)
-                                          construct))
-                                 (roles assoc :revision revision)))
-                      assocs)))))
+      (let ((other-roles
+             (remove-null
+              (map 'list #'(lambda(assoc)
+                             (find-if-not #'(lambda(role)
+                                              (eql (player role :revision revision)
+                                                   construct))
+                                          (roles assoc :revision revision)))
+                   assocs))))
+        (remove-null (map 'list #'(lambda(role)
+                                    (player role :revision revision))
+                          other-roles))))))
 
 
@@ -218 +241 @@
   "Returns all type topics of the passed construct and their super-types."
   (declare (integer revision))
-  (let ((all-super-types (supertypes construct :revision revision)))
-    (let ((all-types
-           (loop for topic in (append (list construct) all-super-types)
-                append (direct-instance-of topic :revision revision))))
-      (remove-duplicates
-       (remove-if #'null all-types)))))
+  (let ((direct-types (direct-instance-of construct :revision revision)))
+    (let ((supertypes-of-types
+           (loop for type in direct-types
+              append (supertypes type :revision revision))))
+      (union direct-types supertypes-of-types))))
 
 
@@ -232 +254 @@
                    value is first casted by the cast-operation to another type
                    and afterwords processed by main-opertion.")
-  (:method ((construct TopicC) (operation Function))
+  (:method ((construct CharacteristicC) (operation Function))
     (funcall operation (charvalue construct))))
 
 
-(defgeneric names-by-type (construct type-identifier &key revision)
+(defgeneric names-by-type (construct nametype &key revision)
   (:documentation "Returns all names that are of the corresponding type.")
-  (:method ((construct TopicC) (type-identifier IdentifierC)
+  (:method ((construct TopicC) nametype &key (revision *TM-REVISION*))
+    (declare (integer revision)
+             (type (or Null TopicC) nametype))
+    (remove-if-not #'(lambda(name)
+                       (eql nametype (instance-of name :revision revision)))
+                   (names construct :revision revision))))
+
+
+(defgeneric occurrences-by-type (construct occurrencetype &key revision)
+  (:documentation "Returns all names that are of the corresponding type.")
+  (:method ((construct TopicC) (occurrencetype TopicC)
             &key (revision *TM-REVISION*))
     (declare (integer revision))
-    (let ((type-topic (identified-construct type-identifier :revision revision)))
-      (unless (typep type-topic 'TopicC)
-        (error (make-bad-type-condition (format nil "from name-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic)))
-      (let ((results
-             (map 'list #'(lambda(name)
-                            (when (instance-of name :revision revision)
-                              name))
-                  (names construct :revision revision))))
-        (remove-if #'null results)))))
-
-
-(defgeneric occurrences-by-type (construct type-identifier &key revision)
-  (:documentation "Returns all names that are of the corresponding type.")
-  (:method ((construct TopicC) (type-identifier IdentifierC)
-            &key (revision *TM-REVISION*))
-    (declare (integer revision))
-    (let ((type-topic (identified-construct type-identifier :revision revision)))
-      (unless (typep type-topic 'TopicC)
-        (error (make-bad-type-condition (format nil "from occurrence-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic)))
-      (let ((results
-             (map 'list #'(lambda(occ)
-                            (when (instance-of occ :revision revision)
-                              occ))
-                  (occurrences construct :revision revision))))
-        (remove-if #'null results)))))
-
-
-(defgeneric characteristic-by-type (construct type-identifier &key revision)
+    (remove-if-not #'(lambda(occ)
+                       (eql occurrencetype (instance-of occ :revision revision)))
+                   (occurrences construct :revision revision))))
+
+
+(defgeneric characteristics-by-type (construct chartype &key revision)
   (:documentation "Returns all characteristics that are of the
                    corresponding type.")
-  (:method ((construct TopicC) (type-identifier IdentifierC)
-            &key (revision *TM-REVISION*))
-    (declare (integer revision))
-    (union (names-by-type construct type-identifier :revision revision)
-           (occurrences-by-type construct type-identifier :revision revision))))
+  (:method ((construct TopicC) (chartype TopicC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (union (names-by-type construct chartype :revision revision)
+           (occurrences-by-type construct chartype :revision revision))))
 
 
@@ -288 +297 @@
                             occ))
                 (occurrences construct :revision revision))))
-      (remove-if #'null results))))
+      (remove-null results))))
 
 
@@ -301 +310 @@
                             name))
                 (names construct :revision revision))))
-      (remove-if #'null results))))
-
-
-(defgeneric characteristic-by-value (construct filter &key revision)
+      (remove-null results))))
+
+
+(defgeneric characteristics-by-value (construct filter &key revision)
   (:documentation "Returns a list of all characteristics of the passed
                    topic, that return a true value when calling filter.")
@@ -311 +320 @@
     (union (names-by-value construct filter :revision revision)
            (occurrences-by-value construct filter :revision revision))))
+
+
+(defgeneric isa (construct type &key revision)
+  (:documentation "Returns all types if the passed construct
+                   is of the specified type.")
+  (:method ((construct TopicC) (type TopicC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (let ((all-types (instance-of construct :revision revision)))
+      (when (find type all-types)
+        all-types))))
+
+
+(defgeneric aka (construct supertype &key revision)
+  (:documentation "Returns all types if the passed construct
+                   is of the specified type.")
+  (:method ((construct TopicC) (supertype TopicC) &key (revision *TM-REVISION*))
+    (declare (integer revision))
+    (let ((all-supertypes (supertypes construct :revision revision)))
+      (when (find supertype all-supertypes)
+        all-supertypes))))

trunk/src/unit_tests/fixtures.lisp ¶

@@ -14 +14 @@
    :datamodel
    :it.bese.FiveAM
+   :base-tools
    :unittests-constants)
   (:import-from :constants
@@ -39 +40 @@
            :rdf-init-db
            :rdf-test-db
-           :with-empty-db))
+           :with-empty-db
+           :with-tm-filled-db))
 
 (in-package :fixtures)
@@ -220 +222 @@
   (&body)
   (tear-down-test-db))
+
+
+(def-fixture with-tm-filled-db (dir xtm-path)
+  (clean-out-db dir)
+  (let ((tm-id "http://www.isidor.us/unittests/testtm")
+        (xtm-id (full-path xtm-path)))
+    (xml-importer:setup-repository xtm-path dir :tm-id tm-id :xtm-id xtm-id)
+    (elephant:open-store (xml-importer:get-store-spec dir))
+    (&body)
+    (tear-down-test-db)))

trunk/src/unit_tests/poems.xtm ¶

@@ -2630 +2630 @@
 
   <tm:association>
-    <tm:itemIdentity href="wrrtten-by-erlkoenig-goethe"/>
+    <tm:itemIdentity href="written-by-erlkoenig-goethe"/>
     <tm:type><tm:topicRef href="#written-by"/></tm:type>
     <tm:role>

trunk/src/unit_tests/trivial_queries_test.lisp ¶

@@ -11 +11 @@
   (:use  :cl
          :it.bese.FiveAM
-         :datamodel)
+         :datamodel
+         :unittests-constants
+         :fixtures
+         :constants)
   (:export :run-trivial-queries-tests
-           :trivial-queries-tests))
+           :trivial-queries-tests
+           :test-aka
+           :test-isa
+           :test-x-by-value
+           :test-x-by-type
+           :test-invoke-on
+           :test-instance-of
+           :test-supertypes
+           :test-direct-instance-of
+           :test-direct-supertypes
+           :test-supertype-associations
+           :test-instance-of-associations
+           :test-associations-of
+           :test-roles-by-type
+           :test-roles-by-player
+           :test-filter-associations-by-type
+           :test-filter-associations-by-role))
 
 
@@ -19 +38 @@
 
 
-(def-suite trivial-queries-test
+(def-suite trivial-queries-tests
      :description "tests various key functions of the trivial-query-test of
                    the datamodel module")
 
-(in-suite trivial-queries-test)
+(in-suite trivial-queries-tests)
+
+(test test-aka
+  "Tests the function aka."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (city (get-item-by-id "city"))
+            (poem (get-item-by-id "poem"))
+            (supertype (get-item-by-psi *supertype-psi*))
+            (subtype (get-item-by-psi *subtype-psi*))
+            (supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
+            (rev (get-revision)))
+        (is-true region)
+        (is-true city)
+        (is-true poem)
+        (is-true supertype)
+        (is-true subtype)
+        (is-true supertype-subtype)
+        (is-true (aka city region))
+        (is-false (aka city city))
+        (make-construct 'AssociationC
+                        :start-revision rev
+                        :instance-of supertype-subtype
+                        :roles (list (list :start-revision rev
+                                           :player region
+                                           :instance-of subtype)
+                                     (list :start-revision rev
+                                           :player poem
+                                           :instance-of supertype)))
+        (is-true (aka city region))
+        (is-true (aka city poem))
+        (is-true (aka region poem))))))
+
+
+(test test-isa
+  "Tests the function isa."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (metropolis (get-item-by-id "metropolis"))
+            (poem (get-item-by-id "poem"))
+            (frankfurt (get-item-by-id "frankfurt_am_main")))
+        (is-true region)
+        (is-true frankfurt)
+        (is-true metropolis)
+        (is-true poem)
+        (is-true (isa frankfurt metropolis))
+        (is-true (isa frankfurt region))))))
+
+
+(test test-x-by-value
+  "Tests the functions names-by-value, occurrences-by-value
+   and characteristics-by-value."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((goethe (get-item-by-id "goethe"))
+            (poem (get-item-by-id "poem"))
+            (fn "Johann Wolfgang")
+            (ln "von Goethe")
+            (ai "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")
+            (as "any string"))
+        (let ((fun-fn (lambda(value)
+                        (string= value fn)))
+              (fun-ln (lambda(value)
+                        (string= value ln)))
+              (fun-ai (lambda(value)
+                        (string= value ai)))
+              (fun-as (lambda(value)
+                        (string= value as))))
+          (is-true goethe)
+          (is-true poem)
+          (is-false (names-by-value goethe fun-as))
+          (is-false (occurrences-by-value goethe fun-as))
+          (is-false (characteristics-by-value goethe fun-as))
+          (is (= (length (names-by-value goethe fun-fn)) 1))
+          (is (= (length (names-by-value goethe fun-ln)) 1))
+          (is (= (length (occurrences-by-value goethe fun-ai)) 1))
+          (is (string= (charvalue (first (names-by-value goethe fun-fn)))
+                       fn))
+          (is (string= (charvalue (first (names-by-value goethe fun-ln)))
+                       ln))
+          (is (string= (charvalue (first (occurrences-by-value goethe fun-ai)))
+                       ai))
+          (is (= (length (characteristics-by-value goethe fun-fn)) 1))
+          (is (string=
+               (charvalue (first (characteristics-by-value goethe fun-fn)))
+               fn)))))))
+
+
+(test test-x-by-type
+  "Tests the functions names-by-type, occurrences-by-type
+   and characteristics-by-type."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((goethe (get-item-by-id "goethe"))
+            (first-name (get-item-by-id "first-name"))
+            (last-name (get-item-by-id "last-name"))
+            (author-info (get-item-by-id "author-info"))
+            (poem (get-item-by-id "poem")))
+        (is-true goethe)
+        (is-true first-name)
+        (is-true last-name)
+        (is-true author-info)
+        (is-true poem)
+        (is-false (names-by-type goethe poem))
+        (is-false (occurrences-by-type goethe poem))
+        (is-false (characteristics-by-type goethe poem))
+        (is (= (length (names-by-type goethe first-name)) 1))
+        (is (= (length (names-by-type goethe last-name)) 1))
+        (is (= (length (occurrences-by-type goethe author-info)) 1))
+        (is (string= (charvalue (first (names-by-type goethe first-name)))
+                     "Johann Wolfgang"))
+        (is (string= (charvalue (first (names-by-type goethe last-name)))
+                     "von Goethe"))
+        (is (string=
+             (charvalue (first (occurrences-by-type goethe author-info)))
+             "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe"))
+        (is (= (length (characteristics-by-type goethe first-name)) 1))
+        (is (string=
+             (charvalue (first (characteristics-by-type goethe first-name)))
+             "Johann Wolfgang"))))))
+
+
+(test test-invoke-on
+  "Tests the function invoke-on."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((frankfurt (get-item-by-id "frankfurt_am_main")))
+        (is-true frankfurt)
+        (is (= (length (occurrences frankfurt)) 1))
+        (is (= (invoke-on (first (occurrences frankfurt))
+                          #'(lambda(value)
+                              (+ 1 (parse-integer value))))
+               (+ 1 659021)))))))
+
+
+
+(test test-instance-of
+  "Tests the function instance-of."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (metropolis (get-item-by-id "metropolis"))
+            (poem (get-item-by-id "poem"))
+            (frankfurt (get-item-by-id "frankfurt_am_main")))
+        (is-true region)
+        (is-true frankfurt)
+        (is-true metropolis)
+        (is-true poem)
+        (is (= (length (instance-of frankfurt)) 2))
+        (is-false (set-exclusive-or (instance-of frankfurt)
+                                    (list metropolis region)))))))
+
+
+(test test-supertypes
+  "Tests the function supertypes."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (city (get-item-by-id "city"))
+            (poem (get-item-by-id "poem"))
+            (supertype (get-item-by-psi *supertype-psi*))
+            (subtype (get-item-by-psi *subtype-psi*))
+            (supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
+            (rev (get-revision)))
+        (is-true region)
+        (is-true city)
+        (is-true poem)
+        (is-true supertype)
+        (is-true subtype)
+        (is-true supertype-subtype)
+        (is (= (length (supertypes city)) 1))
+        (is (eql (first (supertypes city)) region))
+        (is-false (supertypes region))
+        (make-construct 'AssociationC
+                        :start-revision rev
+                        :instance-of supertype-subtype
+                        :roles (list (list :start-revision rev
+                                           :player region
+                                           :instance-of subtype)
+                                     (list :start-revision rev
+                                           :player poem
+                                           :instance-of supertype)))
+        (is (= (length (supertypes city)) 2))))))
+
+
+(test test-direct-instance-of
+  "Tests the function direct-instance-of."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (frankfurt (get-item-by-id "frankfurt_am_main"))
+            (metropolis (get-item-by-id "metropolis")))
+        (is-true region)
+        (is-true metropolis)
+        (is-true frankfurt)
+        (is (= (length (direct-instance-of frankfurt)) 1))
+        (is (eql (first (direct-instance-of frankfurt)) metropolis))
+        (is-false (direct-instance-of metropolis))))))
+
+
+(test test-direct-supertypes
+  "Tests the function direct-supertypes."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (city (get-item-by-id "city"))
+            (poem (get-item-by-id "poem"))
+            (supertype (get-item-by-psi *supertype-psi*))
+            (subtype (get-item-by-psi *subtype-psi*))
+            (supertype-subtype (get-item-by-psi *supertype-subtype-psi*))
+            (rev (get-revision)))
+        (is-true region)
+        (is-true city)
+        (is-true poem)
+        (is-true supertype)
+        (is-true subtype)
+        (is-true supertype-subtype)
+        (is (= (length (direct-supertypes city)) 1))
+        (is (eql (first (direct-supertypes city)) region))
+        (is-false (direct-supertypes region))
+        (make-construct 'AssociationC
+                        :start-revision rev
+                        :instance-of supertype-subtype
+                        :roles (list (list :start-revision rev
+                                           :player region
+                                           :instance-of subtype)
+                                     (list :start-revision rev
+                                           :player poem
+                                           :instance-of supertype)))
+        (is (= (length (direct-supertypes city)) 1))))))
+
+
+(test test-supertype-associations
+  "Tests the function supertype-associations."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((region (get-item-by-id "region"))
+            (city (get-item-by-id "city"))
+            (metropolis (get-item-by-id "metropolis"))
+            (assocs (get-all-associations))
+            (supertype (get-item-by-psi *supertype-psi*))
+            (subtype (get-item-by-psi *subtype-psi*))
+            (supertype-subtype (get-item-by-psi *supertype-subtype-psi*)))
+        (is-true region)
+        (is-true city)
+        (is-true metropolis)
+        (is-true supertype)
+        (is-true subtype)
+        (is-true supertype-subtype)
+        (let ((assoc-city
+               (find-if
+                #'(lambda(assoc)
+                    (and (eql (instance-of assoc) supertype-subtype)
+                         (find-if #'(lambda(role)
+                                      (and (eql (player role) city)
+                                           (eql (instance-of role) subtype)))
+                                  (roles assoc))
+                         (find-if #'(lambda(role)
+                                      (and (eql (player role) region)
+                                           (eql (instance-of role) supertype)))
+                                  (roles assoc))))
+                assocs))
+              (assoc-metropolis
+               (find-if
+                #'(lambda(assoc)
+                    (and (eql (instance-of assoc) supertype-subtype)
+                         (find-if #'(lambda(role)
+                                      (and (eql (player role) metropolis)
+                                           (eql (instance-of role) subtype)))
+                                  (roles assoc))
+                         (find-if #'(lambda(role)
+                                      (and (eql (player role) region)
+                                           (eql (instance-of role) supertype)))
+                                  (roles assoc))))
+                assocs)))
+          (is-true assoc-city)
+          (is-true assoc-metropolis)
+          (is (= (length (supertype-associations city)) 1))
+          (is (= (length (supertype-associations metropolis)) 1))
+          (is (eql (first (supertype-associations city)) assoc-city))
+          (is (eql (first (supertype-associations metropolis)) assoc-metropolis))
+          (is-false (supertype-associations region)))))))
+
+
+(test test-instance-of-associations
+  "Tests the function instance-of-associations."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((goethe (get-item-by-id "goethe"))
+            (instance (get-item-by-psi *instance-psi*))
+            (type (get-item-by-psi *type-psi*))
+            (type-instance (get-item-by-psi *type-instance-psi*))
+            (author (get-item-by-id "author")))
+        (is-true goethe)
+        (is-true instance)
+        (is-true type)
+        (is-true type-instance)
+        (is-true author)
+        (is (= (length (instance-of-associations goethe)) 1))
+        (is (eql type-instance
+                 (instance-of (first (instance-of-associations goethe)))))
+        (is-true (filter-associations-by-role (instance-of-associations goethe)
+                                              instance goethe))
+        (is-true (filter-associations-by-role (instance-of-associations goethe)
+                                              type author))
+        (is-true (filter-associations-by-type (instance-of-associations goethe)
+                                              type-instance))))))
+
+
+(test test-associations-of
+  "Tests the function associations-of."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((goethe (get-item-by-id "goethe"))
+            (writer (get-item-by-id "writer"))
+            (written-by (get-item-by-id "written-by"))
+            (written (get-item-by-id "written"))
+            (erlkoenig (get-item-by-id "erlkoenig"))
+            (instance (get-item-by-psi *instance-psi*))
+            (poem (get-item-by-id "poem")))
+        (is-true goethe)
+        (is-true writer)
+        (is-true written-by)
+        (is-true written)
+        (is-true erlkoenig)
+        (is-true instance)
+        (is-true poem)
+        (is (= (length (associations-of goethe nil nil nil nil)) 4))
+        (is (= (length (associations-of goethe writer nil nil nil)) 3))
+        (is (= (length (associations-of goethe writer written-by nil nil)) 2))
+        (is (= (length (associations-of goethe writer written-by written nil)) 2))
+        (is (= (length (associations-of goethe writer written-by written erlkoenig)) 1))
+        (is-false (associations-of goethe writer written-by written instance))
+        (is-false (associations-of goethe writer written-by instance erlkoenig))
+        (is (= (length (associations-of goethe instance nil nil nil)) 1))
+        (is-false (associations-of goethe writer written-by written erlkoenig
+                                   :other-role-player-is-type t))
+        (is (= (length (associations-of  goethe writer written-by written poem
+                                         :other-role-player-is-type t)) 2))))))
+
+
+(test test-roles-by-type
+  "Tests the function roles-by-type bound to TopicC and AssociationC."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((goethe (get-item-by-id "goethe"))
+            (writer (get-item-by-id "writer"))
+            (written (get-item-by-id "written"))
+            (instance (get-item-by-psi *instance-psi*))
+            (assoc (get-item-by-item-identifier "written-by-erlkoenig-goethe")))
+        (is-true goethe)
+        (is-true writer)
+        (is-true written)
+        (is-true instance)
+        (is-true assoc)
+        (is (= (length (roles-by-type goethe writer)) 3))
+        (is (= (length (roles-by-type goethe nil)) 4))
+        (is (= (length (roles-by-type goethe instance)) 1))
+        (is-false (roles-by-type goethe written))
+        (is (= (length (roles-by-type assoc writer)) 1))
+        (is (eql writer (instance-of (first (roles-by-type assoc writer)))))
+        (is (= (length (roles-by-type assoc nil)) 2))))))
+
+
+(test test-roles-by-player
+  "Tests the function roles-by-player."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((goethe (get-item-by-id "goethe"))
+            (writer (get-item-by-id "writer"))
+            (written (get-item-by-id "written"))
+            (instance (get-item-by-psi *instance-psi*))
+            (assoc (get-item-by-item-identifier "written-by-erlkoenig-goethe"))
+            (author (get-item-by-id "author")))
+        (is-true goethe)
+        (is-true author)
+        (is-true writer)
+        (is-true written)
+        (is-true instance)
+        (is-true assoc)
+        (is (= (length (roles-by-player assoc goethe)) 1))
+        (is (eql goethe (player (first (roles-by-player assoc goethe)))))
+        (is (= (length (roles-by-player assoc written)) 0))
+        (is (= (length (roles-by-player assoc nil)) 2))
+        (is (= (length (roles-by-player assoc author :role-player-is-type t))
+               1))
+        (is-false (roles-by-player assoc goethe :role-player-is-type t))
+        (is (eql goethe (player (first (roles-by-player
+                                        assoc author
+                                        :role-player-is-type t)))))))))
+
+
+(test test-filter-associations-by-type
+  "Tests the function roles-by-player."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((written-by (get-item-by-id "written-by"))
+            (born-in (get-item-by-id "born-in"))
+            (assocs (get-all-associations)))
+        (is-true written-by)
+        (is-true assocs)
+        (is-true born-in)
+        (is (= (length (filter-associations-by-type assocs written-by)) 4))
+        (is (> (length (filter-associations-by-type assocs nil)) (+ 4 2)))
+        (is (= (length (filter-associations-by-type assocs born-in)) 2))))))
+
+
+(test test-filter-associations-by-role
+  "Tests the function roles-by-player."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let ((written-by (get-item-by-id "written-by"))
+            (born-in (get-item-by-id "born-in"))
+            (written (get-item-by-id "written"))
+            (writer (get-item-by-id "writer"))
+            (place (get-item-by-id "place"))
+            (goethe (get-item-by-id "goethe"))
+            (frankfurt (get-item-by-id "frankfurt_am_main"))
+            (assocs (get-all-associations))
+            (author (get-item-by-id "author")))
+        (is-true written-by)
+        (is-true assocs)
+        (is-true born-in)
+        (is-true author)
+        (is-true written)
+        (is-true writer)
+        (is-true place)
+        (is-true frankfurt)
+        (is (= (length (filter-associations-by-role assocs place frankfurt)) 1))
+        (is (= (length (filter-associations-by-role assocs written nil)) 4))
+        (is (= (length (filter-associations-by-role assocs written goethe)) 2))
+        (is (= (length (filter-associations-by-role assocs writer nil)) 6))
+        (is (= (length (filter-associations-by-role assocs nil goethe)) 4))
+        (is (> (length (filter-associations-by-role assocs nil nil)) (+ 4 3)))
+        (is-false (filter-associations-by-role assocs writer goethe
+                                               :role-player-is-type t))
+        (is (= (length (filter-associations-by-role assocs writer author
+                                                    :role-player-is-type t))
+               6))))))
+        
+
+
 
 

trunk/src/unit_tests/unittests-constants.lisp ¶

@@ -30 +30 @@
            :*atom_test.xtm*
            :*atom-conf.lisp*
+           :*poems.xtm*
            :*poems_light.rdf*
            :*poems_light.xtm*
@@ -101 +102 @@
    (asdf:find-component *unit-tests-component* "atom-conf")))
 
+(defparameter *poems.xtm*
+  (asdf:component-pathname
+   (asdf:find-component *unit-tests-component* "poems.xtm")))
+
 (defparameter *poems_light.rdf*
   (asdf:component-pathname