[isidorus-cvs] r337 - in trunk/src: . base-tools model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Nov 11 08:47:23 UTC 2010
Author: lgiessmann
Date: Thu Nov 11 03:47:23 2010
New Revision: 337
Log:
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.
Modified:
trunk/src/base-tools/base-tools.lisp
trunk/src/isidorus.asd
trunk/src/model/datamodel.lisp
trunk/src/model/trivial-queries.lisp
trunk/src/unit_tests/fixtures.lisp
trunk/src/unit_tests/poems.xtm
trunk/src/unit_tests/trivial_queries_test.lisp
trunk/src/unit_tests/unittests-constants.lisp
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Thu Nov 11 03:47:23 2010
@@ -11,7 +11,9 @@
(:use :cl)
(:nicknames :tools)
(:export :push-string
- :when-do))
+ :when-do
+ :remove-null
+ :full-path))
(in-package :base-tools)
@@ -31,3 +33,23 @@
,do-with-result
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))))
\ No newline at end of file
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Thu Nov 11 03:47:23 2010
@@ -39,7 +39,7 @@
:depends-on ("datamodel" "trivial-queries"))
(:file "model_tools"
:depends-on ("exceptions")))
- :depends-on ("constants"))
+ :depends-on ("constants" "base-tools"))
(:module "TM-SPARQL"
:components ((:file "sparql"
:depends-on ("sparql_tokenizer"))
@@ -177,7 +177,9 @@
"model"
"xml"
"json"
- "threading"))
+ "threading"
+ "base-tools"
+ "TM-SPARQL"))
(:module "json"
:components ((:file "json_exporter"
:depends-on ("json_tmcl_constants"))
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Thu Nov 11 03:47:23 2010
@@ -170,11 +170,13 @@
:direct-instance-of
: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)
Modified: trunk/src/model/trivial-queries.lisp
==============================================================================
--- trunk/src/model/trivial-queries.lisp (original)
+++ trunk/src/model/trivial-queries.lisp Thu Nov 11 03:47:23 2010
@@ -21,12 +21,12 @@
(declare (integer revision)
(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)))
@@ -35,28 +35,35 @@
(declare (integer revision)
(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))))
@@ -77,38 +84,44 @@
(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.
If any of the passed values is set to nil, it won't be
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))
(roles-by-type construct role-type
@@ -116,8 +129,10 @@
(let ((assocs-by-type
(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)))))
(defgeneric instance-of-associations (construct &key revision)
@@ -172,14 +187,18 @@
(:method ((construct TopicC) &key (revision *TM-REVISION*))
(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))))))
(defgeneric supertypes (construct &key revision valid-supertypes)
@@ -196,7 +215,8 @@
direct-super-type :revision revision
:valid-supertypes current-valid-super-types))))
(remove-duplicates
- (remove-if #'null recursive-super-types)))))))
+ (remove-null (union recursive-super-types
+ current-valid-super-types))))))))
(defgeneric direct-instance-of (construct &key revision)
@@ -204,25 +224,27 @@
(:method ((construct TopicC) &key (revision *TM-REVISION*))
(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))))))
(defmethod instance-of (construct &key (revision *TM-REVISION*))
"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))))
(defgeneric invoke-on (construct operation)
@@ -231,50 +253,37 @@
If cast-operation is set to a function the characteristic's
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)
- &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)))))
+ (: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 type-identifier &key revision)
+(defgeneric occurrences-by-type (construct occurrencetype &key revision)
(:documentation "Returns all names that are of the corresponding type.")
- (:method ((construct TopicC) (type-identifier IdentifierC)
+ (: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 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)))))
+ (remove-if-not #'(lambda(occ)
+ (eql occurrencetype (instance-of occ :revision revision)))
+ (occurrences construct :revision revision))))
-(defgeneric characteristic-by-type (construct type-identifier &key 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*))
+ (:method ((construct TopicC) (chartype TopicC) &key (revision *TM-REVISION*))
(declare (integer revision))
- (union (names-by-type construct type-identifier :revision revision)
- (occurrences-by-type construct type-identifier :revision revision))))
+ (union (names-by-type construct chartype :revision revision)
+ (occurrences-by-type construct chartype :revision revision))))
(defgeneric occurrences-by-value (construct filter &key revision)
@@ -287,7 +296,7 @@
(when (invoke-on occ filter)
occ))
(occurrences construct :revision revision))))
- (remove-if #'null results))))
+ (remove-null results))))
(defgeneric names-by-value (construct filter &key revision)
@@ -300,13 +309,33 @@
(when (invoke-on name filter)
name))
(names construct :revision revision))))
- (remove-if #'null results))))
+ (remove-null results))))
-(defgeneric characteristic-by-value (construct filter &key revision)
+(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.")
(:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*))
(declare (integer revision))
(union (names-by-value construct filter :revision revision)
- (occurrences-by-value construct filter :revision revision))))
\ No newline at end of file
+ (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))))
\ No newline at end of file
Modified: trunk/src/unit_tests/fixtures.lisp
==============================================================================
--- trunk/src/unit_tests/fixtures.lisp (original)
+++ trunk/src/unit_tests/fixtures.lisp Thu Nov 11 03:47:23 2010
@@ -13,6 +13,7 @@
:xml-importer
:datamodel
:it.bese.FiveAM
+ :base-tools
:unittests-constants)
(:import-from :constants
*xtm2.0-ns*)
@@ -38,7 +39,8 @@
:*XTM-MERGE2-TM*
:rdf-init-db
:rdf-test-db
- :with-empty-db))
+ :with-empty-db
+ :with-tm-filled-db))
(in-package :fixtures)
@@ -218,4 +220,14 @@
(clean-out-db dir)
(elephant:open-store (xml-importer:get-store-spec dir))
(&body)
- (tear-down-test-db))
\ No newline at end of file
+ (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)))
\ No newline at end of file
Modified: trunk/src/unit_tests/poems.xtm
==============================================================================
--- trunk/src/unit_tests/poems.xtm (original)
+++ trunk/src/unit_tests/poems.xtm Thu Nov 11 03:47:23 2010
@@ -2629,7 +2629,7 @@
</tm:association>
<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>
<tm:type><tm:topicRef href="#writer"/></tm:type>
Modified: trunk/src/unit_tests/trivial_queries_test.lisp
==============================================================================
--- trunk/src/unit_tests/trivial_queries_test.lisp (original)
+++ trunk/src/unit_tests/trivial_queries_test.lisp Thu Nov 11 03:47:23 2010
@@ -10,19 +10,481 @@
(defpackage :trivial-queries-test
(: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))
(in-package :trivial-queries-test)
-(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))))))
+
+
+
(defun run-trivial-queries-tests ()
Modified: trunk/src/unit_tests/unittests-constants.lisp
==============================================================================
--- trunk/src/unit_tests/unittests-constants.lisp (original)
+++ trunk/src/unit_tests/unittests-constants.lisp Thu Nov 11 03:47:23 2010
@@ -29,6 +29,7 @@
:*t100.xtm*
:*atom_test.xtm*
:*atom-conf.lisp*
+ :*poems.xtm*
:*poems_light.rdf*
:*poems_light.xtm*
:*poems_light.xtm.txt*
@@ -100,6 +101,10 @@
(asdf:component-pathname
(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
(asdf:find-component *unit-tests-component* "poems_light.rdf")))
More information about the Isidorus-cvs
mailing list