From 9b8dee133bd6a080d557990a7e575a177f9a3941 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Fri, 18 Mar 2022 16:03:49 +0100 Subject: [PATCH 001/157] adding category-linking-mode :path-exists-ignore-transitive-closure --- .../fcg/categorial-networks/categorial-network.lisp | 12 ++++++++++++ .../repair-add-categorial-links.lisp | 5 ++--- .../tests/test-add-categorial-links-repair.lisp | 5 ++--- 3 files changed, 16 insertions(+), 6 deletions(-) diff --git a/systems/fcg/categorial-networks/categorial-network.lisp b/systems/fcg/categorial-networks/categorial-network.lisp index 2f9a92d35..06b14adb0 100644 --- a/systems/fcg/categorial-networks/categorial-network.lisp +++ b/systems/fcg/categorial-networks/categorial-network.lisp @@ -574,6 +574,18 @@ "Succeeds if categories are connected (= linked directly or indirectly)." (categories-linked-p category-1 category-2 (categorial-network cxn-inventory) mode)) +(defmethod categories-linked-p (category-1 category-2 (categorial-network categorial-network) (mode (eql :path-exists-ignore-transitive-closure))) + "Succeeds if categories are connected (= linked directly or indirectly). Does not consult transitive closure." + (graph-utils:connected? (graph categorial-network) category-1 category-2)) + +(defmethod categories-linked-p (category-1 category-2 (cxn-inventory fcg-construction-set) (mode (eql :path-exists-ignore-transitive-closure))) + "Succeeds if categories are connected (= linked directly or indirectly). Does not consult transitive closure." + (graph-utils:connected? (graph (categorial-network cxn-inventory)) category-1 category-2)) + +(defmethod categories-linked-p (category-1 category-2 (cxn-inventory hashed-fcg-construction-set) (mode (eql :path-exists-ignore-transitive-closure))) + "Succeeds if categories are connected (= linked directly or indirectly). Does not consult transitive closure." + (graph-utils:connected? (graph (categorial-network cxn-inventory)) category-1 category-2)) + (defmethod categories-linked-p (category-1 category-2 (categorial-network categorial-network) (mode (eql :path-exists-w-weight-above-0))) "Succeeds if categories are connected (= linked directly or indirectly) with all links above 0." (connected-categories-p category-1 category-2 categorial-network :threshold 0.0)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp index af728a165..002f3033a 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp @@ -36,7 +36,7 @@ :restart-data cxns-and-categorial-links)))) (defun disable-meta-layer-configuration (cxn-inventory) - (set-configuration cxn-inventory :category-linking-mode :path-exists) + (set-configuration cxn-inventory :category-linking-mode :path-exists-ignore-transitive-closure) (set-configuration cxn-inventory :update-categorial-links nil) (set-configuration cxn-inventory :use-meta-layer nil) (set-configuration cxn-inventory :consolidate-repairs nil)) @@ -63,8 +63,7 @@ collect (cons holistic-cxn-lex-class item-slot-lex-class))) (defun create-categorial-links (problem node) - "Return the categorial links and applied cxns from a comprehend with :categorial-linking-mode :path-exists instead of :neighbours" - (compute-transitive-closure (categorial-network (construction-inventory node))) + "Return the categorial links and applied cxns from a comprehend with :category-linking-mode :path-exists instead of :neighbours" (let* ((utterance (random-elt (get-data problem :utterances))) (gold-standard-meaning (random-elt (get-data problem :meanings))) (cxn-inventory (construction-inventory node)) diff --git a/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp b/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp index d3fb68a21..3293f8f0f 100644 --- a/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp +++ b/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp @@ -81,6 +81,5 @@ ; issues: -; 1. why aren't the equivalent 'what is the size of the x cube' cxns recognised as existing in the substitution repair? - - +; 1. why aren't the equivalent 'what is the size of the x cube' cxns recognised as existing in the substitution repair +; 2. restore the category-linking-mode with some other flag \ No newline at end of file -- GitLab From c14c14fc308f60e40650307fe67c18476a2ce90b Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Fri, 18 Mar 2022 16:44:21 +0100 Subject: [PATCH 002/157] aligning repair class names --- experiments/grammar-learning/clevr/test.lisp | 7 +- .../irl-anti-unification-example.lisp | 96 ------------------- .../repair-holistic-to-item-based-cxn.lisp | 6 +- .../experiment-setup/grammar.lisp | 2 +- .../experiment-setup/interaction.lisp | 4 +- .../test-holistic-to-item-based-repair.lisp | 8 +- .../tests/test-substitution-repair.lisp | 39 ++++++++ 7 files changed, 53 insertions(+), 109 deletions(-) delete mode 100644 systems/grammar-learning/development-grammars/irl-anti-unification-example.lisp diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 8d38f5178..49133bd65 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -43,8 +43,9 @@ (deactivate-all-monitors) (activate-monitor print-a-dot-for-each-interaction) (activate-monitor summarize-results-after-n-interactions) - (activate-monitor show-type-hierarchy-after-n-interactions) - (activate-monitor trace-interactions-in-wi)) + ;(activate-monitor show-type-hierarchy-after-n-interactions) + ;(activate-monitor trace-interactions-in-wi) + ) (progn (wi::reset) @@ -75,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 800) +;(run-series *experiment* 9000) #| QUESTIONS diff --git a/systems/grammar-learning/development-grammars/irl-anti-unification-example.lisp b/systems/grammar-learning/development-grammars/irl-anti-unification-example.lisp deleted file mode 100644 index 1a2d8eeda..000000000 --- a/systems/grammar-learning/development-grammars/irl-anti-unification-example.lisp +++ /dev/null @@ -1,96 +0,0 @@ -(ql:quickload :fcg) - -(in-package :fcg) -(activate-monitor trace-fcg) - - - -(def-fcg-constructions demo-grammar - :feature-types ((args sequence) - (form set-of-predicates) - (meaning set-of-predicates) - (de-render-mode de-render-string-meets) - (constituents sequence) - (dependents sequence)) - :hierarchy-features (constituents dependents)) - - - -(def-fcg-cxn large-gray-cxn - ((?large-gray-unit - (args (?target-1 ?target-39552)) - (syn-cat (phrase-type holistic) - (lex-class large-gray)) - (boundaries - (left ?large-unit) - (right ?gray-unit)) - ) - <- - (?large-gray-unit - (HASH meaning ((filter ?target-2 ?target-1 ?color-2) - (filter ?target-39552 ?target-2 ?size-4) - (bind size-category ?size-4 large) - (bind color-category ?color-2 gray))) - -- - (HASH form ((string ?large-unit "large") - (string ?gray-unit "gray") - (meets ?large-unit ?gray-unit)))))) - -(def-fcg-cxn tiny-yellow-cxn - ((?tiny-yellow-unit - (args (?target-1 ?target-39552)) - (syn-cat (phrase-type holistic) - (lex-class large-gray)) - (boundaries - (left ?tiny-unit) - (right ?yellow-unit)) - ) - <- - (?tiny-yellow-unit - (HASH meaning ((filter ?target-2 ?target-1 ?color-2) - (filter ?target-39552 ?target-2 ?size-4) - (bind size-category ?size-4 tiny) - (bind color-category ?color-2 yellow))) - -- - (HASH form ((string ?tiny-unit "tiny") - (string ?yellow-unit "yellow") - (meets ?tiny-unit ?yellow-unit)))))) - - -(def-fcg-cxn the-x-object-is-what-shape-cxn - ((?item-based-unit - (syn-cat (phrase-type item-based)) - (subunits (?large-gray-unit))) - (?large-gray-unit - (syn-cat (lex-class large-gray))) - - <- - (?item-based-unit - (HASH meaning ((query ?target-8 ?source-10 ?attribute-2) - (bind shape-category ?shape-8 thing) - (bind attribute-category ?attribute-2 shape) - (filter ?target-1 ?source-1 ?shape-8) - (unique ?source-10 ?target-39552) - (get-context ?source-1))) - -- - (HASH form ((string ?the-66 "The") - (string ?object-66 "object") - (string ?is-66 "is") - (string ?what-66 "what") - (string ?shape?-66 "shape?") - (meets ?the-66 ?large-unit) - (meets ?gray-unit ?object-66) - (meets ?object-66 ?is-66) - (meets ?is-66 ?what-66) - (meets ?what-66 ?shape?-66)))) - (?large-gray-unit - (args (?target-1 ?target-39552)) - -- - (boundaries - (left ?large-unit) - (right ?gray-unit))))) - - - -(comprehend-and-formulate "The tiny yellow object is what shape?") -(comprehend-and-formulate "The large gray object is what shape?") diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index 031e2efe9..ac61dba3c 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -4,10 +4,10 @@ ;; Repair from holistic to item-based cxn ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass repair-holistic->item-based-cxn (add-cxns-and-categorial-links) +(defclass holistic->item-based (add-cxns-and-categorial-links) ((trigger :initform 'fcg::new-node))) -(defmethod repair ((repair repair-holistic->item-based-cxn) +(defmethod repair ((repair holistic->item-based) (problem non-gold-standard-meaning) (node cip-node) &key &allow-other-keys) @@ -20,7 +20,7 @@ :problem problem :restart-data constructions-and-th-links))))) -(defmethod repair ((repair repair-holistic->item-based-cxn) +(defmethod repair ((repair holistic->item-based) (problem non-gold-standard-utterance) (node cip-node) &key &allow-other-keys) diff --git a/systems/grammar-learning/experiment-setup/grammar.lisp b/systems/grammar-learning/experiment-setup/grammar.lisp index 61142b1b5..ba09685c6 100644 --- a/systems/grammar-learning/experiment-setup/grammar.lisp +++ b/systems/grammar-learning/experiment-setup/grammar.lisp @@ -66,7 +66,7 @@ gl::holophrase->item-based+holistic+holistic--substitution gl::holophrase->item-based+holistic--addition gl::holophrase->item-based+holistic+holophrase--deletion - gl::repair-holistic->item-based-cxn + gl::holistic->item-based gl::nothing->holophrase) :visualization-configurations ((:show-constructional-dependencies . nil) (:show-categorial-network . t)))))) diff --git a/systems/grammar-learning/experiment-setup/interaction.lisp b/systems/grammar-learning/experiment-setup/interaction.lisp index ee9f238b2..9f089d602 100644 --- a/systems/grammar-learning/experiment-setup/interaction.lisp +++ b/systems/grammar-learning/experiment-setup/interaction.lisp @@ -46,12 +46,12 @@ (if (not (find 'ADDED-BY-REPAIR node-statuses :test #'string=)) (if (determine-communicative-success cipn) "." "x") ; return a dot or x in evaluation mode (cond ((find 'nothing->holophrase node-statuses :test #'string=) "h") - ((find 'repair-holistic->item-based-cxn node-statuses :test #'string=) "i") + ((find 'holistic->item-based node-statuses :test #'string=) "i") ((find 'item-based->holistic node-statuses :test #'string=) "l") ((find 'holophrase->item-based+holistic+holistic--substitution node-statuses :test #'string=) "s") ((find 'holophrase->item-based+holistic--addition node-statuses :test #'string=) "a") ((find 'holophrase->item-based+holistic+holophrase--deletion node-statuses :test #'string=) "d") - ((find 'add-categorial-links node-statuses :test #'string=) "t") + ((find 'add-categorial-links node-statuses :test #'string=) "c") (t (error "Did not find any repair node statuses and no solution was found!")))))) (defmethod interact :before ((experiment grammar-learning-experiment) diff --git a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp index b764f6cbb..2466097c1 100644 --- a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp +++ b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp @@ -27,7 +27,7 @@ (filter ?target-2 ?target-1 ?color-2) (bind size-category ?size-4 large) (query ?target-8 ?source-10 ?attribute-2))) - (test-repair-status 'repair-holistic->item-based-cxn + (test-repair-status 'holistic->item-based (second (multiple-value-list (comprehend "What is the color of the large object?" :cxn-inventory cxn-inventory @@ -69,7 +69,7 @@ (filter ?target-61008 ?target-2 ?color-4) (bind size-category ?size-4 large) (query ?target-7 ?source-9 ?attribute-2))) - (test-repair-status 'repair-holistic->item-based-cxn + (test-repair-status 'holistic->item-based (second (multiple-value-list (comprehend "What is the material of the tiny gray object?" :cxn-inventory cxn-inventory @@ -119,7 +119,7 @@ (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 yellow) (query ?target-7 ?source-9 ?attribute-2))) - (test-repair-status 'repair-holistic->item-based-cxn + (test-repair-status 'holistic->item-based (second (multiple-value-list (comprehend "What is the shape of the large gray thing?" :cxn-inventory cxn-inventory @@ -201,7 +201,7 @@ (filter ?target-2 ?target-1 ?color-2) (bind size-category ?size-4 large) (query ?target-8 ?source-10 ?attribute-2))) - (test-repair-status 'repair-holistic->item-based-cxn + (test-repair-status 'holistic->item-based (second (multiple-value-list (comprehend "What is the shape of the large yellow object?" :cxn-inventory cxn-inventory diff --git a/systems/grammar-learning/tests/test-substitution-repair.lisp b/systems/grammar-learning/tests/test-substitution-repair.lisp index edd780731..a484c5ebd 100644 --- a/systems/grammar-learning/tests/test-substitution-repair.lisp +++ b/systems/grammar-learning/tests/test-substitution-repair.lisp @@ -301,6 +301,44 @@ (bind size-category ?size-4 large) (query ?target-8 ?source-10 ?attribute-2)))))))) +(deftest test-no-duplicate-item-based-cxns-substitution-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "What is the size of the red cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-4) + (unique ?target-object-1 ?target-2) + (bind shape-category ?shape-2 cube) + (bind attribute-category ?attribute-6 size) + (filter ?target-1 ?source-1 ?shape-2) + (bind color-category ?color-4 red) + (query ?target-4 ?target-object-1 ?attribute-6))) + (comprehend "What is the size of the blue cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-6) + (unique ?target-object-1 ?target-2) + (bind attribute-category ?attribute-6 size) + (bind shape-category ?shape-2 cube) + (filter ?target-1 ?source-1 ?shape-2) + (bind color-category ?color-6 blue) + (query ?target-4 ?target-object-1 ?attribute-6))) + + + (test-repair-status 'holophrase->item-based+holistic+holistic--substitution + (second (multiple-value-list + (comprehend "What is the size of the yellow cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-16) + (unique ?target-object-1 ?target-2) + (bind shape-category ?shape-2 cube) + (bind attribute-category ?attribute-6 size) + (filter ?target-1 ?source-1 ?shape-2) + (bind color-category ?color-16 yellow) + (query ?target-4 ?target-object-1 ?attribute-6)))))))) + ;; (test-substitution-repair-comprehension) ;ok ;; (test-substitution-repair-comprehension-right) ;ok ;; (test-substitution-repair-comprehension-multi-diff) ;should be holophrase @@ -311,6 +349,7 @@ ;; (test-varying-word-order-substitution-comprehension) ;should be holophrase ;; (test-varying-length-substitution-repair-comprehension) ;ok ;; (test-varying-length-substitution-repair-comprehension-reversed) ;ok +;; (test-no-duplicate-item-based-cxns-substitution-comprehension) -- GitLab From 04f084faa278cb933bbc0e909f228b963c0b955f Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Fri, 18 Mar 2022 17:22:25 +0100 Subject: [PATCH 003/157] try to unify boundaries in check for existing cxns --- .../grammar-learning/diagnostics-and-repairs/utils.lisp | 8 ++++---- .../grammar-learning/tests/test-substitution-repair.lisp | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 74005d09e..c19c7a5da 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -172,12 +172,12 @@ (defun find-cxn-by-form-and-meaning (form meaning cxn-inventory &key boundary-list) "returns a cxn with the same meaning and form if it's in the cxn-inventory" - (loop for cxn in (constructions cxn-inventory) + (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) + for boundary-list-cxn = (boundary-list cxn) when (and (irl:equivalent-irl-programs? form (extract-form-predicates cxn)) (irl:equivalent-irl-programs? meaning (extract-meaning-predicates cxn)) - (if boundary-list ;; needed for item-based cxns! - (and (irl::embedding boundary-list (boundary-list cxn)) - (irl::embedding (boundary-list cxn) boundary-list)) + (if boundary-list ;; needed for item-based cxns! check if variables unify + (unify boundary-list-cxn boundary-list) ;; issue: large yellow vs blue wouldn't unify. t)) return cxn)) diff --git a/systems/grammar-learning/tests/test-substitution-repair.lisp b/systems/grammar-learning/tests/test-substitution-repair.lisp index a484c5ebd..ba4d39fe1 100644 --- a/systems/grammar-learning/tests/test-substitution-repair.lisp +++ b/systems/grammar-learning/tests/test-substitution-repair.lisp @@ -328,7 +328,7 @@ (test-repair-status 'holophrase->item-based+holistic+holistic--substitution (second (multiple-value-list - (comprehend "What is the size of the yellow cube?" + (comprehend "What is the size of the large yellow cube?" :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) (filter ?target-2 ?target-1 ?color-16) @@ -349,7 +349,7 @@ ;; (test-varying-word-order-substitution-comprehension) ;should be holophrase ;; (test-varying-length-substitution-repair-comprehension) ;ok ;; (test-varying-length-substitution-repair-comprehension-reversed) ;ok -;; (test-no-duplicate-item-based-cxns-substitution-comprehension) +;; (test-no-duplicate-item-based-cxns-substitution-comprehension) ;ok but we want to reuse the item-based cxn, the boundaries don't unify though... a case for anti-unification! -- GitLab From 70c18c011f095af52c7337d67be346b9d2ee27ed Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Fri, 18 Mar 2022 17:34:46 +0100 Subject: [PATCH 004/157] minor comments --- experiments/grammar-learning/clevr/test.lisp | 2 +- systems/grammar-learning/diagnostics-and-repairs/utils.lisp | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 49133bd65..0f00d40bc 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 9000) +;(run-series *experiment* 150) #| QUESTIONS diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index c19c7a5da..88b385c9e 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -177,7 +177,7 @@ when (and (irl:equivalent-irl-programs? form (extract-form-predicates cxn)) (irl:equivalent-irl-programs? meaning (extract-meaning-predicates cxn)) (if boundary-list ;; needed for item-based cxns! check if variables unify - (unify boundary-list-cxn boundary-list) ;; issue: large yellow vs blue wouldn't unify. + (unify boundary-list-cxn boundary-list) ;; issue: blue1234 blue 1234 vs large134 red124 unifies, won't apply! we want to avoid that two variables are bound to one or maybe model the boundaries otherwise t)) return cxn)) -- GitLab From 82de9bb23de224232afe2579c15b30a3208b70f7 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Mon, 21 Mar 2022 13:49:56 +0100 Subject: [PATCH 005/157] intramsitive info and argument structure cxns --- .../bidirectional_grammar_info_arg_struct.fcg | 157 +++++++++++++++--- 1 file changed, 137 insertions(+), 20 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 85d9e11be..2ae9ad7ea 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -14,9 +14,6 @@ :no-applicable-cxns :connected-structure :no-meaning-in-root))) -;(comprehend "den Mann") -(formulate-all '((shop x))) - (def-fcg-cxn der-cxn ((?the-word @@ -70,6 +67,7 @@ (HASH form ((string ?the-word "die"))))) :disable-automatic-footprints t) + (def-fcg-cxn den-cxn ((?the-word (footprints (article))) @@ -87,6 +85,7 @@ (HASH form ((string ?the-word "den"))))) :disable-automatic-footprints t) + (def-fcg-cxn das-cxn ((?the-word (footprints (article))) @@ -105,8 +104,6 @@ :disable-automatic-footprints t) - - (def-fcg-cxn zum-cxn (<- (?to-word @@ -119,6 +116,7 @@ -- (HASH form ((string ?to-word "zum")))))) + (def-fcg-cxn aus-cxn (<- (?from-word @@ -164,6 +162,7 @@ -- (HASH form ((string ?man-word "Mann")))))) + (def-fcg-cxn Shop-cxn ((?shop-word (referent ?x) @@ -172,7 +171,7 @@ (?am ?am - - -) (- - - - -) (?dm ?dm - - -) - (?sm + - - ?np))))) + (?s + - - ?np))))) <- (?shop-word (HASH meaning ((shop ?x))) @@ -212,7 +211,6 @@ -- (HASH form ((string ?clown-word "Clown")))))) - (def-fcg-cxn noun-phrase-cxn ((?noun-phrase (referent ?x) @@ -251,6 +249,7 @@ :disable-automatic-footprints t) + (def-fcg-cxn contracted-prep-phrase-cxn ((?contracted-prep-phrase (referent ?x) @@ -286,7 +285,7 @@ :disable-automatic-footprints t) ;(comprehend "zum Mann") -;(formulate '((aus x))) +;(formulate-all '((aus x))) (def-fcg-cxn prep-phrase-cxn @@ -296,7 +295,7 @@ (case ?case)) (constituents (?preposition ?noun-phrase)) (boundaries (leftmost-unit ?preposition) - (rightmost-unit ?leftmost-noun-phrase))) + (rightmost-unit ?rightmost-noun-phrase))) (?preposition (part-of-prep-phrase +) (referent ?x)) @@ -322,6 +321,20 @@ )) :disable-automatic-footprints t) + +(def-fcg-cxn kommt-cxn + ((?come-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive)) + (referent ?k)) + + <- + (?come-word + (HASH meaning ((kommen-01 ?k))) + -- + (HASH form ((string ?come-word "kommt")))))) + (def-fcg-cxn sucht-cxn ((?search-word (syn-cat (lex-class verb) @@ -349,21 +362,19 @@ (HASH form ((string ?gift-word "schenkt")))))) -(def-fcg-cxn transitive-argument-structure-cxn ;can be both topicalized and not (make topicalized -) +(def-fcg-cxn transitive-argument-structure-cxn ((?transitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit)) - - ) + (constituents (?verb-unit ?agent-unit ?patient-unit))) <- (?verb-unit (syn-cat (lex-class verb) - (type transitive) - (tense ?tense)) + (aspect ?aspect) + (type transitive)) (referent ?v) -- (syn-cat (lex-class verb) - (type transitive) - (tense ?tense)) + (aspect ?aspect) + (type transitive)) (referent ?v)) (?agent-unit @@ -424,12 +435,12 @@ (?verb-unit (syn-cat (lex-class verb) (type transitive) - (tense ?tense)) + (aspect ?aspect)) (referent ?v) -- (syn-cat (lex-class verb) (type transitive) - (tense ?tense)) + (aspect ?aspect)) (referent ?v)) (?agent-unit @@ -456,6 +467,7 @@ (meets ?verb-unit ?leftmost-agent-unit))) ))) + ;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) ;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) @@ -593,8 +605,113 @@ +;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) -;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) +(def-fcg-cxn intransitive-argument-structure-cxn ;can be both topicalized and not (make topicalized -) + ((?intransitive-argument-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?location-unit + (syn-cat (syn-role complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg3) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg3)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg3 ?v ?arg3))) + -- + ))) + +(def-fcg-cxn intransitive-information-structure-cxn + ((?intransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit))) + (?arg-and-info-struct-unit + (constituents (?intransitive-information-structure-unit ?argument-structure-unit))) + <- + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit)) + -- + (constituents (?verb-unit ?agent-unit ?location-unit)) + ) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?location-unit + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + + )) + +(formulate-all '((man x))) + +;(formulate '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg3 k s))) +;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg3 k s))) -- GitLab From 018adcf02d9c3a7ddf6f4c3bd1e140dc7f58e371 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Mon, 21 Mar 2022 15:29:51 +0100 Subject: [PATCH 006/157] working on intransitive cxn with two prepositional cxns --- .../bidirectional_grammar_info_arg_struct.fcg | 296 +++++++++++++++++- 1 file changed, 291 insertions(+), 5 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 2ae9ad7ea..f80c2c75e 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -104,6 +104,19 @@ :disable-automatic-footprints t) +(def-fcg-cxn zur-cxn + (<- + (?to-word + (syn-cat (lex-class contracted-preposition) + (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) + (- - - - -) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (+ - ?df - -) + (+ - ?df - -)))) + -- + (HASH form ((string ?to-word "zur")))))) + + (def-fcg-cxn zum-cxn (<- (?to-word @@ -116,6 +129,19 @@ -- (HASH form ((string ?to-word "zum")))))) +(def-fcg-cxn mit-cxn + (<- + (?with-word + (syn-cat (lex-class preposition) + (preposition +) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?dm ?df ?dn ?dp)))) + -- + (HASH form ((string ?with-word "mit")))))) + (def-fcg-cxn aus-cxn (<- @@ -146,6 +172,20 @@ -- (HASH form ((string ?flowers-word "Blumen")))))) +(def-fcg-cxn Arbeit-cxn + ((?work-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nf - ?nf - -) + (?af - ?af - -) + (?gf - ?gf - -) + (?df - ?df - -) + (+ - + - -))))) + <- + (?work-word + (HASH meaning ((work ?x))) + -- + (HASH form ((string ?work-word "Arbeit")))))) (def-fcg-cxn Mann-cxn ((?man-word @@ -162,6 +202,21 @@ -- (HASH form ((string ?man-word "Mann")))))) +(def-fcg-cxn Fahrrad-cxn + ((?bike-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nn - - ?nn -) + (?an - - ?an -) + (- - - - -) + (?dn - - ?dn -) + (+ - - + -))))) + <- + (?bike-word + (HASH meaning ((bike ?x))) + -- + (HASH form ((string ?bike-word "Fahrrad")))))) + (def-fcg-cxn Shop-cxn ((?shop-word @@ -249,7 +304,6 @@ :disable-automatic-footprints t) - (def-fcg-cxn contracted-prep-phrase-cxn ((?contracted-prep-phrase (referent ?x) @@ -285,7 +339,7 @@ :disable-automatic-footprints t) ;(comprehend "zum Mann") -;(formulate-all '((aus x))) +;(formulate-all '((bike x))) (def-fcg-cxn prep-phrase-cxn @@ -335,6 +389,19 @@ -- (HASH form ((string ?come-word "kommt")))))) +(def-fcg-cxn geht-cxn + ((?go-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive)) + (referent ?g)) + + <- + (?go-word + (HASH meaning ((gehen-01 ?g))) + -- + (HASH form ((string ?go-word "geht")))))) + (def-fcg-cxn sucht-cxn ((?search-word (syn-cat (lex-class verb) @@ -475,7 +542,8 @@ -(def-fcg-cxn ditransitive-argument-structure-cxn ;can be both topicalized and not (make topicalized -) +;der Mann schenkt dem Clown die Blumen +(def-fcg-cxn ditransitive-argument-structure-cxn ((?ditransitive-argument-structure-unit (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) (?agent-unit @@ -608,8 +676,8 @@ ;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) - -(def-fcg-cxn intransitive-argument-structure-cxn ;can be both topicalized and not (make topicalized -) +;der Mann geht zur Arbeit +(def-fcg-cxn intransitive-argument-structure-cxn ((?intransitive-argument-structure-unit (constituents (?verb-unit ?agent-unit ?location-unit))) (?agent-unit @@ -710,6 +778,224 @@ )) +;(formulate-all '((gehen-01 g) (man m) (arg0 g m) (arbeit a) (arg3 g a))) + +;der Mann fährt mit der Wagen zur Arbeit + + +;;;;;;;BEFORE this cxns is applied, the intransitive-cxn applies (this double one has one more additional element) + + +#|(def-fcg-cxn double-intransitive-argument-structure-cxn + ((?double-intransitive-argument-structure-unit + (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?medium-unit + (syn-cat (syn-role m-complement))) + (?location-unit + (syn-cat (syn-role l-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?medium-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ms ?dm ?df ?dn ?dp)))) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ms ?dm ?df ?dn ?dp)))) + (referent ?arg2)) + + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg1)) + + (?double-intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) + + +(def-fcg-cxn double-intransitive-information-structure-cxn + ((?double-intransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit))) + (?arg-and-info-struct-unit + (constituents (?double-intransitive-information-structure-unit ?argument-structure-unit))) + <- + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit)) + -- + (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit)) + ) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?medium-unit + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-medium-unit) + (rightmost-unit ?rightmost-medium-unit)) + -- + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-medium-unit) + (rightmost-unit ?rightmost-medium-unit))) + + (?location-unit + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + + ))|# + + +(def-fcg-cxn diintransitive-argument-structure-cxn + ((?diintransitive-argument-structure-unit + (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?medium-unit + (syn-cat (syn-role medium-complement))) + (?location-unit + (syn-cat (syn-role location-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?medium-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ms ?dm ?df ?dn ?dp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ms ?dm ?df ?dn ?dp)))) + (referent ?arg1) + ) + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg2)) + + (?diintransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) + + (formulate-all '((man x))) ;(formulate '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg3 k s))) -- GitLab From b6e3cac98bd8a9fc0e3854e77759a39be65ee60a Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Mon, 21 Mar 2022 16:04:12 +0100 Subject: [PATCH 007/157] reworked all repairs to always include a ?left-?x-boundary and ?right-?x-boundary in form constraints of item based cxns --- experiments/grammar-learning/clevr/test.lisp | 2 +- .../basic-holistic-chunking.lisp | 21 +++++++- .../repair-holistic-to-item-based-cxn.lisp | 12 +++-- ...based+holistic+holistic--substitution.lisp | 22 ++++---- ...m-based+holistic+holophrase--deletion.lisp | 17 +++--- ...rase-to-item-based+holistic--addition.lisp | 18 ++++--- .../diagnostics-and-repairs/utils.lisp | 25 +++++++-- .../tests/test-deletion-repair.lisp | 17 +++++- .../test-holistic-to-item-based-repair.lisp | 3 +- .../tests/test-substitution-repair.lisp | 54 +++++++++++++++---- 10 files changed, 143 insertions(+), 48 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 0f00d40bc..eeb49834f 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 150) +;(run-series *experiment* 157) #| QUESTIONS diff --git a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp index 006daaabe..ee62e63d9 100644 --- a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp +++ b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp @@ -56,6 +56,25 @@ (meets ?tiny-unit ?yellow-unit)))))) +(def-fcg-cxn yellow-cxn + ((?yellow-unit + (args (?size-4 ?color-2)) + (syn-cat (phrase-type holistic) + (lex-class large-gray)) + (boundaries + (left ?yellow-unit) + (right ?yellow-unit)) + ) + <- + (?tiny-yellow-unit + (HASH meaning ((bind size-category ?size-4 tiny) + (bind color-category ?color-2 yellow))) + -- + (HASH form ( + (string ?yellow-unit "yellow") + ))))) + + (def-fcg-cxn the-x-object-is-what-shape-cxn ((?item-based-unit (syn-cat (phrase-type item-based)) @@ -92,6 +111,6 @@ (right ?gray-unit))))) - +(comprehend-and-formulate "The yellow object is what shape?") (comprehend-and-formulate "The tiny yellow object is what shape?") (comprehend-and-formulate "The large gray object is what shape?") diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index ac61dba3c..31b608bb6 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -90,11 +90,15 @@ for subtracted-meaning = (get-subtracted-meaning-from-car car gold-standard-meaning) for args = (extract-args-from-irl-network subtracted-meaning) for boundaries = (unit-feature-value unit 'boundaries) - for leftmost-unit-holistic-cxn = (second (first boundaries)) - for rightmost-unit-holistic-cxn = (second (second boundaries)) + for boundary-list = (list (second (first boundaries)) (second (second boundaries))) for holistic-slot-lex-class = (create-item-based-lex-class-with-var placeholder-var-string-predicates cxn-name-item-based-cxn string-var) ;; look up the X and Y in bindings + for placeholder-var = (third (find string-var placeholder-var-string-predicates :key #'second)) + for updated-form-constraints-and-boundaries = (multiple-value-list (add-boundaries-to-form-constraints item-based-cxn-form-constraints boundary-list :placeholder-var placeholder-var)) + for updated-form-constraints = (first updated-form-constraints-and-boundaries) + for updated-boundaries = (second updated-form-constraints-and-boundaries) for holistic-cxn-lex-class = (unit-feature-value (unit-feature-value unit 'syn-cat) 'lex-class) for categorial-link = (cons holistic-cxn-lex-class holistic-slot-lex-class) + do (setf item-based-cxn-form-constraints updated-form-constraints) collect subtracted-meaning into subtracted-meanings collect categorial-link into categorial-links collect holistic-cxn-unit-name into holistic-subunit-names @@ -104,8 +108,8 @@ (args ,args) -- (boundaries - (left ,leftmost-unit-holistic-cxn) - (right ,rightmost-unit-holistic-cxn)) + (left ,(first updated-boundaries)) + (right ,(second updated-boundaries))) ) into conditional-units finally (return (values conditional-units contributing-units holistic-subunit-names categorial-links subtracted-meanings))))) (holistic-cxn-conditional-units diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp index 485c53c9a..02522bb91 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp @@ -13,7 +13,7 @@ &key &allow-other-keys) "Repair by making a new item-based construction." (when (initial-node-p node) - (let ((constructions-and-categorial-links (create-item-based-cxn problem node))) + (let ((constructions-and-categorial-links (repair-holophrase->item-based+holistic+holistic--substitution problem node))) (when constructions-and-categorial-links (make-instance 'fcg::cxn-fix :repair repair @@ -26,14 +26,14 @@ &key &allow-other-keys) "Repair by making a new item-based construction." (when (initial-node-p node) - (let ((constructions-and-categorial-links (create-item-based-cxn problem node))) + (let ((constructions-and-categorial-links (repair-holophrase->item-based+holistic+holistic--substitution problem node))) (when constructions-and-categorial-links (make-instance 'fcg::cxn-fix :repair repair :problem problem :restart-data constructions-and-categorial-links))))) -(defun create-item-based-cxn (problem node) +(defun repair-holophrase->item-based+holistic+holistic--substitution (problem node) "Creates item-based construction and holistic constructions based on existing construction with sufficient overlap." (let* ((cxn-inventory (original-cxn-set (construction-inventory node))) @@ -72,13 +72,15 @@ based on existing construction with sufficient overlap." (boundaries-cxn-2 (get-boundary-units non-overlapping-form-observation)) (leftmost-unit-holistic-cxn-2 (first boundaries-cxn-2)) (rightmost-unit-holistic-cxn-2 (second boundaries-cxn-2)) + + (overlapping-form-and-rewritten-boundaries (multiple-value-list (add-boundaries-to-form-constraints overlapping-form-observation boundaries-cxn-2))) + (overlapping-form-with-rewritten-boundaries (first overlapping-form-and-rewritten-boundaries)) + (rewritten-boundaries (second overlapping-form-and-rewritten-boundaries)) (existing-item-based-cxn (find-cxn-by-form-and-meaning - overlapping-form-observation + overlapping-form-with-rewritten-boundaries overlapping-meaning-observation - cxn-inventory :boundary-list boundaries-cxn-2)) - - + cxn-inventory)) ;; unit names (unit-name-holistic-cxn-1 (unit-ify (make-cxn-name non-overlapping-form-cxn cxn-inventory :add-cxn-suffix nil))) @@ -168,13 +170,13 @@ based on existing construction with sufficient overlap." (?item-based-unit (HASH meaning ,overlapping-meaning-observation) -- - (HASH form ,overlapping-form-observation)) + (HASH form ,overlapping-form-with-rewritten-boundaries)) (,unit-name-holistic-cxn-2 (args ,args-holistic-cxn-2) -- (boundaries - (left ,leftmost-unit-holistic-cxn-2) - (right ,rightmost-unit-holistic-cxn-2)))) + (left ,(first rewritten-boundaries)) + (right ,(second rewritten-boundaries))))) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic+holistic--substitution :meaning ,(loop for predicate in overlapping-meaning-observation diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp index 6556ed61e..0dc604502 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp @@ -14,7 +14,7 @@ &key &allow-other-keys) "Repair by making a new item-based construction, holophrase and holistic cxn." (when (initial-node-p node) - (let ((constructions-and-categorial-links (create-repair-cxns-holophrase-single-deletion problem node))) + (let ((constructions-and-categorial-links (repair-holophrase->item-based+holistic+holophrase--deletion problem node))) (when constructions-and-categorial-links (make-instance 'fcg::cxn-fix :repair repair @@ -27,14 +27,14 @@ &key &allow-other-keys) "Repair by making a new item-based construction, holophrase and holistic cxn." (when (initial-node-p node) - (let ((constructions-and-categorial-links (create-repair-cxns-holophrase-single-deletion problem node))) + (let ((constructions-and-categorial-links (repair-holophrase->item-based+holistic+holophrase--deletion problem node))) (when constructions-and-categorial-links (make-instance 'fcg::cxn-fix :repair repair :problem problem :restart-data constructions-and-categorial-links))))) -(defun create-repair-cxns-holophrase-single-deletion (problem node) ;;node = cip node (transient struct, applied cxns, cxn-inventory, ..) +(defun repair-holophrase->item-based+holistic+holophrase--deletion (problem node) ;;node = cip node (transient struct, applied cxns, cxn-inventory, ..) "Creates item-based construction, a holophrase and a holistic construction based on an existing holophrase construction of which the form/meaning are a superset of the observed phrase. @@ -72,6 +72,9 @@ (find-cxn-by-form-and-meaning non-overlapping-form non-overlapping-meaning cxn-inventory)) (boundaries-holistic-cxn (get-boundary-units non-overlapping-form)) + (overlapping-form-and-rewritten-boundaries (multiple-value-list (add-boundaries-to-form-constraints overlapping-form boundaries-holistic-cxn))) + (overlapping-form-with-rewritten-boundaries (first overlapping-form-and-rewritten-boundaries)) + (rewritten-boundaries (second overlapping-form-and-rewritten-boundaries)) (leftmost-unit-holistic-cxn (first boundaries-holistic-cxn)) (rightmost-unit-holistic-cxn (second boundaries-holistic-cxn)) (holistic-cxn-name @@ -79,7 +82,7 @@ (cxn-name-item-based-cxn (make-cxn-name (substitute-slot-meets-constraints non-overlapping-form overlapping-form) cxn-inventory :add-numeric-tail t)) (existing-item-based-cxn - (find-cxn-by-form-and-meaning overlapping-form overlapping-meaning cxn-inventory :boundary-list boundaries-holistic-cxn)) + (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries overlapping-meaning cxn-inventory)) (unit-name-holistic-cxn (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil))) ;; lex-class @@ -165,13 +168,13 @@ (?item-based-unit (HASH meaning ,overlapping-meaning) -- - (HASH form ,overlapping-form)) + (HASH form ,overlapping-form-with-rewritten-boundaries)) (,unit-name-holistic-cxn (args ,args-holistic-cxn) -- (boundaries - (left ,leftmost-unit-holistic-cxn) - (right ,rightmost-unit-holistic-cxn)))) + (left ,(first rewritten-boundaries)) + (right ,(second rewritten-boundaries))))) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic+holophrase--deletion :meaning ,(loop for predicate in overlapping-meaning diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp index b4e212e2f..16376ab7f 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp @@ -13,7 +13,7 @@ &key &allow-other-keys) "Repair by making a new item-based construction and holistic cxn." (when (initial-node-p node) - (let ((constructions-and-categorial-links (create-repair-cxns-holophrase-addition problem node))) + (let ((constructions-and-categorial-links (repair-holophrase->item-based+holistic--addition problem node))) (when constructions-and-categorial-links (make-instance 'fcg::cxn-fix :repair repair @@ -26,7 +26,7 @@ &key &allow-other-keys) "Repair by making a new item-based construction and holistic cxn." (when (initial-node-p node) - (let ((constructions-and-categorial-links (create-repair-cxns-holophrase-addition problem node))) + (let ((constructions-and-categorial-links (repair-holophrase->item-based+holistic--addition problem node))) (when constructions-and-categorial-links (make-instance 'fcg::cxn-fix :repair repair @@ -34,7 +34,7 @@ :restart-data constructions-and-categorial-links))))) -(defun create-repair-cxns-holophrase-addition (problem node) ;;node = cip node (transient struct, applied cxns, cxn-inventory, ..) +(defun repair-holophrase->item-based+holistic--addition (problem node) ;;node = cip node (transient struct, applied cxns, cxn-inventory, ..) "Creates item-based construction and a holistic construction based on an existing holophrase construction of which the form/meaning are a subset of the observed phrase, and there is a maximum of one differing meaning predicate @@ -66,6 +66,9 @@ (existing-holistic-cxn (find-cxn-by-form-and-meaning non-overlapping-form non-overlapping-meaning cxn-inventory)) (boundaries-holistic-cxn (get-boundary-units non-overlapping-form)) + (overlapping-form-and-rewritten-boundaries (multiple-value-list (add-boundaries-to-form-constraints overlapping-form boundaries-holistic-cxn))) + (overlapping-form-with-rewritten-boundaries (first overlapping-form-and-rewritten-boundaries)) + (rewritten-boundaries (second overlapping-form-and-rewritten-boundaries)) (leftmost-unit-holistic-cxn (first boundaries-holistic-cxn)) (rightmost-unit-holistic-cxn (second boundaries-holistic-cxn)) (holistic-cxn-name (make-cxn-name non-overlapping-form cxn-inventory :add-numeric-tail t)) @@ -73,7 +76,7 @@ (cxn-name-item-based-cxn (make-cxn-name (substitute-slot-meets-constraints non-overlapping-form overlapping-form) cxn-inventory :add-numeric-tail t)) (existing-item-based-cxn - (find-cxn-by-form-and-meaning overlapping-form overlapping-meaning cxn-inventory :boundary-list boundaries-holistic-cxn)) + (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries overlapping-meaning cxn-inventory)) (unit-name-holistic-cxn (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil)) ) @@ -128,13 +131,13 @@ (?item-based-unit (HASH meaning ,overlapping-meaning) -- - (HASH form ,overlapping-form)) + (HASH form ,overlapping-form-with-rewritten-boundaries)) (,unit-name-holistic-cxn (args ,args-holistic-cxn) -- (boundaries - (left ,leftmost-unit-holistic-cxn) - (right ,rightmost-unit-holistic-cxn)))) + (left ,(first rewritten-boundaries)) + (right ,(second rewritten-boundaries))))) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic--addition :meaning ,(loop for predicate in overlapping-meaning @@ -144,6 +147,7 @@ return (first predicate)) :string ,(third (find 'string overlapping-form :key #'first))) :cxn-inventory ,(copy-object cxn-inventory))))))) + (existing-cxns (list existing-holistic-cxn existing-item-based-cxn)) (cxns-to-apply (list holistic-cxn item-based-cxn)) (cat-links-to-add (list categorial-link)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 88b385c9e..654b9477e 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -56,6 +56,24 @@ (not meets-string-diff)) t))) +(defun add-boundaries-to-form-constraints (form-constraints boundaries &key placeholder-var) + "given a list of boundaries that correspond to a certain slot and a list of form constraints, + create a new variable for left and right boundary, also if the original left and right boundary vars were identical + return both the form constraints and the new boundary list" + (let* ((new-form-constraints (copy-object form-constraints)) + (placeholder-var (string-upcase (if placeholder-var placeholder-var "?X"))) + (left-var (intern (format nil "?LEFT-~a-BOUNDARY" placeholder-var))) + (right-var (intern (format nil "?RIGHT-~a-BOUNDARY" placeholder-var))) + (left-boundary (first boundaries)) + (right-boundary (second boundaries)) + (matching-left-predicate (find left-boundary new-form-constraints :key #'third)) + (matching-right-predicate (find right-boundary new-form-constraints :key #'second))) + (when matching-left-predicate + (setf (nth 2 matching-left-predicate) left-var)) + (when matching-right-predicate + (setf (nth 1 matching-right-predicate) right-var)) + (values new-form-constraints (list left-var right-var)))) + (defun get-boundary-units (form-constraints) "returns the leftmost and rightmost unit based on meets constraints, even when the meets predicates are in a random order" (let* ((left-units (loop for fc in form-constraints @@ -170,15 +188,14 @@ (set-difference network-2 unique-part-network-2))) (values unique-part-network-1 unique-part-network-2)))) -(defun find-cxn-by-form-and-meaning (form meaning cxn-inventory &key boundary-list) +(defun find-cxn-by-form-and-meaning (form meaning cxn-inventory) "returns a cxn with the same meaning and form if it's in the cxn-inventory" (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) for boundary-list-cxn = (boundary-list cxn) when (and (irl:equivalent-irl-programs? form (extract-form-predicates cxn)) (irl:equivalent-irl-programs? meaning (extract-meaning-predicates cxn)) - (if boundary-list ;; needed for item-based cxns! check if variables unify - (unify boundary-list-cxn boundary-list) ;; issue: blue1234 blue 1234 vs large134 red124 unifies, won't apply! we want to avoid that two variables are bound to one or maybe model the boundaries otherwise - t)) + ; note: boundaries and args are ignored, as they are designed to always match, and fully depend on form and meaning anyway. + ) return cxn)) diff --git a/systems/grammar-learning/tests/test-deletion-repair.lisp b/systems/grammar-learning/tests/test-deletion-repair.lisp index 0cf548b54..f8b95dd65 100644 --- a/systems/grammar-learning/tests/test-deletion-repair.lisp +++ b/systems/grammar-learning/tests/test-deletion-repair.lisp @@ -26,7 +26,19 @@ (bind attribute-category ?attribute-2 shape) (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 gray) - (query ?target-7 ?source-9 ?attribute-2)))))))) + (query ?target-7 ?source-9 ?attribute-2)))))) + (comprehend "The large gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-39552 ?target-2 ?size-4) + (unique ?source-10 ?target-39552) + (bind color-category ?color-2 gray) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-4 large) + (query ?target-8 ?source-10 ?attribute-2))))) (deftest test-reordered-double-deletion-repair-comprehension () @@ -57,7 +69,8 @@ (bind attribute-category ?attribute-2 shape) (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 gray) - (query ?target-7 ?source-9 ?attribute-2)))))))) + (query ?target-7 ?source-9 ?attribute-2)))))) + (add-element (make-html cxn-inventory)))) (deftest test-double-deletion-repair-comprehension () diff --git a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp index 2466097c1..04cccee14 100644 --- a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp +++ b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp @@ -215,10 +215,11 @@ (filter ?target-2 ?target-1 ?color-16) (bind size-category ?size-4 large) (query ?target-4 ?target-object-1 ?attribute-2)))))))) +;; (activate-monitor trace-fcg) (defun run-holistic-to-item-based-tests () (test-holistic-to-item-based-from-substitution-comprehension) - (test-holistic-to-item-based-from-double-substitution-comprehension) + (test-holistic-to-item-based-from-double-substitution-comprehension) (test-multiple-holistic-to-item-based-repair-comprehension) (test-holistic-to-item-based-duplicates-comprehension) (test-double-holistic-to-item-based-from-substitution-repair-comprehension) diff --git a/systems/grammar-learning/tests/test-substitution-repair.lisp b/systems/grammar-learning/tests/test-substitution-repair.lisp index ba4d39fe1..93ec6a949 100644 --- a/systems/grammar-learning/tests/test-substitution-repair.lisp +++ b/systems/grammar-learning/tests/test-substitution-repair.lisp @@ -328,17 +328,55 @@ (test-repair-status 'holophrase->item-based+holistic+holistic--substitution (second (multiple-value-list - (comprehend "What is the size of the large yellow cube?" + (comprehend "What is the size of the yellow metallic cube?" :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) - (filter ?target-2 ?target-1 ?color-16) + (filter ?target-86448 ?target-2 ?color-16) + (unique ?target-object-1 ?target-86448) + (bind material-category ?material-4 metal) + (filter ?target-1 ?source-1 ?shape-2) + (bind attribute-category ?attribute-6 size) + (bind shape-category ?shape-2 cube) + (filter ?target-2 ?target-1 ?material-4) + (bind color-category ?color-16 yellow) + (query ?target-4 ?target-object-1 ?attribute-6)))))))) + +(defun test-deletion-variable-rightmost-boundary-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "What is the size of the red cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-4) (unique ?target-object-1 ?target-2) (bind shape-category ?shape-2 cube) (bind attribute-category ?attribute-6 size) (filter ?target-1 ?source-1 ?shape-2) - (bind color-category ?color-16 yellow) + (bind color-category ?color-4 red) + (query ?target-4 ?target-object-1 ?attribute-6))) + (comprehend "What is the size of the cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-1 ?source-1 ?shape-2) + (unique ?target-object-1 ?target-1) + (bind attribute-category ?attribute-6 size) + (bind shape-category ?shape-2 cube) + (query ?target-4 ?target-object-1 ?attribute-6))) + + + (test-repair-status 'holophrase->item-based+holistic+holistic--substitution + (second (multiple-value-list + (comprehend "What is the size of the red cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-4) + (unique ?target-object-1 ?target-2) + (bind shape-category ?shape-2 cube) + (bind attribute-category ?attribute-6 size) + (filter ?target-1 ?source-1 ?shape-2) + (bind color-category ?color-4 red) (query ?target-4 ?target-object-1 ?attribute-6)))))))) - +;; (activate-monitor trace-fcg) ;; (test-substitution-repair-comprehension) ;ok ;; (test-substitution-repair-comprehension-right) ;ok ;; (test-substitution-repair-comprehension-multi-diff) ;should be holophrase @@ -349,10 +387,4 @@ ;; (test-varying-word-order-substitution-comprehension) ;should be holophrase ;; (test-varying-length-substitution-repair-comprehension) ;ok ;; (test-varying-length-substitution-repair-comprehension-reversed) ;ok -;; (test-no-duplicate-item-based-cxns-substitution-comprehension) ;ok but we want to reuse the item-based cxn, the boundaries don't unify though... a case for anti-unification! - - - - - - +;; (test-no-duplicate-item-based-cxns-substitution-comprehension) ;ok -- GitLab From 1ed75d0a66039e1ae6e3895d0b99209929889f16 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Mon, 21 Mar 2022 16:17:05 +0100 Subject: [PATCH 008/157] minor fix in oneliner to visualise categorial network --- experiments/grammar-learning/clevr/test.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index eeb49834f..5b3fdda2a 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -65,7 +65,7 @@ ;(cl-store:store (grammar (first (agents *experiment*))) (babel-pathname :directory '("experiments" "clevr-grammar-learning" "raw-data") :name "cxn-inventory-train-random" :type "store")) -;(add-element (make-html (get-type-hierarchy (grammar (first (agents *experiment*)))) :weights t)) +;(add-element (make-html (categorial-network (grammar (first (agents *experiment*)))) :weights t)) ;(add-element (make-html (grammar (first (agents *experiment*))))) ;(defparameter *th* (categorial-network (grammar (first (interacting-agents *experiment*))))) @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 157) +;(run-series *experiment* 1000) #| QUESTIONS -- GitLab From fcad982e7601719502db7d3666571adf01287599 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Mon, 21 Mar 2022 19:35:48 +0100 Subject: [PATCH 009/157] reworked tristan grammar with semantic frame/facts meaning and procedural discourse meaning --- .../discourse-understanding.asd | 3 + .../tristan-experiment/grammar.lisp | 526 ++++++++++++++++++ .../start-tristan.lisp | 7 +- 3 files changed, 534 insertions(+), 2 deletions(-) create mode 100644 applications/discourse-understanding/tristan-experiment/grammar.lisp rename applications/discourse-understanding/{ => tristan-experiment}/start-tristan.lisp (70%) diff --git a/applications/discourse-understanding/discourse-understanding.asd b/applications/discourse-understanding/discourse-understanding.asd index 4c136e098..2492f8a72 100644 --- a/applications/discourse-understanding/discourse-understanding.asd +++ b/applications/discourse-understanding/discourse-understanding.asd @@ -18,6 +18,9 @@ ) :serial t :components ((:file "package") + (:module "tristan-experiment" + :serial t + :components ((:file "grammar"))) (:module "matilda-experiment" :serial t :components ((:file "discourse-memory") diff --git a/applications/discourse-understanding/tristan-experiment/grammar.lisp b/applications/discourse-understanding/tristan-experiment/grammar.lisp new file mode 100644 index 000000000..9194dca00 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/grammar.lisp @@ -0,0 +1,526 @@ +(in-package :discourse-understanding) + +;;; ------------------------------------------------------------------------------------------------ +;;; Grammar of Pangloss. Professor Pangloss is wise and has world knowledge available for reasoning. +;;; ------------------------------------------------------------------------------------------------ + +(def-fcg-constructions pangloss-grammar + :feature-types ((boundaries set-of-predicates) + (ontology-class set) + (discourse-function set-of-predicates) + (meaning set-of-predicates) + (form set-of-predicates) + (subunits set) + (discourse-meaning set-of-predicates) + (facts-meaning set-of-predicates) + (gender sequence) ;; (m v o) + (number sequence)) ;; (1sg 2sg 3sg pl) + :fcg-configurations (;(:construction-inventory-processor-mode . :incremental-processing) + ;(:node-expansion-mode . :incremental-processing) + (:form-predicates meets last) + (:de-render-mode . :de-render-with-scope) + (:node-tests :update-references + :check-duplicate :restrict-nr-of-nodes) + (:parse-order morph-lex phrasal cxn topology tam) + ) + :cxn-inventory *pangloss*) + + ;; We put a pointer to the discourse memory in the construction inventory: +; (set-data (blackboard *pangloss*) 'discourse-memory (make-instance 'discourse-memory)) + ; (set-data (blackboard *pangloss*) 'ontology (make-pangloss-ontology)) + + ;; Morphological constructions + + (def-fcg-cxn geboren-morph + (<- + (?geboren + (lex-id baren) + (syn-cat (lex-class verb) + (verb-form past-participle) + (number ?number) + (finite -)) + -- + (hash form ((string ?geboren "geboren"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + +(def-fcg-cxn dood-morph + (<- + (?dood + (lex-id dead) + (syn-cat (lex-class adjective)) + -- + (hash form ((string ?dood "dood"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + +; when lex-id dead is found, add dead-frame and roles +(def-fcg-cxn dood-frame-cxn + ((?dood-lex + (referent ?ent) + (sem-valence (undergoer ?deceased))) + <- + (?dood-lex + (hash meaning ((entity ?ent) + (death-frame ?ent ?event) + (deceased-role ?event ?deceased))) + -- + (lex-id dead))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + + ;; Lexical constructions + (def-fcg-cxn toen-cxn + ((?toen + (lex-id toen) + (referent ?ev) + (syn-cat (lex-class adverb) + ;(phrase-type adverbial-phrase) + ) + (parent ?parent) + ) + <- + (?toen + ;(hash meaning ((reference-point ?some-ev ?ev))) + -- + (hash form ((string ?toen "Toen"))))) ;; Todo: take care of case sensitivity + :cxn-inventory *pangloss* + :cxn-set morph-lex) + + (def-fcg-cxn Tristan-cxn + ((?tristan + (referent ?ent) + (lex-id tristan) + ; (sem-cat (discourse-status identifiable)) + (syn-cat (lex-class propernoun) + (phrase-type noun-phrase) + (agreement (number (- - 3sg -)) + (gender (m - -))))) + <- + (?tristan + (discourse-meaning ((handle-referent ?ent ?status) + (bind discourse-status ?status identifiable))) + (meaning ((entity ?ent) + (tristan-frame ?ent ?ref) + (name-role ?ref "Tristan") + (gender-role ?ref male))) + -- + (hash form ((string ?tristan "Tristan"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + + (def-fcg-cxn Adverbial-Clause-passive-cxn + ((?adverbial-clause-unit + (referent ?ev) + (syn-cat (clause-type adverbial-clause)) + (subunits (?adverb-unit ?np-unit ?vp-unit)) + ) + <- + (?adverbial-clause-unit + -- + (HASH form ((meets ?adverb-unit ?np-unit ?scope) + (meets ?np-unit ?vp-unit ?scope)))) + (?adverb-unit + -- + (syn-cat (lex-class adverb))) + (?np-unit + -- + (referent ?referent) + (syn-cat (phrase-type noun-phrase))) + (?vp-unit + -- + (referent ?ev) + (sem-valence (actor ?mother) + (undergoer ?referent)) + (syn-cat (voice passive) + (phrase-type verb-phrase)))) + :cxn-set cxn + :cxn-inventory *pangloss*) + + +; when lex-id baren, add birth-frame, and its roles + (def-fcg-cxn baren-frame-cxn + ((?baren + (referent ?ent) + (sem-valence (actor ?mother) + (undergoer ?child))) + <- + (?baren + (meaning ((entity ?ent) + (birth-frame ?ent ?ev) + (mother-role ?ev ?mother) + (father-role ?ev ?father) + (child-role ?ev ?child))) + (discourse-meaning ((handle-referent ?ent ?status) + (bind discourse-status ?status identifiable))) + -- + (lex-id baren) + (syn-cat (lex-class verb) + (verb-form ?verb-form) + (finite ?finite) + (number ?number)))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + + + (def-fcg-cxn werd-morph + ((?werd + (parent ?parent) + (referent ?ref)) + <- + (?werd + (lex-id zijn) + (syn-cat (lex-class ?lex-class) + (passive-aux? +) + (verb-form verleden-tijd) + (finite +) + (number (?1sg ?2sg ?3sg -))) + -- + (hash form ((string ?werd "werd"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + +(def-fcg-cxn vp-passive-cxn + ((?vp-unit + (referent ?ref) + (syn-cat (lex-class verb) + (voice passive) + (phrase-type verb-phrase) + (finite +)) + (sem-valence (actor ?mother) + (undergoer ?child)) + (subunits (?aux-unit ?main-verb-unit))) + <- + (?vp-unit + -- + (HASH form ((meets ?main-verb-unit ?aux-unit ?scope))) + ) + (?aux-unit + (referent ?ref) + -- + (syn-cat (verb-form ?verb-form) + (passive-aux? +) + (finite +))) + (?main-verb-unit + (referent ?ref) + -- + (sem-valence (actor ?mother) + (undergoer ?child)) + (syn-cat (lex-class verb) + (verb-form past-participle)))) + :cxn-set cxn + :cxn-inventory *pangloss*) + + + (def-fcg-cxn was-morph + ((?was + (referent ?ev) + (parent ?parent) + (syn-cat (is-passive-aux ?passive-aux) + (is-copula ?is-copula))) + <- + (?was + (lex-id zijn) + (syn-cat (lex-class ?lex-class) + (verb-form verleden-tijd) + (number (?1sg ?2sg ?3sg -)) + (finite +)) + -- + (hash form ((string ?was "was"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + + (def-fcg-cxn vader-lex ;; we will ignore number differences + ((?vader + (parent ?parent) + (referent ?ent) + (ontological-class father-frame) + (syn-cat (lex-class noun) + (agreement (number (- - 3sg -)) + (gender (M - -))))) + <- + (?vader + (meaning ((entity ?ent) + (father-frame ?ent ?ref) + (child-role ?ref ?child) + ;(mother-role ?ref ?mother) + )) + -- + (hash form ((string ?vader "vader"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss* + ) + + (def-fcg-cxn zijn-morph + ((?zijn + (referent ?man) + (parent ?parent)) + <- + (?zijn + (lex-id possessive-pronoun) + (syn-cat (lex-class determiner) + (lex-subclass possessive-pronoun) + (agreement (number (- - 3sg -)) + (gender (?m - ?o)))) + ;(meaning ((gender ?man male))) + + -- + (hash form ((string ?zijn "zijn"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + + (def-fcg-cxn possessive-NP-cxn + ((?poss-pronoun-unit + (discourse-meaning ((handle-referent ?owner ?status) + (bind discourse-status ?status identifiable)))) + (?noun-unit + (discourse-meaning ((handle-referent ?ent ?status) + (bind discourse-status ?status identifiable)))) + (?possessive-np-unit + (referent ?ent) + (syn-cat (phrase-type noun-phrase)) + (subunits (?poss-pronoun-unit ?noun-unit))) + <- + (?possessive-np-unit + -- + (hash form ((meets ?poss-pronoun-unit ?noun-unit ?scope)))) + (?poss-pronoun-unit + (referent ?owner) + -- + (lex-id possessive-pronoun) + (syn-cat (agreement (number (?msg ?fsg ?osg ?pl)) + (gender (?m ?f ?o))))) + (?noun-unit + (referent ?ent) + (syn-cat (phrase-type noun-phrase) + (discourse-status identifiable) + (agreement (number (?msg ?fsg ?osg ?pl)) + (gender (?m ?f ?o)))) + + -- + (meaning ((?frame ?ent ?ref) + (?role ?ref ?owner))) + (ontological-class ?frame) + (syn-cat (lex-class noun)) + )) + :cxn-set phrasal + :cxn-inventory *pangloss*) + + #|(def-fcg-cxn possessive-NP-cxn + ((?poss-pronoun-unit + (discourse-meaning ((handle-referent ?owner ?status) + (bind discourse-status ?status identifiable)))) + (?noun-unit + (discourse-meaning ((handle-referent ?ref ?status) + (bind discourse-status ?status identifiable)))) + (?possessive-np-unit + (referent ?ref) + (syn-cat (phrase-type noun-phrase)) + (subunits (?poss-pronoun-unit ?noun-unit))) + <- + (?possessive-np-unit + -- + (hash form ((meets ?poss-pronoun-unit ?noun-unit ?scope)))) + (?poss-pronoun-unit + (referent ?owner) + -- + (lex-id possessive-pronoun)) + (?noun-unit + (referent ?ref) + (syn-cat (phrase-type noun-phrase) + (discourse-status identifiable)) + (meaning ((?class ?owner ?ref))) + -- + (ontological-class ?class) + (syn-cat (lex-class noun)) + )) + :cxn-set phrasal + :cxn-inventory *pangloss*)|# + + (def-fcg-cxn adverbial-clause-front-field-cxn + ((?matrix-clause + (referent ?ev) + (syn-cat (clause-type main-clause)) + (fields (front-field ?adverbial-clause) + (left-bracket ?finite-verb) + (midfield ?midfield)) + (subunits (?adverbial-clause ?comma ?finite-verb ?subject-np ?adjective))) + <- + (?matrix-clause + -- + (hash form ((meets ?adverbial-clause ?comma ?scope) + (meets ?comma ?finite-verb ?scope) + (meets ?finite-verb ?subject-np ?scope) + (meets ?subject-np ?adjective ?scope)))) + (?comma + (punctuation-type comma) + -- + (hash form ((string ?comma ",")))) + (?adverbial-clause + ;(parent ?matrix-clause) + -- + (syn-cat (clause-type adverbial-clause))) + + (?finite-verb + -- + (referent ?ev) + (syn-cat (lex-class verb) + (finite +))) + (?subject-np + -- + (referent ?subject-ref) + (syn-cat (phrase-type noun-phrase))) + (?adjective + -- + (referent ?ref) + (sem-valence (undergoer ?subject-ref)) + (syn-cat (lex-class adjective)))) + :cxn-set topology + :cxn-inventory *pangloss*) + + + + (def-fcg-cxn toen-x-y-cxn + (<- + (?toen-phrase + (meaning ((event-time ?ev ?rp))) + (referent ?ev) + -- + (lex-id toen) + (syn-cat (clause-type adverbial-clause))) + (?main-clause + (meaning ((reference-point ?ev ?rp))) + -- + (syn-cat (clause-type main-clause)) + (fields (front-field ?toen-phrase)))) + :cxn-set tam + :cxn-inventory *pangloss*) + + + #|(def-fcg-cxn al-cxn + ((?al + (syn-cat (lex-class adverb) + (phrase-type adverbial-phrase)) + (parent ?parent)) + <- + (?al + (lex-id al) + -- + (hash form ((string ?al "al"))))) ;; Todo: take care of case sensitivity + :cxn-inventory *pangloss* + :cxn-set morph-lex) + + (def-fcg-cxn twee-lex + ((?twee + (lex-id twee) + (referent ?ref) + (parent ?parent) + (syn-cat (lex-class determiner) + (lex-subclass adjectival-determiner) + (agreement (number (- - - pl)) + (gender ?gender)))) + <- + (?twee + (hash meaning ((two ?ref))) + -- + (hash form ((string ?twee "twee"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*)|# + + #|(def-fcg-cxn adjectival-determined-noun-phrase-cxn + (<- + (?adjectival-determiner + (parent ?noun) + (referent ?ref) + -- + (syn-cat (lex-subclass adjectival-determiner) + (agreement (number ?number) + (gender ?gender)))) + (?noun + (referent ?ref) + (subunits (?adjectival-determiner)) + (syn-cat (phrase-type noun-phrase) + (discourse-status ?discourse-status)) + -- + (syn-cat (lex-class noun) + (agreement (number ?number) + (gender ?gender))))) + :cxn-set phrasal + :cxn-inventory *pangloss*)|# +#| + (def-fcg-cxn maand-lex + ((?maand-woord + (lex-id maand) + (parent ?parent) + (referent ?ref) + (sem-cat (ontology-class (measure-of-time))) + (syn-cat (lex-class noun) + (agreement (number ?number) + (gender (?m ?v -))))) + <- + (?maand-woord + (hash meaning ((month ?ref))) + -- + (lex-id maand))) + :cxn-set morph-lex + :cxn-inventory *pangloss*) + + (def-fcg-cxn maanden-morph + (<- + (?maanden + (lex-id maand) + (syn-cat (lex-class noun) + (agreement (number (- - - pl)) + (gender (?m ?v -)))) + -- + (hash form ((string ?maanden "maanden"))))) + :cxn-set morph-lex + :cxn-inventory *pangloss*)|# + + +#| ;; Midfield expansion: + (def-fcg-cxn Midfield-Adverbial-cxn + (<- + (?midfield + (subunits (?adverbial-phrase)) + -- + (unit-type midfield) + (subunits (?noun-phrase)) + (hash form ((meets ?noun-phrase ?adverbial-phrase ?scope)))) + (?adverbial-phrase + (parent ?midfield) + -- + (syn-cat (phrase-type adverbial-phrase)))) + :cxn-set topology + :cxn-inventory *pangloss*) +|# + +;;; (def-fcg-cxn attributive-complement-cxn +;;; (<- +;;; (?midfield +;;; (subunits (?attributive-phrase)) +;;; -- +;;; (unit-type midfield) +;;; (subunits (?noun-phrase)) +;;; (hash form ((meets ?noun-phrase ?attributive-phrase ?scope)))) +;;; (?noun-phrase +;;; -- +;;; (syn-cat (phrase-type noun-phrase))) +;;; (?attributive-phrase +;;; (parent ?midfield) +;;; (syn-cat (phrase-type attributive-phrase)) +;;; -- +;;; (syn-cat (lex-class adjective)))) +;;; :cxn-set topology +;;; :cxn-inventory *pangloss*)) + +#| +(progn + (setf *pangloss* (make-pangloss-grammar-cxns)) + (read-story *document* *pangloss*) + (add-element `((h2) "Entities in discourse memory:")) + (loop for entity in (accessible-entities (discourse-memory *pangloss*)) + do (add-element (make-html entity)))) +|# + + diff --git a/applications/discourse-understanding/start-tristan.lisp b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp similarity index 70% rename from applications/discourse-understanding/start-tristan.lisp rename to applications/discourse-understanding/tristan-experiment/start-tristan.lisp index 3c7e77a73..b284d103a 100644 --- a/applications/discourse-understanding/start-tristan.lisp +++ b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp @@ -4,7 +4,8 @@ (activate-monitor trace-fcg) (activate-monitor trace-irl) - +(comprehend "Toen Tristan geboren werd , was zijn vader dood" :cxn-inventory *pangloss*) +(comprehend-all "Toen Tristan geboren werd , was zijn vader dood" :cxn-inventory *pangloss*) ;; Do this after loading the file: #| (progn @@ -14,4 +15,6 @@ (add-element `((h2) "Entities in discourse memory:")) (loop for entity in (accessible-entities (discourse-memory *pangloss*)) do (add-element (make-html entity)))) -| \ No newline at end of file +| + +;; mss moeten discourse cxns toch nog meer apart \ No newline at end of file -- GitLab From cd578755c78be4a29c89d6e2c57ca5b29ba6eee3 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 22 Mar 2022 10:10:04 +0100 Subject: [PATCH 010/157] moving helper functions to utils --- experiments/grammar-learning/clevr/test.lisp | 6 ++-- .../repair-holistic-to-item-based-cxn.lisp | 33 ++----------------- .../diagnostics-and-repairs/utils.lisp | 32 +++++++++++++++++- 3 files changed, 36 insertions(+), 35 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 5b3fdda2a..49ef5de49 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 1000) +;(run-series *experiment* 8800) #| QUESTIONS @@ -109,7 +109,7 @@ TODO uncovered = length of what is left in root = what is the = 3 try: yellow object, shape -voorbeeld: +example: utterance: what is the color of the sphere step 1: find all matching cxns: what is the color of the, what is the, color of the cube @@ -119,7 +119,7 @@ step 3: try collisions (while collisions: try) what is the + color of the cube: uncovered = 0 - for item-based to holistic cxn, use fcg-apply for all holistic cxns, then the item-based cxns (must be at least one!), then create the missing holistic cxns for whatever is left in the root if it's continuous -- fix namen van monitors +- fix monitor names - reverse exported jsonl graph |# diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index 31b608bb6..8dcaccf9a 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -33,26 +33,6 @@ :problem problem :restart-data constructions-and-th-links))))) -(defun create-item-based-lex-class-with-var (placeholder-var-string-predicates cxn-name-item-based-cxn slot-var) - "create the what-is-the-size-of-the-?Y-?X-12-(?X) lex class for a specific slot var" - (let ((placeholder (third (find slot-var placeholder-var-string-predicates :key #'second)))) - (make-lex-class (concatenate 'string (symbol-name cxn-name-item-based-cxn) "-(" placeholder ")")))) - - -(defun get-car-for-unit (unit cars) - (loop for car in cars - for resulting-left-pole-structure = (left-pole-structure (car-resulting-cfs car)) - for root = (get-root resulting-left-pole-structure) - for res-unit = (last-elt (remove root resulting-left-pole-structure)) ;;match with last - when (equal res-unit unit) - return car)) - -(defun get-subtracted-meaning-from-car (car gold-standard-meaning) - (let* ((cxn-meaning (extract-meaning-predicates (original-cxn (car-applied-cxn car)))) - (subtracted-meaning (second (multiple-value-list (commutative-irl-subset-diff gold-standard-meaning cxn-meaning))))) - subtracted-meaning)) - - (defun create-item-based-cxn-from-partial-holistic-analysis (problem node) "Creates item-based construction around matching holistic constructions" (let* ((cxn-inventory (construction-inventory node)) @@ -69,13 +49,7 @@ (resulting-root (get-root resulting-left-pole-structure)) (resulting-units (remove resulting-root resulting-left-pole-structure)) (item-based-cxn-form-constraints (unit-feature-value resulting-root 'form)) - ; create function for this with a descriptive name - (chunk-item-based-cxn-form-constraints (loop with item-based-fc = item-based-cxn-form-constraints - for unit in resulting-units - for fc = (unit-feature-value unit 'form) - do (setf item-based-fc (substitute-slot-meets-constraints fc item-based-fc)) - finally return item-based-fc)) - + (chunk-item-based-cxn-form-constraints (make-item-based-name-form-constraints-from-units item-based-cxn-form-constraints resulting-units)) (placeholder-var-string-predicates (variablify-missing-form-strings chunk-item-based-cxn-form-constraints)) (cxn-name-item-based-cxn (make-cxn-name (append placeholder-var-string-predicates chunk-item-based-cxn-form-constraints) @@ -120,10 +94,7 @@ (third holistic-cxn-subunit-blocks)) (cat-links-to-add (fourth holistic-cxn-subunit-blocks)) (subtracted-meanings (fifth holistic-cxn-subunit-blocks)) - (item-based-cxn-meaning (loop with item-based-meaning = (copy-object gold-standard-meaning) - for network in subtracted-meanings - do (setf item-based-meaning (set-difference item-based-meaning network :test #'equal)) - finally return item-based-meaning)) + (item-based-cxn-meaning (subtract-holistic-from-item-based-meaning gold-standard-meaning subtracted-meanings)) (item-based-cxn (second (multiple-value-list (eval `(def-fcg-cxn ,(add-cxn-suffix cxn-name-item-based-cxn) diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 654b9477e..e288e1766 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -344,7 +344,37 @@ (mapcar #'variablify (rest fc-with-const))) collect (cons first-fc-with-var rest-fc-with-var)))) - +(defun create-item-based-lex-class-with-var (placeholder-var-string-predicates cxn-name-item-based-cxn slot-var) + "create the what-is-the-size-of-the-?Y-?X-12-(?X) lex class for a specific slot var" + (let ((placeholder (third (find slot-var placeholder-var-string-predicates :key #'second)))) + (make-lex-class (concatenate 'string (symbol-name cxn-name-item-based-cxn) "-(" placeholder ")")))) + + +(defun get-car-for-unit (unit cars) + (loop for car in cars + for resulting-left-pole-structure = (left-pole-structure (car-resulting-cfs car)) + for root = (get-root resulting-left-pole-structure) + for res-unit = (last-elt (remove root resulting-left-pole-structure)) ;;match with last + when (equal res-unit unit) + return car)) + +(defun get-subtracted-meaning-from-car (car gold-standard-meaning) + (let* ((cxn-meaning (extract-meaning-predicates (original-cxn (car-applied-cxn car)))) + (subtracted-meaning (second (multiple-value-list (commutative-irl-subset-diff gold-standard-meaning cxn-meaning))))) + subtracted-meaning)) + +(defun subtract-holistic-from-item-based-meaning (gold-standard-meaning subtracted-meanings) + (loop with item-based-meaning = (copy-object gold-standard-meaning) + for network in subtracted-meanings + do (setf item-based-meaning (set-difference item-based-meaning network :test #'equal)) + finally return item-based-meaning)) + +(defun make-item-based-name-form-constraints-from-units (item-based-cxn-form-constraints resulting-units) + (loop with item-based-fc = item-based-cxn-form-constraints + for unit in resulting-units + for fc = (unit-feature-value unit 'form) + do (setf item-based-fc (substitute-slot-meets-constraints fc item-based-fc)) + finally return item-based-fc)) (defgeneric meaning-predicates-with-variables (meaning mode)) -- GitLab From 35ef86b601dc694bc5f5d4ddcdb525fa9d09033a Mon Sep 17 00:00:00 2001 From: EHAI Date: Tue, 22 Mar 2022 10:12:04 +0100 Subject: [PATCH 011/157] Adapted manuals path for windows --- libraries/lw-add-ons/documentation.lisp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libraries/lw-add-ons/documentation.lisp b/libraries/lw-add-ons/documentation.lisp index dc06eee09..ba1b55c86 100644 --- a/libraries/lw-add-ons/documentation.lisp +++ b/libraries/lw-add-ons/documentation.lisp @@ -34,8 +34,10 @@ directory, optionally appending the string RELATIVE-PATH." (namestring (sys:lispworks-dir (format nil - #+:lispworks8 + #+(and :lispworks8 :macosx) "manual/html-m/~A" + #+(and :lispworks8 :win32) + "manual/html-w/~A" #+(or :lispworks6.1 :lispworks7) "manual/online/~A" #-(or :lispworks6.1 :lispworks7 :lispworks8) -- GitLab From fc94e7b538ac90720cbaa5224b3bb9ea77feb748 Mon Sep 17 00:00:00 2001 From: EHAI Linux Date: Tue, 22 Mar 2022 11:02:31 +0100 Subject: [PATCH 012/157] adapted path to lispworks documentation folder for linux --- libraries/lw-add-ons/documentation.lisp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libraries/lw-add-ons/documentation.lisp b/libraries/lw-add-ons/documentation.lisp index ba1b55c86..6bb854134 100644 --- a/libraries/lw-add-ons/documentation.lisp +++ b/libraries/lw-add-ons/documentation.lisp @@ -38,6 +38,8 @@ directory, optionally appending the string RELATIVE-PATH." "manual/html-m/~A" #+(and :lispworks8 :win32) "manual/html-w/~A" + #+(and :lispworks8 :linux) + "manual/html-l/~A" #+(or :lispworks6.1 :lispworks7) "manual/online/~A" #-(or :lispworks6.1 :lispworks7 :lispworks8) -- GitLab From 840597ad1f955341a2bd9b35247a7540004872da Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 22 Mar 2022 14:18:38 +0100 Subject: [PATCH 013/157] fixing bug in holistic-to-item-based, now all form constraints are variablified --- experiments/grammar-learning/clevr/test.lisp | 2 +- .../repair-add-categorial-links.lisp | 2 +- .../repair-holistic-to-item-based-cxn.lisp | 22 ++++-- ...based+holistic+holistic--substitution.lisp | 3 +- ...m-based+holistic+holophrase--deletion.lisp | 5 +- ...rase-to-item-based+holistic--addition.lisp | 7 +- .../repair-item-based-to-holistic.lisp | 2 +- .../diagnostics-and-repairs/utils.lisp | 68 ++++++------------- .../test-add-categorial-links-repair.lisp | 63 +++++++++++++++-- .../test-holistic-to-item-based-repair.lisp | 4 ++ .../grammar-learning/tests/test-utils.lisp | 4 ++ 11 files changed, 118 insertions(+), 64 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 49ef5de49..088e67ae2 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 8800) +;(run-series *experiment* 50) #| QUESTIONS diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp index 002f3033a..495366d76 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-add-categorial-links.lisp @@ -51,7 +51,7 @@ "returns all cxns in the list for the given type" (loop for cxn in cxns for orig-cxn = (get-original-cxn cxn) - for phrase-type = (phrase-type orig-cxn) + for phrase-type = (attr-val cxn :cxn-type) when (equal phrase-type type) collect orig-cxn)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index 8dcaccf9a..ffa98794e 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -48,7 +48,7 @@ (resulting-left-pole-structure (left-pole-structure car-res-cfs)) (resulting-root (get-root resulting-left-pole-structure)) (resulting-units (remove resulting-root resulting-left-pole-structure)) - (item-based-cxn-form-constraints (unit-feature-value resulting-root 'form)) + (item-based-cxn-form-constraints (variablify-form-constraints-with-constants (unit-feature-value resulting-root 'form))) (chunk-item-based-cxn-form-constraints (make-item-based-name-form-constraints-from-units item-based-cxn-form-constraints resulting-units)) (placeholder-var-string-predicates (variablify-missing-form-strings chunk-item-based-cxn-form-constraints)) (cxn-name-item-based-cxn (make-cxn-name @@ -57,14 +57,14 @@ (holistic-cxn-subunit-blocks (multiple-value-list (loop for unit in resulting-units - for form-constraints = (unit-feature-value unit 'form) + for form-constraints = (variablify-form-constraints-with-constants (unit-feature-value unit 'form)) for holistic-cxn-unit-name = (unit-ify (make-cxn-name form-constraints original-cxn-set :add-cxn-suffix nil)) for string-var = (first (get-boundary-units form-constraints)) for car = (get-car-for-unit unit optimal-coverage-cars) for subtracted-meaning = (get-subtracted-meaning-from-car car gold-standard-meaning) for args = (extract-args-from-irl-network subtracted-meaning) for boundaries = (unit-feature-value unit 'boundaries) - for boundary-list = (list (second (first boundaries)) (second (second boundaries))) + for boundary-list = (list (variablify (second (first boundaries))) (variablify (second (second boundaries)))) for holistic-slot-lex-class = (create-item-based-lex-class-with-var placeholder-var-string-predicates cxn-name-item-based-cxn string-var) ;; look up the X and Y in bindings for placeholder-var = (third (find string-var placeholder-var-string-predicates :key #'second)) for updated-form-constraints-and-boundaries = (multiple-value-list (add-boundaries-to-form-constraints item-based-cxn-form-constraints boundary-list :placeholder-var placeholder-var)) @@ -95,8 +95,15 @@ (cat-links-to-add (fourth holistic-cxn-subunit-blocks)) (subtracted-meanings (fifth holistic-cxn-subunit-blocks)) (item-based-cxn-meaning (subtract-holistic-from-item-based-meaning gold-standard-meaning subtracted-meanings)) - - (item-based-cxn (second (multiple-value-list (eval + (existing-item-based-cxn (find-cxn-by-form-and-meaning + item-based-cxn-form-constraints + item-based-cxn-meaning + original-cxn-set + :cxn-type 'item-based)) + (bla (when existing-item-based-cxn + (format t "existing found"))) + (item-based-cxn (or existing-item-based-cxn + (second (multiple-value-list (eval `(def-fcg-cxn ,(add-cxn-suffix cxn-name-item-based-cxn) ((?item-based-unit (syn-cat (phrase-type item-based)) @@ -116,9 +123,10 @@ (equal (first predicate) 'bind)) return (first predicate)) :string ,(third (find 'string item-based-cxn-form-constraints :key #'first))) - :cxn-inventory ,(copy-object original-cxn-set)))))) + :cxn-inventory ,(copy-object original-cxn-set))))))) (cxns-to-apply (append (mapcar #'original-cxn (mapcar #'car-applied-cxn optimal-coverage-cars)) (list item-based-cxn))) - (cxns-to-consolidate (list item-based-cxn))) + (cxns-to-consolidate (unless existing-item-based-cxn + (list item-based-cxn)))) ;(add-element (make-html item-based-cxn)) (list diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp index 02522bb91..c4a76d6e0 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp @@ -80,7 +80,8 @@ based on existing construction with sufficient overlap." (existing-item-based-cxn (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries overlapping-meaning-observation - cxn-inventory)) + cxn-inventory + :cxn-type 'item-based)) ;; unit names (unit-name-holistic-cxn-1 (unit-ify (make-cxn-name non-overlapping-form-cxn cxn-inventory :add-cxn-suffix nil))) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp index 0dc604502..a0c15635c 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp @@ -82,7 +82,10 @@ (cxn-name-item-based-cxn (make-cxn-name (substitute-slot-meets-constraints non-overlapping-form overlapping-form) cxn-inventory :add-numeric-tail t)) (existing-item-based-cxn - (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries overlapping-meaning cxn-inventory)) + (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries + overlapping-meaning + cxn-inventory + :cxn-type 'item-based)) (unit-name-holistic-cxn (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil))) ;; lex-class diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp index 16376ab7f..ddf60fe16 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp @@ -76,7 +76,10 @@ (cxn-name-item-based-cxn (make-cxn-name (substitute-slot-meets-constraints non-overlapping-form overlapping-form) cxn-inventory :add-numeric-tail t)) (existing-item-based-cxn - (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries overlapping-meaning cxn-inventory)) + (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries + overlapping-meaning + cxn-inventory + :cxn-type 'item-based)) (unit-name-holistic-cxn (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil)) ) @@ -85,7 +88,7 @@ (if existing-holistic-cxn (lex-class-cxn existing-holistic-cxn) (make-lex-class holistic-cxn-name :trim-cxn-suffix t))) - (lex-class-item-based-cxn(if existing-item-based-cxn + (lex-class-item-based-cxn (if existing-item-based-cxn (lex-class-cxn existing-item-based-cxn) (make-lex-class cxn-name-item-based-cxn :trim-cxn-suffix t))) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp index 7f2090689..26de8a70d 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp @@ -73,7 +73,7 @@ (form-predicates-holistic-cxn (if (= 1 (length string-predicates-in-root)) string-predicates-in-root (subtract-holistic-cxn-forms matching-holistic-cxns string-predicates-in-root))) - (existing-holistic-cxn (find-cxn-by-form-and-meaning form-predicates-holistic-cxn meaning-predicates-holistic-cxn original-cxn-inventory)) + (existing-holistic-cxn (find-cxn-by-form-and-meaning form-predicates-holistic-cxn meaning-predicates-holistic-cxn original-cxn-inventory :cxn-type 'holistic)) (cxn-name (make-cxn-name (third (first form-predicates-holistic-cxn)) original-cxn-inventory)) (unit-name (second (first form-predicates-holistic-cxn))) (lex-class (if existing-holistic-cxn diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index e288e1766..375b4d549 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -62,8 +62,8 @@ return both the form constraints and the new boundary list" (let* ((new-form-constraints (copy-object form-constraints)) (placeholder-var (string-upcase (if placeholder-var placeholder-var "?X"))) - (left-var (intern (format nil "?LEFT-~a-BOUNDARY" placeholder-var))) - (right-var (intern (format nil "?RIGHT-~a-BOUNDARY" placeholder-var))) + (left-var (make-var (make-const (format nil "?LEFT-~a-BOUNDARY" placeholder-var)))) + (right-var (make-var (make-const (format nil "?RIGHT-~a-BOUNDARY" placeholder-var)))) (left-boundary (first boundaries)) (right-boundary (second boundaries)) (matching-left-predicate (find left-boundary new-form-constraints :key #'third)) @@ -110,13 +110,6 @@ for lex-class = (lex-class-item-based unit) collect lex-class)) -(defun phrase-type (cxn) - (loop for unit in (contributing-part cxn) - for syn-cat = (cdr (find 'syn-cat (fcg::unit-structure unit) :key #'first)) - for phrase-type = (when syn-cat (second (find 'phrase-type syn-cat :key #'first))) - when phrase-type - return phrase-type)) - (defun boundary-list (cxn) (loop for unit in (conditional-part cxn) for comprehension-lock = (comprehension-lock unit) @@ -131,12 +124,6 @@ (equal 'string (first fc))) (extract-forms (left-pole-structure transient-structure)))) -(defun diff-subset-superset-form (subset-cxn superset-form) - (set-difference - superset-form - (extract-form-predicates subset-cxn) - :test #'irl:unify-irl-programs)) - (defun lex-class (unit) (let* ((syn-cat (find 'syn-cat (unit-body unit) :key #'first)) (lex-class (find 'lex-class (second syn-cat) :key #'first))) @@ -188,14 +175,16 @@ (set-difference network-2 unique-part-network-2))) (values unique-part-network-1 unique-part-network-2)))) -(defun find-cxn-by-form-and-meaning (form meaning cxn-inventory) +(defun find-cxn-by-form-and-meaning (form meaning cxn-inventory &key cxn-type) "returns a cxn with the same meaning and form if it's in the cxn-inventory" (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) - for boundary-list-cxn = (boundary-list cxn) - when (and (irl:equivalent-irl-programs? form (extract-form-predicates cxn)) - (irl:equivalent-irl-programs? meaning (extract-meaning-predicates cxn)) + for cxn-type-cxn = (attr-val cxn :cxn-type) + when (and + (if cxn-type (equal cxn-type cxn-type-cxn) t) + (irl:equivalent-irl-programs? form (extract-form-predicates cxn)) + (irl:equivalent-irl-programs? meaning (extract-meaning-predicates cxn)) ; note: boundaries and args are ignored, as they are designed to always match, and fully depend on form and meaning anyway. - ) + ) return cxn)) @@ -282,7 +271,6 @@ (let* ((slot-boundaries (get-boundary-units chunk-meet-constraints)) (left-boundary (first slot-boundaries)) (right-boundary (second slot-boundaries))) - ;(new-slot-var (variablify "X"))) (loop for fc in (copy-object item-based-meet-constraints) collect (replace-chunk-variables fc left-boundary right-boundary left-boundary)))) @@ -331,6 +319,14 @@ when (and (consp form-value) (eq (first form-value) symbol)) collect form-value)) +(defun variablify-form-constraints-with-constants (form-constraints-with-constants) + (loop for fc-with-const in form-constraints-with-constants + for first-fc-with-var = (first fc-with-const) + for rest-fc-with-var = (if (equal 'string (first fc-with-const)) + (list (variablify (second fc-with-const)) (third fc-with-const)) + (mapcar #'variablify (rest fc-with-const))) + collect (cons first-fc-with-var rest-fc-with-var))) + (defun form-constraints-with-variables (utterance mode) "Extract form constraints from utterance in the format they would appear in a construction." (let ((form-constraints-with-constants (remove 'sequence @@ -372,7 +368,7 @@ (defun make-item-based-name-form-constraints-from-units (item-based-cxn-form-constraints resulting-units) (loop with item-based-fc = item-based-cxn-form-constraints for unit in resulting-units - for fc = (unit-feature-value unit 'form) + for fc = (variablify-form-constraints-with-constants (unit-feature-value unit 'form)) do (setf item-based-fc (substitute-slot-meets-constraints fc item-based-fc)) finally return item-based-fc)) @@ -530,7 +526,7 @@ for non-overlapping-meanings = (multiple-value-list (diff-clevr-networks gold-standard-meaning cxn-meaning-constraints)) for non-overlapping-meaning = (first non-overlapping-meanings) for non-overlapping-meaning-inverted = (second non-overlapping-meanings) - for cxn-type = (phrase-type cxn) + for cxn-type = (attr-val cxn :cxn-type) when (and (eql cxn-type 'holophrase) ; todo: we might want to remove this! non-overlapping-form non-overlapping-meaning @@ -546,7 +542,7 @@ (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) for cxn-form-constraints = (extract-form-predicates cxn) for cxn-meaning-constraints = (extract-meaning-predicates cxn) - for cxn-type = (phrase-type cxn) + for cxn-type = (attr-val cxn :cxn-type) for superset-form = (form-constraints-with-variables utterance (get-configuration (cxn-inventory cxn) :de-render-mode)) for non-overlapping-form = (non-overlapping-form superset-form cxn :nof-cxn t) for non-overlapping-meanings = (multiple-value-list (diff-clevr-networks cxn-meaning-constraints gold-standard-meaning)) @@ -573,7 +569,7 @@ (defun select-cxn-for-making-item-based-cxn (cxn-inventory utterance-form-constraints meaning) (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) - do (when (eql (phrase-type cxn) 'holophrase) + do (when (eql (attr-val cxn :cxn-type) 'holophrase) (let* ((non-overlapping-meanings (multiple-value-list (diff-clevr-networks meaning (extract-meaning-predicates cxn)))) (non-overlapping-meaning-observation (first non-overlapping-meanings)) (non-overlapping-meaning-cxn (second non-overlapping-meanings)) @@ -656,26 +652,6 @@ finally return (values applied-cars unapplied-cars) )))) - -(defun find-matching-holistic-cxns (cxn-inventory var-form gold-standard-meaning utterance) - "return all holistic cxns that can apply by checking whether they are a subset of the observed form and meaning" - ;; if a certain item matches twice, we'll discard it to avoid ambiguity - ;; e.g.: is there a cylinder next to the blue cylinder? will only return blue (if in inventory), not cylinder - (let ((remaining-form var-form)) - (sort (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) - for prev-remaining-form-length = (length (extract-form-predicate-by-type remaining-form 'string)) - for string-predicates-cxn = (extract-form-predicate-by-type (extract-form-predicates cxn) 'string) - when (and (eql (phrase-type cxn) 'holistic) - (irl:unify-irl-programs (extract-form-predicates cxn) remaining-form) - (setf remaining-form (set-difference remaining-form (extract-form-predicates cxn) :test #'irl:unify-irl-programs)) - (irl:unify-irl-programs (extract-meaning-predicates cxn) gold-standard-meaning) - (= (length string-predicates-cxn) (- prev-remaining-form-length (length (extract-form-predicate-by-type remaining-form 'string))))) ;; make sure it can only apply once, if multiple times, the resulting set diff is shorter - - collect cxn) - #'(lambda (x y) - (< - (search (third (first (extract-form-predicates x))) utterance) - (search (third (first (extract-form-predicates y))) utterance)))))) (defun diff-non-overlapping-form (observed-form matching-lex-cxns) "subtract all lexical forms from the gold standard, @@ -762,7 +738,7 @@ (remove nil (loop for remaining-form in root-strings for root-string = (third remaining-form) collect (loop for cxn in (constructions cxn-inventory) - when (and (eql (phrase-type cxn) 'lexical) + when (and (eql (attr-val cxn :cxn-type) 'lexical) (string= (third (first (extract-form-predicates cxn))) root-string)) return cxn)))) diff --git a/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp b/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp index 3293f8f0f..d8934fb18 100644 --- a/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp +++ b/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp @@ -77,9 +77,64 @@ (bind color-category ?color-8 yellow) (query ?target-4 ?target-object-1 ?attribute-6)))))))) - ; (test-categorial-links-repair-comprehension) +(deftest test-add-categorial-link-after-holistic-to-item-based-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "The tiny gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-39552 ?target-2 ?size-4) + (unique ?source-10 ?target-39552) + (bind color-category ?color-2 gray) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-4 small) + (query ?target-8 ?source-10 ?attribute-2))) + (comprehend "The large yellow object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-39552 ?target-2 ?size-4) + (unique ?source-10 ?target-39552) + (bind color-category ?color-2 yellow) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-4 large) + (query ?target-8 ?source-10 ?attribute-2))) + (test-repair-status 'holistic->item-based + (second (multiple-value-list + (comprehend "What is the shape of the tiny gray object?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-39552 ?target-2 ?size-4) + (unique ?source-10 ?target-39552) + (bind color-category ?color-2 gray) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-4 small) + (query ?target-8 ?source-10 ?attribute-2)))))) + (test-repair-status 'add-categorial-links + (second (multiple-value-list + (comprehend "What is the shape of the large yellow object?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-56342 ?target-2 ?size-4) + (unique ?target-object-1 ?target-56342) + (bind color-category ?color-16 yellow) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-16) + (bind size-category ?size-4 large) + (query ?target-4 ?target-object-1 ?attribute-2)))))))) + +; (activate-monitor trace-fcg) +; (test-categorial-links-repair-comprehension) +; (test-add-categorial-link-after-holistic-to-item-based-comprehension) -; issues: -; 1. why aren't the equivalent 'what is the size of the x cube' cxns recognised as existing in the substitution repair -; 2. restore the category-linking-mode with some other flag \ No newline at end of file diff --git a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp index 04cccee14..97d83e196 100644 --- a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp +++ b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp @@ -215,6 +215,9 @@ (filter ?target-2 ?target-1 ?color-16) (bind size-category ?size-4 large) (query ?target-4 ?target-object-1 ?attribute-2)))))))) + + + ;; (activate-monitor trace-fcg) (defun run-holistic-to-item-based-tests () @@ -223,5 +226,6 @@ (test-multiple-holistic-to-item-based-repair-comprehension) (test-holistic-to-item-based-duplicates-comprehension) (test-double-holistic-to-item-based-from-substitution-repair-comprehension) + ) diff --git a/systems/grammar-learning/tests/test-utils.lisp b/systems/grammar-learning/tests/test-utils.lisp index 680479453..7bc0c21e2 100644 --- a/systems/grammar-learning/tests/test-utils.lisp +++ b/systems/grammar-learning/tests/test-utils.lisp @@ -236,3 +236,7 @@ ;(test-extract-args-from-irl-network) ;(test-extract-vars-from-irl-network) + + + + -- GitLab From 121e1d2fd6ec8c92f636a2cb1ddb62947f136840 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 22 Mar 2022 15:56:47 +0100 Subject: [PATCH 014/157] aligning category names between repairs --- ...olophrase-to-item-based+holistic+holistic--substitution.lisp | 2 +- ...-holophrase-to-item-based+holistic+holophrase--deletion.lisp | 2 +- .../repair-holophrase-to-item-based+holistic--addition.lisp | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp index c4a76d6e0..fcec9d0a6 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp @@ -100,7 +100,7 @@ based on existing construction with sufficient overlap." (lex-class-item-based-cxn (if existing-item-based-cxn (lex-class-cxn existing-item-based-cxn) - (make-lex-class cxn-name-item-based-cxn :trim-cxn-suffix t))) + (make-lex-class (concatenate 'string (symbol-name cxn-name-item-based-cxn) "-(x)") :trim-cxn-suffix t))) ;; categorial links (categorial-link-1 (cons lex-class-holistic-cxn-1 lex-class-item-based-cxn)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp index a0c15635c..ff8c6a60e 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp @@ -96,7 +96,7 @@ (lex-class-item-based-cxn (if existing-item-based-cxn (lex-class-cxn existing-item-based-cxn) - (make-lex-class cxn-name-item-based-cxn :trim-cxn-suffix t))) + (make-lex-class (concatenate 'string (symbol-name cxn-name-item-based-cxn) "-(x)") :trim-cxn-suffix t))) ;; type hierachy links (categorial-link (cons lex-class-holistic-cxn lex-class-item-based-cxn)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp index ddf60fe16..e37c5e747 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp @@ -90,7 +90,7 @@ (make-lex-class holistic-cxn-name :trim-cxn-suffix t))) (lex-class-item-based-cxn (if existing-item-based-cxn (lex-class-cxn existing-item-based-cxn) - (make-lex-class cxn-name-item-based-cxn :trim-cxn-suffix t))) + (make-lex-class (concatenate 'string (symbol-name cxn-name-item-based-cxn) "-(x)") :trim-cxn-suffix t))) ;; categorial links (categorial-link -- GitLab From f9489a979d00f5cea6252727eb6a9bed240d6814 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 22 Mar 2022 15:58:01 +0100 Subject: [PATCH 015/157] reusing existing item-based-cxn in holistic-to-item-based when no indirect cat-links existed --- .../repair-holistic-to-item-based-cxn.lisp | 13 +++++++-- .../diagnostics-and-repairs/utils.lisp | 29 +++++++++++++++++++ 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index ffa98794e..d0ebde803 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -37,6 +37,7 @@ "Creates item-based construction around matching holistic constructions" (let* ((cxn-inventory (construction-inventory node)) (original-cxn-set (original-cxn-set cxn-inventory)) + (utterance (random-elt (get-data problem :utterances))) (meaning-representation-formalism (get-configuration cxn-inventory :meaning-representation-formalism)) (gold-standard-meaning (meaning-predicates-with-variables (random-elt (get-data problem :meanings)) meaning-representation-formalism)) (matching-holistic-cxns (find-all-matching-cxn-cars-for-node cxn-inventory node))) @@ -47,7 +48,7 @@ (car-res-cfs (car-resulting-cfs last-car)) (resulting-left-pole-structure (left-pole-structure car-res-cfs)) (resulting-root (get-root resulting-left-pole-structure)) - (resulting-units (remove resulting-root resulting-left-pole-structure)) + (resulting-units (sort-units-by-form-string (remove resulting-root resulting-left-pole-structure) utterance original-cxn-set)) (item-based-cxn-form-constraints (variablify-form-constraints-with-constants (unit-feature-value resulting-root 'form))) (chunk-item-based-cxn-form-constraints (make-item-based-name-form-constraints-from-units item-based-cxn-form-constraints resulting-units)) (placeholder-var-string-predicates (variablify-missing-form-strings chunk-item-based-cxn-form-constraints)) @@ -100,8 +101,6 @@ item-based-cxn-meaning original-cxn-set :cxn-type 'item-based)) - (bla (when existing-item-based-cxn - (format t "existing found"))) (item-based-cxn (or existing-item-based-cxn (second (multiple-value-list (eval `(def-fcg-cxn ,(add-cxn-suffix cxn-name-item-based-cxn) @@ -127,6 +126,14 @@ (cxns-to-apply (append (mapcar #'original-cxn (mapcar #'car-applied-cxn optimal-coverage-cars)) (list item-based-cxn))) (cxns-to-consolidate (unless existing-item-based-cxn (list item-based-cxn)))) + (when existing-item-based-cxn ; we ordered the units, so they'll always be in the order in which they appear in the utterance + (loop for item-lc in (get-all-unit-lex-classes existing-item-based-cxn) + for cat-link in cat-links-to-add + for holistic-lc = (first cat-link) + collect (cons holistic-lc item-lc) into new-cat-links + finally do (setf cat-links-to-add new-cat-links)) + ;(add-element (make-html (categorial-network original-cxn-set))) + ) ;(add-element (make-html item-based-cxn)) (list diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 375b4d549..66cc8914c 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -32,6 +32,35 @@ (setf (nth i resulting-list) cxn-obj)))) (remove nil resulting-list)))) +(defun sort-units-by-form-string (units-to-sort utterance cxn-inventory) + "sorts lexical cxns by matching their form strings to the utterance. handles duplicate cxns in one utterance." + ;; warning, this function depends on space separation without further punctuation! + ;; todo: replace by looking up meets constraints! + (if (< (length units-to-sort) 2) + units-to-sort + (let ((resulting-list (make-list (length utterance)))) + (loop for cxn-obj in units-to-sort + for cxn-string = (format nil "~{~a~^ ~}" (render (unit-feature-value cxn-obj 'form) (get-configuration cxn-inventory :render-mode))) + do (loop + with sub-length = (length cxn-string) + for i from 0 to (- (length utterance) sub-length) + when (string= utterance cxn-string + :start1 i :end1 (+ i sub-length)) + do (when (and + (or + (= (+ i sub-length) (length utterance)) ;; end of utterance + (loop for punct across ".;,!?: " + thereis (string= punct utterance + :start2 (+ i sub-length) + :end2 (+ i sub-length 1)))) ;; next char is word boundary + (or + (= i 0) ;; start of utterance + (string= " " utterance + :start2 (- i 1) + :end2 i))) ;; prev char is space + (setf (nth i resulting-list) cxn-obj)))) + (remove nil resulting-list)))) + (defun check-meets-continuity (form-constraints) "check if within a holistic chunk, all form strings are connected" (let* ((left-units (loop for fc in form-constraints -- GitLab From 350bcec4a653bba355e9f4c6543b9b63ba2c6d42 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Tue, 22 Mar 2022 20:52:52 +0100 Subject: [PATCH 016/157] added topicalized ditransitive info and arg structure cxns with perfect and non-perfect verbs --- .../bidirectional_grammar_info_arg_struct.fcg | 202 +++++++++++++++--- 1 file changed, 171 insertions(+), 31 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index f80c2c75e..19066221c 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -129,6 +129,32 @@ -- (HASH form ((string ?to-word "zum")))))) +(def-fcg-cxn gegen-cxn + (<- + (?against-word + (syn-cat (lex-class preposition) + (preposition +) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?against-word "gegen")))))) + +(def-fcg-cxn für-cxn + (<- + (?for-word + (syn-cat (lex-class preposition) + (preposition +) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?for-word "für")))))) + (def-fcg-cxn mit-cxn (<- (?with-word @@ -429,6 +455,56 @@ (HASH form ((string ?gift-word "schenkt")))))) +(def-fcg-cxn ist-gefahren-cxn + ((?drove-word + (constituents (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (aspect perfect) + (type intransitive)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?ig)) + + <- + + (?aux-unit + -- + (HASH form ((string ?aux-unit "ist")))) + + (?participle-unit + -- + (HASH form ((string ?participle-unit "gefahren")))) + + (?drove-word + (HASH meaning ((drove-01 ?ig))) + -- + ))) + +(def-fcg-cxn hat-mitgebracht-cxn + ((?brought-word + (constituents (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (aspect perfect) + (type ditransitive)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?hm)) + + <- + + (?aux-unit + -- + (HASH form ((string ?aux-unit "hat")))) + + (?participle-unit + -- + (HASH form ((string ?participle-unit "mitgebracht")))) + + (?brought-word + (HASH meaning ((brought-01 ?hm))) + -- + ))) + (def-fcg-cxn transitive-argument-structure-cxn ((?transitive-argument-structure-unit (constituents (?verb-unit ?agent-unit ?patient-unit))) @@ -597,20 +673,12 @@ (referent ?arg1) ) (?receiver-unit - (syn-cat (lex-class noun-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?rs ?dm ?df ?dn ?dp)))) + (syn-cat + (case ?case)) (referent ?arg2) -- - (syn-cat (lex-class noun-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?rs ?dm ?df ?dn ?dp)))) + (syn-cat + (case ?case)) (referent ?arg2)) (?ditransitive-argument-structure-unit @@ -622,18 +690,24 @@ (def-fcg-cxn topicalized-ditransitive-information-structure-cxn - ( + ((?topicalized-ditransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?arg-and-info-struct-unit + (constituents (?topicalized-ditransitive-information-structure-unit ?argument-structure-unit))) <- + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + -- + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?verb-unit (syn-cat (lex-class verb) - (type ditransitive) - (aspect non-perfect)) + (type ditransitive)) -- (syn-cat (lex-class verb) - (type ditransitive) - (aspect non-perfect))) + (type ditransitive))) (?agent-unit (syn-cat (syn-role subject)) @@ -675,6 +749,8 @@ ;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) +(formulate-all '((drove-01 ig) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) + ;der Mann geht zur Arbeit (def-fcg-cxn intransitive-argument-structure-cxn @@ -714,24 +790,16 @@ (?location-unit (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ls ?dm ?df ?dn ?dp)))) - (referent ?arg3) + (case ?case)) + (referent ?arg1) -- (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ls ?dm ?df ?dn ?dp)))) - (referent ?arg3)) + (case ?case)) + (referent ?arg1)) (?intransitive-argument-structure-unit (HASH meaning ((:arg0 ?v ?arg0) - (:arg3 ?v ?arg3))) + (:arg1 ?v ?arg1))) -- ))) @@ -778,6 +846,78 @@ )) + + + +;Der Mann ist gegen den Baum gefahren. + + +#|(def-fcg-cxn intransitive-acc-past-arg-structure-cxn + ((?intransitive-acc-past-arg-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?location-unit + (syn-cat (syn-role complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + (referent ?arg0)) + + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ?case)) + (boundaries (leftmost-unit ?leftmost-loc-unit) + (rightmost-unit ?rightmost-loc-unit)) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (boundaries (leftmost-unit ?leftmost-loc-unit) + (rightmost-unit ?rightmost-loc-unit)) + (referent ?arg1)) + + (?intransitive-acc-past-arg-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1))) + -- + (HASH form ((meets ?rightmost-agent-unit ?aux-unit) + (meets ?aux-unit ?leftmost-loc-unit) + (meets ?rightmost-loc-unit ?participle-unit)) + ) + )))|# + ;(formulate-all '((gehen-01 g) (man m) (arg0 g m) (arbeit a) (arg3 g a))) ;der Mann fährt mit der Wagen zur Arbeit @@ -916,7 +1056,7 @@ (rightmost-unit ?rightmost-location-unit))) ))|# - +;;; DOESNT GET APPLIED BUT THE INTRANSITIVE ARG STRUCTURE WITH ONE LESS UNIT DOES (def-fcg-cxn diintransitive-argument-structure-cxn ((?diintransitive-argument-structure-unit -- GitLab From 9b7119f63ab208b23b5381efdc730d33c1fb9679 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:10:41 +0100 Subject: [PATCH 017/157] added list-of-facts variable to handle-referent primitive --- .../tristan-experiment/grammar.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/grammar.lisp b/applications/discourse-understanding/tristan-experiment/grammar.lisp index 9194dca00..317a3510f 100644 --- a/applications/discourse-understanding/tristan-experiment/grammar.lisp +++ b/applications/discourse-understanding/tristan-experiment/grammar.lisp @@ -98,7 +98,7 @@ (gender (m - -))))) <- (?tristan - (discourse-meaning ((handle-referent ?ent ?status) + (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status) (bind discourse-status ?status identifiable))) (meaning ((entity ?ent) (tristan-frame ?ent ?ref) @@ -151,7 +151,7 @@ (mother-role ?ev ?mother) (father-role ?ev ?father) (child-role ?ev ?child))) - (discourse-meaning ((handle-referent ?ent ?status) + (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status) (bind discourse-status ?status identifiable))) -- (lex-id baren) @@ -271,10 +271,10 @@ (def-fcg-cxn possessive-NP-cxn ((?poss-pronoun-unit - (discourse-meaning ((handle-referent ?owner ?status) + (discourse-meaning ((handle-referent ?owner ?list-of-facts ?status) (bind discourse-status ?status identifiable)))) (?noun-unit - (discourse-meaning ((handle-referent ?ent ?status) + (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status) (bind discourse-status ?status identifiable)))) (?possessive-np-unit (referent ?ent) -- GitLab From c9ed9fc061209de0b6d52e648a7d7ad05faf242f Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:11:23 +0100 Subject: [PATCH 018/157] added discourse-model class --- .../tristan-experiment/discourse-model.lisp | 44 +++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 applications/discourse-understanding/tristan-experiment/discourse-model.lisp diff --git a/applications/discourse-understanding/tristan-experiment/discourse-model.lisp b/applications/discourse-understanding/tristan-experiment/discourse-model.lisp new file mode 100644 index 000000000..1df2e3c88 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/discourse-model.lisp @@ -0,0 +1,44 @@ +(in-package :discourse-understanding) + +(defclass discourse-model (entity) + ((entities :type list + :accessor entities + :initarg :entities + :initform nil + :documentation "The referents introduced in the discourse memory") + (entities-in-focus :type list + :accessor entities-in-focus + :initarg entities-in-focus + :initform nil + :documentation "The referents in focus in the discourse memory"))) + +(defclass discourse-entity (entity) + ((facts :accessor facts + :initarg :facts + :initform '()) + (accessibility-status + :accessor accessibility-status + :initarg :accessibility-status + :initform nil))) + +(defclass fact (entity) + ((content :accessor content + :initarg :content) ;; the fact itself + (added-at :accessor added-at + :initarg :added-at + :initform nil) ;; added at point in time + (added-by :accessor added-by + :initarg :added-by + :initform nil) ;; added by rule/cxn/prim? + )) + +(defclass discourse-status (entity) + ((status :accessor status + :initarg :status + :initform nil))) + +(defclass list-of-facts (entity) + ((facts :accessor facts + :initarg :facts + :initform nil))) + \ No newline at end of file -- GitLab From 62091a4700eb2140c085bc0cca04f5c9a1aa7e86 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:11:45 +0100 Subject: [PATCH 019/157] first version handle-referent primitive --- .../primitives/handle-referent.lisp | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp diff --git a/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp b/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp new file mode 100644 index 000000000..1faabe56f --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp @@ -0,0 +1,16 @@ +(in-package :discourse-understanding) + +(defprimitive handle-referent ((de discourse-entity) + (facts list-of-facts) + (status discourse-status)) + ((facts status => de) + (let* ((dm (get-data ontology 'discourse-model)) + (ent (make-instance 'discourse-entity :id (id facts) :facts (facts facts)))) + (bind (de 1.0 ent))))) + +(defun extract-relevant-facts (meaning referent) + (let* ((frame-vars + (loop for fact in meaning + when (eq (second fact) referent) + collect (third fact)))) + frame-vars)) \ No newline at end of file -- GitLab From 3ed06e209600a07c9a03dea8b05a7dc3d081188a Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:12:08 +0100 Subject: [PATCH 020/157] added html --- .../tristan-experiment/html.lisp | 121 ++++++++++++++++++ 1 file changed, 121 insertions(+) create mode 100644 applications/discourse-understanding/tristan-experiment/html.lisp diff --git a/applications/discourse-understanding/tristan-experiment/html.lisp b/applications/discourse-understanding/tristan-experiment/html.lisp new file mode 100644 index 000000000..07d391b79 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/html.lisp @@ -0,0 +1,121 @@ +(in-package :discourse-understanding) + +;; ######################################################### +;; discourse-entity - make-html-for-entity-details +;; --------------------------------------------------------- + +(defmethod make-html-for-entity-details ((e discourse-entity) &key expand-initially) + "Default HTML visualisation method for object of class discourse-entity" + (loop for slot in (closer-mop:class-slots (class-of e)) + for slot-name = (closer-mop:slot-definition-name slot) + for slot-value = (slot-value e slot-name) + if (and + (not (null slot-value)) + (or (symbolp slot-value) (stringp slot-value) (numberp slot-value))) + collect + (if (eq 'id slot-name) + "" + `((div :class "entity-detail") + ,(format nil "~(~a~): ~(~a~)" slot-name slot-value))) + else if (and + (not (null slot-value)) + (listp slot-value)) + collect + `((div :class "entity-detail") + ,(format nil "~(~a~): " slot-name) + ,@(loop for el in slot-value + collect (make-html el :expand-initially expand-initially))) + else if (not (null slot-value)) + collect + `((div :class "entity-detail") + ,(format nil "~(~a~): " slot-name) + ,(make-html slot-value :expand-initially expand-initially)))) + + + +;; ######################################################### +;; discourse-memory - make-html +;; --------------------------------------------------------- + +(export '(make-html-for-discourse-model)) + +(defgeneric make-html-for-discourse-model (discourse-model &key) + (:documentation "Creates a list of divs for the expanded version of an entity")) + +(export 'make-html-for-discourse-model) + +(defmethod make-html-for-discourse-model ((e discourse-model) &key &allow-other-keys) + '("")) + +(define-css 'discourse-model " +div.discourse-model { display:inline-block;margin-right:10px;margin-top:4px; +margin-bottom:4px;padding:0px; } +div.discourse-model { border:1px solid #562; display:inline-block;} +div.discourse-model div.discourse-model-title { + padding:0px;padding-left:3px;padding-right:3px; + white-space:nowrap; background-color:#EEA187; } +div.discourse-model div.discourse-model-title > a {color:#fff;} +div.discourse-model div.discourse-model-title > span {color:#fff;} +table.discourse-model { border-collapse:collapse; } +table.discourse-model td.discourse-model-type { font-style:italic;padding:0px;padding-left:4px;padding-right:4px;} +table.discourse-model tr.discourse-model-type {border-bottom:1px dashed #563; padding-left:4px;} +table.discourse-model td.discourse-model-details div.discourse-model-detail { + padding-left:4px; padding-right:4px;padding-bottom:1px;padding-top:1px; + border-top:1px dashed #563;text-align:left; } +table.discourse-model td.discourse-model-details div.discourse-model-detail-title { + padding-left:4px; padding-right:4px;padding-bottom:1px;padding-top:1px; + ;text-align:left; } +table.discourse-model td.discourse-model-details > div { overflow:hidden; } +table.discourse-model td.discourse-model-details div.discourse-model-detail:first-child { border-top:none;} +") + +(defmethod collapsed-dm-html ((e discourse-model) element-id) + "html for the collapsed version of a discourse memory" + `((div :class "discourse-model-box") + ((div :class "discourse-model-title") + ((a ,@(make-expand/collapse-link-parameters + element-id t "expand discourse model") + :name ,(mkstr (id e))) + ,(format nil "~(~a~)" (id e)))))) + +(defmethod expanded-dm-html ((e discourse-model) element-id parameters) + "html for the expanded version of an entity" + (lambda () + `((div :class "discourse-model-box") + ((div :class "discourse-model-title") + ((a ,@(make-expand/collapse-link-parameters + element-id nil "collapse discourse model") + :name ,(mkstr (id e))) + ,(format nil "~(~a~)" (id e)))) + ((table :class "discourse-model" :cellpadding "0" :cellspacing "0") + ((tr :class "discourse-model-type") + ((td :class "discourse-model-type" :style "font-weight: bold; font-style: normal;") ,(format nil "Entities: ")) + ((div :class "entity-detail" :border "1px") + ,@(loop for ae in (entities e) + collect (make-html ae)))))))) + +(defmethod make-html ((e discourse-model) + &rest parameters + &key (expand/collapse-all-id (make-id 'discourse-model)) + (expand-initially t)) + `((div :class "discourse-model") + ,(let ((element-id (make-id (id e)))) + (make-expandable/collapsable-element + element-id expand/collapse-all-id + ;; collapsed version + (collapsed-dm-html e element-id) + ;; expanded version + (expanded-dm-html e element-id parameters) + :expand-initially expand-initially)) + ((table :class "discourse-model") + ((tr) + ((td :class "discourse-model-type") + ,(format nil "~(~a~)" (type-of e))))))) + +(defmethod make-html-for-discourse-model ((dm discourse-model) &key) + `(;((div :class "entity-detail") ,(make-html (accessible-entities dm) :expand-initially t)) + ((div :class "discourse-model-detail-title" ) ,(format nil "Entities")) + ((div :class "discourse-model-detail") + ,@(loop for ae in (entities dm) + collect (make-html ae :expand-initially t))))) + -- GitLab From a7f636383453540099e605d97a6c02c3fbd34a61 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:12:34 +0100 Subject: [PATCH 021/157] added utils file --- .../tristan-experiment/utils.lisp | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 applications/discourse-understanding/tristan-experiment/utils.lisp diff --git a/applications/discourse-understanding/tristan-experiment/utils.lisp b/applications/discourse-understanding/tristan-experiment/utils.lisp new file mode 100644 index 000000000..3067e6991 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/utils.lisp @@ -0,0 +1,17 @@ +(in-package :discourse-understanding) + +(defun extract-discourse-meaning (cip) + (let* ((ts (fcg-get-transient-unit-structure cip)) + (meaning (loop for unit in ts + for discourse-meaning = (unit-feature-value unit 'discourse-meaning) + when discourse-meaning + collect discourse-meaning))) + meaning)) + +(defun extract-facts-meaning (cip) + (let* ((ts (fcg-get-transient-unit-structure cip)) + (meaning (loop for unit in ts + for meaning = (unit-feature-value unit 'meaning) + when meaning + collect meaning))) + meaning)) -- GitLab From 2587ca8576641a7085678f5e67ed238d02bdc1e8 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:13:09 +0100 Subject: [PATCH 022/157] updates asd and package.lisp --- .../discourse-understanding.asd | 15 +++++++++++---- applications/discourse-understanding/package.lisp | 4 +++- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/applications/discourse-understanding/discourse-understanding.asd b/applications/discourse-understanding/discourse-understanding.asd index 2492f8a72..6fe9e3b1f 100644 --- a/applications/discourse-understanding/discourse-understanding.asd +++ b/applications/discourse-understanding/discourse-understanding.asd @@ -10,7 +10,7 @@ :web-interface :irl :fcg - :web-services + ;:web-services :cl-json :cl-ppcre :network @@ -20,8 +20,15 @@ :components ((:file "package") (:module "tristan-experiment" :serial t - :components ((:file "grammar"))) - (:module "matilda-experiment" + :components ((:file "grammar") + (:file "discourse-model") + (:file "html") + (:file "utils") + (:module "primitives" + :serial t + :components ((:file "handle-referent"))) + )) + #|(:module "matilda-experiment" :serial t :components ((:file "discourse-memory") (:file "grammar") @@ -38,4 +45,4 @@ (:file "get-discourse-memory") (:file "introduce-event") (:file "introduce-referent") - (:file "link-arguments"))))))) \ No newline at end of file + (:file "link-arguments")))))|#)) \ No newline at end of file diff --git a/applications/discourse-understanding/package.lisp b/applications/discourse-understanding/package.lisp index 5a60f4c2b..06e310559 100644 --- a/applications/discourse-understanding/package.lisp +++ b/applications/discourse-understanding/package.lisp @@ -2,7 +2,9 @@ (defpackage :discourse-understanding (:documentation "Package for analysing discourse based on the integration of knowledge from wikidata ") - (:use :common-lisp :web-interface :irl :fcg :web-services :utils :network) + (:use :common-lisp :web-interface :irl :fcg :utils :network + ;:web-services + ) (:import-from :monitors :activate-monitor) (:import-from :cl-ppcre -- GitLab From f1c8648da4f81328ae14d6022ad14a2f0ebf27cd Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Tue, 22 Mar 2022 22:14:17 +0100 Subject: [PATCH 023/157] progress on understand function that comprehends, extracts and changes discourse meaning and executes it --- .../tristan-experiment/start-tristan.lisp | 45 +++++++++++++++++-- 1 file changed, 42 insertions(+), 3 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/start-tristan.lisp b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp index b284d103a..264152771 100644 --- a/applications/discourse-understanding/tristan-experiment/start-tristan.lisp +++ b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp @@ -1,11 +1,50 @@ (ql:quickload :discourse-understanding) (in-package :discourse-understanding) -(activate-monitor trace-fcg) -(activate-monitor trace-irl) +(monitors:activate-monitor trace-irl) +(monitors:activate-monitor trace-fcg) (comprehend "Toen Tristan geboren werd , was zijn vader dood" :cxn-inventory *pangloss*) (comprehend-all "Toen Tristan geboren werd , was zijn vader dood" :cxn-inventory *pangloss*) + +(defparameter *ontology* (make-blackboard)) +(set-data *ontology* 'discourse-model (make-instance 'discourse-model)) +(set-data *ontology* 'entities (cons (make-instance 'discourse-status :id 'identifiable) + (make-instance 'list-of-facts :id 'list-of-facts))) + +;;collect facts and put them into the meaning + +(defun understand (utterance cxn-inventory ontology) + ;first comprehend + (multiple-value-bind (cipn cip) + (comprehend utterance :cxn-inventory cxn-inventory) + ;prepare meaning network, this means extracting discourse-meaning and adding relevant facts from facts-meaning to this discourse-meaning + (let* ((discourse-meaning (first (extract-discourse-meaning cip))) + (facts-meaning (first (extract-facts-meaning cip)))) + (loop for primitive in discourse-meaning + for prim = (first primitive) + for entity-var = (second primitive) + for list-of-facts-var = (third primitive) + for status = (last-elt primitive) + when (equal prim 'handle-referent) + do (let* ((frame (find-all entity-var facts-meaning :key 'second)) + (list-of-facts (make-instance 'list-of-facts :id entity-var :facts frame)) + (bind-statement `(bind list-of-facts ,list-of-facts-var ,list-of-facts)) + (new-entities-list (cons list-of-facts (get-data ontology 'entities)))) + (set-data ontology 'entities new-entities-list) + (push bind-statement discourse-meaning) + ; (setf (nth 3 primitive) frame) + )) + (set-data ontology 'facts-meaning facts-meaning) + (evaluate-irl-program discourse-meaning ontology) + discourse-meaning + ))) + + +(understand "Tristan" *pangloss* *ontology*) + + + ;; Do this after loading the file: #| (progn @@ -17,4 +56,4 @@ do (add-element (make-html entity)))) | -;; mss moeten discourse cxns toch nog meer apart \ No newline at end of file +;; mss moeten discourse cxns toch nog meer apart -- GitLab From 68fde0ba85864364f82e46387df81fec4d5200e4 Mon Sep 17 00:00:00 2001 From: katrien Date: Wed, 23 Mar 2022 09:14:45 +0100 Subject: [PATCH 024/157] added read-timeout and write-timeout keys to send-request --- systems/nlp-tools/penelope-interface.lisp | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/systems/nlp-tools/penelope-interface.lisp b/systems/nlp-tools/penelope-interface.lisp index 45a6de96c..d2a620607 100644 --- a/systems/nlp-tools/penelope-interface.lisp +++ b/systems/nlp-tools/penelope-interface.lisp @@ -52,13 +52,15 @@ ;; Interfacing with using http request and json ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun send-request (route json &key (host *penelope-host*)) +(defun send-request (route json &key (host *penelope-host*) (read-timeout 20) (write-timeout 20)) "Send curl request and returns the answer." (let* ((url (string-append host route)) (response (drakma:http-request url :method :post :content-type "application/json" - :content json))) + :content json + :read-timeout read-timeout + :write-timeout write-timeout))) (when response (handler-case (cl-json:decode-json-from-string response) (error (e) (format t "Error in response from spacy API service [nlp-tools penelope-interface]: ~S.~&" e)))))) -- GitLab From a3736bd87c4e05c7df18825f35039a27b611ff47 Mon Sep 17 00:00:00 2001 From: katrien Date: Wed, 23 Mar 2022 09:19:20 +0100 Subject: [PATCH 025/157] helper functions to query abe_sim API: to-get-kitchen, to-fetch, to-portion --- applications/muhai-cookingbot/muhai-cookingbot.asd | 1 + .../recipes/almond-cookies-grammar.lisp | 12 ++++++------ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/applications/muhai-cookingbot/muhai-cookingbot.asd b/applications/muhai-cookingbot/muhai-cookingbot.asd index ff66d693e..f96275355 100644 --- a/applications/muhai-cookingbot/muhai-cookingbot.asd +++ b/applications/muhai-cookingbot/muhai-cookingbot.asd @@ -10,6 +10,7 @@ :fcg :cl-json :closer-mop + :nlp-tools #+lispworks :drakma) :serial t :components ((:file "package") diff --git a/applications/muhai-cookingbot/recipes/almond-cookies-grammar.lisp b/applications/muhai-cookingbot/recipes/almond-cookies-grammar.lisp index 034b87d7d..22f3efb61 100644 --- a/applications/muhai-cookingbot/recipes/almond-cookies-grammar.lisp +++ b/applications/muhai-cookingbot/recipes/almond-cookies-grammar.lisp @@ -1363,7 +1363,7 @@ ;(clear-output) -#| + (defparameter *pdm* (initialise-personal-dynamic-memory *fcg-constructions* @@ -1389,10 +1389,10 @@ "dust with powdered sugar" "end" ) - *pdm* - ;(initialise-personal-dynamic-memory - ; *fcg-constructions* - ; `((get-kitchen ,(make-var 'kitchen-state)))) + ; *pdm* + (initialise-personal-dynamic-memory + *fcg-constructions* + `((get-kitchen ,(make-var 'kitchen-state)))) ) -|# + -- GitLab From 5b2c63dadee3b3de496339bf1999ecbc3fe535cb Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 10:40:07 +0100 Subject: [PATCH 026/157] bugfix pathname --- .../execution/understand-execute-remember.lisp | 6 +++--- .../visual-dialog/ontology/classes.lisp | 8 +++++--- applications/visual-dialog/ontology/utils.lisp | 2 +- .../primitives/segment-scene.lisp | 16 ++++++++-------- applications/visual-dialog/start.lisp | 18 +++++++++++++++--- 5 files changed, 32 insertions(+), 18 deletions(-) diff --git a/applications/visual-dialog/execution/understand-execute-remember.lisp b/applications/visual-dialog/execution/understand-execute-remember.lisp index 587fc7c21..77392bb3b 100644 --- a/applications/visual-dialog/execution/understand-execute-remember.lisp +++ b/applications/visual-dialog/execution/understand-execute-remember.lisp @@ -6,7 +6,7 @@ (multiple-value-bind (irl-program cipn) (clevr-dialog-grammar::understand-until-solution input-sentence :silent (if silent silent)) (let* ((scene-var (extract-scene-unit-variable cipn)) - (scene-var-bind-statement `(bind pathname-entity ,scene-var ,(make-instance 'pathname-entity :pathname scene-pathname))) + (scene-var-bind-statement `(bind pathname-entity ,scene-var ,(make-instance 'pathname-entity :path scene-pathname))) (irl-program (append (list scene-var-bind-statement) irl-program)) (solutions (evaluate-irl-program irl-program ontology :silent (if silent silent) :primitive-inventory (get-primitive-inventory (get-data ontology 'world))))) (if solutions @@ -36,7 +36,7 @@ (multiple-value-bind (irl-program cipn) (clevr-dialog-grammar::understand-until-solution input-sentence :silent (if silent silent)) (let* ((scene-var (extract-scene-unit-variable cipn)) - (scene-var-bind-statement `(bind pathname-entity ,scene-var ,(make-instance 'pathname-entity :pathname scene-pathname))) + (scene-var-bind-statement `(bind pathname-entity ,scene-var ,(make-instance 'pathname-entity :path scene-pathname))) (irl-program (push scene-var-bind-statement irl-program)) (solutions (evaluate-irl-program irl-program ontology :silent (if silent silent) :primitive-inventory (get-primitive-inventory (get-data ontology 'world))))) (if solutions @@ -79,7 +79,7 @@ (multiple-value-bind (irl-program cipn) (clevr-dialog-grammar::understand-until-solution input-sentence :silent (if silent silent)) (let* ((scene-var (extract-scene-unit-variable cipn)) - (scene-var-bind-statement `(bind pathname-entity ,scene-var ,(make-instance 'pathname-entity :pathname scene-pathname))) + (scene-var-bind-statement `(bind pathname-entity ,scene-var ,(make-instance 'pathname-entity :path scene-pathname))) (irl-program (push scene-var-bind-statement irl-program)) (memory-var (extract-memory-unit-variable cipn)) (memory-var-bind-statement `(bind world-model ,memory-var ,memory)) diff --git a/applications/visual-dialog/ontology/classes.lisp b/applications/visual-dialog/ontology/classes.lisp index 3499dc40c..0f3770ebc 100644 --- a/applications/visual-dialog/ontology/classes.lisp +++ b/applications/visual-dialog/ontology/classes.lisp @@ -158,13 +158,14 @@ (defclass world-model (object-or-set) ((set-items :type list :initarg :set-items :accessor set-items :initform nil) (dataset :type symbol :initarg :dataset :accessor dataset :initform nil) - (pathname :type pathname :initarg :pathname :accessor pathname :initform nil))) + (path :type path :initarg :path :accessor path :initform nil) + )) (defmethod make-context ((world world)) (make-instance 'world-model :id 'context ;:dataset (dataset world) - :pathname (image (current-scene world)) + :path (image (current-scene world)) :set-items (list (make-instance 'turn @@ -209,4 +210,5 @@ ;; ################################ (defclass pathname-entity (entity) - ((pathname :type pathname :initarg :pathname :accessor pathname))) + ((path :type pathname :initarg :path :accessor path))) + diff --git a/applications/visual-dialog/ontology/utils.lisp b/applications/visual-dialog/ontology/utils.lisp index 23f2bd7bc..b9a33c258 100644 --- a/applications/visual-dialog/ontology/utils.lisp +++ b/applications/visual-dialog/ontology/utils.lisp @@ -304,7 +304,7 @@ :id (id wm) :set-items (loop for item in (set-items wm) collect (copy-object item)) - :pathname (pathname wm))) + :path (path wm))) (defmethod copy-object ((turn turn)) (make-instance 'turn diff --git a/applications/visual-dialog/primitives/segment-scene.lisp b/applications/visual-dialog/primitives/segment-scene.lisp index 452500a32..7beae4785 100644 --- a/applications/visual-dialog/primitives/segment-scene.lisp +++ b/applications/visual-dialog/primitives/segment-scene.lisp @@ -10,25 +10,25 @@ ;; if computed scene is already calculated, find it back in ontology, so no problems with ids changing over turns in dialog ((scene-pathname => segmented-scene) (if (or (not (find-data ontology 'segmented-scene)) - (not (find (pathname scene-pathname) (get-data ontology 'segmented-scene) :test #'equal :key #'first))) + (not (find (path scene-pathname) (get-data ontology 'segmented-scene) :test #'equal :key #'first))) (let* ((world (get-data ontology 'world)) - (scene-index (position (pathname scene-pathname) (scenes world))) + (scene-index (position (path scene-pathname) (scenes world))) (scene (get-scene-by-index world scene-index)) (context (make-context world))) (if (not (find-data ontology 'segmented-scene)) - (set-data ontology 'segmented-scene (list (cons (pathname scene-pathname) context))) - (set-data ontology 'segmented-scene (push (cons (pathname scene-pathname) context) (get-data ontology 'segmented-scene)))) + (set-data ontology 'segmented-scene (list (cons (path scene-pathname) context))) + (set-data ontology 'segmented-scene (push (cons (path scene-pathname) context) (get-data ontology 'segmented-scene)))) (bind (segmented-scene 1.0 context))) - (when (find (pathname scene-pathname) (get-data ontology 'segmented-scene) :key #'first) - (bind (segmented-scene 1.0 (cdr (find (pathname scene-pathname) (get-data ontology 'segmented-scene) :key #'first))))))) + (when (find (path scene-pathname) (get-data ontology 'segmented-scene) :key #'first) + (bind (segmented-scene 1.0 (cdr (find (path scene-pathname) (get-data ontology 'segmented-scene) :key #'first))))))) ;; second case; given segmented-scene compute scene-pathname ((segmented-scene => scene-pathname) - (bind (scene-pathname 1.0 (pathname segmented-scene)))) + (bind (scene-pathname 1.0 (path segmented-scene)))) ;; third case; check consistency ((segmented-scene scene-pathname =>) - (equal (pathname segmented-scene) scene-pathname)) + (equal (path segmented-scene) scene-pathname)) :primitive-inventory *symbolic-primitives*) \ No newline at end of file diff --git a/applications/visual-dialog/start.lisp b/applications/visual-dialog/start.lisp index a0301beb5..dbccd7735 100644 --- a/applications/visual-dialog/start.lisp +++ b/applications/visual-dialog/start.lisp @@ -19,7 +19,7 @@ (evaluate-mnist-dialogs-symbolic 10 20) (evaluate-clevr-dialogs-symbolic 50 60) -(evaluate-clevr-dialogs-symbolic 75 75) +(evaluate-clevr-dialogs-symbolic 70 80) (understand "does the earlier brown object have objects to its right") @@ -53,8 +53,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - + +(let* ((ontology (initialize-agent-ontology-and-world *ontology* *world*)) + (scene-pathname (get-scene-pathname-by-index 0 *world*)) + (scene-pathname-2 (get-scene-pathname-by-index 1 *world*)) + (pathname-entity (make-instance 'pathname-entity :pathname scene-pathname)) + (pathname-entity-2 (make-instance 'pathname-entity :pathname scene-pathname-2))) + (evaluate-irl-program `((segment-scene ?scene ?pathname) + (bind pathname-entity ?pathname ,pathname-entity) + (filter-by-attribute ?out ?scene ?pathname ?category) + (bind shape-category ?category cube) + (segment-scene ?scene-2 ?pathname-2) + (bind pathname-entity ?pathname-2 ,pathname-entity-2) + (filter-by-attribute ?out-2 ?scene-2 ?pathname-2 ?category-2) + (bind shape-category ?category-2 cylinder)) ontology :primitive-inventory (get-primitive-inventory (get-data ontology 'world)))) -- GitLab From 75888a4946c24b039e0176da25532d522ea87722 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 10:40:15 +0100 Subject: [PATCH 027/157] bugfix evaluation --- applications/visual-dialog/evaluation/evaluation.lisp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/applications/visual-dialog/evaluation/evaluation.lisp b/applications/visual-dialog/evaluation/evaluation.lisp index f944c2f1a..3a96f034d 100644 --- a/applications/visual-dialog/evaluation/evaluation.lisp +++ b/applications/visual-dialog/evaluation/evaluation.lisp @@ -36,7 +36,7 @@ "returns question-level-accuracy" (with-open-file (str (make-file-name-with-time (babel-pathname - :directory '("applications" "visual-dialog" "evaluation") + :directory '("applications" "visual-dialog" "evaluation" "results") :name (format nil "evaluation-~a-~a-~a" (get-configuration world :dataset) start-scene end-scene) :type "txt")) :direction :output @@ -48,9 +48,8 @@ (number-of-dialogs (compute-number-of-dialogs world)) (results - (first (loop for scene from start-scene to end-scene - collect (progn + append (progn (format str "evaluation of scene ~a~%" scene) (force-output str) (loop for dialog from 0 to number-of-dialogs for (result-whole-dialog result-one-dialog) = (multiple-value-list @@ -60,7 +59,7 @@ :ontology ontology)) do (progn (format str "~a : ~a~%" dialog result-one-dialog) (force-output str)) - collect (list result-whole-dialog result-one-dialog)))))) + collect (list result-whole-dialog result-one-dialog))))) (dialog-level-accuracy (average (loop for result in results collect (if (eql (first result) T) -- GitLab From de038e2ae8830dc014a55213d3814e9e823a98a0 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 14:31:54 +0100 Subject: [PATCH 028/157] fix pathnames for evaluation + added job scripts for hydra --- .../visual-dialog/evaluation/evaluation.lisp | 14 ++++++---- .../evaluation-clevr-symbolic.lisp | 11 ++++++++ .../job_scripts/evaluation-clevr-symbolic.sh | 26 +++++++++++++++++++ 3 files changed, 46 insertions(+), 5 deletions(-) create mode 100644 applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp create mode 100644 applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh diff --git a/applications/visual-dialog/evaluation/evaluation.lisp b/applications/visual-dialog/evaluation/evaluation.lisp index 3a96f034d..04fe85ac2 100644 --- a/applications/visual-dialog/evaluation/evaluation.lisp +++ b/applications/visual-dialog/evaluation/evaluation.lisp @@ -34,11 +34,15 @@ (defun evaluate-dialogs (start-scene end-scene world ) "evaluate all dialogs from start-scene to end-scene" "returns question-level-accuracy" - (with-open-file (str (make-file-name-with-time - (babel-pathname - :directory '("applications" "visual-dialog" "evaluation" "results") - :name (format nil "evaluation-~a-~a-~a" (get-configuration world :dataset) start-scene end-scene) - :type "txt")) + (ensure-directories-exist + (babel-pathname :directory `("applications" "visual-dialog" "evaluation" "results" + ,(format nil "~a-~a" (get-configuration world :dataset) (get-configuration world :mode))))) + (with-open-file (str (make-file-name-with-time + (babel-pathname + :directory `("applications" "visual-dialog" "evaluation" "results" ,(format nil "~a-~a" (get-configuration world :dataset) (get-configuration world :mode))) + :name (format nil "evaluation-~a-~a-~a" (get-configuration world :dataset) start-scene end-scene) + :type "txt")) + :direction :output :if-exists :supersede :if-does-not-exist :create) diff --git a/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp new file mode 100644 index 000000000..6e6ea06d2 --- /dev/null +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp @@ -0,0 +1,11 @@ +(ql:quickload :visual-dialog) +(in-package :visual-dialog) + +(defun main (args) + (let ((arg-plist (args->plist args))) + (print arg-plist) + (let ((start (* (parse-integer (getf arg-plist 'start)) 100)) + (end (+ 99 (* (parse-integer (getf arg-plist 'end)) 100)))) + (evaluate-clevr-dialogs-symbolic start-scene end-scene)))) + +(main #+sbcl (rest sb-ext:*posix-argv*)) \ No newline at end of file diff --git a/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh new file mode 100644 index 000000000..fa72ead58 --- /dev/null +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh @@ -0,0 +1,26 @@ +#!/bin/bash +#SBATCH --time=24:0:0 +#SBATCH --job-name=evaluation_clevr_symbolic +#SBATCH --ntasks=1 +#SBATCH --mem-per-cpu=20gb +#SBATCH --error /user/brussel/102/vsc10279/evaluation-clevr-symbolic/evaluation-clevr-symbolic_%a.log +#SBATCH --output /user/brussel/102/vsc10279/evaluation-clevr-symbolic/evaluation-clevr-symbolic_%a.log +#SBATCH --array=0-149 + + +cd $SLURM_SUBMIT_DIR +export TMPDIR=${TMPDIR/[/-} +export TMPDIR=${TMPDIR/]/} +mkdir -p $TMPDIR + +cd $VSC_DATA/ehai-babel/applications/visual-dialog/job_scripts + +module purge +module load SBCL/2.2.1-GCCcore-10.3.0 + +START=$SLURM_ARRAY_TASK_ID +END=$SLURM_ARRAY_TASK_ID + +sbcl --dynamic-space-size 6000 --load evaluation-clevr-symbolic.lisp --quit \ + start $START \ + end $END \ -- GitLab From 648a40a9c7fa49960fc915c4515f2a5325011470 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Wed, 23 Mar 2022 14:37:04 +0100 Subject: [PATCH 029/157] fixed formulation problem with prepositional phrases and added new cxns while checking formulation --- .../bidirectional_grammar_info_arg_struct.fcg | 510 +++++++++++------- 1 file changed, 308 insertions(+), 202 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 19066221c..df82b7d3b 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -1,4 +1,3 @@ - (def-fcg-constructions german-case-grammar :feature-types ((args sequence) (form set-of-predicates) @@ -129,58 +128,87 @@ -- (HASH form ((string ?to-word "zum")))))) + (def-fcg-cxn gegen-cxn - (<- + ((?against-word + (footprints (preposition))) + <- (?against-word + (footprints (not preposition)) (syn-cat (lex-class preposition) - (preposition +) (case ((- - - - -) (?acc ?am ?af ?an ?ap) (- - - - -) (- - - - -) (?as ?am ?af ?an ?ap)))) -- - (HASH form ((string ?against-word "gegen")))))) + (HASH form ((string ?against-word "gegen"))))) + :disable-automatic-footprints t) (def-fcg-cxn für-cxn - (<- + ((?for-word + (footprints (preposition))) + <- (?for-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?for-word "für"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn für-cxn + ((?without-word + (footprints (preposition))) + <- + (?without-word + (footprints (not preposition)) (syn-cat (lex-class preposition) - (preposition +) (case ((- - - - -) (?acc ?am ?af ?an ?ap) (- - - - -) (- - - - -) (?as ?am ?af ?an ?ap)))) -- - (HASH form ((string ?for-word "für")))))) + (HASH form ((string ?without-word "ohne"))))) + :disable-automatic-footprints t) (def-fcg-cxn mit-cxn - (<- + ((?with-word + (footprints (preposition))) + <- (?with-word + (footprints (not preposition)) (syn-cat (lex-class preposition) - (preposition +) (case ((- - - - -) (- - - - -) (- - - - -) (?dat ?dm ?df ?dn ?dp) (?s ?dm ?df ?dn ?dp)))) -- - (HASH form ((string ?with-word "mit")))))) + (HASH form ((string ?with-word "mit"))))) + :disable-automatic-footprints t) (def-fcg-cxn aus-cxn - (<- + ((?from-word + (footprints (preposition))) + <- (?from-word + (footprints (not preposition)) (syn-cat (lex-class preposition) - (preposition +) (case ((- - - - -) (- - - - -) (- - - - -) (?dat ?dm ?df ?dn ?dp) (?s ?dm ?df ?dn ?dp)))) -- - (HASH form ((string ?from-word "aus")))))) + (HASH form ((string ?from-word "aus"))))) + :disable-automatic-footprints t) (def-fcg-cxn Blumen-cxn @@ -373,31 +401,40 @@ (referent ?x) (syn-cat (lex-class prep-phrase) (case ?case)) - (constituents (?preposition ?noun-phrase)) + (constituents (?preposition ?article ?noun)) (boundaries (leftmost-unit ?preposition) - (rightmost-unit ?rightmost-noun-phrase))) + (rightmost-unit ?noun))) (?preposition (part-of-prep-phrase +) (referent ?x)) - (?noun-phrase + (?article + (referent ?x) + (part-of-noun-phrase +)) + (?noun (footprints (determined))) <- (?preposition -- (syn-cat (lex-class preposition) (case ?case))) - (?noun-phrase + (?article + -- + (syn-cat (lex-class article) + (case ?case))) + (?noun (footprints (not determined)) (referent ?x) - -- - (syn-cat (lex-class noun-phrase) + (syn-cat (lex-class noun) (case ?case)) - (boundaries (leftmost-unit ?leftmost-noun-phrase) - (rightmost-unit ?rightmost-noun-phrase))) - + + -- + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ?case))) (?prep-phrase -- - (HASH form ((meets ?preposition ?leftmost-noun-phrase))) + (HASH form ((meets ?preposition ?article) + (meets ?article ?noun))) )) :disable-automatic-footprints t) @@ -611,15 +648,82 @@ ))) -;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) -;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) +;der Mann schenkt dem Clown die Blumen +(def-fcg-cxn ditransitive-argument-structure-cxn + ((?ditransitive-argument-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?patient-unit + (syn-cat (syn-role direct-object))) + (?receiver-unit + (syn-cat (syn-role indirect-object))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type ditransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?patient-unit + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1) + ) + (?receiver-unit + (syn-cat + (case ?case)) + (referent ?arg2) + -- + (syn-cat + (case ?case)) + (referent ?arg2)) + + (?ditransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) -;der Mann schenkt dem Clown die Blumen -(def-fcg-cxn ditransitive-argument-structure-cxn +;;;this cxn contains boundaries for formulation (?) +#|(def-fcg-cxn ditransitive-argument-structure-cxn ((?ditransitive-argument-structure-unit (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) (?agent-unit @@ -645,6 +749,8 @@ (- - - - -) (- - - - -) (?as ?nm ?nf ?nn ?np)))) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) (referent ?arg0) -- (syn-cat (lex-class noun-phrase) @@ -653,6 +759,8 @@ (- - - - -) (- - - - -) (?as ?nm ?nf ?nn ?np)))) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) (referent ?arg0)) (?patient-unit @@ -662,6 +770,8 @@ (- - - - -) (- - - - -) (?ps ?am ?af ?an ?ap)))) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) (referent ?arg1) -- (syn-cat (lex-class noun-phrase) @@ -670,15 +780,21 @@ (- - - - -) (- - - - -) (?ps ?am ?af ?an ?ap)))) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) (referent ?arg1) ) (?receiver-unit (syn-cat (case ?case)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit)) (referent ?arg2) -- (syn-cat (case ?case)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit)) (referent ?arg2)) (?ditransitive-argument-structure-unit @@ -686,7 +802,14 @@ (:arg1 ?v ?arg1) (:arg2 ?v ?arg2))) -- - ))) + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-receiver-unit) + (meets ?rightmost-receiver-unit ?leftmost-patient-unit))) + )))|# + + + +;;; this cxn does not work if I add boundaries in the previous one for formulation (def-fcg-cxn topicalized-ditransitive-information-structure-cxn @@ -747,9 +870,68 @@ -;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) +#|(def-fcg-cxn topicalized-ditransitive-information-structure-cxn + ((?topicalized-ditransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?arg-and-info-struct-unit + (constituents (?topicalized-ditransitive-information-structure-unit ?argument-structure-unit))) + <- + + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + -- + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive)) + + -- + (syn-cat (lex-class verb) + (type ditransitive))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?patient-unit + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + + (?receiver-unit + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit)) + (referent ?arg2) + -- + (referent ?arg2) + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit))) + + (?topicalized-ditransitive-information-structure-unit + (HASH meaning ((topicalized ?arg2 +))) + -- + (HASH form ((meets ?rightmost-patient-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit) + (meets ?rightmost-agent-unit ?leftmost-patient-unit))) + ) + ))|# + + -(formulate-all '((drove-01 ig) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) +;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) ;der Mann geht zur Arbeit @@ -843,178 +1025,83 @@ (syn-cat (syn-role complement)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) + + (?intransitive-information-structure-unit + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-location-unit))) + ) )) - -;Der Mann ist gegen den Baum gefahren. - - -#|(def-fcg-cxn intransitive-acc-past-arg-structure-cxn - ((?intransitive-acc-past-arg-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit))) - (?agent-unit - (syn-cat (syn-role subject))) - (?location-unit - (syn-cat (syn-role complement))) +(def-fcg-cxn intransitive-information-structure-past-cxn + ((?intransitive-information-structure-past-unit + (constituents (?verb-unit ?agent-unit ?location-unit))) + (?arg-and-info-struct-unit + (constituents (?intransitive-information-structure-past-unit ?argument-structure-unit))) <- + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit)) + -- + (constituents (?verb-unit ?agent-unit ?location-unit)) + ) + (?verb-unit + (constituents (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) + (type intransitive) (aspect perfect)) (boundaries (leftmost-unit ?aux-unit) - (rightmost-unit ?participle-unit)) - (referent ?v) + (rightmost-unit ?participle-unit)) + -- + (constituents (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) + (type intransitive) (aspect perfect)) (boundaries (leftmost-unit ?aux-unit) - (rightmost-unit ?participle-unit)) - (referent ?v)) + (rightmost-unit ?participle-unit))) (?agent-unit - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) - (rightmost-unit ?rightmost-agent-unit)) - (referent ?arg0) + (rightmost-unit ?rightmost-agent-unit)) -- - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) - (rightmost-unit ?rightmost-agent-unit)) - (referent ?arg0)) + (rightmost-unit ?rightmost-agent-unit))) - (?location-unit - (syn-cat (lex-class prep-phrase) - (case ?case)) - (boundaries (leftmost-unit ?leftmost-loc-unit) - (rightmost-unit ?rightmost-loc-unit)) - (referent ?arg1) + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (lex-class prep-phrase) - (case ?case)) - (boundaries (leftmost-unit ?leftmost-loc-unit) - (rightmost-unit ?rightmost-loc-unit)) - (referent ?arg1)) - (?intransitive-acc-past-arg-structure-unit - (HASH meaning ((:arg0 ?v ?arg0) - (:arg1 ?v ?arg1))) + (syn-cat (syn-role complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + + (?intransitive-information-structure-past-unit -- (HASH form ((meets ?rightmost-agent-unit ?aux-unit) - (meets ?aux-unit ?leftmost-loc-unit) - (meets ?rightmost-loc-unit ?participle-unit)) + (meets ?aux-unit ?leftmost-location-unit) + (meets ?rightmost-location-unit ?participle-unit))) ) - )))|# - -;(formulate-all '((gehen-01 g) (man m) (arg0 g m) (arbeit a) (arg3 g a))) - -;der Mann fährt mit der Wagen zur Arbeit - - -;;;;;;;BEFORE this cxns is applied, the intransitive-cxn applies (this double one has one more additional element) - - -#|(def-fcg-cxn double-intransitive-argument-structure-cxn - ((?double-intransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit))) - (?agent-unit - (syn-cat (syn-role subject))) - (?medium-unit - (syn-cat (syn-role m-complement))) - (?location-unit - (syn-cat (syn-role l-complement))) - <- - (?verb-unit - (syn-cat (lex-class verb) - (type intransitive)) - (referent ?v) - -- - (syn-cat (lex-class verb) - (type intransitive)) - (referent ?v)) - - (?agent-unit - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) - (referent ?arg0) - -- - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) - (referent ?arg0)) - - (?medium-unit - (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ms ?dm ?df ?dn ?dp)))) - (referent ?arg2) - -- - (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ms ?dm ?df ?dn ?dp)))) - (referent ?arg2)) - - (?location-unit - (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ls ?dm ?df ?dn ?dp)))) - (referent ?arg1) - -- - (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ls ?dm ?df ?dn ?dp)))) - (referent ?arg1)) - - (?double-intransitive-argument-structure-unit - (HASH meaning ((:arg0 ?v ?arg0) - (:arg1 ?v ?arg1) - (:arg2 ?v ?arg2))) - -- - ))) - + )) -(def-fcg-cxn double-intransitive-information-structure-cxn - ((?double-intransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit))) +(def-fcg-cxn topicalized-intransitive-information-structure-cxn + ((?topicalized-intransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?double-intransitive-information-structure-unit ?argument-structure-unit))) + (constituents (?topicalized-intransitive-information-structure-unit ?argument-structure-unit))) <- (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit)) + (constituents (?verb-unit ?agent-unit ?location-unit)) -- - (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit)) + (constituents (?verb-unit ?agent-unit ?location-unit)) ) (?verb-unit @@ -1033,17 +1120,9 @@ (rightmost-unit ?rightmost-agent-unit)) -- (syn-cat (syn-role subject)) + (referent ?arg0) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) - - (?medium-unit - (syn-cat (syn-role complement)) - (boundaries (leftmost-unit ?leftmost-medium-unit) - (rightmost-unit ?rightmost-medium-unit)) - -- - (syn-cat (syn-role complement)) - (boundaries (leftmost-unit ?leftmost-medium-unit) - (rightmost-unit ?rightmost-medium-unit))) (?location-unit (syn-cat (syn-role complement)) @@ -1052,19 +1131,29 @@ -- (syn-cat (syn-role complement)) + (referent ?arg1) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) - - ))|# -;;; DOESNT GET APPLIED BUT THE INTRANSITIVE ARG STRUCTURE WITH ONE LESS UNIT DOES -(def-fcg-cxn diintransitive-argument-structure-cxn - ((?diintransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?medium-unit ?location-unit))) + (?topicalized-intransitive-information-structure-unit + (HASH meaning ((topicalized ?arg1 +))) + -- + (HASH form ((meets ?rightmost-location-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit))) + ))) + + + + +;der Mann geht ohne den Clown zur Arbeit + +(def-fcg-cxn double-intransitive-argument-structure-cxn + ((?double-intransitive-argument-structure-unit + (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) (?agent-unit (syn-cat (syn-role subject))) - (?medium-unit - (syn-cat (syn-role medium-complement))) + (?ad-info-unit + (syn-cat (syn-role extra-complement))) (?location-unit (syn-cat (syn-role location-complement))) <- @@ -1094,21 +1183,13 @@ (?as ?nm ?nf ?nn ?np)))) (referent ?arg0)) - (?medium-unit + (?ad-info-unit (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ms ?dm ?df ?dn ?dp)))) + (case ?case)) (referent ?arg1) -- (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ms ?dm ?df ?dn ?dp)))) + (case ?case)) (referent ?arg1) ) (?location-unit @@ -1128,7 +1209,7 @@ (?ls ?dm ?df ?dn ?dp)))) (referent ?arg2)) - (?diintransitive-argument-structure-unit + (?double-intransitive-argument-structure-unit (HASH meaning ((:arg0 ?v ?arg0) (:arg1 ?v ?arg1) (:arg2 ?v ?arg2))) @@ -1136,8 +1217,33 @@ ))) -(formulate-all '((man x))) -;(formulate '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg3 k s))) -;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg3 k s))) + + +;;; NPs with Determiners and PPs with NP+P or Contracted P +;(formulate-all '((baker x))) + +;;;; der Mann sucht den Clown +;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) + +;;; den Clown sucht der Mann +;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) + + +;;; der Mann kommt aus dem Shop +;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg1 k s))) + +;;; aus dem Shop kommt der Mann +;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg1 k s) (topicalized s +))) + + +;;;der Mann schenkt dem Clown die Blumen +;(formulate '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f))) + +;;; der Mann ist gegen die Blumen gefahren +;(formulate-all '((drove-01 ig) (man m) (arg0 ig m) (flowers f) (arg1 ig f))) + +;;; der Mann geht ohne den Clown zur Arbeit +;(formulate-all '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg2 g w))) + -- GitLab From e97a37353f8293e41bcf11b76e360f77630e969b Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Wed, 23 Mar 2022 14:48:38 +0100 Subject: [PATCH 030/157] fixed double-intransitive-information-structure-cxn and double-intransitive-argument-structure-cxn --- .../bidirectional_grammar_info_arg_struct.fcg | 56 +++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index df82b7d3b..53b000ecc 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -1217,7 +1217,63 @@ ))) +(def-fcg-cxn double-intransitive-information-structure-cxn + ((?double-intransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + (?arg-and-info-struct-unit + (constituents (?double-intransitive-information-structure-unit ?argument-structure-unit))) + <- + + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit)) + -- + (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + + -- + (syn-cat (lex-class verb) + (type intransitive))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?ad-info-unit + (syn-cat (syn-role extra-complement)) + (boundaries (leftmost-unit ?leftmost-ad-info-unit) + (rightmost-unit ?rightmost-ad-info-unit)) + -- + + (syn-cat (syn-role extra-complement)) + (boundaries (leftmost-unit ?leftmost-ad-info-unit) + (rightmost-unit ?rightmost-ad-info-unit))) + (?location-unit + (syn-cat (syn-role location-complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + (referent ?arg2) + -- + (referent ?arg2) + (syn-cat (syn-role location-complement)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + + (?double-intransitive-information-structure-unit + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-ad-info-unit) + (meets ?rightmost-ad-info-unit ?leftmost-location-unit)))) + + )) -- GitLab From d0b60b0de2589ba13397486b020278208fababcd Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 16:06:48 +0100 Subject: [PATCH 031/157] working job scripts --- .../job_scripts/evaluation-clevr-symbolic.lisp | 13 +++++++++++-- .../job_scripts/evaluation-clevr-symbolic.sh | 4 ++-- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp index 6e6ea06d2..71cef5c24 100644 --- a/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp @@ -1,11 +1,20 @@ (ql:quickload :visual-dialog) (in-package :visual-dialog) +(defparameter *clevr-data-path* + (make-pathname :directory '(:absolute "scratch" "brussel" "102" "vsc10279" "CLEVR-v1.0"))) + +(defun args->plist (args) + (loop for arg in args + for i from 0 + if (evenp i) collect (internal-symb (upcase arg)) + else collect arg)) + (defun main (args) (let ((arg-plist (args->plist args))) (print arg-plist) (let ((start (* (parse-integer (getf arg-plist 'start)) 100)) (end (+ 99 (* (parse-integer (getf arg-plist 'end)) 100)))) - (evaluate-clevr-dialogs-symbolic start-scene end-scene)))) + (evaluate-clevr-dialogs-symbolic start end)))) -(main #+sbcl (rest sb-ext:*posix-argv*)) \ No newline at end of file +(main #+sbcl (rest sb-ext:*posix-argv*)) diff --git a/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh index fa72ead58..8a088bd67 100644 --- a/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.sh @@ -3,7 +3,7 @@ #SBATCH --job-name=evaluation_clevr_symbolic #SBATCH --ntasks=1 #SBATCH --mem-per-cpu=20gb -#SBATCH --error /user/brussel/102/vsc10279/evaluation-clevr-symbolic/evaluation-clevr-symbolic_%a.log +#SBATCH --error /user/brussel/102/vsc10279/evaluation-clevr-symbolic/evaluation-clevr-symbolic_%a.err #SBATCH --output /user/brussel/102/vsc10279/evaluation-clevr-symbolic/evaluation-clevr-symbolic_%a.log #SBATCH --array=0-149 @@ -13,7 +13,7 @@ export TMPDIR=${TMPDIR/[/-} export TMPDIR=${TMPDIR/]/} mkdir -p $TMPDIR -cd $VSC_DATA/ehai-babel/applications/visual-dialog/job_scripts +cd $VSC_DATA/babel/applications/visual-dialog/evaluation/job_scripts/ module purge module load SBCL/2.2.1-GCCcore-10.3.0 -- GitLab From a1a429037302669632809c404d5c67bf20008929 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 16:24:44 +0100 Subject: [PATCH 032/157] added mnist symbolic job scripts --- .../evaluation-mnist-symbolic.lisp | 20 ++++++++++++++ .../job_scripts/evaluation-mnist-symbolic.sh | 26 +++++++++++++++++++ 2 files changed, 46 insertions(+) create mode 100644 applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.lisp create mode 100644 applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.sh diff --git a/applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.lisp b/applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.lisp new file mode 100644 index 000000000..742d6637e --- /dev/null +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.lisp @@ -0,0 +1,20 @@ +(ql:quickload :visual-dialog) +(in-package :visual-dialog) + +(defparameter *mnist-data-path* + (make-pathname :directory '(:absolute "scratch" "brussel" "102" "vsc10279" "MNIST_VD"))) + +(defun args->plist (args) + (loop for arg in args + for i from 0 + if (evenp i) collect (internal-symb (upcase arg)) + else collect arg)) + +(defun main (args) + (let ((arg-plist (args->plist args))) + (print arg-plist) + (let ((start (* (parse-integer (getf arg-plist 'start)) 100)) + (end (+ 99 (* (parse-integer (getf arg-plist 'end)) 100)))) + (evaluate-mnist-dialogs-symbolic start end)))) + +(main #+sbcl (rest sb-ext:*posix-argv*)) diff --git a/applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.sh b/applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.sh new file mode 100644 index 000000000..eb296ff06 --- /dev/null +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-mnist-symbolic.sh @@ -0,0 +1,26 @@ +#!/bin/bash +#SBATCH --time=24:0:0 +#SBATCH --job-name=evaluation_mnist_symbolic +#SBATCH --ntasks=1 +#SBATCH --mem-per-cpu=20gb +#SBATCH --error /user/brussel/102/vsc10279/evaluation-mnist-symbolic/evaluation-mnist-symbolic_%a.err +#SBATCH --output /user/brussel/102/vsc10279/evaluation-mnist-symbolic/evaluation-mnist-symbolic_%a.log +#SBATCH --array=0-99 + + +cd $SLURM_SUBMIT_DIR +export TMPDIR=${TMPDIR/[/-} +export TMPDIR=${TMPDIR/]/} +mkdir -p $TMPDIR + +cd $VSC_DATA/babel/applications/visual-dialog/evaluation/job_scripts/ + +module purge +module load SBCL/2.2.1-GCCcore-10.3.0 + +START=$SLURM_ARRAY_TASK_ID +END=$SLURM_ARRAY_TASK_ID + +sbcl --dynamic-space-size 6000 --load evaluation-mnist-symbolic.lisp --quit \ + start $START \ + end $END \ -- GitLab From 6cb8bc44107d8b2c24ddda421cc0f9c087494094 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 19:59:27 +0100 Subject: [PATCH 033/157] bugfix grammar --- grammars/clevr-dialog-grammar-new/relations.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/grammars/clevr-dialog-grammar-new/relations.lisp b/grammars/clevr-dialog-grammar-new/relations.lisp index f11fd125c..69f97185e 100644 --- a/grammars/clevr-dialog-grammar-new/relations.lisp +++ b/grammars/clevr-dialog-grammar-new/relations.lisp @@ -912,7 +912,7 @@ (syn-cat (syn-class adjective) (leftmost-unit ?the-unit) (rightmost-unit ?thing-unit)) - (subunits (?the-unit ?leftmost-unit ?thing-unit)) + (subunits (?the-unit ?midmost-unit ?thing-unit)) (footprints (xmost-thing))) <- (?the-midmost-thing-unit @@ -941,7 +941,7 @@ (syn-cat (syn-class adjective) (leftmost-unit ?the-unit) (rightmost-unit ?thing-unit)) - (subunits (?the-unit ?leftmost-unit ?thing-unit)) + (subunits (?the-unit ?midmost-unit ?thing-unit)) (footprints (xmost-thing))) <- (?the-midmost-thing-unit -- GitLab From d1858cce54ad246080b4309b230d078f07166382 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Wed, 23 Mar 2022 20:01:49 +0100 Subject: [PATCH 034/157] print progress evaluation --- applications/visual-dialog/evaluation/evaluation.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/applications/visual-dialog/evaluation/evaluation.lisp b/applications/visual-dialog/evaluation/evaluation.lisp index 04fe85ac2..b8aa54b94 100644 --- a/applications/visual-dialog/evaluation/evaluation.lisp +++ b/applications/visual-dialog/evaluation/evaluation.lisp @@ -55,6 +55,7 @@ (loop for scene from start-scene to end-scene append (progn (format str "evaluation of scene ~a~%" scene) (force-output str) + (format t "evaluation of scene ~a~%" scene) (loop for dialog from 0 to number-of-dialogs for (result-whole-dialog result-one-dialog) = (multiple-value-list (evaluate-dialog :scene-index scene -- GitLab From dfe752fe37712a44ba784dfefce5fd86c8b5b6e5 Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 24 Mar 2022 10:11:45 +0100 Subject: [PATCH 035/157] bugfix in clevr-world; changed pathname accessor to reader --- sharing/clevr-world/clevr-ontology.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sharing/clevr-world/clevr-ontology.lisp b/sharing/clevr-world/clevr-ontology.lisp index dd668a777..9609afe20 100644 --- a/sharing/clevr-world/clevr-ontology.lisp +++ b/sharing/clevr-world/clevr-ontology.lisp @@ -59,7 +59,7 @@ (defclass pathname-entity (entity) ((pathname :type (or null pathname) :initarg :pathname - :accessor pathname :initform nil)) + :reader pathname :initform nil)) (:documentation "Using pathnames as irl entities")) ;; ################################ -- GitLab From 533dcd3d48a9dc215c8f390c1a6548d9eaf71b41 Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 24 Mar 2022 10:12:18 +0100 Subject: [PATCH 036/157] added spatial concept game --- experiments/spatial-concept-game/.gitignore | 3 + experiments/spatial-concept-game/agent.lisp | 441 +++++++++++++ .../spatial-concept-game/alignment.lisp | 202 ++++++ .../color-conversions.lisp | 238 +++++++ experiments/spatial-concept-game/concept.lisp | 221 +++++++ .../spatial-concept-game/experiment.lisp | 151 +++++ .../fuzzy-operations.lisp | 55 ++ experiments/spatial-concept-game/html.lisp | 28 + .../spatial-concept-game/interaction.lisp | 256 ++++++++ experiments/spatial-concept-game/misc.lisp | 99 +++ .../spatial-concept-game/monitors.lisp | 616 ++++++++++++++++++ experiments/spatial-concept-game/package.lisp | 21 + experiments/spatial-concept-game/run.lisp | 342 ++++++++++ .../spatial-concept-game/spatial-concepts.asd | 33 + experiments/spatial-concept-game/utils.lisp | 222 +++++++ .../spatial-concept-game/web-demo.lisp | 140 ++++ .../spatial-concept-game/web-monitor.lisp | 182 ++++++ experiments/spatial-concept-game/world.lisp | 206 ++++++ 18 files changed, 3456 insertions(+) create mode 100644 experiments/spatial-concept-game/.gitignore create mode 100644 experiments/spatial-concept-game/agent.lisp create mode 100644 experiments/spatial-concept-game/alignment.lisp create mode 100644 experiments/spatial-concept-game/color-conversions.lisp create mode 100644 experiments/spatial-concept-game/concept.lisp create mode 100644 experiments/spatial-concept-game/experiment.lisp create mode 100644 experiments/spatial-concept-game/fuzzy-operations.lisp create mode 100644 experiments/spatial-concept-game/html.lisp create mode 100644 experiments/spatial-concept-game/interaction.lisp create mode 100644 experiments/spatial-concept-game/misc.lisp create mode 100644 experiments/spatial-concept-game/monitors.lisp create mode 100644 experiments/spatial-concept-game/package.lisp create mode 100644 experiments/spatial-concept-game/run.lisp create mode 100644 experiments/spatial-concept-game/spatial-concepts.asd create mode 100644 experiments/spatial-concept-game/utils.lisp create mode 100644 experiments/spatial-concept-game/web-demo.lisp create mode 100644 experiments/spatial-concept-game/web-monitor.lisp create mode 100644 experiments/spatial-concept-game/world.lisp diff --git a/experiments/spatial-concept-game/.gitignore b/experiments/spatial-concept-game/.gitignore new file mode 100644 index 000000000..8b3d46b96 --- /dev/null +++ b/experiments/spatial-concept-game/.gitignore @@ -0,0 +1,3 @@ +raw-data/* +graphs/* +store/* diff --git a/experiments/spatial-concept-game/agent.lisp b/experiments/spatial-concept-game/agent.lisp new file mode 100644 index 000000000..0901085d1 --- /dev/null +++ b/experiments/spatial-concept-game/agent.lisp @@ -0,0 +1,441 @@ +(in-package :spatial-concepts) + +;; ------------- +;; + MWM agent + +;; ------------- +(defclass mwm-agent (agent) + ((lexicon + :documentation "The agent's lexicon" + :type list :accessor lexicon :initform nil) + (concept-history + :documentation "Maintaining versions of concepts" + :type list :accessor concept-history :initform nil)) + (:documentation "The agent class")) + +;; --------------------------- +;; + Agent utility functions + +;; --------------------------- +(defmethod speakerp ((agent mwm-agent)) + (eql (discourse-role agent) 'speaker)) + +(defmethod hearerp ((agent mwm-agent)) + (eql (discourse-role agent) 'hearer)) + +(defmethod learnerp ((agent mwm-agent)) + (eql (id agent) 'learner)) + +(defmethod tutorp ((agent mwm-agent)) + (eql (id agent) 'tutor)) + +(defun make-tutor-agent (experiment) + (make-instance 'mwm-agent :id 'tutor + :experiment experiment)) + +(defun make-learner-agent (experiment) + (make-instance 'mwm-agent :id 'learner + :experiment experiment)) + + +;;;; +;;;; concept history +;;;; +(defun add-to-concept-history (agent concept) + "Keep the 5 latest versions of each concept" + (let ((entry (assoc (form concept) (concept-history agent) :test #'string=)) + (copy (copy-object concept))) + (if entry + (progn + (when (> (length (rest entry)) 5) + (setf (rest entry) (butlast (rest entry)))) + (push copy (rest entry))) + (push (cons (form concept) (list copy)) + (concept-history agent))))) + +(defun average-over-concepts (list-of-concepts) + (let ((all-attributes + (remove-duplicates + (loop for concept in list-of-concepts + append (loop for prototype in (meaning concept) + collect (attribute prototype)))))) + ;; if an attribute occurs in all 5 concepts in the concept history + ;; return it + (loop with latest-concept = (first list-of-concepts) + for attribute in all-attributes + when (loop for concept in list-of-concepts + for attributes-with-positive-certainty + = (loop for prototype in (meaning concept) + when (> (certainty prototype) 0.01) + collect (attribute prototype)) + always (member attribute attributes-with-positive-certainty)) + collect (find attribute (meaning latest-concept) + :key #'attribute) into meaning + finally (return meaning)))) + +(defun average-over-concept-history (agent) + (loop for (form . concepts) in (concept-history agent) + for averaged-meaning = (average-over-concepts concepts) + collect (make-instance 'concept :form form :meaning averaged-meaning))) + +;; --------------------- +;; + Conceptualisation + +;; --------------------- +(define-event conceptualisation-finished (agent mwm-agent)) + +(defgeneric conceptualise (agent) + (:documentation "run conceptualisation")) + +(defmethod conceptualise (agent) + (case (id agent) + (tutor (tutor-conceptualise agent)) + (learner (learner-conceptualise agent)))) + + +;;;; Tutor conceptualisation +(defmethod tutor-conceptualise ((agent mwm-agent)) + (loop while t + for success = (run-tutor-conceptualisation agent) + if success return success + else do (sample-topic (experiment agent)))) + +(defun discriminative-combination? (list-of-attributes list-of-object-attributes) + "Returns t if the attribute combination in list-of-attributes + does not occur in any of the list-of-object-attributes." + (let ((unique t)) ;; unique until opposite is proven + (loop for object-attributes in list-of-object-attributes + while unique + when (loop for attribute in list-of-attributes + always (eql (rest attribute) + (rest (assoc (car attribute) object-attributes)))) + do (setf unique nil)) + unique)) + +(defun discriminate-topic (topic list-of-objects) + "Returns the minimal amount of (attr . val) conses that + discriminates object from the objects in list-of-objects. + Make sure the object is not in list-of-objects, otherwise + the functions will logically return nil." + (loop for nr-of-attr-needed from 1 to (length topic) + for attr-combinations = (shuffle (combinations-of-length topic nr-of-attr-needed)) + do (loop for attr-combination in attr-combinations + when (discriminative-combination? attr-combination list-of-objects) + do (return-from discriminate-topic attr-combination)))) + +(defmethod run-tutor-conceptualisation ((agent mwm-agent)) + "The tutor uses a symbolic representation of the context and + computes the minimal discriminative set of attributes" + (let* ((all-objects-features + (loop for object in (objects (get-data agent 'tutor-context)) + collect (cons (id object) (object->alist object)))) + (topic (get-data agent 'tutor-topic)) + (topic-features + (cdr (find (id topic) all-objects-features :key #'car))) + (context-features + (mapcar #'cdr + (remove-if #'(lambda (id) (eql id (id topic))) + all-objects-features :key #'car))) + (discriminative-features + (mapcar #'cdr (discriminate-topic topic-features context-features)))) + ;; fixed to 1 discriminative feature + (when (length= discriminative-features 1) + (set-data agent 'tutor-conceptualisation (first discriminative-features))) + (notify conceptualisation-finished agent) + ;; returns the feature or nil + (find-data agent 'tutor-conceptualisation))) + + +;;;; Learner conceptualisation +(defmethod learner-conceptualise ((agent mwm-agent)) + "In some cases, the tutor cannot even discriminate the topic. + If this is the case, the learner should not even try" + (let ((tutor (find 'tutor (population (experiment agent)) :key #'id))) + (loop while t + for possible-to-conceptualise-symbolically + = (with-disabled-monitors (run-tutor-conceptualisation tutor)) + if possible-to-conceptualise-symbolically + return (run-learner-conceptualisation agent) + else do (sample-topic (experiment agent))))) + +(defmethod run-learner-conceptualisation ((agent mwm-agent)) + "The learner conceptualises the topic using a single cxn." + (when (lexicon agent) + (let ((topic (get-data agent 'topic)) + (context (objects (get-data agent 'context)))) + (loop with most-discriminating-concept = nil + with best-similarity = 0 + with biggest-delta = 0 + for concept in (lexicon agent) + for topic-similarity = (weighted-similarity topic concept) + for best-other-similarity + = (loop for object in (remove topic context) + maximize (weighted-similarity object concept)) + for delta = (- topic-similarity best-other-similarity) + when (and (> topic-similarity best-other-similarity) + (< best-other-similarity 0) + (> delta biggest-delta) + (> topic-similarity best-similarity)) + do (setf most-discriminating-concept concept + biggest-delta delta + best-similarity topic-similarity) + finally + (set-data agent 'applied-concept most-discriminating-concept)) + (notify conceptualisation-finished agent)) + (find-data agent 'applied-concept))) + +#| +(defparameter *impossible-combinations* + (append + (combinations-of-length '("BLUE-CXN" "BROWN-CXN" "CYAN-CXN" "GRAY-CXN" + "GREEN-CXN" "PURPLE-CXN" "RED-CXN" "YELLOW-CXN") 2) + (combinations-of-length '("BEHIND-CXN" "LEFT-CXN" "RIGHT-CXN" "FRONT-CXN") 2) + (combinations-of-length '("CUBE-CXN" "CYLINDER-CXN" "SPHERE-CXN") 2) + (combinations-of-length '("METAL-CXN" "RUBBER-CXN") 2) + (combinations-of-length '("LARGE-CXN" "SMALL-CXN") 2))) + +(defun valid-combination-p (cxns) + (let ((cxn-names (mapcar (compose #'upcase #'mkstr #'name) cxns))) + (loop for (name-a name-b) in *impossible-combinations* + never (and (find name-a cxn-names :test #'string=) + (find name-b cxn-names :test #'string=))))) + +(defun get-discriminating-cxn-for-object (agent object cxns meanings) + (loop with best-cxn = nil + with best-similarity = 0 + with largest-difference = 0 + for cxn in cxns + for meaning in meanings + for object-similarity = (weighted-similarity object meaning) + for best-other-similarity + = (when (> object-similarity 0) + (loop for other in (remove object (objects (get-data agent 'context))) + maximize (weighted-similarity other meaning))) + for diff = (when best-other-similarity + (- object-similarity best-other-similarity)) + when (and object-similarity best-other-similarity + (> object-similarity best-other-similarity) + (> diff largest-difference) + (> object-similarity best-similarity)) + do (setf best-cxn cxn + best-similarity object-similarity + largest-difference diff) + finally (return best-cxn))) + +(defun get-best-cxn-for-others (agent cxns meanings) + (loop for object in (remove (get-data agent 'topic) + (objects (get-data agent 'context))) + collect (loop with best-cxn = nil + with best-similarity = 0 + for cxn in cxns + for meaning in meanings + for object-similarity = (weighted-similarity object meaning) + when (> object-similarity best-similarity) + do (setf best-cxn cxn + best-similarity object-similarity) + finally (return best-cxn)))) + +(defmethod conceptualise ((agent mwm-agent) (role (eql 'learner))) + (when (constructions (grammar agent)) + (loop for i from 1 to (get-configuration agent :max-tutor-utterance-length) + for cxns = (if (= i 1) (constructions (grammar agent)) + (remove-if-not #'valid-combination-p + (combinations-of-length + (constructions (grammar agent)) i))) + for meanings = (loop for elem in cxns + if (listp elem) + collect (reduce #'fuzzy-union + (mapcar #'(lambda (cxn) (attr-val cxn :meaning)) + elem)) + else collect (attr-val elem :meaning)) + for topic-cxn + = (get-discriminating-cxn-for-object agent (get-data agent 'topic) cxns meanings) + for other-cxns + = (when topic-cxn + (get-best-cxn-for-others agent cxns meanings)) + unless (member topic-cxn other-cxns :test #'equal) + do (progn (set-data agent 'applied-cxns + (if (listp topic-cxn) topic-cxn (list topic-cxn))) + (return)))) + (notify conceptualisation-finished agent) + (find-data agent 'applied-cxns)) + + (defmethod run-learner-conceptualisation ((agent mwm-agent)) + (when (constructions (grammar agent)) + (let* ((cxns (loop for i from 1 to (get-configuration agent :max-tutor-utterance-length) + append (if (= i 1) (constructions (grammar agent)) + (remove-if-not #'valid-combination-p + (combinations-of-length (constructions (grammar agent)) i))))) + (meanings (loop for cxn in cxns + if (listp cxn) + collect (reduce #'fuzzy-union + (mapcar #'(lambda (cxn) + (attr-val cxn :meaning)) + cxn)) + else collect (attr-val cxn :meaning))) + (topic (get-data agent 'topic)) + (context (objects (get-data agent 'context)))) + (when meanings + (loop with best-cxn = nil + with best-similarity = 0 + with largest-difference = 0 + for cxn in cxns + for meaning in meanings + for topic-similarity = (weighted-similarity topic meaning) + for best-other-similarity + = (when (> topic-similarity 0) + (loop for object in (remove topic context) + maximize (weighted-similarity object meaning))) + for diff = (when best-other-similarity + (- topic-similarity best-other-similarity)) + when (and topic-similarity best-other-similarity + (> topic-similarity best-other-similarity) + (> diff largest-difference) + (> topic-similarity best-similarity)) + do (setf best-cxn cxn + best-similarity topic-similarity + largest-difference diff) + finally (set-data agent 'applied-cxns + (if (listp best-cxn) best-cxn + (list best-cxn))))))) + (notify conceptualisation-finished agent) + (find-data agent 'applied-cxns)) +|# + + + +;; -------------- +;; + Production + +;; -------------- +(define-event production-finished (agent mwm-agent)) + +(defgeneric produce-word (agent) + (:documentation "Produce an utterance")) + +(defmethod produce-word ((agent mwm-agent)) + (case (id agent) + (tutor (tutor-produce-word agent)) + (learner (learner-produce-word agent)))) + +(defmethod tutor-produce-word ((agent mwm-agent)) + "Simply make strings from the symbols. When lexical variation is + enabled, the tutor randomly chooses one of the available + synonyms." + (setf (utterance agent) + (downcase + (mkstr + (get-data agent 'tutor-conceptualisation)))) + (notify production-finished agent) + (utterance agent)) + +(defmethod learner-produce-word ((agent mwm-agent)) + (when (find-data agent 'applied-concept) + (setf (utterance agent) + (form (find-data agent 'applied-concept)))) + (notify production-finished agent) + (utterance agent)) + +;; ----------- +;; + Parsing + +;; ----------- +(define-event parsing-finished (agent mwm-agent)) + +(defgeneric parse-word (agent) + (:documentation "Parse an utterance")) + +(defmethod parse-word ((agent mwm-agent)) + (case (id agent) + (tutor (tutor-parse-word agent)) + (learner (learner-parse-word agent)))) + +(defmethod tutor-parse-word ((agent mwm-agent)) + t) + +(defmethod learner-parse-word ((agent mwm-agent)) + "Parse as much words as possible and compute the combined meaning + using the fuzzy-union operation. Set the applied-cxns and parsed-meaning. + This is overkill since only single words are being used." + (let ((concept (find (utterance agent) (lexicon agent) :key #'form :test #'string=))) + (when concept + (set-data agent 'applied-concept concept))) + (notify parsing-finished agent) + (find-data agent 'applied-concept)) + +;; ------------------ +;; + Interpretation + +;; ------------------ +(define-event interpretation-finished (agent mwm-agent)) + +(defgeneric interpret (agent) + (:documentation "Interpret a meaning")) + +(defmethod interpret ((agent mwm-agent)) + (case (id agent) + (tutor (tutor-interpret agent)) + (learner (learner-interpret agent)))) + +(defun match-utterance-to-objects (objects utterance) + (let ((all-objects-as-alist + (loop for object in objects + collect (cons (id object) (object->alist object))))) + (loop for (id . object) in all-objects-as-alist + for object-attributes = (mapcar (compose #'downcase #'mkstr #'cdr) object) + when (member utterance object-attributes :test #'string=) + collect (find id objects :key #'id)))) + +(defmethod tutor-interpret ((agent mwm-agent)) + ;; if the learner says 'blue', the tutor will find + ;; all objects that are indeed blue. If the tutor finds more + ;; than one object, interpretation fails. + ;; there is no guessing + (let ((objects-with-utterance + (match-utterance-to-objects + (objects (get-data agent 'tutor-context)) + (utterance agent)))) + (when (and objects-with-utterance + (length= objects-with-utterance 1)) + (set-data agent 'interpreted-topic (first objects-with-utterance)))) + (notify interpretation-finished agent) + (find-data agent 'interpreted-topic)) + + +(defmethod learner-interpret ((agent mwm-agent)) + "The agent computes the weighted similarity between the parsed-meaning + and each of the objects in the context. The topic is the + object for which this value is maximized." + (when (find-data agent 'applied-concept) + (let* ((objects-with-similarity + (loop with concept = (find-data agent 'applied-concept) + for object in (objects (get-data agent 'context)) + for sim = (weighted-similarity object concept) + collect (cons object sim))) + ;; if two objects have exactly the same + ;; maximum similarity, interpretation fails + (highest-pair + (the-biggest #'cdr objects-with-similarity)) + (maybe-topic (car highest-pair)) + (duplicatesp (> (count (cdr highest-pair) + objects-with-similarity + :key #'cdr :test #'=) + 1))) + (set-data agent 'interpreted-topic + (unless duplicatesp maybe-topic)))) + (notify interpretation-finished agent) + (find-data agent 'interpreted-topic)) + + +;; --------------------- +;; + Determine success + +;; --------------------- + +(defgeneric determine-success (speaker hearer) + (:documentation "Determine the success of the interaction")) + +(defmethod determine-success ((speaker mwm-agent) (hearer mwm-agent)) + (if (and (eql (id speaker) 'tutor) + (eql (id hearer) 'learner)) + (and (find-data hearer 'interpreted-topic) + (eql (id (get-data speaker 'topic)) + (id (get-data hearer 'interpreted-topic)))) + (and (find-data hearer 'interpreted-topic) + (eql (id (get-data speaker 'tutor-topic)) + (id (get-data hearer 'interpreted-topic)))))) + + diff --git a/experiments/spatial-concept-game/alignment.lisp b/experiments/spatial-concept-game/alignment.lisp new file mode 100644 index 000000000..66313d970 --- /dev/null +++ b/experiments/spatial-concept-game/alignment.lisp @@ -0,0 +1,202 @@ +(in-package :spatial-concepts) + +;;;; Adopting unknown words +(define-event new-concept-added (concept concept)) + +(defgeneric adopt-concept (agent topic word) + (:documentation "Adopt an unknown word by making a concept + with this word + all feature-values of the topic object. + Each feature receives an initial certainty value. The + newly created concept is added to the agent's lexicon.")) + +(defmethod adopt-concept ((agent mwm-agent) (topic mwm-object) word) + (let ((new-concept + (make-concept word (attributes topic) + (get-configuration agent :initial-certainty)))) + (push new-concept (lexicon agent)) + (notify new-concept-added new-concept) + new-concept)) + + + + +;;;; Aligning known concept +(define-event scores-updated (concept concept) (rewarded-attrs list) (punished-attrs list)) +(define-event found-discriminating-attributes (attributes list)) +(define-event found-subset-to-reward (subset list)) + +;; compute the (weighted) similarities between the concept +;; and all objects in the scene, for all attributes of the concept +;; and store them/re-use them to compute the discriminative +;; attributes and to find the most discriminative subset +;; this saves a lot of computations!! +(defun make-similarity-table (agent concept) + (loop with attribute-hash = (make-hash-table) + for prototype in (meaning concept) + for attribute = (attribute prototype) + for objects-hash + = (loop with hash = (make-hash-table) + for object in (objects (get-data agent 'context)) + for s = (similarity object prototype) + for ws = (* (certainty prototype) s) + do (setf (gethash (id object) hash) (cons s ws)) + finally (return hash)) + do (setf (gethash attribute attribute-hash) objects-hash) + finally (return attribute-hash))) + +;; retrieve the similarity for the given object-attribute combination +(defun get-s (object attribute table) + (car (gethash (id object) (gethash attribute table)))) + +;; retrieve the weighted similarity for the given object-attribute combination +(defun get-ws (object attribute table) + (cdr (gethash (id object) (gethash attribute table)))) + +(defun find-discriminating-attributes (agent concept topic similarity-table) + "Find all attributes that are discriminating for the topic" + (let ((context (remove topic (objects (get-data agent 'context))))) + (loop with discriminating-attributes = nil + for prototype in (meaning concept) + for attribute = (attribute prototype) + for topic-similarity = (get-s topic attribute similarity-table) + for best-other-similarity + = (when (> topic-similarity 0) + (loop for object in context + maximize (get-s object attribute similarity-table))) + when (and topic-similarity best-other-similarity + (> topic-similarity best-other-similarity)) + do (push attribute discriminating-attributes) + finally + (progn (notify found-discriminating-attributes discriminating-attributes) + (return discriminating-attributes))))) + + +(defmethod filter-subsets (all-subsets discriminating-attributes (mode (eql :none))) + (declare (ignorable discriminating-attributes)) + all-subsets) + +(defmethod filter-subsets (all-subsets discriminating-attributes (mode (eql :all))) + "Filter all subsets with the discriminating attributes, only + keeping those subsets where all discriminating attributes occur in" + (loop with applicable-subsets = nil + for subset in all-subsets + for subset-attributes + = (mapcar #'attribute subset) + when (null (set-difference discriminating-attributes subset-attributes)) + do (push subset applicable-subsets) + finally + (return applicable-subsets))) + +(defmethod filter-subsets (all-subsets discriminating-attributes (mode (eql :at-least-one))) + "Filter all subsets with the discriminating attributes, only + keeping those subsets where at least one discriminating attribute occurs in" + (loop with applicable-subsets = nil + for subset in all-subsets + for subset-attributes + = (mapcar #'attribute subset) + unless (null (intersection discriminating-attributes subset-attributes)) + do (push subset applicable-subsets) + finally + (return applicable-subsets))) + + +(defun weighted-similarity-with-table (object list-of-prototypes table) + (loop for prototype in list-of-prototypes + for attribute = (attribute prototype) + for ws = (get-ws object attribute table) + collect ws into weighted-similarities + finally (return (average weighted-similarities)))) + + +(defun find-most-discriminating-subset (agent subsets topic similarity-table) + "Find the subset that maximizes the difference in similarity + between the topic and the best other object" + (let ((context (remove topic (objects (get-data agent 'context)))) + (best-subset nil) + (largest-diff 0) + (best-similarity 0)) + (dolist (subset subsets) + (let ((topic-similarity (weighted-similarity-with-table topic subset similarity-table))) + (when (> topic-similarity 0) + (let* ((best-other-similarity + (loop for object in context + maximize (weighted-similarity-with-table object subset similarity-table))) + (diff (- topic-similarity best-other-similarity))) + (when (and (> topic-similarity best-other-similarity) + (> diff largest-diff) + (> topic-similarity best-similarity)) + (setf best-subset subset + largest-diff diff + best-similarity topic-similarity)))))) + (notify found-subset-to-reward best-subset) + best-subset)) + + +(defgeneric align-concept (agent topic concept) + (:documentation "Align the concept that was used during the + game so that it better fits with the topic object of the + game.")) + + +(defmethod align-concept ((agent mwm-agent) (topic mwm-object) concept) + ;; 1. update the prototypical values + (loop for prototype in (meaning concept) + do (update-prototype prototype topic)) + ;; 2. determine which attributes should get an increase + ;; in certainty, and which should get a decrease. + (let* ((similarity-table + (make-similarity-table agent concept)) + (discriminating-attributes + (find-discriminating-attributes + agent concept topic similarity-table)) + (all-attribute-subsets + (all-subsets (meaning concept))) + (subsets-to-consider + (filter-subsets + all-attribute-subsets discriminating-attributes + (get-configuration agent :alignment-filter))) + (best-subset + (find-most-discriminating-subset + agent subsets-to-consider topic similarity-table))) + (when (null best-subset) + ;; when best-subset returns NIL + ;; reward all attributes... + (format t "!") + (setf best-subset (meaning concept))) + (add-to-concept-history agent concept) + ;; 3. actually update the certainty scores + (loop with rewarded-attributes = nil + with punished-attributes = nil + for prototype in (meaning concept) + if (member (attribute prototype) best-subset :key #'attribute) + do (progn (push (attribute prototype) rewarded-attributes) + (adjust-certainty agent concept (attribute prototype) + (get-configuration agent :certainty-incf))) + else + do (progn (push (attribute prototype) punished-attributes) + (adjust-certainty agent concept (attribute prototype) + (get-configuration agent :certainty-decf) + :remove-on-lower-bound + (get-configuration agent :remove-on-lower-bound))) + finally + (notify scores-updated concept rewarded-attributes punished-attributes)))) + + +;; ------------- +;; + Alignment + +;; ------------- +(defgeneric alignment (agent topic applied-concept) + (:documentation "Do alignment")) + +(define-event align-concept-started (word string)) +(define-event adopt-concept-started (word string)) + +(defmethod alignment ((agent mwm-agent) (topic mwm-object) applied-concept) + ;; applied-concept can be NIL + (if applied-concept + (progn (notify align-concept-started (form applied-concept)) + (align-concept agent topic applied-concept)) + (progn (notify adopt-concept-started (utterance agent)) + (adopt-concept agent topic (utterance agent))))) + + \ No newline at end of file diff --git a/experiments/spatial-concept-game/color-conversions.lisp b/experiments/spatial-concept-game/color-conversions.lisp new file mode 100644 index 000000000..857765f96 --- /dev/null +++ b/experiments/spatial-concept-game/color-conversions.lisp @@ -0,0 +1,238 @@ +(in-package :spatial-concepts) + +;; based on http://www.brucelindbloom.com/index.html?Eqn_ChromAdapt.html +(defparameter *reference-white-D50* (list 0.96422 1.00000 0.82521) + "Represents natural daylight.") +(defparameter *reference-white-D65* (list 0.95047 1.00000 1.08883) + "Represents natural daylight.") +(defparameter *reference-white-c* (list 0.98074 1.00000 1.18232)) + +(defun check-domain (vals min max) + (loop for val in vals + unless (and (>= val min) (<= val max)) + do (return-from check-domain nil)) + vals) + +;; --------------- +;; + XYZ <-> LAB + +;; --------------- + +;; based on http://www.brucelindbloom.com/Eqn_XYZ_to_Lab.html +(defun xyz->lab (xyz reference-white) + "Converts values from XYZ [0,1] to CIEL*a*b* colour space." + (let ((x (first xyz)) + (y (second xyz)) + (z (third xyz)) + (x_r (first reference-white)) + (y_r (second reference-white)) + (z_r (third reference-white)) + (epsilon (/ 216 24389)) + (kappa (/ 24389 27))) + (let ((x-_r (/ x x_r)) + (y-_r (/ y y_r)) + (z-_r (/ z z_r))) + (let ((f_x (if (> x-_r epsilon) + (expt x-_r (/ 1 3)) + (/ (+ (* kappa x-_r) 16) 116))) + (f_y (if (> y-_r epsilon) + (expt y-_r (/ 1 3)) + (/ (+ (* kappa y-_r) 16) 116))) + (f_z (if (> z-_r epsilon) + (expt z-_r (/ 1 3)) + (/ (+ (* kappa z-_r) 16) 116)))) + (list (- (* 116 f_y) 16) + (* 500 (- f_x f_y)) + (* 200 (- f_y f_z))))))) + +;; based on http://www.brucelindbloom.com/Eqn_Lab_to_XYZ.html +(defun lab->xyz (lab reference-white) + "Converts values from CIEL*a*b* colour space to XYZ [0,1]." + (let ((l (first lab)) + (a (second lab)) + (b (third lab)) + (x_r (first reference-white)) + (y_r (second reference-white)) + (z_r (third reference-white)) + (epsilon (/ 216 24389)) + (kappa (/ 24389 27))) + (let ((f_y (/ (+ l 16) 116))) + (let ((f_x (+ (/ a 500) f_y)) + (f_z (- f_y (/ b 200)))) + (let ((x-_r (if (> (expt f_x 3) epsilon) + (expt f_x 3) + (/ (- (* 116 f_x) 16) kappa))) + (y-_r (if (> l (* kappa epsilon)) + (expt (/ (+ l 16) 116) 3) + (/ l kappa))) + (z-_r (if (> (expt f_z 3) epsilon) + (expt f_z 3) + (/ (- (* 116 f_z) 16) kappa)))) + (list (* x-_r x_r) + (* y-_r y_r) + (* z-_r z_r))))))) + +;; --------------- +;; + XYZ <-> LUV + +;; --------------- + +;; based on http://www.brucelindbloom.com/index.html?Eqn_Luv_to_XYZ.html +(defun luv->xyz (luv reference-white) + "Converts values from CIEL*u*v* colour space to XYZ [0,1]." + (let ((l (first luv)) + (u (second luv)) + (v (third luv)) + (x_r (first reference-white)) + (y_r (second reference-white)) + (z_r (third reference-white)) + (epsilon (/ 216 24389)) + (kappa (/ 24389 27))) + (let* ((y (if (> l (* kappa epsilon)) + (expt (/ (+ l 16) 116) 3) + (/ l kappa))) + (den_0 (+ x_r (* 15 y_r) (* 3 z_r))) + (u_0 (/ (* 4 x_r) den_0)) + (v_0 (/ (* 9 y_r) den_0))) + (let ((a (/ (- (/ (* 52 l) (+ u (* 13 l u_0))) 1) 3)) + (b (- (* 5 y))) + (c (- (/ 1 3))) + (d (* y (- (/ (* 39 l) (+ v (* 13 l v_0))) 5)))) + (let ((x (/ (- d b) (- a c)))) + (list x y (+ (* x a) b))))))) + +;; based on http://www.brucelindbloom.com/Eqn_XYZ_to_Luv.html +(defun xyz->luv (xyz reference-white) + "Converts values from XYZ [0,1] to CIEL*u*v* colour space." + (let ((x (first xyz)) + (y (second xyz)) + (z (third xyz)) + (x_r (first reference-white)) + (y_r (second reference-white)) + (z_r (third reference-white)) + (epsilon (/ 216 24389)) + (kappa (/ 24389 27))) + (let ((den (+ x (* 15 y) (* 3 z))) + (den_r (+ x_r (* 15 y_r) (* 3 z_r))) + (y-_r (/ y y_r))) + (let ((uq (/ (* 4 x) den)) + (vq (/ (* 9 y) den)) + (uq_r (/ (* 4 x_r) den_r)) + (vq_r (/ (* 9 y_r) den_r)) + (l (if (> y-_r epsilon) + (- (* 116 (expt y-_r (/ 1 3))) 16) + (* kappa y-_r)))) + (list l (* 13 l (- uq uq_r)) (* 13 l (- vq vq_r))))))) + +;; --------------- +;; + RGB <-> XYZ + +;; --------------- + +;; based on http://www.brucelindbloom.com/Eqn_XYZ_to_RGB.html +;; and http://www.brucelindbloom.com/index.html?Eqn_RGB_XYZ_Matrix.html +(defun xyz->rgb (xyz &optional (gamma 2.2) (allow-unreproducable-colours t)) + "Transformation from XYZ to Adobe (1998) RGB working space (gamma=2.2, d65)." + (let ((x (first xyz)) + (y (second xyz)) + (z (third xyz))) + (let ((rgb (list (+ (* 2.04148 x) (* -0.564977 y) (* -0.344713 z)) + (+ (* -0.969258 x) (* 1.87599 y) (* 0.0415557 z)) + (+ (* 0.0134455 x) (* -0.118373 y) (* 1.01527 z))))) + (when (and (not allow-unreproducable-colours) + (not (check-domain rgb 0 1))) + (return-from xyz->rgb nil)) + (mapcar #'(lambda (x) (expt (max (min x 1) 0) + (/ 1 gamma))) + rgb)))) + +;; based on http://www.brucelindbloom.com/Eqn_RGB_XYZ_Matrix.html +(defun rgb->xyz (rgb &optional (gamma 2.2)) + "Transforms from RGB (Adobe 1998, d=2.2, d65) to XYZ." + (let ((r (expt (first rgb) gamma)) + (g (expt (second rgb) gamma)) + (b (expt (third rgb) gamma))) + (let ((xyz (list (+ (* 0.5767309 r) (* 0.1855540 g) (* 0.1881852 b)) + (+ (* 0.2973769 r) (* 0.6273491 g) (* 0.0752741 b)) + (+ (* 0.0270343 r) (* 0.0706872 g) (* 0.9911085 b))))) + (mapcar #'(lambda (x) (max 0 (min 1 x))) xyz)))) + + +;; --------------- +;; + RGB <-> LAB + +;; --------------- + +(defun rgb->lab (rgb) + "Transforms from RGB to CIEL*a*b*" + (let ((scaled-rgb (mapcar (lambda (x) (/ x 255.0)) rgb))) + (xyz->lab (rgb->xyz scaled-rgb) *reference-white-D65*))) + +(defun lab->rgb (lab) + "Transforms from CIEL*a*b* to RGB" + (let ((scaled-rgb (xyz->rgb (lab->xyz lab *reference-white-D65*)))) + (mapcar (lambda (x) (* x 255.0)) scaled-rgb))) + +;; ----------------- +;; + _ -> RGBHEX + +;; ----------------- + +(defun rgb->rgbhex (rgb) + "Converts a RGB [0,1] value to an 8-bit hexadecimal string." + (format nil "~{~2,'0X~}" rgb)) + +(defun normalize-rgb (rgb) + (mapcar #'(lambda (x) (float (/ x 255.0))) rgb)) + +(defun lab->rgbhex (lab reference-white) + "Convert from CIEL*a*b* coordinates to rgbhex" + (rgb->rgbhex (xyz->rgb (lab->xyz lab reference-white)))) + +;; --------------- +;; + RGB <-> HSV + +;; --------------- + +(defun hsv->rgb (hsv) + "Transforms HSV (with H in [0,360], S in [0,100] + and V in [0,100]) to RGB [0,255]" + (let ((h (first hsv)) + (s (/ (second hsv) 100)) + (v (/ (third hsv) 100))) + (labels ((f (n) + (let ((k (mod (+ n (/ h 60)) 6))) + (- v (* v s (max (min k (- 4 k) 1) 0)))))) + (mapcar #'(lambda (x) (float x)) + (mapcar #'(lambda (x) (* x 255)) + (mapcar #'(lambda (x) (f x)) '(5 3 1))))))) + +(defun rgb->hsv (rgb) + "Transforms RGB [0,255] to HSV (with H in [0,360], + S in [0,100] and V in [0,100])" + (let* ((scaled-rgb (mapcar #'(lambda (x) (/ x 255)) rgb)) + (max (apply #'max scaled-rgb)) + (min (apply #'min scaled-rgb)) + (r (first scaled-rgb)) + (g (second scaled-rgb)) + (b (third scaled-rgb)) + h s v) + (setf h (cond ((= max min) 0) + ((= max r) + (* 60 (+ 0 (/ (- g b) (- max min))))) + ((= max g) + (* 60 (+ 2 (/ (- b r) (- max min))))) + ((= max b) + (* 60 (+ 4 (/ (- r g) (- max min))))))) + (when (< h 0) + (setf h (+ h 360))) + (setf s (cond ((= max 0) 0) + (t (* 100 (/ (- max min) max))))) + (setf v (* 100 max)) + (mapcar #'(lambda (x) (float x)) + (list h s v)))) + +;; --------------- +;; + HSV <-> LAB + +;; --------------- + +(defun hsv->lab (hsv) + (rgb->lab (hsv->rgb hsv))) + +(defun lab->hsv (lab) + (rgb->hsv (lab->rgb lab))) + \ No newline at end of file diff --git a/experiments/spatial-concept-game/concept.lisp b/experiments/spatial-concept-game/concept.lisp new file mode 100644 index 000000000..c6d9f5348 --- /dev/null +++ b/experiments/spatial-concept-game/concept.lisp @@ -0,0 +1,221 @@ +(in-package :spatial-concepts) + +(export '(concept)) + +(defclass concept () + ((form + :documentation "the word of the concept" + :accessor form :initarg :form :type string) + (meaning + :documentation "a list of prototypes" + :accessor meaning :initarg :meaning :type list)) + (:documentation "a concept, or lexical item")) + +(defun make-concept (form attribute-proto-cons initial-certainty) + (make-instance 'concept + :form form + :meaning (loop for (attribute . proto-value) in attribute-proto-cons + collect (make-prototype attribute proto-value + initial-certainty)))) + + +(defmethod copy-object-content ((source entity) (destination entity)) + (setf (id destination) (make-id (get-base-name (mkstr (id source)))))) + + +(defmethod copy-object-content ((source concept) (destination concept)) + (setf (form destination) (form source)) + (setf (meaning destination) + (loop for p in (meaning source) + collect (my-copy-object p :concept destination)))) + + +(defclass prototype (entity) + ((attribute + :documentation "the name of the attribute" + :accessor attribute :initarg :attribute :type symbol) + (value + :documentation "the prototypical value" + :accessor value :initarg :value :type number) + (certainty + :documentation "the certainty of the attribute" + :accessor certainty :initarg :certainty :type number) + (nr-samples + :accessor nr-samples :initarg :nr-samples :initform 0) + (M2 + :accessor M2 :initarg :M2 :initform nil) + (concept + :documentation "a pointer back to the entire concept" + :accessor concept :initarg :concept :initform nil)) + (:documentation "Prototype category")) + +(defmethod copy-object-content ((source prototype) (destination prototype)) + (setf (attribute destination) (attribute source) + (value destination) (value source) + (certainty destination) (certainty source) + (M2 destination) (M2 source) + (nr-samples destination) (nr-samples source) + (concept destination) (concept source))) + + +(defmethod my-copy-object ((p prototype) &key concept) + (make-instance 'prototype + :id (make-id (get-base-name (mkstr (id p)))) + :attribute (attribute p) :value (value p) + :certainty (certainty p) :nr-samples (nr-samples p) + :M2 (M2 p) :concept concept)) + + +(defun make-prototype (attribute prototypical-value initial-certainty) + (make-instance 'prototype + :attribute attribute + :value prototypical-value + :certainty initial-certainty + :nr-samples 1 + :M2 0.05)) + + +(defgeneric update-prototype (prototype object) + (:documentation "Update the category based on the object")) + +(defmethod update-prototype ((prototype prototype) + (object mwm-object)) + ;; take the object pointed to by the tutor + ;; and estimate the mean and variance of the category + (incf (nr-samples prototype)) + (let* ((exemplar (get-attr-val object (attribute prototype))) + (delta-1 (- exemplar (value prototype))) + (new-prototypical-value (+ (value prototype) (/ delta-1 (nr-samples prototype)))) + (delta-2 (- exemplar new-prototypical-value)) + (new-M2 (+ (M2 prototype) (* delta-1 delta-2)))) + (setf (value prototype) new-prototypical-value + (M2 prototype) new-M2) + prototype)) + + +(defgeneric weighted-similarity (object concept) + (:documentation "Compute the weighted similarity between an object and a concept")) + +(defmethod weighted-similarity ((object mwm-object) (concept concept)) + (loop for prototype in (meaning concept) + for similarity = (similarity object prototype) + collect (* (certainty prototype) similarity) into weighted-similarities + finally (return (average weighted-similarities)))) + + +(defgeneric similarity (object prototype) + (:documentation "Similarity on the level of a single prototype")) + +(defmethod similarity ((object mwm-object) (prototype prototype)) + (let* ((max-z-score 2) + (exemplar (get-attr-val object (attribute prototype))) + (stdev (sqrt (/ (M2 prototype) (nr-samples prototype)))) + (z-score (abs (/ (- exemplar (value prototype)) stdev)))) + (max (/ (+ (- z-score) max-z-score) max-z-score) -1))) + + +(define-event attribute-removed (concept concept) (attribute symbol)) +(define-event concept-removed (concept concept)) + +(defun adjust-certainty (agent concept attribute delta + &key (upper-bound 1.0) + (lower-bound 0.0) + (remove-on-lower-bound t)) + (let ((prototype (find attribute (meaning concept) :key #'attribute))) + ;; update the certainty + (setf (certainty prototype) + (+ (certainty prototype) delta)) + ;; check the boundaries + (when (> (certainty prototype) upper-bound) + (setf (certainty prototype) upper-bound)) + (when (<= (certainty prototype) lower-bound) + (if remove-on-lower-bound + (progn (notify attribute-removed concept attribute) + (setf (meaning concept) + (remove prototype (meaning concept)))) + (setf (certainty prototype) lower-bound))) + ;; check if the concept is empty + (when (null (meaning concept)) + (notify concept-removed concept) + (setf (lexicon agent) + (remove concept (lexicon agent)))))) + + + +;;;; concept -> s-dot +(defgeneric concept->s-dot (concept &key highlight-green highlight-red) + (:documentation "Display a concept using s-dot")) + +(defmethod concept->s-dot ((concept concept) &key highlight-green highlight-red) + (let ((g '(((s-dot::ranksep "0.3") + (s-dot::nodesep "0.5") + (s-dot::margin "0") + (s-dot::rankdir "LR")) + s-dot::graph))) + ;; the form + (push + `(s-dot::record + ((s-dot::style "solid") + (s-dot::fontsize "9.5") + (s-dot::fontname #+(or :win32 :windows) "Sans" + #-(or :win32 :windows) "Arial") + (s-dot::height "0.01")) + (s-dot::node ((s-dot::id ,(downcase (mkdotstr (form concept)))) + (s-dot::label ,(downcase (mkdotstr (form concept)))) + (s-dot::fontcolor "#AA0000")))) + g) + ;; the meaning + (loop for prototype in (meaning concept) + for record = (prototype->s-dot prototype + :green (member (attribute prototype) highlight-green) + :red (member (attribute prototype) highlight-red)) + when (> (certainty prototype) 0.0) + do (push record g)) + ;; the edges + (loop for prototype in (meaning concept) + when (> (certainty prototype) 0.0) + do (push + `(s-dot::edge + ((s-dot::from ,(downcase (mkdotstr (form concept)))) + (s-dot::to ,(mkdotstr (downcase (attribute prototype)))) + (s-dot::label ,(format nil "~,2f" (certainty prototype))) + (s-dot::labelfontname #+(or :win32 :windows) "Sans" + #-(or :win32 :windows) "Arial") + (s-dot::fontsize "8.5") + (s-dot::arrowsize "0.5") + (s-dot::style ,(if (= (certainty prototype) 1.0) "solid" "dashed")))) + g)) + ;; return + (reverse g))) + + +(defgeneric prototype->s-dot (prototype &key green red) + (:documentation "Display a prototype using s-dot")) + +(defmethod prototype->s-dot ((prototype prototype) &key green red) + (let* ((stdev (sqrt (/ (M2 prototype) (nr-samples prototype)))) + (lower-bound (- (value prototype) (* 2 stdev))) + (upper-bound (+ (value prototype) (* 2 stdev))) + (record-properties + (cond (green '((s-dot::style "filled") + (s-dot::fillcolor "#AAFFAA"))) + (red '((s-dot::style "filled") + (s-dot::fillcolor "#AA0000") + (s-dot::fontcolor "#FFFFFF"))) + (t (if (= (certainty prototype) 1.0) + '((s-dot::style "solid")) + '((s-dot::style "dashed"))))))) + `(s-dot::record + ,(append record-properties + '((s-dot::fontsize "9.5") + (s-dot::fontname #+(or :win32 :windows) "Sans" + #-(or :win32 :windows) "Arial") + (s-dot::height "0.01"))) + (s-dot::node ((s-dot::id ,(downcase (mkdotstr (attribute prototype)))) + (s-dot::label ,(format nil "~a: ~,2f, [~,2f - ~,2f]" + (downcase (mkdotstr (attribute prototype))) + (value prototype) lower-bound upper-bound))))))) + + + + diff --git a/experiments/spatial-concept-game/experiment.lisp b/experiments/spatial-concept-game/experiment.lisp new file mode 100644 index 000000000..8b62d380f --- /dev/null +++ b/experiments/spatial-concept-game/experiment.lisp @@ -0,0 +1,151 @@ +(in-package :spatial-concepts) + +;; ------------------ +;; + Configurations + +;; ------------------ + +;; :baseline - :cogent - :incremental - :compositional +(define-configuration-default-value :experiment-type :baseline) + +;; :simulated - :extracted +(define-configuration-default-value :world-type :simulated) + +;; :A or :B +(define-configuration-default-value :cogent-stage :A) + +;; 1, 2, 3, 4 or 5 +(define-configuration-default-value :incremental-stage 1) + +(define-configuration-default-value :dot-interval 100) +(define-configuration-default-value :determine-interacting-agents-mode :tutor-speaks) +(define-configuration-default-value :initial-certainty 0.5) +(define-configuration-default-value :certainty-incf 0.1) +(define-configuration-default-value :certainty-decf -0.1) +(define-configuration-default-value :remove-on-lower-bound nil) +(define-configuration-default-value :lexical-variation nil) +(define-configuration-default-value :export-lexicon-interval 500) +(define-configuration-default-value :switch-conditions-after-n-interactions nil) +(define-configuration-default-value :alignment-filter :all) ; :none - :at-least-one - :all + +;; -------------- +;; + Experiment + +;; -------------- +(defclass mwm-experiment (experiment) + () + (:documentation "The experiment class")) + + + +;; path to each variant of the CLEVR dataset +;; every variant should have a subdirectory 'scenes' +(defparameter *baseline-clevr-data-path* + *clevr-data-path*) + +(defparameter *cogent-clevr-data-path* + (merge-pathnames (make-pathname :directory '(:relative "CLEVR-CoGenT")) + cl-user:*babel-corpora*)) + +(defparameter *incremental-clevr-data-path* + (merge-pathnames (make-pathname :directory '(:relative "Frontiers-data" "CLEVR-incremental")) + cl-user:*babel-corpora*)) + + + +(defun initial-data-set (experiment) + (case (get-configuration experiment :experiment-type) + (:baseline "val") + (:cogent "valA") + (:incremental "phase_1") + (:compositional "val"))) + + +(defmethod initialize-instance :after ((experiment mwm-experiment) &key) + "Create the population and load the scenes from file" + (activate-monitor print-a-dot-for-each-interaction) + ;; set the population + (setf (population experiment) + (list (make-tutor-agent experiment) + (make-learner-agent experiment))) + ;; set the clevr-data-path + ;; this will be used to load the 'clevr-world below + (setf *clevr-data-path* + (case (get-configuration experiment :experiment-type) + (:baseline *baseline-clevr-data-path*) + (:cogent *cogent-clevr-data-path*) + (:incremental *incremental-clevr-data-path*) + (:compositional *baseline-clevr-data-path*))) + ;; set the world (it uses the global variable *clevr-data-path*) + (setf (world experiment) + (make-instance 'clevr-world :data-sets (list (initial-data-set experiment)))) + ;; store the data-sets and data-path in the blackboard + (set-data experiment :ns-vqa-data-path + (case (get-configuration experiment :experiment-type) + (:baseline + (merge-pathnames + (make-pathname + :directory `(:relative "Frontiers-data" "CLEVR" + ,(initial-data-set experiment))) + cl-user:*babel-corpora*)) + (:cogent + (merge-pathnames + (make-pathname + :directory `(:relative "Frontiers-data" "CoGenT" + ,(initial-data-set experiment))) + cl-user:*babel-corpora*)) + (:incremental + (merge-pathnames + (make-pathname + :directory `(:relative "Frontiers-data" "incremental" + ,(initial-data-set experiment))) + cl-user:*babel-corpora*)) + (:compositional + (merge-pathnames + (make-pathname + :directory `(:relative "Frontiers-data" "CLEVR" + ,(initial-data-set experiment))) + cl-user:*babel-corpora*))))) + + +(defmethod learner ((experiment mwm-experiment)) + (find 'learner (population experiment) :key #'id)) + +(defmethod learner ((interaction interaction)) + (find 'learner (interacting-agents interaction) :key #'id)) + +(defmethod tutor ((experiment mwm-experiment)) + (find 'tutor (population experiment) :key #'id)) + +(defmethod tutor ((interaction interaction)) + (find 'tutor (interacting-agents interaction) :key #'id)) + + +;; -------------------------------- +;; + Determine interacting agents + +;; -------------------------------- + +(defmethod determine-interacting-agents ((experiment mwm-experiment) + (interaction interaction) + (mode (eql :tutor-speaks)) + &key &allow-other-keys) + "The tutor is always the speaker" + (let ((tutor (find 'tutor (population experiment) :key #'id)) + (learner (find 'learner (population experiment) :key #'id))) + (setf (interacting-agents interaction) + (list tutor learner)) + (setf (discourse-role tutor) 'speaker + (discourse-role learner) 'hearer) + (notify interacting-agents-determined experiment interaction))) + + +(defmethod determine-interacting-agents ((experiment mwm-experiment) + (interaction interaction) + (mode (eql :learner-speaks)) + &key &allow-other-keys) + "The learner is always the speaker" + (let ((tutor (find 'tutor (population experiment) :key #'id)) + (learner (find 'learner (population experiment) :key #'id))) + (setf (interacting-agents interaction) + (list tutor learner)) + (setf (discourse-role tutor) 'hearer + (discourse-role learner) 'speaker) + (notify interacting-agents-determined experiment interaction))) diff --git a/experiments/spatial-concept-game/fuzzy-operations.lisp b/experiments/spatial-concept-game/fuzzy-operations.lisp new file mode 100644 index 000000000..87cdc761b --- /dev/null +++ b/experiments/spatial-concept-game/fuzzy-operations.lisp @@ -0,0 +1,55 @@ +(in-package :spatial-concepts) + +;; ------------------------ +;; + Fuzzy Set Operations + +;; ------------------------ + +(defun fuzzy-set-channels (set) + (mapcar #'attribute (mapcar #'car set))) + +(defun fuzzy-set-values (set) + (mapcar #'second set)) + +(defun fuzzy-set-certainties (set) + (mapcar #'third set)) + +(defun fuzzy-cardinality (set) + (reduce #'+ set :key #'third :initial-value 0)) + +(defun fuzzy-union (a b) + (loop with result + for channel in (union (fuzzy-set-channels a) + (fuzzy-set-channels b)) + for a-entry = (find channel a + :key #'(lambda (entry) + (attribute (car entry)))) + for b-entry = (find channel b + :key #'(lambda (entry) + (attribute (car entry)))) + do (push + (cond + ;; if both are present with the same certainty + ;; choose random + ((and a-entry b-entry + (= (cdr a-entry) (cdr b-entry))) + (random-elt (list a-entry b-entry))) + ;; if both are present with different certainty + ;; take the one with highest certainty + ((and a-entry b-entry + (/= (cdr a-entry) (cdr b-entry))) + (the-biggest #'cdr (list a-entry b-entry))) + ;; if only one is present, take that one + (t (or a-entry b-entry))) + result) + finally + (return result))) + +(defun fuzzy-intersection (a b) + (loop with channel-intersection = (intersection (fuzzy-set-channels a) + (fuzzy-set-channels b)) + for channel in channel-intersection + for a-entry = (find channel a :key #'first) + collect a-entry)) + +(defun fuzzy-difference (a b) + (set-difference a b :key #'first)) diff --git a/experiments/spatial-concept-game/html.lisp b/experiments/spatial-concept-game/html.lisp new file mode 100644 index 000000000..91f410023 --- /dev/null +++ b/experiments/spatial-concept-game/html.lisp @@ -0,0 +1,28 @@ +(in-package :spatial-concepts) + +;; make html of mwm-object +(defmethod make-html-for-entity-details ((object mwm-object) &key) + (loop for (attr . val) in (attributes object) + append `(((div :class "entity-detail") + ,(format nil "~a = ~,2f" attr val))))) + +;; make html of object set +(defmethod make-html-for-entity-details ((set mwm-object-set) &key) + `(((div :class "entity-detail") + ,@(loop for object in (objects set) + collect (make-html object :expand-initially t))))) + +;; make-html of concept +(defmethod make-html ((concept concept) &key) + `((div) + ,(s-dot->svg + (concept->s-dot concept)))) + +;; make html of mwm-category +(defmethod make-html-for-entity-details ((prototype prototype) &key) + `(((div :class "entity-detail") + ,(format nil "attribute: ~a" (attribute prototype))) + ((div :class "entity-detail") + ,(format nil "prototype: ~,2f" (value prototype))) + ((div :class "entity-detail") + ,(format nil "variance: ~,2f" (/ (M2 prototype) (nr-samples prototype)))))) \ No newline at end of file diff --git a/experiments/spatial-concept-game/interaction.lisp b/experiments/spatial-concept-game/interaction.lisp new file mode 100644 index 000000000..9507325a4 --- /dev/null +++ b/experiments/spatial-concept-game/interaction.lisp @@ -0,0 +1,256 @@ +(in-package :spatial-concepts) + +;;;; +;;;; Setup interaction +;;;; + +(defun clear-agent (agent) + "Clear the slots of the agent for the next interaction." + (setf (blackboard agent) nil + (utterance agent) nil + (communicated-successfully agent) nil)) + +(defun closest-object (mwm-topic symbolic-clevr-context) + "Given a topic from the 'extracted' world, find + the closest object in the symbolic world using + the xy-coordinates." + (let ((topic-x (get-attr-val mwm-topic 'xpos)) + (topic-y (get-attr-val mwm-topic 'ypos))) + (the-smallest #'(lambda (object) + (abs (euclidean (list topic-x topic-y) + (list (x-pos object) + (y-pos object))))) + (objects symbolic-clevr-context)))) + +(defgeneric before-interaction (experiment) + (:documentation "Initialize the interaction")) + +(define-event context-determined (experiment mwm-experiment)) +(define-event topic-determined (experiment mwm-experiment)) + +(defmethod before-interaction ((experiment mwm-experiment)) + ;; 1. load a random scene + ;; 2. pick a random topic + ;; step 2 can be retried if conceptualisation fails + ;; but need to keep track of the objects that have + ;; been tried (in some blackboard probably) + (loop for agent in (interacting-agents experiment) + do (clear-agent agent)) + (sample-scene experiment) + (sample-topic experiment)) + + +(defun sample-scene (experiment) + (let* ((world-type (get-configuration experiment :world-type)) + (symbolic-clevr-context (random-scene (world experiment))) + (mwm-context + (case world-type + (:simulated + (clevr->simulated symbolic-clevr-context)) + (:extracted + (clevr->extracted symbolic-clevr-context + :directory (find-data experiment :ns-vqa-data-path)))))) + (if (length> (objects mwm-context) 1) + (progn + (loop for agent in (interacting-agents experiment) + do (set-data agent 'context mwm-context) + do (set-data agent 'tutor-context symbolic-clevr-context)) + (notify context-determined experiment)) + (sample-scene experiment)))) + + +(defun sample-topic (experiment) + (let* ((interaction (current-interaction experiment)) + (world-type (get-configuration experiment :world-type)) + (agent (first (population experiment))) + (symbolic-clevr-context (find-data agent 'tutor-context)) + (mwm-context (find-data agent 'context)) + (tried-topics (tried-topics interaction (name symbolic-clevr-context))) + (available-topics (set-difference (objects mwm-context) tried-topics))) + (if (null available-topics) + (progn + (sample-scene experiment) + (sample-topic experiment)) + (let* ((mwm-topic (random-elt available-topics)) + (tutor-topic + (case world-type + (:simulated (find (id mwm-topic) (objects symbolic-clevr-context) :key #'id)) + (:extracted (closest-object mwm-topic symbolic-clevr-context)))) + (scene-topic-cons (cons (name symbolic-clevr-context) mwm-topic))) + (notify topic-determined experiment) + (push-data interaction 'attempted-topics scene-topic-cons) + (loop for agent in (interacting-agents experiment) + do (set-data agent 'topic mwm-topic) + do (set-data agent 'tutor-topic tutor-topic)))))) + + +(defun tried-topics (interaction scene-name) + (let ((attempts (find-data interaction 'attempted-topics))) + (mapcar #'cdr (find-all scene-name attempts :key #'car :test #'string=)))) + + +;;;; +;;;; Run interaction +;;;; +(defgeneric do-interaction (experiment) + (:documentation "Run the interaction script")) + +(defmethod do-interaction ((experiment mwm-experiment)) + "The tutor conceptualises the topic and produces + one or multiple words. The hearer tries to parse + and interpret the utterance. If both succeed and + the interpretation is correct, the interaction is + a success. Adoption is handled together with + alignment." + (let ((speaker (speaker experiment)) + (hearer (hearer experiment))) + (conceptualise speaker) + (produce-word speaker) + (when (utterance speaker) + (setf (utterance hearer) (utterance speaker)) + (when (and (parse-word hearer) + (interpret hearer) + (determine-success speaker hearer)) + (setf (communicated-successfully speaker) t + (communicated-successfully hearer) t))))) + +;;;; +;;;; Alignment +;;;; +(defgeneric after-interaction (experiment) + (:documentation "Finalize the interaction")) + +(defmethod after-interaction ((experiment mwm-experiment)) + ;; only in condition B of the cogent experiment, there is no alignment + (unless (and (eql (get-configuration experiment :experiment-type) :cogent) + (eql (get-configuration experiment :cogent-stage) :B)) + (let ((tutor (tutor experiment)) + (learner (learner experiment))) + (if (speakerp tutor) + ;; alignment when tutor is speaker + ;; the tutor reveals the topic and + ;; the learner aligns its concept to it + (when (find-data tutor 'tutor-conceptualisation) + (alignment learner (get-data learner 'topic) + (find-data learner 'applied-concept))) + ;; alignment when learner is speaker + (cond + ;; success? do alignment + ((and (communicated-successfully tutor) + (communicated-successfully learner)) + (alignment learner (get-data learner 'topic) + (find-data learner 'applied-concept))) + ;; learner could not conceptualise? do nothing + ((null (find-data learner 'applied-concept)) + nil) + ;; learner could conceptualise, but interpretation failed? + ;; do nothing + ((null (find-data tutor 'interpreted-topic)) + nil) + ;; learner could conceptualise and interpretation succeeded + ;; but incorrectly? do nothing + (t nil)))))) + + +;;;; +;;;; Experimental conditions +;;;; +(defgeneric switch-condition-p (experiment experiment-type) + (:documentation "Predicate that checks whether the experiment should + advance to the next condition")) + +(defmethod switch-condition-p ((experiment mwm-experiment) experiment-type) + "Switch when N interactions have been played." + (let ((switch-condition-interval + (get-configuration experiment :switch-conditions-after-n-interactions)) + (current-interaction-number + (interaction-number (current-interaction experiment)))) + (= (mod current-interaction-number switch-condition-interval) 0))) + +(defmethod switch-condition-p ((experiment mwm-experiment) + (experiment-type (eql :baseline))) + "Never switch conditions" + nil) + +(defmethod switch-condition-p ((experiment mwm-experiment) + (experiment-type (eql :cogent))) + "Switch when N interactions have been played + and the experiment is still in stage A." + (and (call-next-method) + (eql (get-configuration experiment :cogent-stage) :A))) + +(defmethod switch-condition-p ((experiment mwm-experiment) + (experiment-type (eql :incremental))) + "Switch when N interactions have been played + and the experiment has not reached stage 5." + (and (call-next-method) + (< (get-configuration experiment :incremental-stage) 5))) + +(defmethod switch-condition-p ((experiment mwm-experiment) + (experiment-type (eql :compositional))) + "Never switch conditions" + nil) + + +(defgeneric setup-next-condition (experiment experiment-type) + (:documentation "Setup the next experimental condition.")) + +(defmethod setup-next-condition ((experiment mwm-experiment) + (experiment-type (eql :cogent))) + ;; message + (format t "~%~%SWITCHING FROM CONDITION A TO CONDITION B. SWITCHED OFF LEARNING~%~%") + ;; set the config + (set-configuration experiment :cogent-stage :B :replace t) + ;; load the scenes + (setf (world experiment) + (make-instance 'clevr-world :data-sets '("valB"))) + ;; load the extracted scenes + (when (eql (get-configuration experiment :world-type) :extracted) + (let ((data-path (namestring (find-data experiment :ns-vqa-data-path)))) + (set-data experiment :ns-vqa-data-path + (parse-namestring + (cl-ppcre:regex-replace-all "valA" data-path "valB")))))) + +(defmethod setup-next-condition ((experiment mwm-experiment) + (experiment-type (eql :incremental))) + (let* ((current-stage (get-configuration experiment :incremental-stage)) + (next-stage (1+ current-stage)) + (next-stage-name (format nil "phase_~a" next-stage))) + ;; message + (format t "~%~%SWITCHING FROM CONDITION ~a TO CONDITION ~a~%~%" + current-stage next-stage) + ;; export the lexicon before each condition switch + (lexicon->pdf (learner experiment) :serie (series-number experiment)) + ;; set the config + (set-configuration experiment :incremental-stage next-stage :replace t) + ;; reload the world with a different dataset + (setf (world experiment) + (make-instance 'clevr-world :data-sets (list next-stage-name))) + ;; when the data-type is :extracted + ;; also changed the data-path + (when (eql (get-configuration experiment :world-type) :extracted) + (let ((data-path (namestring (find-data experiment :ns-vqa-data-path)))) + (set-data experiment :ns-vqa-data-path + (parse-namestring + (cl-ppcre:regex-replace-all (format nil "/phase_~a" current-stage) + data-path + (format nil "/phase_~a" next-stage)))))))) + + + + + + + +;;;; +;;;; interact +;;;; +(defmethod interact ((experiment mwm-experiment) interaction &key) + (let ((experiment-type (get-configuration experiment :experiment-type))) + (when (switch-condition-p experiment experiment-type) + (setup-next-condition experiment experiment-type))) + ;; regular interaction + (before-interaction experiment) + (do-interaction experiment) + (after-interaction experiment)) + diff --git a/experiments/spatial-concept-game/misc.lisp b/experiments/spatial-concept-game/misc.lisp new file mode 100644 index 000000000..1d7bce46e --- /dev/null +++ b/experiments/spatial-concept-game/misc.lisp @@ -0,0 +1,99 @@ +(in-package :spatial-concepts) + +;;;; Export learner lexicon to pdf +(defun experiment-name-from-configurations (experiment) + (let ((parts + (list (mkstr (get-configuration experiment :experiment-type)) + (mkstr (get-configuration experiment :world-type)) + (mkstr (get-configuration experiment :determine-interacting-agents-mode))))) + (when (eql (get-configuration experiment :experiment-type) :cogent) + (pushend + (format nil "train-~a" (get-configuration experiment :switch-conditions-after-n-interactions)) + parts)) + (when (eql (get-configuration experiment :experiment-type) :incremental) + (pushend + (format nil "train-~a" (get-configuration experiment :switch-conditions-after-n-interactions)) + parts) + (pushend + (format nil "phase-~a" (get-configuration experiment :incremental-stage)) + parts)) + (pushend "lexicon" parts) + (downcase (list-of-strings->string parts :separator "-")))) + +(defun lexicon->pdf (agent &key dirname serie) + (let* ((experiment-name + (if dirname dirname (experiment-name-from-configurations (experiment agent)))) + (base-path + (if serie + (babel-pathname + :directory `("experiments" "multidimensional-word-meanings" + "graphs" ,(downcase experiment-name) + ,(format nil "serie-~a" serie))) + (babel-pathname + :directory `("experiments" "multidimensional-word-meanings" + "graphs" ,(downcase experiment-name)))))) + (ensure-directories-exist base-path) + (loop for concept in (average-over-concept-history agent) + do (s-dot->image + (concept->s-dot concept) + :path (merge-pathnames + (make-pathname :name (format nil "~a-cxn" (form concept)) + :type "pdf") + base-path) + :format "pdf" :open nil)))) + +(defun lexicon->store (agent &key dirname serie) + (let* ((experiment-name + (if dirname dirname (experiment-name-from-configurations (experiment agent)))) + (base-path + (if serie + (babel-pathname + :directory `("experiments" "multidimensional-word-meanings" + "store" ,(downcase experiment-name) + ,(format nil "serie-~a" serie))) + (babel-pathname + :directory `("experiments" "multidimensional-word-meanings" + "store" ,(downcase experiment-name)))))) + (ensure-directories-exist base-path) + (loop for concept in (average-over-concept-history agent) + for pathname = (merge-pathnames + (make-pathname :name (format nil "~a-cxn" (form concept)) + :type "store") + base-path) + do (cl-store:store concept pathname)))) + + + + + + +#| +;; lexicon -> function plots +(defun lexicon->function-plots (agent) + (loop for cxn in (constructions (grammar agent)) + for experiment-name = (downcase (mkstr (get-configuration agent :category-representation))) + do (cxn->function-plot cxn (get-configuration agent :category-representation) + :directory `("experiments" "multidimensional-word-meanings" + "graphs" ,experiment-name "function-plots")))) + +;;;; Export concepts (= cxns) as functions +(defgeneric cxn->function-plot (cxn category-representation &key directory) + (:documentation "Plot the functions that are stored in the categories")) + +(defmethod cxn->function-plot ((cxn fcg-construction) (category-representation (eql :prototype)) + &key (directory '(".tmp"))) + (let ((equations + (loop for (category . certainty) in (attr-val cxn :meaning) + collect (format nil "normal(x,~a,~a)" + (prototype category) + (sqrt (/ (M2 category) (nr-samples category))))))) + (create-function-plot equations + :function-definitions '("normal(x,mu,sd) = (1/(sd*sqrt(2*pi)))*exp(-(x-mu)**2/(2*sd**2))") + :title (format nil "~a" (downcase (mkstr (name cxn)))) + :captions (loop for (category . certainty) in (attr-val cxn :meaning) + collect (format nil "~a" (downcase (mkstr (attribute category))))) + :plot-file-name (format nil "~a" (downcase (mkstr (name cxn)))) + :plot-directory directory + :x-label nil :y-min 0 :y-max nil + :open nil))) +|# \ No newline at end of file diff --git a/experiments/spatial-concept-game/monitors.lisp b/experiments/spatial-concept-game/monitors.lisp new file mode 100644 index 000000000..c9aed1811 --- /dev/null +++ b/experiments/spatial-concept-game/monitors.lisp @@ -0,0 +1,616 @@ +(in-package :spatial-concepts) + +;; ------------ +;; + Monitors + +;; ------------ + +;;;; Communicative success +(define-monitor record-communicative-success + :class 'data-recorder + :average-window 100 + :documentation "records the game outcome of each game (1 or 0).") + +(define-monitor display-communicative-success + :class 'gnuplot-display + :documentation "Plots the communicative success." + :data-sources '(record-communicative-success) + :update-interval 100 + :caption '("communicative success") + :x-label "# Games" + :y1-label "Communicative Success" + :y1-max 1.0 :y1-min 0 + :draw-y1-grid t) + +(define-monitor export-communicative-success + :class 'lisp-data-file-writer + :documentation "Exports communicative success" + :data-sources '((average record-communicative-success)) + :file-name (babel-pathname :name "communicative-success" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil + :column-separator " " + :comment-string "#") + +(define-event-handler (record-communicative-success interaction-finished) + (record-value monitor (if (communicated-successfully interaction) 1 0))) + +;;;; Communicative Success given Conceptualisation +(define-monitor record-communicative-success-given-conceptualisation + :class 'data-recorder + :average-window 100 + :documentation "records the game outcome of each game (1 or 0).") + +(define-monitor export-communicative-success-given-conceptualisation + :class 'lisp-data-file-writer + :documentation "Exports communicative success" + :data-sources '((average record-communicative-success-given-conceptualisation)) + :file-name (babel-pathname :name "communicative-success-given-conceptualisation" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil + :column-separator " " + :comment-string "#") + +(define-event-handler (record-communicative-success-given-conceptualisation interaction-finished) + (record-value monitor (determine-communicative-success-given-conceptualisation interaction monitor))) + +(defun determine-communicative-success-given-conceptualisation (interaction monitor) + (if (eql (tutor interaction) (speaker interaction)) + (if (communicated-successfully interaction) 1 0) + (if (find-data (speaker interaction) 'applied-concept) + (if (communicated-successfully interaction) 1 0) + (if (caaar (monitors::get-values monitor)) (caaar (monitors::get-values monitor)) 0)))) + + +;;;; Lexicon size +(define-monitor record-lexicon-size + :class 'data-recorder + :average-window 1 + :documentation "records the avg lexicon size.") + +(define-monitor export-lexicon-size + :class 'lisp-data-file-writer + :documentation "Exports lexicon size" + :data-sources '(record-lexicon-size) + :file-name (babel-pathname :name "lexicon-size" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil + :column-separator " " + :comment-string "#") + +(defun get-lexicon-size (agent) + (length (lexicon agent))) + +(define-event-handler (record-lexicon-size interaction-finished) + (record-value monitor (get-lexicon-size (learner experiment)))) + + +;;;; Monitor that tracks what the tutor uses when the interaction fails +(define-monitor record-tutor-conceptualisation-in-failed-interactions + :class 'alist-recorder :average-window 1) + +(defparameter *used-features* nil) + +(define-event-handler (record-tutor-conceptualisation-in-failed-interactions interaction-finished) + (when (eql (tutor experiment) (speaker experiment)) + (let ((tutor-feature (find-data (tutor experiment) 'tutor-conceptualisation))) + (unless (communicated-successfully (current-interaction experiment)) + (if (assoc tutor-feature *used-features*) + (incf (cdr (assoc tutor-feature *used-features*))) + (push (cons tutor-feature 1) *used-features*))))) + (loop for (feature . count) in *used-features* + do (set-value-for-symbol monitor feature count))) + +(define-monitor plot-tutor-conceptualisation-in-failed-interactions + :class 'alist-gnuplot-graphic-generator + :recorder 'record-tutor-conceptualisation-in-failed-interactions + :draw-y-1-grid t + :y-label "Tutor word use" + :x-label "# Games" + :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :name "tutor-word-use" :type "pdf") + :graphic-type "pdf") + +(defun create-tutor-word-use-graph (&key (configurations nil) + (nr-of-interactions 5000)) + (format t "~%Running ~a interactions in order to create a tutor word use graph." nr-of-interactions) + (setf *used-features* nil) + (activate-monitor plot-tutor-conceptualisation-in-failed-interactions) + (run-batch 'mwm-experiment nr-of-interactions 1 + :configuration (make-configuration :entries configurations)) + (deactivate-monitor plot-tutor-conceptualisation-in-failed-interactions) + (format t "~%Graphs have been created")) + +;;;; Monitor that tracks what the learner uses when the interaction fails +(define-monitor record-learner-failed-conceptualisations + :class 'alist-recorder :average-window 1) + +(defparameter *failed-conceptualisations* nil) + +(define-event-handler (record-learner-failed-conceptualisations interaction-finished) + (when (eql (learner experiment) (speaker experiment)) + (let ((symbolic-feature (find-data (tutor experiment) 'tutor-conceptualisation))) + (unless (communicated-successfully (current-interaction experiment)) + (if (assoc symbolic-feature *failed-conceptualisations*) + (incf (cdr (assoc symbolic-feature *failed-conceptualisations*))) + (push (cons symbolic-feature 1) *failed-conceptualisations*))))) + (loop for (feature . count) in *failed-conceptualisations* + do (set-value-for-symbol monitor feature count))) + +(define-monitor plot-learner-failed-conceptualisations + :class 'alist-gnuplot-graphic-generator + :recorder 'record-learner-failed-conceptualisations + :draw-y-1-grid t + :y-label "Learner failed conceptualisation" + :x-label "# Games" + :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :name "learner-failed-conceptualisation" :type "pdf") + :graphic-type "pdf") + +(defun create-learner-failed-conceptualisation-graph (&key configurations + (nr-of-interactions 5000)) + (format t "~%Running ~a interactions in order to create a graph." nr-of-interactions) + (setf *failed-conceptualisations* nil) + (activate-monitor plot-learner-failed-conceptualisations) + (run-batch 'mwm-experiment nr-of-interactions 1 + :configuration (make-configuration :entries configurations)) + (deactivate-monitor plot-learner-failed-conceptualisations) + (format t "~%Graphs have been created")) + +;;;; Export the lexicon to pdf at the end of a series +(define-monitor export-learner-concepts-to-pdf) + +(define-event-handler (export-learner-concepts-to-pdf run-series-finished) + (lexicon->pdf (learner experiment) :serie (series-number experiment))) + + +;;;; Export the lexicon to .store at the end of a series +(define-monitor export-learner-concepts-to-store) + +(define-event-handler (export-learner-concepts-to-store run-series-finished) + (lexicon->store (learner experiment) :serie (series-number experiment))) + + +;;;; Export the configurations of the experiment at the end of the first series +(define-monitor export-experiment-configurations) + +(define-event-handler (export-experiment-configurations run-series-finished) + (when (= (series-number experiment) 1) + (let* ((experiment-name (experiment-name-from-configurations experiment)) + (path (babel-pathname + :directory `("experiments" "multidimensional-word-meanings" + "raw-data" ,(downcase experiment-name)) + :name "experiment-configurations" :type "lisp"))) + (ensure-directories-exist path) + (with-open-file (stream path :direction :output + :if-exists :overwrite + :if-does-not-exist :create) + (write (entries experiment) + :stream stream))))) + + + + + + + + + + + + + + + + +#| +;;;; Utterance length +(define-monitor record-utterance-length + :class 'data-recorder + :average-window 1 + :documentation "records the utterance length") + +(define-monitor export-utterance-length + :class 'lisp-data-file-writer + :documentation "Exports utterance length" + :data-sources '(record-utterance-length) + :file-name (babel-pathname :name "utterance-length" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil + :column-separator " " + :comment-string "#") + +(define-event-handler (record-utterance-length interaction-finished) + (record-value monitor (length (utterance (speaker interaction))))) + + +;;;; monitor tutor word use (a-list) +(define-monitor record-tutor-word-use + :documentation "Record how often the tutor uses each word" + :class 'alist-recorder + :average-window 100) + +(defparameter *word-count* nil) + +(define-event-handler (record-tutor-word-use interaction-finished) + (let* ((tutor (find 'tutor (population experiment) :key #'id)) + (used-words (find-data tutor 'tutor-conceptualisation))) + (loop for used-word in used-words + if (assoc used-word *word-count*) + do (incf (cdr (assoc used-word *word-count*))) + else do (push (cons used-word 1) *word-count*)) + (loop for (word . count) in *word-count* + do (set-value-for-symbol monitor word count)))) + +(define-monitor plot-tutor-word-use + :class 'alist-gnuplot-graphic-generator + :recorder 'record-tutor-word-use + :draw-y-1-grid t + :y-label "Tutor word use" + :x-label "# Games" + :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :name "tutor-word-use" :type "pdf") + :graphic-type "pdf") + +(defun create-tutor-word-use-graph (&key (configurations nil) + (nr-of-interactions 5000)) + (format t "~%Running ~a interactions in order to create a tutor word use graph." nr-of-interactions) + (activate-monitor plot-tutor-word-use) + (run-batch 'mwm-experiment nr-of-interactions 1 + :configuration (make-configuration :entries configurations)) + (deactivate-monitor plot-tutor-word-use) + (format t "~%Graphs have been created")) + + +;;;; success per attribute type +(define-monitor record-success-per-attribute-type + :documentation "For each type of attribute (e.g. color), record the success separately" + :class 'alist-recorder + :average-window 100) + +(defparameter *word->type-map* + '(("left" . xpos) ("right" . xpos) + ("front" . ypos) ("behind" . ypos) + ("cube" . shape) ("cylinder" . shape) ("sphere" . shape) + ("metal" . material) ("rubber" . material) + ("large" . size) ("small" . size) + ("blue" . color) ("brown" . color) ("cyan" . color) + ("gray" . color) ("green" . color) ("purple" . color) + ("red" . color) ("yellow" . color))) + +(define-event-handler (record-success-per-attribute-type interaction-finished) + (let* ((tutor (find 'tutor (population experiment) :key #'id)) + (used-attribute-type (rest (assoc (first (utterance tutor)) *word->type-map* :test #'string=))) + (success (communicated-successfully interaction))) + (set-value-for-symbol monitor used-attribute-type (if success 1 0)) + (set-value-for-symbol monitor 'overall (if success 1 0)))) + +(define-monitor plot-success-per-attribute-type + :class 'alist-gnuplot-graphic-generator + :recorder 'record-success-per-attribute-type + :draw-y-1-grid t + :y-label "Success / attribute type" + :y-max 1.0 + :x-label "# Games" + :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :name "success-per-attribute-type" + :type "pdf") + :graphic-type "pdf") + +(defun create-success-per-attribute-type-graph (&key (configurations nil) + (nr-of-interactions 5000)) + (format t "~%Running ~a interactions in order to create an a-list graph." nr-of-interactions) + (activate-monitor plot-success-per-attribute-type) + (run-batch 'mwm-experiment nr-of-interactions 1 + :configuration (make-configuration :entries configurations)) + (deactivate-monitor plot-success-per-attribute-type) + (format t "~%Graphs have been created")) + +;;;; Sankey diagram data +;; every 100'th interaction, we export the entire lexicon +;; the columns are: interaction number, word, feature, certainty, value +;; from this csv, we can create a Sankey diagram in Python +(define-monitor record-lexicon-evolution + :class 'data-recorder + :average-window 1 + :documentation "records the evolution of the lexicon") + +(define-monitor export-lexicon-evolution + :class 'lisp-data-file-writer + :documentation "Exports communicative success" + :data-sources '(record-lexicon-evolution) + :file-name (babel-pathname :name "lexicon-evolution" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil + :column-separator " " + :comment-string "#") + +(defun collect-initial-cxn (cxn) + (loop with form = (attr-val cxn :form) + for (category . certainty) in (attr-val cxn :meaning) + collect (list 0 + (format nil "\"~a\"" (downcase form)) + (format nil "\"~a\"" (downcase (mkstr (attribute category)))) + (format nil "~$" certainty) + (format nil "~$" (prototype category))))) + +(define-event-handler (record-lexicon-evolution new-cxn-added) + ;; record the initial representation of a concept + (let ((lexicon (list (collect-initial-cxn cxn)))) + (record-value monitor lexicon))) + +(define-event-handler (record-lexicon-evolution interaction-finished) + ;; record every 100'th interactions + (let ((i-nr (interaction-number interaction))) + (if (= (mod i-nr (get-configuration experiment :dot-interval)) 0) + (let* ((learner (find 'learner (population experiment) :key #'id)) + (lexicon (loop for cxn in (constructions (grammar learner)) + for form = (attr-val cxn :form) + collect (loop for (category . certainty) in (attr-val cxn :meaning) + collect (list i-nr + (format nil "\"~a\"" (downcase form)) + (format nil "\"~a\"" (downcase (mkstr (attribute category)))) + (format nil "~2f" certainty) + (format nil "~2f" (prototype category))))))) + (record-value monitor lexicon)) + (unless (listp (current-value monitor)) + (record-value monitor '()))))) + + +;; recording tutor utterance length for bar plots +(define-monitor record-tutor-utterance-length-1 + :class 'data-recorder + :average-window 1) + +(define-monitor export-tutor-utterance-length-1 + :class 'lisp-data-file-writer + :data-sources '(record-tutor-utterance-length-1) + :file-name (babel-pathname :name "tutor-utterance-length-1" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-utterance-length-1 interaction-finished) + (let ((tutor-utterance-len (length (utterance (speaker interaction))))) + (record-value monitor (if (= tutor-utterance-len 1) 1 0)))) + +(define-monitor record-tutor-utterance-length-2 + :class 'data-recorder + :average-window 1) + +(define-monitor export-tutor-utterance-length-2 + :class 'lisp-data-file-writer + :data-sources '(record-tutor-utterance-length-2) + :file-name (babel-pathname :name "tutor-utterance-length-2" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-utterance-length-2 interaction-finished) + (let ((tutor-utterance-len (length (utterance (speaker interaction))))) + (record-value monitor (if (= tutor-utterance-len 2) 1 0)))) + +(define-monitor record-tutor-utterance-length-3 + :class 'data-recorder + :average-window 1) + +(define-monitor export-tutor-utterance-length-3 + :class 'lisp-data-file-writer + :data-sources '(record-tutor-utterance-length-3) + :file-name (babel-pathname :name "tutor-utterance-length-3" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-utterance-length-3 interaction-finished) + (let ((tutor-utterance-len (length (utterance (speaker interaction))))) + (record-value monitor (if (= tutor-utterance-len 3) 1 0)))) + +(define-monitor record-tutor-utterance-length-4 + :class 'data-recorder + :average-window 1) + +(define-monitor export-tutor-utterance-length-4 + :class 'lisp-data-file-writer + :data-sources '(record-tutor-utterance-length-4) + :file-name (babel-pathname :name "tutor-utterance-length-4" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-utterance-length-4 interaction-finished) + (let ((tutor-utterance-len (length (utterance (speaker interaction))))) + (record-value monitor (if (= tutor-utterance-len 4) 1 0)))) + + +;; recording tutor attribute use for bar plots +(define-monitor record-tutor-uses-color + :class 'data-recorder :average-window 1) + +(define-monitor export-tutor-uses-color + :class 'lisp-data-file-writer + :data-sources '(record-tutor-uses-color) + :file-name (babel-pathname :name "tutor-uses-color" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-uses-color interaction-finished) + (let* ((utterance (utterance (speaker interaction))) + (types (loop for word in utterance + for type = (rest (assoc word *word->type-map* :test #'string=)) + collect type))) + (record-value monitor (if (find 'color types) (/ 1 (length utterance)) 0)))) + +(define-monitor record-tutor-uses-shape + :class 'data-recorder :average-window 1) + +(define-monitor export-tutor-uses-shape + :class 'lisp-data-file-writer + :data-sources '(record-tutor-uses-shape) + :file-name (babel-pathname :name "tutor-uses-shape" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-uses-shape interaction-finished) + (let* ((utterance (utterance (speaker interaction))) + (types (loop for word in utterance + for type = (rest (assoc word *word->type-map* :test #'string=)) + collect type))) + (record-value monitor (if (find 'shape types) (/ 1 (length utterance)) 0)))) + +(define-monitor record-tutor-uses-material + :class 'data-recorder :average-window 1) + +(define-monitor export-tutor-uses-material + :class 'lisp-data-file-writer + :data-sources '(record-tutor-uses-material) + :file-name (babel-pathname :name "tutor-uses-material" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-uses-material interaction-finished) + (let* ((utterance (utterance (speaker interaction))) + (types (loop for word in utterance + for type = (rest (assoc word *word->type-map* :test #'string=)) + collect type))) + (record-value monitor (if (find 'material types) (/ 1 (length utterance)) 0)))) + +(define-monitor record-tutor-uses-size + :class 'data-recorder :average-window 1) + +(define-monitor export-tutor-uses-size + :class 'lisp-data-file-writer + :data-sources '(record-tutor-uses-size) + :file-name (babel-pathname :name "tutor-uses-size" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-uses-size interaction-finished) + (let* ((utterance (utterance (speaker interaction))) + (types (loop for word in utterance + for type = (rest (assoc word *word->type-map* :test #'string=)) + collect type))) + (record-value monitor (if (find 'size types) (/ 1 (length utterance)) 0)))) + +(define-monitor record-tutor-uses-xpos + :class 'data-recorder :average-window 1) + +(define-monitor export-tutor-uses-xpos + :class 'lisp-data-file-writer + :data-sources '(record-tutor-uses-xpos) + :file-name (babel-pathname :name "tutor-uses-xpos" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-uses-xpos interaction-finished) + (let* ((utterance (utterance (speaker interaction))) + (types (loop for word in utterance + for type = (rest (assoc word *word->type-map* :test #'string=)) + collect type))) + (record-value monitor (if (find 'xpos types) (/ 1 (length utterance)) 0)))) + +(define-monitor record-tutor-uses-ypos + :class 'data-recorder :average-window 1) + +(define-monitor export-tutor-uses-ypos + :class 'lisp-data-file-writer + :data-sources '(record-tutor-uses-ypos) + :file-name (babel-pathname :name "tutor-uses-ypos" :type "lisp" + :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :add-time-and-experiment-to-file-name nil) + +(define-event-handler (record-tutor-uses-ypos interaction-finished) + (let* ((utterance (utterance (speaker interaction))) + (types (loop for word in utterance + for type = (rest (assoc word *word->type-map* :test #'string=)) + collect type))) + (record-value monitor (if (find 'ypos types) (/ 1 (length utterance)) 0)))) + + +;;;; Record reason for failure +;; a-list monitor that keeps track of the reason why the game failed +(define-monitor record-game-outcome + :documentation "records in a few symbols the game outcome" + :class 'alist-recorder + :average-window 100) + +(define-event-handler (record-game-outcome interaction-finished) + (let ((learner (find 'learner (population experiment) :key #'id)) + (tutor (find 'tutor (population experiment) :key 'id))) + (if (communicated-successfully interaction) + (set-value-for-symbol monitor 'success 1) + ;; if the tutor speaks + ;; - either the word is new for the learner + ;; - either the interpreted object is wrong + ;; if the learner speaks + ;; - either the learner cannot discriminate the topic + ;; - either the tutor cannot interpret the utterance + ;; - either the agents do not agree + (set-value-for-symbol monitor + (if (speakerp tutor) + (cond ((null (find-data learner 'parsed-meaning)) 'new-word-for-learner) + (t 'agents-not-agree)) + (cond ((null (find-data learner 'applied-cxns)) 'not-discriminate) + ((null (find-data tutor 'interpreted-topic)) 'tutor-not-interpret) + (t 'agents-not-agree))) + 1)))) + +(define-monitor plot-game-outcomes + :class 'alist-gnuplot-graphic-generator + :recorder 'record-game-outcome + :draw-y-1-grid t + :y-label "Game outcomes" + :x-label "# Games" + :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :name "game-outcomes" + :type "pdf") + :graphic-type "pdf") + +(defun create-game-outcome-graph (&key + (configurations nil) + (nr-of-interactions 5000)) + (format t "~%Running ~a interactions in order to create a game outcome graph." nr-of-interactions) + (activate-monitor plot-game-outcomes) + (run-batch 'mwm-experiment nr-of-interactions 1 + :configuration (make-configuration :entries configurations)) + (deactivate-monitor plot-game-outcomes) + (format t "~%Graphs have been created")) + + +;;;; Learner used attribute +;; a-list monitor that keeps track of the attributes used by the learner +(define-monitor record-learner-attribute-use + :documentation "Record how often the learner uses each type of attribute" + :class 'alist-recorder + :average-window 100) + +(defparameter *attribute-count* nil) + +(define-event-handler (record-learner-attribute-use interaction-finished) + (let ((learner (find 'learner (population experiment) :key #'id))) + (when (find-data learner 'parsed-meaning) + (loop for (category . score) in (find-data learner 'parsed-meaning) + for attr = (attribute category) + if (> score 0.0) + do (if (assoc attr *attribute-count*) + (incf (cdr (assoc attr *attribute-count*))) + (push (cons attr 1) *attribute-count*)))) + (loop for (attr . count) in *attribute-count* + do (set-value-for-symbol monitor attr count)))) + +(define-monitor plot-learner-attribute-use + :class 'alist-gnuplot-graphic-generator + :recorder 'record-learner-attribute-use + :draw-y-1-grid t + :y-label "Learner attribute use" + :x-label "# Games" + :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :name "learner-attribute-use" + :type "pdf") + :graphic-type "pdf") + +(defun create-learner-attribute-use-graph (&key + (configurations nil) + (nr-of-interactions 5000)) + (format t "~%Running ~a interactions in order to create a learner attribute use graph." nr-of-interactions) + (activate-monitor plot-learner-attribute-use) + (run-batch 'mwm-experiment nr-of-interactions 1 + :configuration (make-configuration :entries configurations)) + (deactivate-monitor plot-learner-attribute-use) + (format t "~%Graphs have been created")) +|# diff --git a/experiments/spatial-concept-game/package.lisp b/experiments/spatial-concept-game/package.lisp new file mode 100644 index 000000000..829df8f8b --- /dev/null +++ b/experiments/spatial-concept-game/package.lisp @@ -0,0 +1,21 @@ +(in-package :cl-user) + +(defpackage :spatial-concepts + (:documentation "spatial concept learning experiment") + (:use :common-lisp + :utils + :web-interface + :monitors + :plot-raw-data + :experiment-framework + :irl + :fcg + :clevr-world) + (:import-from :cl-mop + :slot-names + :map-slots) + (:import-from :cl-json + :decode-json-from-string + :encode-json-to-string + :encode-json-alist-to-string) + (:shadowing-import-from :fcg :size :attributes)) diff --git a/experiments/spatial-concept-game/run.lisp b/experiments/spatial-concept-game/run.lisp new file mode 100644 index 000000000..120fb55c6 --- /dev/null +++ b/experiments/spatial-concept-game/run.lisp @@ -0,0 +1,342 @@ + +(ql:quickload :spatial-concepts) +(in-package :spatial-concepts) + +(activate-monitor trace-interaction-in-web-interface) +;(deactivate-monitor trace-interaction-in-web-interface) + +(activate-monitor print-a-dot-for-each-interaction) + +(activate-monitor display-communicative-success) +;(deactivate-monitor display-communicative-success) + +;; -------------------- +;; + Run interactions + +;; -------------------- + +;;;; CONFIGURATIONS +(defparameter *baseline-simulated* + (make-configuration + :entries '((:experiment-type . :baseline) + (:world-type . :simulated) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all)))) + +(defparameter *baseline-extracted* + (make-configuration + :entries '((:experiment-type . :baseline) + (:world-type . :extracted) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all)))) + +(defparameter *cogent-simulated* + (make-configuration + :entries '((:experiment-type . :cogent) + (:world-type . :simulated) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all) + (:switch-conditions-after-n-interactions . 100)))) + +(defparameter *cogent-extracted* + (make-configuration + :entries '((:experiment-type . :cogent) + (:world-type . :extracted) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all) + (:switch-conditions-after-n-interactions . 100)))) + +(defparameter *incremental-simulated* + (make-configuration + :entries '((:experiment-type . :incremental) + (:world-type . :simulated) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all) + (:switch-conditions-after-n-interactions . 100)))) + +(defparameter *incremental-extracted* + (make-configuration + :entries '((:experiment-type . :incremental) + (:world-type . :extracted) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all) + (:switch-conditions-after-n-interactions . 100)))) + +;;;; EXPERIMENT +(defparameter *experiment* + (make-instance 'mwm-experiment + :configuration *cogent-extracted*)) + +(run-interaction *experiment*) + +(run-series *experiment* 300) + +(display-lexicon (find 'learner (population *experiment*) :key #'id)) + +;; --------------------------------- +;; + Running series of experiments + +;; --------------------------------- + +(run-experiments `( + (test + ((:experiment-type . :baseline) + (:world-type . :simulated) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all))) + ) + :number-of-interactions 2000 + :number-of-series 1 + :monitors (list "export-communicative-success" + "export-lexicon-size" + "export-communicative-success-given-conceptualisation" + ;"export-learner-concepts-to-pdf" + ;"export-learner-concepts-to-store" + ;"export-experiment-configurations" + )) + +(create-graph-for-single-strategy + "test" '("communicative-success" "lexicon-size") + :plot-file-name "baseline-simulated" + :average-windows '(100 1) + :use-y-axis '(1 2) + :y1-min 0 :y1-max 1 + :y2-min 0 :y2-max 30 + :x-label "Number of Games" + :y1-label "Communicative Success" + :y2-label "Number of Concepts" + :captions '("communicative success" + "concept repertoire size") + :error-bars '(:percentile 5 95) + :error-bar-modes '(:lines) + :key-location "bottom" + :open nil) + +(create-tutor-word-use-graph + :configurations + '((:experiment-type . :baseline) + (:world-type . :extracted) + (:determine-interacting-agents-mode . :tutor-speaks)) + :nr-of-interactions 2500) + +(create-learner-failed-conceptualisation-graph + :configurations + '((:experiment-type . :baseline) + (:world-type . :extracted) + (:determine-interacting-agents-mode . :default)) + :nr-of-interactions 5000) + + + +;; ------------- +;; + All plots + +;; ------------- +(create-graph-mixing-strategies + :experiment-measure-conses + '(("baseline-simulated" . "communicative-success") + ("baseline-simulated-bidirectional" . "communicative-success") + ("baseline-simulated-bidirectional" . "communicative-success-given-conceptualisation") + ("baseline-simulated-bidirectional" . "lexicon-size")) + :plot-file-name "baseline-simulated-comparison" + :xlabel "Number of Games" + :y1-label "Communicative Success" + :y2-label "Number of Concepts" + :captions '("communicative success (always listener)" + "communicative success (both roles)" + "communicative success given conceptualisation (both roles)" + "concept repertoire size") + :window '(100 100 100 1) + :use-y-axis '(1 1 1 2) :y1-max 1 :y2-max 30 + :end 5000) + +(create-graph-mixing-strategies + :experiment-measure-conses + '(("baseline-extracted" . "communicative-success") + ("baseline-extracted-bidirectional" . "communicative-success") + ("baseline-extracted-bidirectional" . "communicative-success-given-conceptualisation") + ("baseline-extracted-bidirectional" . "lexicon-size")) + :plot-file-name "baseline-extracted-comparison" + :xlabel "Number of Games" + :y1-label "Communicative Success" + :y2-label "Number of Concepts" + :captions '("communicative success (always listener)" + "communicative success (both roles)" + "communicative success given conceptualisation (both roles)" + "concept repertoire size") + :window '(100 100 100 1) + :use-y-axis '(1 1 1 2) :y1-max 1 :y2-max 30 + :end 5000) + + +(create-graph-mixing-strategies + '(("cogent-simulated-bidirectional-switch-1000" . "communicative-success") + ("cogent-extracted-bidirectional-switch-500" . "communicative-success")) + :plot-file-name "cogent-bidirectional-switch-500" + :x-label "Number of Games" + :y1-label "Communicative Success" + :captions '("simulated environment" + "noisy environment") + :average-windows '(100 100) + :use-y-axis '(1 1) :y1-min 0 :y1-max 1 + :error-bars '(:percentile 5 95) + :error-bar-modes '(:lines) + :key-location "bottom" + :fsize 12 :open nil) + + +;; ----------------------------- +;; + Computing average success + +;; ----------------------------- + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-main-results" + "baseline-simulated") + :name "communicative-success" :type "lisp")) + (defparameter *simulated-success-data* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-main-results" + "baseline-simulated-bidirectional") + :name "communicative-success" :type "lisp")) + (defparameter *bidirectional-simulated-success-data* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-main-results" + "baseline-simulated-bidirectional") + :name "communicative-success-given-conceptualisation" + :type "lisp")) + (defparameter *bidirectional-simulated-success-given-conceptualisation-data* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-main-results" + "baseline-extracted") + :name "communicative-success" :type "lisp")) + (defparameter *extracted-success-data* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-main-results" + "baseline-extracted-bidirectional") + :name "communicative-success" :type "lisp")) + (defparameter *bidirectional-extracted-success-data* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-main-results" + "baseline-extracted-bidirectional") + :name "communicative-success-given-conceptualisation" + :type "lisp")) + (defparameter *bidirectional-extracted-success-given-conceptualisation-data* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-simulated-switch-500") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-simulated-switch-500* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-simulated-switch-1000") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-simulated-switch-1000* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-simulated-bidirectional-switch-500") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-simulated-bidirectional-switch-500* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-simulated-bidirectional-switch-1000") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-simulated-bidirectional-switch-1000* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-extracted-switch-500") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-extracted-switch-500* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-extracted-switch-1000") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-extracted-switch-1000* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-extracted-bidirectional-switch-500") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-extracted-bidirectional-switch-500* (read stream))) + +(with-open-file + (stream (babel-pathname + :directory '("experiments" "multidimensional-word-meanings" + "raw-data" "thesis-cogent" + "cogent-extracted-bidirectional-switch-1000") + :name "communicative-success" + :type "lisp")) + (defparameter *cogent-extracted-bidirectional-switch-1000* (read stream))) + +(defun compute-success-at-point (data point &optional last-n) + (loop for series in (first data) + if last-n + sum (average (subseq series (- point last-n) point)) into sum-list + else + sum (nth point series) into sum-list + end + count series into denom + finally (return (float (/ sum-list denom))))) + +(compute-success-at-point *simulated-success-data* 5000 100) ;; 0.996 +(compute-success-at-point *cogent-simulated-switch-500* 5000 100) ;; 0.983 +(compute-success-at-point *cogent-simulated-switch-1000* 5000 100) ;; 0.993 + + +(compute-success-at-point *bidirectional-simulated-success-data* 5000 100) ;; 0.983 +(compute-success-at-point *bidirectional-simulated-success-given-conceptualisation-data* 5000 100) +(compute-success-at-point *cogent-simulated-bidirectional-switch-500* 5000 100) ;; 0.948 +(compute-success-at-point *cogent-simulated-bidirectional-switch-1000* 5000 100) ;; 0.968 + + +(compute-success-at-point *extracted-success-data* 5000 100) ;; 0.913 +(compute-success-at-point *cogent-extracted-switch-500* 5000 100) ;; 0.879 +(compute-success-at-point *cogent-extracted-switch-1000* 5000 100) ;; 0.892 + + +(compute-success-at-point *bidirectional-extracted-success-data* 5000 100) ;; 0.812 +(compute-success-at-point *bidirectional-extracted-success-given-conceptualisation-data* 5000 100) +(compute-success-at-point *cogent-extracted-bidirectional-switch-500* 5000 100) ;; 0.799 +(compute-success-at-point *cogent-extracted-bidirectional-switch-1000* 5000 100) ;; 0.805 + + diff --git a/experiments/spatial-concept-game/spatial-concepts.asd b/experiments/spatial-concept-game/spatial-concepts.asd new file mode 100644 index 000000000..be395802d --- /dev/null +++ b/experiments/spatial-concept-game/spatial-concepts.asd @@ -0,0 +1,33 @@ +(in-package :asdf) + +(defsystem :spatial-concepts + :description "spatial concept learning experiment" + :author "EHAI" + :maintainer "Jens Nevens" + :depends-on (:test-framework + :utils + :web-interface + :monitors + :plot-raw-data + :experiment-framework + :meta-layer-learning + :irl + :fcg + :clevr-world + :cl-mop + :cl-json) + :serial t + :components ((:file "package") + (:file "color-conversions") + (:file "utils") + (:file "fuzzy-operations") + (:file "world") + (:file "concept") + (:file "agent") + (:file "alignment") + (:file "experiment") + (:file "interaction") + (:file "html") + (:file "web-monitor") + (:file "monitors") + (:file "misc"))) \ No newline at end of file diff --git a/experiments/spatial-concept-game/utils.lisp b/experiments/spatial-concept-game/utils.lisp new file mode 100644 index 000000000..55cbe3b98 --- /dev/null +++ b/experiments/spatial-concept-game/utils.lisp @@ -0,0 +1,222 @@ +(in-package :spatial-concepts) + +(defun run-experiments (strategies + &key + (number-of-interactions 5) + (number-of-series 1) + (monitors + (list "export-communicative-success" + "export-lexicon-size" + "export-features-per-form" + "export-utterance-length" + "export-lexicon-evolution")) + shared-configurations) + (format t "~%Starting experimental runs") + (run-batch-for-different-configurations + :experiment-class 'mwm-experiment + :number-of-interactions number-of-interactions + :number-of-series number-of-series + :monitors monitors + :shared-configuration shared-configurations + :named-configurations strategies + :output-dir (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "raw-data"))) + (format t "~%Experimental runs finished and data has been generated. You can now plot graphs.")) + +(defun create-graph-for-single-strategy (experiment-name measure-names + &rest evo-plot-keyword-args) + ;; take some arguments, but pass along the rest to raw-files->evo-plot + (format t "~%Creating graph for experiment ~a with measures ~a" experiment-name measure-names) + (let* ((raw-file-paths + (loop for measure-name in measure-names + collect `("experiments" "multidimensional-word-meanings" + "raw-data" ,experiment-name ,measure-name))) + (default-plot-file-name + (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) + raw-file-paths :key #'(lambda (path) (first (last path))))) + (plot-file-name + (when (find :plot-file-name evo-plot-keyword-args) + (nth (1+ (position :plot-file-name evo-plot-keyword-args)) evo-plot-keyword-args)))) + (apply #'raw-files->evo-plot + (append `(:raw-file-paths ,raw-file-paths + :plot-directory ("experiments" "multidimensional-word-meanings" "graphs") + :plot-file-name ,(if plot-file-name plot-file-name default-plot-file-name)) + evo-plot-keyword-args))) + (format t "~%Graphs have been created")) + +(defun create-graph-mixing-strategies (experiment-measure-pairs + &rest evo-plot-keyword-args) + ;; take some arguments, but pass along the rest to raw-files->evo-plot + (let* ((raw-file-paths + (loop for (experiment . measure) in experiment-measure-pairs + collect `("experiments" "multidimensional-word-meanings" + "raw-data" ,experiment ,measure))) + (default-plot-file-name + (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) + raw-file-paths :key #'(lambda (path) (first (last path))))) + (captions + (if (find :captions evo-plot-keyword-args) + (nth (1+ (position :captions evo-plot-keyword-args)) evo-plot-keyword-args) + (loop for (experiment . measure) in experiment-measure-pairs + collect (format nil "~a-~a" experiment measure)))) + (plot-file-name + (when (find :plot-file-name evo-plot-keyword-args) + (nth (1+ (position :plot-file-name evo-plot-keyword-args)) evo-plot-keyword-args)))) + (apply #'raw-files->evo-plot + (append `(:raw-file-paths ,raw-file-paths + :plot-directory ("experiments" "multidimensional-word-meanings" "graphs") + :captions ,captions + :plot-file-name ,(if plot-file-name plot-file-name default-plot-file-name)) + evo-plot-keyword-args)))) + + +#| +(defun create-graph-for-single-strategy (&key experiment-name measure-names average-windows + y-axis (y1-min 0) y1-max y2-max xlabel y1-label y2-label + captions (open t) start end plot-file-name (key-location "bottom")) + ;; This function allows you to plot one or more measures for a single experiment + ;; e.g. communicative success and lexicon size + (format t "~%Creating graph for experiment ~a with measures ~a" experiment-name measure-names) + (let* ((raw-file-paths + (loop for measure-name in measure-names + collect `("experiments" "multidimensional-word-meanings" "raw-data" ,experiment-name ,measure-name))) + (default-plot-file-name + (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) + raw-file-paths :key #'(lambda (path) (first (last path)))))) + (raw-files->evo-plot + :raw-file-paths raw-file-paths + :average-windows average-windows + :plot-directory `("experiments" "multidimensional-word-meanings" "graphs") + :plot-file-name (if plot-file-name plot-file-name default-plot-file-name) + :error-bars '(:percentile 5 95) ; '(:stdev) + :error-bar-modes '(:lines) + :captions captions + :use-y-axis y-axis + :y1-min y1-min + :y1-max y1-max + :y2-min 0 + :y2-max y2-max + :x-label (if xlabel xlabel "Number of Games") + :y1-label (when y1-label y1-label) + :y2-label (when y2-label y2-label) + :open open + :start start :end end + :key-location key-location)) + (format t "~%Graphs have been created")) + +(defun create-graph-comparing-strategies (&key experiment-names measure-name + (y-min 0) (y-max 1) xlabel y1-label y2-label + captions title start end (window 1000) + plot-file-name (key-location "bottom")) + ;; This function allows you to compare a given measure accross different + ;; experiments, e.g. comparing lexicon size + (format t "~%Creating graph for experiments ~a with measure ~a" experiment-names measure-name) + (let* ((raw-file-paths + (loop for experiment-name in experiment-names + collect `("experiments" "multidimensional-word-meanings" "raw-data" ,experiment-name ,measure-name))) + (default-plot-file-name + (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) + raw-file-paths :key #'(lambda (path) (first (last path)))))) + (raw-files->evo-plot + :raw-file-paths raw-file-paths + :average-windows window + :captions (if captions captions experiment-names) + :title title + :plot-directory '("experiments" "multidimensional-word-meanings" "graphs") + :plot-file-name (if plot-file-name plot-file-name default-plot-file-name) + :error-bars '(:percentile 5 95) ;'(:stdev) + :error-bar-modes '(:lines) + :y1-min y-min + :y1-max y-max + :x-label (if xlabel xlabel "Number of Games") + :y1-label (when y1-label y1-label) + :y2-label (when y2-label y2-label) + :start start :end end + :key-location key-location)) + (format t "~%Graphs have been created")) + + +(defun create-graph-mixing-strategies (&key + experiment-measure-conses + (y1-min 0) (y1-max 1) (y2-min 0) (y2-max nil) use-y-axis + xlabel y1-label y2-label captions title start end + (window 1000) plot-file-name open (key-location "bottom")) + (let* ((raw-file-paths + (loop for (experiment . measure) in experiment-measure-conses + collect `("experiments" "multidimensional-word-meanings" "raw-data" ,experiment ,measure))) + (default-plot-file-name + (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) + raw-file-paths :key #'(lambda (path) (first (last path)))))) + (raw-files->evo-plot + :raw-file-paths raw-file-paths + :average-windows window + :captions (if captions captions + (loop for (experiment . measure) in experiment-measure-conses + collect (format nil "~a-~a" experiment measure))) + :title title + :plot-directory '("experiments" "multidimensional-word-meanings" "graphs") + :plot-file-name (if plot-file-name plot-file-name default-plot-file-name) + :error-bars '(:percentile 5 95) ;'(:stdev) + :error-bar-modes '(:lines) + :use-y-axis use-y-axis + :y1-min y1-min :y1-max y1-max + :y2-min y2-min :y2-max y2-max + :x-label (if xlabel xlabel "Number of Games") + :y1-label (when y1-label y1-label) + :y2-label (when y2-label y2-label) + :start start :end end + :open open + :key-location key-location)) + (format t "~%Graphs have been created")) + +(defun create-stacked-bars-comparing-strategies (&key experiment-names measure-names + (x-label "") (y-label "") + cluster-labels bar-labels + (title "") (open t) + (y-max nil)) + ;; This functions allows you to plot one or multiple measures for different + ;; experiments. These will be plotted as stacked bars. + (format t "~%Creating graph for experiments ~a with measures ~a" experiment-names measure-names) + (let ((raw-file-paths + (loop for experiment-name in experiment-names + collect (loop for measure-name in measure-names + collect `("experiments" "multidimensional-word-meanings" "raw-data" "final" ,experiment-name ,measure-name))))) + (file-structure->stacked-bar-plot + :raw-file-paths raw-file-paths + :plot-directory '("experiments" "multidimensional-word-meanings" "graphs") + :x-label x-label + :y-label y-label + :title title + :labels-a (if bar-labels + bar-labels + (mapcar #'(lambda (path) (first (last path))) (first raw-file-paths))) + :labels-b (if cluster-labels + cluster-labels + (mapcar #'(lambda (path) (first (last (butlast (first path))))) raw-file-paths)) + :y-max y-max + :open open))) + +(defun create-grouped-bars-comparing-strategies (&key experiment-names measure-names + (x-label "") (y-label "") + cluster-labels bar-labels + (title "") (open t) + (y-max nil)) + ;; This functions allows you to plot one or multiple measures for different + ;; experiments. These will be plotted as grouped bars. + (format t "~%Creating graph for experiments ~a with measures ~a" experiment-names measure-names) + (let ((raw-file-paths + (loop for experiment-name in experiment-names + collect (loop for measure-name in measure-names + collect `("experiments" "multidimensional-word-meanings" "raw-data" ,experiment-name ,measure-name))))) + (file-structure->grouped-bar-plot + :raw-file-paths raw-file-paths + :plot-directory '("experiments" "multidimensional-word-meanings" "graphs") + :x-label x-label :y-label y-label + :title title + :labels-a (if bar-labels bar-labels + (mapcar #'(lambda (path) (first (last path))) (first raw-file-paths))) + :labels-b (if cluster-labels cluster-labels + (mapcar #'(lambda (path) (first (last (butlast (first path))))) raw-file-paths)) + :error-bars :stdev + :y-max y-max + :open open))) +|# \ No newline at end of file diff --git a/experiments/spatial-concept-game/web-demo.lisp b/experiments/spatial-concept-game/web-demo.lisp new file mode 100644 index 000000000..fb7cdbf05 --- /dev/null +++ b/experiments/spatial-concept-game/web-demo.lisp @@ -0,0 +1,140 @@ +;(ql:quickload :mwm) + +(in-package :spatial-concepts) + +(define-css 'main "p {font-size: 11pt}") + +;; HEADER + +(defun make-header () + (clear-page) + (deactivate-all-monitors) + (add-element '((hr))) + (add-element + '((h1 :id "top") "Interactive Learning of Grounded Concepts")) + (add-element '((hr))) + (add-element '((p) "This web demonstration accompanies the following paper:")) + (add-element '((p) ((b) "From Continuous Observations to Symbolic Concepts: A Discrimination-based Strategy for Grounded Concept Learning. Nevens, J, Van Eecke, P, and Beuls, K. In preparation"))) + (add-element '((p) "The goal of this web demo is to provide more insight in the interaction script for the various grounded concept learning experiments. Here, you will find traces that are printed during experimental runs. The success measures, such as communicative success and repertoire size, can be found in the paper. They will not be repeated in this web demo.")) + (add-element '((hr))) + (add-element '((p) "This demonstration has the following parts:")) + (add-element '((h3) ((a :href "#abstract") "I. Abstract"))) + (add-element '((h3) ((a :href "#baseline") "II. Baseline Experiments"))) + (add-element '((h3) ((a :href "#cogent") "III. Generalisation Experiments"))) + (add-element '((h3) ((a :href "#incremental") "IV. Incremental Learning Experiments"))) + (add-element '((p :style "color:darkred") "NOTE: It is recommended to use Firefox to optimally explore the contents of this page.")) + (add-element '((hr))) + ) + +;; ABSTRACT + +(defun make-abstract () + (add-element '((h2 :id "abstract") "I. Abstract")) + (add-element '((p) "Autonomous agents perceive the world through streams of continuous sensori-motor data. Yet, in order to reason and communicate about their environment, agents need to be able to distill meaningful concepts from their raw observations. Most current approaches bridge between the continuous and symbolic domain using deep learning techniques. While these approaches often achieve high levels of accuracy, they rely on large amounts of training data, and the resulting models lack transparency, generality and adaptivity. In this paper, we introduce a novel methodology for grounded concept learning. In a tutor-learner scenario, the method allows an agent to construct a conceptual system in which meaningful concepts are formed by discriminative combinations of prototypical values on human-interpretable feature channels. We evaluate our approach on the CLEVR dataset, using features that are either simulated or extracted using computer vision techniques. Through a range of experiments, we show that our method allows for incremental learning, needs few data points, and that the resulting concepts are general enough to be applied to previously unseen objects. These properties make the approach well-suited to be used in robotic agents as the module that maps from continuous sensori-motor input to grounded, symbolic concepts that can then be used for higher-level reasoning tasks.")) + ) + +;; HELPER FUNCTIONS + +(defun all-words-known-p (experiment) + (let ((learner (find 'learner (population experiment) :key #'id))) + (= (length (constructions (grammar learner))) 19))) + +(defun run-experiments-untill-all-words-known (experiment) + (loop while (not (all-words-known-p experiment)) + do (run-interaction experiment))) + +;; BASELINE EXPERIMENTS + +(defun make-baseline-experiments () + (add-element '((h2 :id "baseline") "II. Baseline Experiments")) + (add-element '((p) "The goal of these experiments is to validate the learning mechanisms. In a simulated environment, the agents should quickly achieve 100% communicative success. The realistic environment, using features extracted using computer vision techniques, is more difficult for the learner agent. Here, the agents are unable to achieve full communicative success. Note that in all experiments below, we use the 'prototype' representation.")) + (make-baseline-simulated-experiments) + (make-baseline-extracted-experiments) + ) + +(defun make-baseline-simulated-experiments () + (let* ((config (make-configuration + :entries `((:data-source . :clevr) + (:scale-world . ,nil) + (:category-representation . :prototype) + (:determine-interacting-agents-mode . :tutor-speaks) + (:data-sets . ("val"))))) + (experiment (make-instance 'mwm-experiment :configuration config))) + (add-element '((h3) "Baseline Simulated Experiment")) + (activate-monitor trace-interaction-in-web-interface) + (add-element '((p) "At the start, the learner has no repertoire of concepts. The word the tutor utters in the very first interaction is thus always unknown. The learner indicates that it does not know the word and the tutor provides feedback by pointing to the indended topic. Now, the learner creates its first concept, simply by storing an exact copy of the topic object. Indeed, the learner cannot yet know which attributes are important or what their prototypical values should be.")) + (run-interaction experiment) + (deactivate-monitor trace-interaction-in-web-interface) + (add-element '((p) "Now, we run a number of interactions untill the learner has acquired all 19 concepts.")) + (add-element '((p) ((b) "Running interactions..."))) + (run-experiments-untill-all-words-known experiment) + (activate-monitor trace-interaction-in-web-interface) + (add-element '((p) "If the learner does know the word, it will try to interpret this word in the current context. If the learner points to the tutor's intended topic, the interaction is a success. Independant of the success of the interaction, the tutor will indicate the intended topic at the end of the interaction. Now, the learner will compare this topic to the concept representation it used. First, the learner will slightly shift the prototypical value of all attributes towards the corresponding attribute values of the topic. Next, based on the notion of discrimination, the learner will decide which attributes to reward and punish. The former are indicated in green, the latter in red.")) + (run-interaction experiment) + (deactivate-monitor trace-interaction-in-web-interface) + (add-element '((p) "Finally, we run 1000 additional interactions and show the learner's lexicon.")) + (add-element '((p) ((b) "Running interactions..."))) + (run-series experiment 1000) + (display-lexicon (find 'learner (population experiment) :key #'id)) + (add-element '((p) ((a :href "#top") "Back to top"))) + )) + +(defun make-baseline-extracted-experiments () + (let* ((config (make-configuration + :entries `((:data-source . :extracted) + (:scale-world . ,nil) + (:category-representation . :prototype) + (:determine-interacting-agents-mode . :tutor-speaks) + (:data-path . ,(merge-pathnames (make-pathname :directory '(:relative "CLEVR" "CLEVR-v1.0" "scenes" "val-ns-vqa")) + cl-user:*babel-corpora*))))) + (experiment (make-instance 'mwm-experiment :configuration config))) + (add-element '((h3) "Baseline Extracted Experiment")) + (add-element '((p) "In the realistic environment, the continuous-valued attributes observed by the learner are obtained using computer vision techniques. More concretely, we use the Mask R-CNN object detection algorithm to detect and segment the objects directly from the input image. The object proposals returned by this algorithm are passed on to feature extractors, extracting various numeric attributes.")) + (add-element '((p) "Given that the object detection and feature extraction are not perfect, the scenes in this experiment are more noisy. This makes the task more difficult for the learner agent, which is also reflected in the communicative success. Below, we show the traces of the first and the 1000'th interaction. Also, we show the learner's concept repertoire after 1000 interactions.")) + (activate-monitor trace-interaction-in-web-interface) + (run-interaction experiment) + (deactivate-monitor trace-interaction-in-web-interface) + (add-element '((p) ((b) "Running interactions..."))) + (run-series experiment 1000) + (display-lexicon (find 'learner (population experiment) :key #'id)) + (add-element '((p) ((a :href "#top") "Back to top"))) + )) + +;; COGENT EXPERIMENTS + +(defun make-cogent-experiments () + (add-element '((h2 :id "cogent") "III. Generalisation Experiments")) + (add-element '((p) "The goal of these experiments is to show the generalisation capabilities of our concept learning approach. For this, we use the CLEVR CoGenT dataset. The learner first performs a number of interactions on condition A, after which the learning operators are turned off and the environment switches to condition B. Now, if the concepts acquired by the learner are bound to statistical distributions and co-occurences of condition A, the communicative success obtained by the learner would drop when switching from condition A to B. As we have demonstrated in the paper, this is not the case. From this, we conclude that the concepts are quite general and dataset-independant.")) + (make-cogent-simulated-experiment) + (make-cogent-extracted-experiment) + ) + +(defun make-cogent-simulated-experiment () + (add-element '((h3) "Generalisation Simulated Experiment")) + (add-element '((p) ((a :href "#top") "Back to top"))) + ) + +(defun make-cogent-extracted-experiment () + (add-element '((h3) "Generalisation Extracted Experiment")) + (add-element '((p) ((a :href "#top") "Back to top"))) + ) + +;; INCREMENTAL LEARNING EXPERIMENTS + +(defun make-incremental-experiments () + (add-element '((h2 :id "incremental") "IV. Incremental learning Experiments")) + (add-element '((p) "The goal of these experiments is to show the incremental learning capabilities of our approach. For this experiment, we created a custom dataset that consists of 3 conditions. In the first condition, there are only contains cubes. In the second condition spheres are added. The third and final condition contains all three types of shapes, as the original CLEVR dataset. Over the course of interactions, the environment transitions from one condition to the next. Here, we show that the learner agent can very quickly adapt to this changing environment. There is no need for complete or even partial retraining of the concepts, as adaptivity is integrated in the methodology and learning operators directly.")) + ) + +;; COMPLETE DEMO +(defun make-static-web-demo () + (make-header) + (make-abstract) + (make-baseline-experiments) + (make-cogent-experiments) + (make-incremental-experiments) + ) + +;(make-static-web-demo) + +;(web-interface:create-static-html-page "concept-learning" (make-static-web-demo)) \ No newline at end of file diff --git a/experiments/spatial-concept-game/web-monitor.lisp b/experiments/spatial-concept-game/web-monitor.lisp new file mode 100644 index 000000000..4f3241783 --- /dev/null +++ b/experiments/spatial-concept-game/web-monitor.lisp @@ -0,0 +1,182 @@ +(in-package :spatial-concepts) + +;;;; Show lexicon in web interface +(defun display-lexicon (agent) + (loop for concept in (lexicon agent) + do (add-element + `((div) + ,(s-dot->svg + (concept->s-dot concept)))) + do (add-element '((hr)))) + (length (lexicon agent))) + +;; ----------------- +;; + Printing dots + +;; ----------------- + +(define-monitor print-a-dot-for-each-interaction + :documentation "Prints a '.' for each interaction + and prints the number after :dot-interval") + +(define-event-handler (print-a-dot-for-each-interaction interaction-finished) + (if (= (mod (interaction-number interaction) + (get-configuration experiment :dot-interval)) 0) + (format t ". (~a)~%" (interaction-number interaction)) + (format t "."))) + + +;; --------- +;; + TIIWI + +;; --------- +(define-monitor trace-interaction-in-web-interface) + + +(define-event-handler (trace-interaction-in-web-interface interaction-started) + (add-element '((hr))) + (add-element + `((h1) ,(format nil "Interaction ~a" + (interaction-number interaction)))) + (add-element + `((h2) ,(format nil "The ~a is the speaker" + (downcase (mkstr (id (speaker interaction))))))) + (add-element + `((h2) ,(format nil "The ~a is the hearer" + (downcase (mkstr (id (hearer interaction))))))) + (add-element '((hr)))) + + +(define-event-handler (trace-interaction-in-web-interface interaction-finished) + (add-element '((hr))) + (add-element + `((h2) "Interaction " + ,(if (communicated-successfully interaction) + `((b :style "color:green") "succeeded") + `((b :style "color:red") "failed"))))) + + +(define-event-handler (trace-interaction-in-web-interface context-determined) + (add-element + `((table) + ((tr) ((th) "CLEVR context")) + ((tr) ((td) ,(make-html (get-data (speaker experiment) 'tutor-context) + :expand-initially t))))) + (add-element + `((table) + ((tr) ((th) "MWM context")) + ((tr) ((td) ,(make-html (get-data (speaker experiment) 'context))))))) + + +(define-event-handler (trace-interaction-in-web-interface conceptualisation-finished) + (add-element + `((h2) + ,(format nil "The topic is ~a (~a)" + (id (find-data agent 'topic)) + (id (find-data agent 'tutor-topic))))) + (cond + ;; tutor + ((and (tutorp agent) (find-data agent 'tutor-conceptualisation)) + (add-element + '((h2) "Tutor found discriminating attributes:")) + (add-element + `((h3) ((i) ,(format nil "~a" + (find-data agent 'tutor-conceptualisation)))))) + ;; learner + ((and (learnerp agent) (find-data agent 'applied-concept)) + (add-element + '((h2) "Learner found a discriminating concept:")) + (add-element + `((div) + ,(s-dot->svg + (concept->s-dot (find-data agent 'applied-concept)))))) + ;; failed + (t + (add-element + `((h2) ,(format nil "~@(~a~) did not find discriminating attributes" + (id agent))))))) + + +(define-event-handler (trace-interaction-in-web-interface production-finished) + (if (utterance agent) + (progn + (add-element + `((h2) ,(format nil "~@(~a~) producted an utterance:" (id agent)))) + (add-element + `((h3) ((i) ,(format nil "\"~a\"" (utterance agent)))))) + (add-element + `((h2) ,(format nil "~@(~a~) could not produce an utterance" (id agent)))))) + + +(define-event-handler (trace-interaction-in-web-interface parsing-finished) + (when (learnerp agent) + (if (find-data agent 'applied-concept) + (progn (add-element '((h2) "The learner parsed the utterance:")) + (add-element + `((div) + ,(s-dot->svg + (concept->s-dot (find-data agent 'applied-concept)))))) + (add-element + '((h2) "The learner could not parse the utterance."))))) + + +(define-event-handler (trace-interaction-in-web-interface interpretation-finished) + (if (find-data agent 'interpreted-topic) + (progn + (add-element + `((h2) ,(format nil "The ~a interpreted the utterance:" + (downcase (mkstr (id agent)))))) + (add-element (make-html (find-data agent 'interpreted-topic) :expand-initially t))) + (add-element + `((h2) ,(format nil "The ~a could not interpret the utterance." + (downcase (mkstr (id agent)))))))) + + +(define-event-handler (trace-interaction-in-web-interface adopt-concept-started) + (add-element + `((h2) ,(format nil "Learner will adopt a new concept for the word \"~a\"" word)))) + + +(define-event-handler (trace-interaction-in-web-interface align-concept-started) + (add-element + `((h2) ,(format nil "Learner will align the concept for the word \"~a\"" word)))) + + +(define-event-handler (trace-interaction-in-web-interface new-concept-added) + (add-element + '((h2) "A new concept was created:")) + (add-element + `((div) ,(s-dot->svg + (concept->s-dot concept))))) + + +(define-event-handler (trace-interaction-in-web-interface scores-updated) + (add-element + `((h2) ,(format nil "Attributes rewarded and punished for \"~a\"" + (form concept)))) + (add-element + `((div) ,(s-dot->svg + (concept->s-dot concept + :highlight-green rewarded-attrs + :highlight-red punished-attrs))))) + + +(define-event-handler (trace-interaction-in-web-interface attribute-removed) + (add-element + `((h2) ,(format nil "Removed attribute ~a from word \"~a\"" + attribute (form concept))))) + + +(define-event-handler (trace-interaction-in-web-interface concept-removed) + (add-element + `((h2) ,(format nil "Removed concept \"~a\"" + (form concept))))) + + +(define-event-handler (trace-interaction-in-web-interface found-discriminating-attributes) + (add-element + `((h3) ,(format nil "The following attributes are discriminating: ~{\"~a\"~^, ~}" + (reverse attributes))))) + +(define-event-handler (trace-interaction-in-web-interface found-subset-to-reward) + (add-element + `((h3) ,(format nil "The agent will reward the following subset: ~{\"~a\"~^, ~}" + (reverse (mapcar #'attribute subset)))))) diff --git a/experiments/spatial-concept-game/world.lisp b/experiments/spatial-concept-game/world.lisp new file mode 100644 index 000000000..5a90e4f3a --- /dev/null +++ b/experiments/spatial-concept-game/world.lisp @@ -0,0 +1,206 @@ +(in-package :spatial-concepts) + +(export '(mwm-object)) + +;; -------------- +;; + MWM object + +;; -------------- +(defclass mwm-object (entity) + ((attributes + :documentation "the attributes of the object (a-list)" + :type list :accessor attributes :initarg :attributes) + (description + :documentation "symbolic description of the original clevr object" + :type list :accessor description :initarg :description)) + (:documentation "A continuous-valued CLEVR object")) + +(defmethod get-attr-val ((object mwm-object) attr) + (rest (assoc attr (attributes object)))) + +(defmethod set-attr-val ((object mwm-object) attr val) + (if (assoc attr (attributes object)) + (setf (rest (assoc attr (attributes object))) val) + (push (cons attr val) (attributes object))) + nil) + +(defmethod object->alist ((object clevr-object)) + `((:color . ,(color object)) + (:size . ,(clevr-world::size object)) + (:shape . ,(shape object)) + (:material . ,(material object)) + (:xpos . ,(if (> (x-pos object) 240) 'right 'left)) + (:ypos . ,(if (> (y-pos object) 160) 'front 'behind)) + )) + +;; ------------------ +;; + MWM object set + +;; ------------------ +(defclass mwm-object-set (entity) + ((objects + :documentation "the objects in the set" + :type list :accessor objects :initarg :objects + :initform nil) + (image + :documentation "path of the image of this set" + :type pathname :accessor image :initarg :image)) + (:documentation "A set of mww-objects")) + +;; ---------------- +;; + CLEVR -> MWM + +;; ---------------- + +(defun add-random-value-from-range (value min-var max-var + &key (min-bound 0.0) (max-bound 1.0)) + (let* ((func (random-elt (list #'+ #'-))) + (variance (random-from-range min-var max-var)) + (new-value (funcall func value variance))) + (when min-bound + (if (< new-value min-bound) + (setf new-value min-bound))) + (when max-bound + (if (> new-value max-bound) + (setf new-value max-bound))) + new-value)) + +;; when xpos and ypos are exactly equal to 0.5 +;; they are considered to be left! +(defmethod to-value ((object clevr-object) (attr (eql 'xpos))) + `((xpos . ,(x-pos object)))) + +(defmethod to-value ((object clevr-object) (attr (eql 'ypos))) + `((ypos . ,(y-pos object)))) + +(defmethod to-value ((object clevr-object) (attr (eql 'area))) + (let* ((area + (case (clevr-world::size object) + (small 30) (large 70))) + (area-w-variance + (add-random-value-from-range area 0 16 :max-bound 100))) + `((area . ,area-w-variance)))) + +(defmethod to-value ((object clevr-object) (attr (eql 'sides-and-corners))) + (let ((sides + (case (shape object) + (cube 6) (sphere 1) (cylinder 3))) + (corners + (case (shape object) + (cube 8) (sphere 0) (cylinder 2)))) + `((nr-of-sides . ,sides) + (nr-of-corners . ,corners)))) + +(defmethod to-value ((object clevr-object) (attr (eql 'color))) + (let* ((rgb-color + (case (color object) + (gray '(87 87 87)) + (red '(173 34 35)) + (blue '(44 76 215)) + (green '(29 105 20)) + (brown '(126 72 25)) + (purple '(130 39 192)) + (cyan '(40 208 208)) + (yellow '(255 238 51)))) + (rgb-with-variance + (loop for channel in rgb-color + collect (add-random-value-from-range channel 0.0 2.0 :max-bound 255.0)))) + `((r . ,(first rgb-with-variance)) + (g . ,(second rgb-with-variance)) + (b . ,(third rgb-with-variance))))) + +(defmethod to-value ((object clevr-object) (attr (eql 'roughness))) + (let* ((roughness + (case (material object) + (metal 8) + (rubber 2))) + (roughness-with-variance + (add-random-value-from-range roughness 0.0 2.5 :max-bound 10.0))) + `((roughness . ,roughness-with-variance)))) + +(defmethod to-value ((object clevr-object) (attr (eql 'wh-ratio))) + (let* ((ratio + (case (shape object) + (cube 1.0) + (sphere 1.0) + (cylinder 0.5))) + (ratio-with-variance + (add-random-value-from-range ratio 0.0 0.25))) + `((wh-ratio . ,ratio-with-variance)))) + +;;;; clevr -> mwm +(defmethod clevr->simulated ((scene clevr-scene)) + (make-instance 'mwm-object-set :id (id scene) + :image (image scene) + :objects (loop for obj in (objects scene) + collect (clevr->simulated obj)))) + +(defmethod clevr->simulated ((object clevr-object)) + (make-instance 'mwm-object :id (id object) ;; !!! + :attributes (append (to-value object 'xpos) + (to-value object 'ypos) + (to-value object 'area) + (to-value object 'wh-ratio) + (to-value object 'color) + (to-value object 'roughness) + (to-value object 'sides-and-corners)) + :description (object->alist object))) + +;; --------- +;; + NOISE + +;; --------- +(defmethod add-noise ((set mwm-object-set) probability amount) + (loop for object in (objects set) + do (add-noise object probability amount))) + +(defmethod add-noise ((object mwm-object) probability amount) + (loop for (attr . val) in (attributes object) + unless (member attr '(nr-of-sides nr-of-corners)) + do (when (< (random 1.0) probability) + (set-attr-val object attr + (add-random-value-from-range val 0.0 amount))))) + +;; ------------------------ +;; + Continous CLEVR data + +;; ------------------------ + +(defun extracted->mwm-object (alist) + "Load a single object" + (let* ((mean-color (rest (assoc :color-mean alist))) + (lab (hsv->lab mean-color))) + ;; create an alist + (setf alist + (mapcar #'(lambda (pair) + (cons (internal-symb (car pair)) + (cdr pair))) + alist)) + ;; split the color channels + (setf alist + (append `((mean-l . ,(first lab)) + (mean-a . ,(second lab)) + (mean-b . ,(third lab))) + alist)) + (setf alist (remove 'color-mean alist :key #'car)) + (setf alist (remove 'color-std alist :key #'car)) + (setf alist (remove 'bb-area alist :key #'car)) + ;; flip the sign for angle + (setf (cdr (assoc 'angle alist)) + (- (cdr (assoc 'angle alist)))) + ;; create an object + (make-instance 'mwm-object + :id (make-id 'object) + :attributes alist))) + +(defmethod clevr->extracted ((scene clevr-scene) &key directory) + ;; take the name of the scene + ;; look it up in 'directory' + ;; and load the data + (let* ((path + (merge-pathnames + (make-pathname :name (name scene) :type "json") + directory)) + (objects + (with-open-file (stream path :direction :input) + (mapcar #'extracted->mwm-object + (mapcar #'decode-json-from-string + (stream->list stream)))))) + (make-instance 'mwm-object-set + :id (make-id 'scene) + :objects objects))) -- GitLab From 312052e772d9b0253e523d7cd57b812f76251100 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Thu, 24 Mar 2022 14:34:17 +0100 Subject: [PATCH 037/157] adding further testcases for addition, holistic-to-item-based and item-based-to-holistic --- experiments/grammar-learning/clevr/test.lisp | 2 +- .../tests/test-addition-repair.lisp | 42 +++- .../test-holistic-to-item-based-repair.lisp | 52 ++++ .../test-item-based-to-holistic-repair.lisp | 231 ++---------------- 4 files changed, 120 insertions(+), 207 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 088e67ae2..072fdb101 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 50) +;(run-series *experiment* 10000) #| QUESTIONS diff --git a/systems/grammar-learning/tests/test-addition-repair.lisp b/systems/grammar-learning/tests/test-addition-repair.lisp index 4eda02513..eb6393644 100644 --- a/systems/grammar-learning/tests/test-addition-repair.lisp +++ b/systems/grammar-learning/tests/test-addition-repair.lisp @@ -59,7 +59,46 @@ (query ?target-4 ?target-object-1 ?attribute-2)))))))) - +(deftest test-addition-with-duplicate-item-based-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "The gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-2) + (unique ?source-9 ?target-2) + (bind shape-category ?shape-8 thing) + (bind attribute-category ?attribute-2 shape) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 gray) + (query ?target-7 ?source-9 ?attribute-2))) + (comprehend "The large gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-39552 ?target-2 ?size-4) + (unique ?source-10 ?target-39552) + (bind color-category ?color-2 gray) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-4 large) + (query ?target-8 ?source-10 ?attribute-2))) + (test-repair-status 'holophrase->item-based+holistic--addition + (second (multiple-value-list + (comprehend "The small gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-107036 ?target-2 ?size-2) + (unique ?source-9 ?target-107036) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 gray) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-2 small) + (query ?target-7 ?source-9 ?attribute-2)))))) + (test-equal 4 (length (constructions cxn-inventory))))) @@ -67,6 +106,7 @@ (defun run-addition-tests () (test-addition-repair-comprehension) (test-double-addition-repair-comprehension) + (test-addition-with-duplicate-item-based-comprehension) ) ;(run-addition-tests) diff --git a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp index 97d83e196..8da456dab 100644 --- a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp +++ b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp @@ -216,6 +216,57 @@ (bind size-category ?size-4 large) (query ?target-4 ?target-object-1 ?attribute-2)))))))) +(deftest test-holistic-to-item-based-double-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "The gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-2) + (unique ?source-9 ?target-2) + (bind shape-category ?shape-8 thing) + (bind attribute-category ?attribute-2 shape) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 gray) + (query ?target-7 ?source-9 ?attribute-2))) + (comprehend "The gray object is what color?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-2 ?target-1 ?color-2) + (unique ?source-9 ?target-2) + (bind shape-category ?shape-8 thing) + (bind attribute-category ?attribute-2 color) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 gray) + (query ?target-7 ?source-9 ?attribute-2))) + (comprehend "The large gray object is what shape?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-39552 ?target-2 ?size-4) + (unique ?source-10 ?target-39552) + (bind color-category ?color-2 gray) + (filter ?target-1 ?source-1 ?shape-8) + (bind attribute-category ?attribute-2 shape) + (bind shape-category ?shape-8 thing) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-4 large) + (query ?target-8 ?source-10 ?attribute-2))) + (test-repair-status 'holistic->item-based + (second (multiple-value-list + (comprehend "The large gray object is what color?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (filter ?target-107036 ?target-2 ?size-2) + (unique ?source-9 ?target-107036) + (bind attribute-category ?attribute-2 color) + (bind shape-category ?shape-8 thing) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 gray) + (filter ?target-2 ?target-1 ?color-2) + (bind size-category ?size-2 large) + (query ?target-7 ?source-9 ?attribute-2)))))) + (test-equal 7 (length (constructions cxn-inventory))))) + ;; (activate-monitor trace-fcg) @@ -226,6 +277,7 @@ (test-multiple-holistic-to-item-based-repair-comprehension) (test-holistic-to-item-based-duplicates-comprehension) (test-double-holistic-to-item-based-from-substitution-repair-comprehension) + (test-holistic-to-item-based-double-comprehension) ) diff --git a/systems/grammar-learning/tests/test-item-based-to-holistic-repair.lisp b/systems/grammar-learning/tests/test-item-based-to-holistic-repair.lisp index 68bf49484..78db6d6c2 100644 --- a/systems/grammar-learning/tests/test-item-based-to-holistic-repair.lisp +++ b/systems/grammar-learning/tests/test-item-based-to-holistic-repair.lisp @@ -1,76 +1,10 @@ -(ql:quickload :clevr-grammar-learning) -(in-package :clevr-grammar-learning) +(in-package :grammar-learning) - - -;; full logging except trace-fcg -(progn - (deactivate-all-monitors) - (activate-monitor display-metrics) - (activate-monitor print-a-dot-for-each-interaction) - (activate-monitor summarize-results-after-n-interactions) - (activate-monitor show-type-hierarchy-after-n-interactions) - (activate-monitor trace-interactions-in-wi)) - -;; minimal logging after 100 interactions with type hierarchy -(progn - (deactivate-all-monitors) - (activate-monitor display-metrics) - (activate-monitor summarize-results-after-n-interactions) - (activate-monitor show-type-hierarchy-after-n-interactions) - (activate-monitor print-a-dot-for-each-interaction)) - -;; minimal logging after 100 interactions -(progn - (deactivate-all-monitors) - (activate-monitor display-metrics) - (activate-monitor summarize-results-after-n-interactions) - (activate-monitor print-a-dot-for-each-interaction)) - -;; full logging -(progn - (deactivate-all-monitors) - (activate-monitor display-metrics) - (activate-monitor trace-fcg) - (activate-monitor print-a-dot-for-each-interaction) - (activate-monitor summarize-results-after-n-interactions) - (activate-monitor show-type-hierarchy-after-n-interactions) - (activate-monitor trace-interactions-in-wi)) - - -(defun disable-learning (grammar) - (set-configuration grammar :update-th-links nil) - (set-configuration grammar :use-meta-layer nil) - (set-configuration grammar :consolidate-repairs nil)) - - -(defun enable-learning (grammar) - (set-configuration grammar :update-th-links t) - (set-configuration grammar :use-meta-layer t) - (set-configuration grammar :consolidate-repairs t)) - - - -(defun set-up-cxn-inventory-and-repairs () - (wi::reset) - (notify reset-monitors) - (make-instance 'clevr-grammar-learning-experiment - :entries '((:observation-sample-mode . :debug) ;; random or sequential - (:determine-interacting-agents-mode . :corpus-learner) - (:de-render-mode . :de-render-string-meets-no-punct) - (:remove-cxn-on-lower-bound . nil) - (:learner-th-connected-mode . :neighbours)))) - - -(defun test-item-based-to-lexical-repair-comprehension () - (defparameter *inventory* (grammar (first (agents (set-up-cxn-inventory-and-repairs))))) - - - ;; enable learning - (enable-learning *inventory*) - - (comprehend "The gray object is what shape?" - :cxn-inventory *inventory* +(deftest test-item-based-to-holistic-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "The gray object is what shape?" + :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) (filter ?target-2 ?target-1 ?color-2) (unique ?source-9 ?target-2) @@ -79,38 +13,18 @@ (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 gray) (query ?target-7 ?source-9 ?attribute-2))) - - (comprehend "The large gray object is what shape?" - :cxn-inventory *inventory* + (comprehend "The gray object is what color?" + :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) - (filter ?target-39552 ?target-2 ?size-4) - (unique ?source-10 ?target-39552) - (bind color-category ?color-2 gray) - (filter ?target-1 ?source-1 ?shape-8) - (bind attribute-category ?attribute-2 shape) - (bind shape-category ?shape-8 thing) (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-4 large) - (query ?target-8 ?source-10 ?attribute-2))) - - (comprehend "The small gray object is what shape?" - :cxn-inventory *inventory* - :gold-standard-meaning '((get-context ?source-1) - (filter ?target-107036 ?target-2 ?size-2) - (unique ?source-9 ?target-107036) - (bind attribute-category ?attribute-2 shape) + (unique ?source-9 ?target-2) (bind shape-category ?shape-8 thing) + (bind attribute-category ?attribute-2 color) (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 gray) - (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-2 small) (query ?target-7 ?source-9 ?attribute-2))) - - ;; disable learning - (disable-learning *inventory*) - - (comprehend "The large gray object is what shape?" - :cxn-inventory *inventory* + (comprehend "The large gray object is what shape?" + :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) (filter ?target-39552 ?target-2 ?size-4) (unique ?source-10 ?target-39552) @@ -121,126 +35,33 @@ (filter ?target-2 ?target-1 ?color-2) (bind size-category ?size-4 large) (query ?target-8 ?source-10 ?attribute-2))) - - - - (comprehend "The gray object is what shape?" - :cxn-inventory *inventory* - :gold-standard-meaning '((get-context ?source-1) - (filter ?target-2 ?target-1 ?color-2) - (unique ?source-9 ?target-2) - (bind shape-category ?shape-8 thing) - (bind attribute-category ?attribute-2 shape) - (filter ?target-1 ?source-1 ?shape-8) - (bind color-category ?color-2 gray) - (query ?target-7 ?source-9 ?attribute-2))) - - (comprehend "The small gray object is what shape?" - :cxn-inventory *inventory* + (comprehend "The large gray object has what color?" + :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) (filter ?target-107036 ?target-2 ?size-2) (unique ?source-9 ?target-107036) - (bind attribute-category ?attribute-2 shape) + (bind attribute-category ?attribute-2 color) (bind shape-category ?shape-8 thing) (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 gray) (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-2 small) - (query ?target-7 ?source-9 ?attribute-2)))) - -(defun test-item-based-to-lexical-repair-production () - (defparameter *inventory* (grammar (first (agents (set-up-cxn-inventory-and-repairs))))) - - - ;; enable learning - (enable-learning *inventory*) - - - (comprehend "The large gray object is what shape?" - :cxn-inventory *inventory* - :gold-standard-meaning '((get-context ?source-1) - (filter ?target-39552 ?target-2 ?size-4) - (unique ?source-10 ?target-39552) - (bind color-category ?color-2 gray) - (filter ?target-1 ?source-1 ?shape-8) - (bind attribute-category ?attribute-2 shape) - (bind shape-category ?shape-8 thing) - (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-4 large) - (query ?target-8 ?source-10 ?attribute-2))) - - (comprehend "The gray object is what shape?" - :cxn-inventory *inventory* - :gold-standard-meaning '((get-context ?source-1) - (filter ?target-2 ?target-1 ?color-2) - (unique ?source-9 ?target-2) - (bind shape-category ?shape-8 thing) - (bind attribute-category ?attribute-2 shape) - (filter ?target-1 ?source-1 ?shape-8) - (bind color-category ?color-2 gray) + (bind size-category ?size-2 large) (query ?target-7 ?source-9 ?attribute-2))) - - (comprehend "The small gray object is what shape?" - :cxn-inventory *inventory* + (test-repair-status 'item-based->holistic + (second (multiple-value-list + (comprehend "The shiny gray object has what color?" + :cxn-inventory cxn-inventory :gold-standard-meaning '((get-context ?source-1) (filter ?target-107036 ?target-2 ?size-2) (unique ?source-9 ?target-107036) - (bind attribute-category ?attribute-2 shape) + (bind attribute-category ?attribute-2 color) (bind shape-category ?shape-8 thing) (filter ?target-1 ?source-1 ?shape-8) (bind color-category ?color-2 gray) (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-2 small) - (query ?target-7 ?source-9 ?attribute-2))) - - ;; disable learning - (disable-learning *inventory*) - - - (formulate '((get-context ?source-1) - (filter ?target-2 ?target-1 ?color-2) - (unique ?source-9 ?target-2) - (bind shape-category ?shape-8 thing) - (bind attribute-category ?attribute-2 shape) - (filter ?target-1 ?source-1 ?shape-8) - (bind color-category ?color-2 gray) - (query ?target-7 ?source-9 ?attribute-2)) - :cxn-inventory *inventory* - :gold-standard-utterance "the gray object is what shape") - - (formulate '((get-context ?source-1) - (filter ?target-39552 ?target-2 ?size-4) - (unique ?source-10 ?target-39552) - (bind color-category ?color-2 gray) - (filter ?target-1 ?source-1 ?shape-8) - (bind attribute-category ?attribute-2 shape) - (bind shape-category ?shape-8 thing) - (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-4 large) - (query ?target-8 ?source-10 ?attribute-2)) - :cxn-inventory *inventory* - :gold-standard-utterance "the large gray object is what shape") - - (formulate '((get-context ?source-1) - (filter ?target-107036 ?target-2 ?size-2) - (unique ?source-9 ?target-107036) - (bind attribute-category ?attribute-2 shape) - (bind shape-category ?shape-8 thing) - (filter ?target-1 ?source-1 ?shape-8) - (bind color-category ?color-2 gray) - (filter ?target-2 ?target-1 ?color-2) - (bind size-category ?size-2 small) - (query ?target-7 ?source-9 ?attribute-2)) - :cxn-inventory *inventory* - :gold-standard-utterance "the small gray object is what shape")) - - -(defun run-tests () - (test-item-based-to-lexical-repair-comprehension) - (test-item-based-to-lexical-repair-production) - ) - - - -;(run-tests) + (bind material-category ?size-2 metal) + (query ?target-7 ?source-9 ?attribute-2)))))) + (test-equal 7 (length (constructions cxn-inventory))))) +; (activate-monitor trace-fcg) +; (test-item-based-to-holistic-comprehension) \ No newline at end of file -- GitLab From 3025288332e493d8d5ad78277de7cc8630279e7f Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Thu, 24 Mar 2022 15:17:47 +0100 Subject: [PATCH 038/157] updated development cxns --- .../basic-holistic-chunking.lisp | 49 +++++-------------- 1 file changed, 12 insertions(+), 37 deletions(-) diff --git a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp index ee62e63d9..52d687e7b 100644 --- a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp +++ b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp @@ -14,60 +14,38 @@ (dependents sequence)) :hierarchy-features (constituents dependents)) - - -(def-fcg-cxn large-gray-cxn - ((?large-gray-unit - (args (?size-4 ?color-2)) - (syn-cat (phrase-type holistic) - (lex-class large-gray)) - (boundaries - (left ?large-unit) - (right ?gray-unit)) - ) - <- - (?large-gray-unit - (HASH meaning ((bind size-category ?size-4 large) - (bind color-category ?color-2 gray))) - -- - (HASH form ((string ?large-unit "large") - (string ?gray-unit "gray") - (meets ?large-unit ?gray-unit)))))) - -(comprehend "large gray") - - (def-fcg-cxn tiny-yellow-cxn ((?tiny-yellow-unit - (args (?size-4 ?color-2)) + (args (?target-1 ?target-39552)) (syn-cat (phrase-type holistic) - (lex-class large-gray)) + (lex-class categorial-network-lookup)) (boundaries (left ?tiny-unit) (right ?yellow-unit)) ) <- (?tiny-yellow-unit - (HASH meaning ((bind size-category ?size-4 tiny) + (HASH meaning ((filter ?target-39552 ?target-2 ?size-4) + (bind size-category ?size-4 tiny) + (filter ?target-2 ?target-1 ?color-2) (bind color-category ?color-2 yellow))) -- (HASH form ((string ?tiny-unit "tiny") (string ?yellow-unit "yellow") (meets ?tiny-unit ?yellow-unit)))))) - (def-fcg-cxn yellow-cxn ((?yellow-unit - (args (?size-4 ?color-2)) + (args (?target-1 ?target-39552)) (syn-cat (phrase-type holistic) - (lex-class large-gray)) + (lex-class categorial-network-lookup)) (boundaries (left ?yellow-unit) (right ?yellow-unit)) ) <- (?tiny-yellow-unit - (HASH meaning ((bind size-category ?size-4 tiny) + (HASH meaning ((filter ?target-39552 ?target-1 ?color-2) (bind color-category ?color-2 yellow))) -- (HASH form ( @@ -80,17 +58,15 @@ (syn-cat (phrase-type item-based)) (subunits (?large-gray-unit))) (?large-gray-unit - (syn-cat (lex-class large-gray))) + (syn-cat (lex-class categorial-network-lookup))) <- (?item-based-unit (HASH meaning ((query ?target-8 ?source-10 ?attribute-2) - (filter ?target-2 ?target-1 ?color-2) (bind shape-category ?shape-8 thing) (bind attribute-category ?attribute-2 shape) (filter ?target-1 ?source-1 ?shape-8) (unique ?source-10 ?target-39552) - (filter ?target-39552 ?target-2 ?size-4) (get-context ?source-1))) -- (HASH form ((string ?the-66 "The") @@ -104,13 +80,12 @@ (meets ?is-66 ?what-66) (meets ?what-66 ?shape?-66)))) (?large-gray-unit - (args (?size-4 ?color-2)) + (args (?target-1 ?target-39552)) -- (boundaries (left ?large-unit) (right ?gray-unit))))) -(comprehend-and-formulate "The yellow object is what shape?") -(comprehend-and-formulate "The tiny yellow object is what shape?") -(comprehend-and-formulate "The large gray object is what shape?") +;(comprehend-and-formulate "The yellow object is what shape?") +;(comprehend-and-formulate "The tiny yellow object is what shape?") -- GitLab From 9765821d600bcb905f4b0b47205be64b5a9de7cd Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Thu, 24 Mar 2022 16:28:23 +0100 Subject: [PATCH 039/157] working ditransitive arg and info cxns in production --- .../bidirectional_grammar_info_arg_struct.fcg | 197 +++++++++++------- 1 file changed, 117 insertions(+), 80 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 53b000ecc..7535c7baf 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -336,8 +336,6 @@ (footprints (determined))) <- (?article - - -- (syn-cat (lex-class article) (case ?case))) @@ -346,7 +344,6 @@ (referent ?x) (syn-cat (lex-class noun) (case ?case)) - -- (footprints (not determined)) (syn-cat (lex-class noun) @@ -387,12 +384,13 @@ (syn-cat (lex-class noun) (case ?case))) (?contracted-prep-phrase + (HASH meaning ((contracted-preposition ?contracted-prep +))) -- (HASH form ((meets ?contracted-prep ?noun))) )) :disable-automatic-footprints t) -;(comprehend "zum Mann") +(comprehend "zum Mann") ;(formulate-all '((bike x))) @@ -705,12 +703,20 @@ (referent ?arg1) ) (?receiver-unit - (syn-cat - (case ?case)) + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ds ?dm ?df ?dn ?dp)))) (referent ?arg2) -- - (syn-cat - (case ?case)) + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ds ?dm ?df ?dn ?dp)))) (referent ?arg2)) (?ditransitive-argument-structure-unit @@ -720,96 +726,63 @@ -- ))) - - -;;;this cxn contains boundaries for formulation (?) -#|(def-fcg-cxn ditransitive-argument-structure-cxn - ((?ditransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) - (?agent-unit - (syn-cat (syn-role subject))) - (?patient-unit - (syn-cat (syn-role direct-object))) - (?receiver-unit - (syn-cat (syn-role indirect-object))) +(def-fcg-cxn ditransitive-information-structure-cxn + ((?ditransitive-information-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?arg-and-info-struct-unit + (constituents (?ditransitive-information-structure-unit ?argument-structure-unit))) <- + + (?argument-structure-unit + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + -- + (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?verb-unit (syn-cat (lex-class verb) - (type ditransitive)) - (referent ?v) + (type ditransitive)) + -- (syn-cat (lex-class verb) - (type ditransitive)) - (referent ?v)) + (type ditransitive))) (?agent-unit - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) - (referent ?arg0) -- - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) - (rightmost-unit ?rightmost-agent-unit)) - (referent ?arg0)) + (rightmost-unit ?rightmost-agent-unit))) (?patient-unit - (syn-cat (lex-class noun-phrase) - (case ((- - - - -) - (+ ?am ?af ?an ?ap) - (- - - - -) - (- - - - -) - (?ps ?am ?af ?an ?ap)))) + (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit)) - (referent ?arg1) -- - (syn-cat (lex-class noun-phrase) - (case ((- - - - -) - (+ ?am ?af ?an ?ap) - (- - - - -) - (- - - - -) - (?ps ?am ?af ?an ?ap)))) + + (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) - (rightmost-unit ?rightmost-patient-unit)) - (referent ?arg1) - ) + (rightmost-unit ?rightmost-patient-unit))) + (?receiver-unit - (syn-cat - (case ?case)) + (syn-cat (syn-role indirect-object)) (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit)) - (referent ?arg2) -- - (syn-cat - (case ?case)) - (boundaries (leftmost-unit ?leftmost-receiver-unit) - (rightmost-unit ?rightmost-receiver-unit)) - (referent ?arg2)) - (?ditransitive-argument-structure-unit - (HASH meaning ((:arg0 ?v ?arg0) - (:arg1 ?v ?arg1) - (:arg2 ?v ?arg2))) + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit))) + + (?ditransitive-information-structure-unit -- (HASH form ((meets ?rightmost-agent-unit ?verb-unit) (meets ?verb-unit ?leftmost-receiver-unit) (meets ?rightmost-receiver-unit ?leftmost-patient-unit))) - )))|# - - + + ))) -;;; this cxn does not work if I add boundaries in the previous one for formulation (def-fcg-cxn topicalized-ditransitive-information-structure-cxn @@ -856,17 +829,20 @@ (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit)) (referent ?arg2) - (HASH meaning ((topicalized ?arg2))) -- - (HASH form ((meets ?rightmost-receiver-unit ?verb-unit) - (meets ?verb-unit ?leftmost-agent-unit) - (meets ?rightmost-agent-unit ?leftmost-patient-unit))) (referent ?arg2) (syn-cat (syn-role indirect-object)) (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit))) + + (?topicalized-ditransitive-information-structure-unit + (HASH meaning ((topicalized ?arg2 +))) + -- + (HASH form ((meets ?rightmost-receiver-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit) + (meets ?rightmost-agent-unit ?leftmost-patient-unit))) - )) + ))) @@ -1277,21 +1253,82 @@ + + + +;;;;;;;;VERBS' ARGUMENTS + +;DITRANSITIVES (DIRECT ACC. AND INDIRECT OBJECT DATIVE) +;;;geben (arg0 giver - arg1 thing given - arg2 entity or person given to) +;Die Frau gibt dem Mann den Apfel. + +;;;;schenken (arg0 giver- arg1 thing given- arg2 entity or person given to) +;Die Lehrerin schenkt dem Direktor die Blumen. + +;;;;zeigen (arg0 shower- arg1 thing seen or shown - arg2 seer) +;Der Vater zeigt dem Sohn die Brille. + + +;;;;verkaufen (arg0 seller- arg1 thing sold- arg2 buyer - arg3 price payed - arg4 benefactive) +;Der Doktor verkauft dem Clown das Buch. + + + + +;TRANSITIVES +;;;;verfolgen (arg0 follower- arg1 thing followed) +;Der Hund verfolgt den Mann. + +;;;;töten (arg0 killer - arg1 corpse - arg2 instrument) +;Der Tiger tötet den Jäger. + +;;;;suchen (arg0 looker - arg1 thing looked for - arg2 attribute/complement of arg1) +;Der Polizist sucht den Bäcker. + + +;;;;rufen (arg0 caller - arg1 entity summoned/person called - arg2 benefactive/complement) +;Der König ruft der Kellner. + + + + + +;;;;fahren (arg0 driver- arg1 vehicle or path) +;Der Mann fährt mit dem Fahrrad zur Arbeit. +;Der Mann ist gegen den Baum gefahren. + +;;;;gehen (arg0 goer - arg1 journey - arg3 start point - arg4 end point) +;Der Junge geht zum Arzt. +;Die Mutter geht ohne den Sohn zum Laden. + + +;;;;mitbringen (arg0 bringen - arg1 thing brought - arg2 benefactive or destination - arg3 attribute - arg4 brought from) +;Die Königin hat für den König Blume mitgebracht. + + + + ;;; NPs with Determiners and PPs with NP+P or Contracted P -;(formulate-all '((baker x))) +(formulate-all '((work x))) ;;;; der Mann sucht den Clown -;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) +(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) ;;; den Clown sucht der Mann -;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) +(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) + +;;; der Mann schenkt dem Clown die Blumen +(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c))) + +;;; der Mann schenkt dem Clown die Blumen +(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) ;;; der Mann kommt aus dem Shop ;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg1 k s))) ;;; aus dem Shop kommt der Mann -;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg1 k s) (topicalized s +))) +;(formulate-all '((kommen-01 k) (man m) (arg1 k m) (shop s) (arg3 k s) (topicalized s +))) ;;;der Mann schenkt dem Clown die Blumen -- GitLab From b4923cd31d8fc9dae3fc92506931ec1db9f39656 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Thu, 24 Mar 2022 17:55:26 +0100 Subject: [PATCH 040/157] adding goal tests to template grammar --- .../development-grammars/basic-holistic-chunking.lisp | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp index 52d687e7b..0410fc0d6 100644 --- a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp +++ b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp @@ -12,6 +12,10 @@ (de-render-mode de-render-string-meets) (constituents sequence) (dependents sequence)) + :fcg-configurations ((:parse-goal-tests + :no-strings-in-root :connected-semantic-network ) + (:production-goal-tests + :no-meaning-in-root )) :hierarchy-features (constituents dependents)) (def-fcg-cxn tiny-yellow-cxn @@ -34,6 +38,7 @@ (string ?yellow-unit "yellow") (meets ?tiny-unit ?yellow-unit)))))) + (def-fcg-cxn yellow-cxn ((?yellow-unit (args (?target-1 ?target-39552)) @@ -52,7 +57,6 @@ (string ?yellow-unit "yellow") ))))) - (def-fcg-cxn the-x-object-is-what-shape-cxn ((?item-based-unit (syn-cat (phrase-type item-based)) @@ -86,6 +90,5 @@ (left ?large-unit) (right ?gray-unit))))) - ;(comprehend-and-formulate "The yellow object is what shape?") ;(comprehend-and-formulate "The tiny yellow object is what shape?") -- GitLab From 156e3d954ba30ae4674317f63ecf851fdc029389 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Thu, 24 Mar 2022 17:56:12 +0100 Subject: [PATCH 041/157] renaming template grammar --- .../{basic-holistic-chunking.lisp => template-grammar.lisp} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename systems/grammar-learning/development-grammars/{basic-holistic-chunking.lisp => template-grammar.lisp} (100%) diff --git a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp b/systems/grammar-learning/development-grammars/template-grammar.lisp similarity index 100% rename from systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp rename to systems/grammar-learning/development-grammars/template-grammar.lisp -- GitLab From 246c46dc2575eba2f17bdb402650e5aacb222e8b Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Thu, 24 Mar 2022 18:06:07 +0100 Subject: [PATCH 042/157] updated template grammar, can now apply item-based cxn first --- .../development-grammars/template-grammar.lisp | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/systems/grammar-learning/development-grammars/template-grammar.lisp b/systems/grammar-learning/development-grammars/template-grammar.lisp index 0410fc0d6..f3b7c6343 100644 --- a/systems/grammar-learning/development-grammars/template-grammar.lisp +++ b/systems/grammar-learning/development-grammars/template-grammar.lisp @@ -62,7 +62,10 @@ (syn-cat (phrase-type item-based)) (subunits (?large-gray-unit))) (?large-gray-unit - (syn-cat (lex-class categorial-network-lookup))) + (syn-cat (lex-class categorial-network-lookup)) + (boundaries + (left ?large-unit) + (right ?gray-unit))) <- (?item-based-unit @@ -86,9 +89,7 @@ (?large-gray-unit (args (?target-1 ?target-39552)) -- - (boundaries - (left ?large-unit) - (right ?gray-unit))))) - + ))) +;(comprehend "The yellow object is what shape?") ;(comprehend-and-formulate "The yellow object is what shape?") ;(comprehend-and-formulate "The tiny yellow object is what shape?") -- GitLab From 9b75a47b20c380ffc561d583d1f337c9cd360224 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Thu, 24 Mar 2022 21:43:24 +0100 Subject: [PATCH 043/157] fixing unit name in template cxn --- .../development-grammars/template-grammar.lisp | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/systems/grammar-learning/development-grammars/template-grammar.lisp b/systems/grammar-learning/development-grammars/template-grammar.lisp index f3b7c6343..3f228c08a 100644 --- a/systems/grammar-learning/development-grammars/template-grammar.lisp +++ b/systems/grammar-learning/development-grammars/template-grammar.lisp @@ -25,8 +25,7 @@ (lex-class categorial-network-lookup)) (boundaries (left ?tiny-unit) - (right ?yellow-unit)) - ) + (right ?yellow-unit))) <- (?tiny-yellow-unit (HASH meaning ((filter ?target-39552 ?target-2 ?size-4) @@ -46,16 +45,16 @@ (lex-class categorial-network-lookup)) (boundaries (left ?yellow-unit) - (right ?yellow-unit)) - ) + (right ?yellow-unit))) + <- - (?tiny-yellow-unit + (?yellow-unit (HASH meaning ((filter ?target-39552 ?target-1 ?color-2) (bind color-category ?color-2 yellow))) -- - (HASH form ( - (string ?yellow-unit "yellow") - ))))) + (HASH form ((string ?yellow-unit "yellow")))) + )) + (def-fcg-cxn the-x-object-is-what-shape-cxn ((?item-based-unit @@ -66,7 +65,6 @@ (boundaries (left ?large-unit) (right ?gray-unit))) - <- (?item-based-unit (HASH meaning ((query ?target-8 ?source-10 ?attribute-2) @@ -90,6 +88,6 @@ (args (?target-1 ?target-39552)) -- ))) -;(comprehend "The yellow object is what shape?") +;(comprehend-all "The yellow object is what shape?") ;(comprehend-and-formulate "The yellow object is what shape?") ;(comprehend-and-formulate "The tiny yellow object is what shape?") -- GitLab From cf45fc4b2f04755e3df8d78369d1fdab9c1758f7 Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 24 Mar 2022 23:00:00 +0100 Subject: [PATCH 044/157] refactoring of mwm-evaluation --- .../clevr/mwm-evaluation/evaluation.lisp | 211 ++++++++++-------- .../clevr/mwm-evaluation/mwm-evaluation.asd | 6 +- .../clevr/mwm-evaluation/mwm-ontology.lisp | 76 ++++--- .../clevr/mwm-evaluation/mwm-utils.lisp | 14 +- .../clevr/mwm-evaluation/package.lisp | 2 +- .../mwm-evaluation/primitives/filter.lisp | 46 ++-- .../primitives/primitive-inventory.lisp | 2 +- .../mwm-evaluation/primitives/query.lisp | 15 +- .../mwm-evaluation/primitives/relate.lisp | 4 +- .../clevr/mwm-evaluation/primitives/same.lisp | 18 +- applications/clevr/mwm-evaluation/start.lisp | 29 ++- 11 files changed, 241 insertions(+), 182 deletions(-) diff --git a/applications/clevr/mwm-evaluation/evaluation.lisp b/applications/clevr/mwm-evaluation/evaluation.lisp index 14fc9fa43..ede7eb8c9 100644 --- a/applications/clevr/mwm-evaluation/evaluation.lisp +++ b/applications/clevr/mwm-evaluation/evaluation.lisp @@ -27,132 +27,139 @@ ;; Compute the answer for an irl-program -(defun compute-answer (irl-program scene-var scene-path-entity) +(defun compute-answer (irl-program scene-var scene-path-entity ontology) "Given an irl-program, a variable and a scene path, compute the answer." (let ((solutions (evaluate-irl-program - (cons `(bind pathname-entity ,scene-var ,scene-path-entity)(substitute-categories irl-program)) - *my-ontology* :primitive-inventory *mwm-primitives*))) + (cons `(bind pathname-entity ,scene-var ,scene-path-entity) + (substitute-categories irl-program)) + ontology + :primitive-inventory *mwm-primitives*))) (when (and solutions (length= solutions 1)) (let* ((target-var (get-target-var irl-program)) (target-value (value (find target-var (first solutions) :key #'var)))) (answer->str target-value))))) + ;; Frequencies of a primitive occurring in a question and frequencies of errors per primitive are added to a hash-table (defun adjust-primitive-errors (irl-program hash-table) (let ((unique-predicates (remove-duplicates (mapcar #'first irl-program)))) (loop for predicate in unique-predicates - do - (case predicate - ('count! (incf (car (gethash 'count! hash-table)))) - ('equal? (incf (car (gethash 'equal? hash-table)))) - ('equal-integer (incf (car (gethash 'equal-integer hash-table)))) - ('less-than (incf (car (gethash 'less-than hash-table)))) - ('greater-than (incf (car (gethash 'greater-than hash-table)))) - ('exist (incf (car (gethash 'exist hash-table)))) - ('filter (incf (car (gethash 'filter hash-table)))) - ('intersect (incf (car (gethash 'intersect hash-table)))) - ('query (incf (car (gethash 'query hash-table)))) - ('relate (incf (car (gethash 'relate hash-table)))) - ('same (incf (car (gethash 'same hash-table)))) - ('union! (incf (car (gethash 'union! hash-table)))) - ('unique (incf (car (gethash 'unique hash-table)))))))) + do (case predicate + (count! (incf (car (gethash 'count! hash-table)))) + (equal? (incf (car (gethash 'equal? hash-table)))) + (equal-integer (incf (car (gethash 'equal-integer hash-table)))) + (less-than (incf (car (gethash 'less-than hash-table)))) + (greater-than (incf (car (gethash 'greater-than hash-table)))) + (exist (incf (car (gethash 'exist hash-table)))) + (filter (incf (car (gethash 'filter hash-table)))) + (intersect (incf (car (gethash 'intersect hash-table)))) + (query (incf (car (gethash 'query hash-table)))) + (relate (incf (car (gethash 'relate hash-table)))) + (same (incf (car (gethash 'same hash-table)))) + (union! (incf (car (gethash 'union! hash-table)))) + (unique (incf (car (gethash 'unique hash-table)))))))) (defun adjust-primitive-frequencies (irl-program hash-table) (let ((unique-predicates (remove-duplicates (mapcar #'first irl-program)))) (loop for predicate in unique-predicates - do - (case predicate - ('count! (incf (cdr (gethash 'count! hash-table)))) - ('equal? (incf (cdr (gethash 'equal? hash-table)))) - ('equal-integer (incf (cdr (gethash 'equal-integer hash-table)))) - ('less-than (incf (cdr (gethash 'less-than hash-table)))) - ('greater-than (incf (cdr (gethash 'greater-than hash-table)))) - ('exist (incf (cdr (gethash 'exist hash-table)))) - ('filter (incf (cdr (gethash 'filter hash-table)))) - ('intersect (incf (cdr (gethash 'intersect hash-table)))) - ('query (incf (cdr (gethash 'query hash-table)))) - ('relate (incf (cdr (gethash 'relate hash-table)))) - ('same (incf (cdr (gethash 'same hash-table)))) - ('union! (incf (cdr (gethash 'union! hash-table)))) - ('unique (incf (cdr (gethash 'unique hash-table)))))))) + do (case predicate + (count! (incf (cdr (gethash 'count! hash-table)))) + (equal? (incf (cdr (gethash 'equal? hash-table)))) + (equal-integer (incf (cdr (gethash 'equal-integer hash-table)))) + (less-than (incf (cdr (gethash 'less-than hash-table)))) + (greater-than (incf (cdr (gethash 'greater-than hash-table)))) + (exist (incf (cdr (gethash 'exist hash-table)))) + (filter (incf (cdr (gethash 'filter hash-table)))) + (intersect (incf (cdr (gethash 'intersect hash-table)))) + (query (incf (cdr (gethash 'query hash-table)))) + (relate (incf (cdr (gethash 'relate hash-table)))) + (same (incf (cdr (gethash 'same hash-table)))) + (union! (incf (cdr (gethash 'union! hash-table)))) + (unique (incf (cdr (gethash 'unique hash-table)))))))) + ;; Error rate is computed by dividing number of errors per primitive by the number of questions that contain the primitive (defun compute-error-rate (hash-table errors-filename) - (let ((logfile (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name errors-filename :type "txt"))) + (let ((logfile + (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name errors-filename :type "txt"))) (ensure-directories-exist logfile) - (with-open-file (stream logfile - :direction :output - :if-does-not-exist :create - :if-exists :overwrite) + (with-open-file (stream logfile + :direction :output + :if-does-not-exist :create + :if-exists :overwrite) (loop for key being the hash-keys of hash-table - if (not (eql 0 (cdr (gethash key hash-table)))) + if (not (= 0 (cdr (gethash key hash-table)))) do (progn (write-line - (format nil "The error rate for ~a is ~,2f" key (/ (car (gethash key hash-table)) (cdr (gethash key hash-table)))) stream) - (force-output stream)) - else do (progn + (format nil "The error rate for ~a is ~,2f" + key (/ (car (gethash key hash-table)) + (cdr (gethash key hash-table)))) + stream) + (force-output stream)) + else + do (progn (write-line - (format nil "The error rate for ~a is ~,2f" key 0 ) stream) - (force-output stream)))))) + (format nil "The error rate for ~a is ~,2f" key 0) stream) + (force-output stream)))))) (defun get-result (cipn answer computed-answer) (if (and (find 'fcg::succeeded (fcg::statuses cipn)) - (string= (upcase answer) - (upcase computed-answer))) - 1 - 0)) + (string= (upcase answer) + (upcase computed-answer))) + 1 0)) (defun write-result (log scene-name q answer computed-answer result irl-program hash-table) - (if (eql result 1) + (if (= result 1) (progn (adjust-primitive-frequencies irl-program hash-table) - (write-line (format nil "~a,~a,~a,~a,~a" scene-name q answer computed-answer result) log) - (force-output log)) + (write-line (format nil "~a,~a,~a,~a,~a" scene-name q answer computed-answer result) log) + (force-output log)) (progn (adjust-primitive-frequencies irl-program hash-table) - (write-line (format nil "~a,~a,~a,~a,~a" scene-name q answer computed-answer result) log) - (force-output log) - (adjust-primitive-errors irl-program hash-table)))) + (write-line (format nil "~a,~a,~a,~a,~a" scene-name q answer computed-answer result) log) + (force-output log) + (adjust-primitive-errors irl-program hash-table)))) ;; Compute the accuracy on a specified number of scenes or questions -(defun compute-accuracy (log clevr-world nr-of-scenes nr-of-questions hash-table) - (average - (remove nil - (loop with processed-questions = 0 - with processed-scenes = 0 - for scene-path in (scenes clevr-world) - for question-path in (question-sets clevr-world) - for set-of-questions = (load-clevr-question-set question-path) - for path-entity = (make-instance 'pathname-entity :pathname scene-path) - for scene-name = (pathname-name scene-path) - if (and nr-of-scenes (>= processed-scenes nr-of-scenes)) +(defun compute-accuracy (log clevr-world ontology hash-table + &key nr-of-scenes nr-of-questions) + (average + (remove nil + (loop with processed-questions = 0 + with processed-scenes = 0 + for scene-path in (scenes clevr-world) + for question-path in (question-sets clevr-world) + for set-of-questions = (load-clevr-question-set question-path) + for path-entity = (make-instance 'pathname-entity :pathname scene-path) + for scene-name = (pathname-name scene-path) + if (and nr-of-scenes (>= processed-scenes nr-of-scenes)) return accuracy - else + else append (loop for clevr-question in (questions set-of-questions) for q = (question clevr-question) for answer = (answer clevr-question) for (irl-program cipn nil) - = (multiple-value-list - (clevr-grammar::understand q)) + = (multiple-value-list + (clevr-grammar::understand q)) for scene-var = (extract-scene-unit-variable cipn) - for computed-answer = (compute-answer irl-program scene-var path-entity) + for computed-answer = (compute-answer irl-program scene-var path-entity ontology) for result = (get-result cipn answer computed-answer) do (incf processed-questions) - (format t ".") + (format t ".") if (and nr-of-questions (>= processed-questions nr-of-questions)) - return scene-accuracy - else if (eql result 1) - collect 1 into scene-accuracy - and do (write-result log scene-name q answer computed-answer result irl-program hash-table) - else collect 0 into scene-accuracy - and do (write-result log scene-name q answer computed-answer result irl-program hash-table) - finally return scene-accuracy) - into accuracy - do (incf processed-scenes) - finally (return accuracy))))) + return scene-accuracy + else if (= result 1) + collect 1 into scene-accuracy + and do (write-result log scene-name q answer computed-answer result irl-program hash-table) + else collect 0 into scene-accuracy + and do (write-result log scene-name q answer computed-answer result irl-program hash-table) + finally (return scene-accuracy)) + into accuracy + do (incf processed-scenes) + finally (return accuracy))))) ;; make an empty error-table (defun make-error-table () @@ -174,27 +181,37 @@ -(defgeneric evaluate-mwm-accuracy (data-split csv-filename errors-filename &key nr-of-scenes nr-of-questions) +(defgeneric evaluate-mwm-accuracy (ontology &key data-split csv-filename errors-filename + nr-of-scenes nr-of-questions) (:documentation "Evaluate the accuracy of the mwm-concepts.")) -(defmethod evaluate-mwm-accuracy (data-split csv-filename errors-filename &key nr-of-scenes nr-of-questions) - (let ((clevr-world (make-instance 'clevr-world - :data-sets (list data-split) - :load-questions t)) +(defmethod evaluate-mwm-accuracy (ontology + &key (data-split "val") + (csv-filename "mwm-evaluation") + (errors-filename "mwm-errors") + nr-of-scenes nr-of-questions) + (let ((clevr-world + (make-instance 'clevr-world + :data-sets (list data-split) + :load-questions t)) (accuracy 0) (error-table (make-error-table)) - (logfile (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name csv-filename :type "txt"))) - + (logfile + (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name csv-filename :type "txt"))) (ensure-directories-exist logfile) (with-open-file (log logfile :direction :output :if-does-not-exist :create :if-exists :overwrite) - (setf accuracy (compute-accuracy log clevr-world nr-of-scenes nr-of-questions error-table))) + (setf accuracy (compute-accuracy log clevr-world ontology error-table + :nr-of-scenes nr-of-scenes + :nr-of-questions nr-of-questions))) (compute-error-rate error-table errors-filename) accuracy)) + + (defun evaluate-mwm-serie (serie-number) (let* ((serie-name (format nil "serie-~a" serie-number)) (directory (list "experiments""multidimensional-word-meanings" "learned-concepts" @@ -206,6 +223,14 @@ (defun evaluate-all-series () - (loop for serie in '("serie-1" "serie-2" "serie-3" "serie-3" "serie-4" "serie-5" "serie-6" "serie-7" "serie-8" "serie-9" "serie-10") - do (make-mwm-ontology (babel-pathname :directory (list "experiments""multidimensional-word-meanings" "learned-concepts" "thesis-main-results" "baseline-simulated-default-lexicon" serie))) - (evaluate-mwm-accuracy "val" (concatenate 'string serie "-evaluation") (concatenate 'string serie "-errors")))) \ No newline at end of file + (loop for serie-nr from 1 to 10 + for serie = (format nil "serie-~a" serie-nr) + for ontology = (make-mwm-ontology + (babel-pathname :directory (list "experiments""multidimensional-word-meanings" "learned-concepts" + "thesis-main-results" "baseline-simulated-default-lexicon" serie))) + do (evaluate-mwm-accuracy ontology + :csv-filename (concatenate 'string serie "-evaluation") + :errors-filename (concatenate 'string serie "-errors")))) + + + diff --git a/applications/clevr/mwm-evaluation/mwm-evaluation.asd b/applications/clevr/mwm-evaluation/mwm-evaluation.asd index 24cadd140..51c6ae2ab 100644 --- a/applications/clevr/mwm-evaluation/mwm-evaluation.asd +++ b/applications/clevr/mwm-evaluation/mwm-evaluation.asd @@ -16,8 +16,7 @@ :fcg :clevr-world :clevr-grammar - :mwm - ) + :mwm) :serial t :components ((:file "package") (:file "mwm-ontology") @@ -37,5 +36,4 @@ (:file "same") (:file "segment-scene") (:file "union") - (:file "unique"))) - )) \ No newline at end of file + (:file "unique"))))) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/mwm-ontology.lisp b/applications/clevr/mwm-evaluation/mwm-ontology.lisp index 9fbd850ef..26aa80543 100644 --- a/applications/clevr/mwm-evaluation/mwm-ontology.lisp +++ b/applications/clevr/mwm-evaluation/mwm-ontology.lisp @@ -24,41 +24,53 @@ ;;function that restores a concept using cl-store and makes it an instance of the concept-entity class (defun restore-concept (path concept-class) (let ((concept (cl-store:restore path))) - (Make-instance concept-class + (make-instance concept-class :id (pathname->conceptname path) :form (form concept) :meaning (copy-object (meaning concept))))) + ;; Make an ontology (instance of #'blackboard) (defun make-mwm-ontology (concepts-pathname) - (defparameter *my-ontology* (make-blackboard)) - (loop for pathname in (directory concepts-pathname) - do (cond ((member (pathname->conceptname pathname) '(blue brown cyan gray green purple red yellow)) - (push-data *my-ontology* 'colors (restore-concept pathname 'color-concept))) - ((member (pathname->conceptname pathname) '(metal rubber)) - (push-data *my-ontology* 'materials (restore-concept pathname 'material-concept))) - ( (member (pathname->conceptname pathname) '(cube cylinder sphere)) - (push-data *my-ontology* 'shapes (restore-concept pathname 'shape-concept))) - ( (member (pathname->conceptname pathname) '(large small)) - (push-data *my-ontology* 'sizes (restore-concept pathname 'size-concept))) - ( (member (pathname->conceptname pathname) '(left right)) - (push-data *my-ontology* 'spatial-relations (restore-concept pathname 'spatial-concept))) - ((eql (pathname->conceptname pathname) 'front) (push-data *my-ontology* 'spatial-relations (let ((concept (cl-store:restore pathname))) - (Make-instance 'spatial-concept - :id 'behind - :form "behind" - :meaning (copy-object (meaning concept)))))) - ((eql (pathname->conceptname pathname) 'behind) (push-data *my-ontology* 'spatial-relations (let ((concept (cl-store:restore pathname))) - (Make-instance 'spatial-concept - :id 'front - :form "front" - :meaning (copy-object (meaning concept)))))) - )) - (set-data *my-ontology* 'thing (list (make-instance 'shape-concept - :id 'thing - :form "thing" - :meaning nil))) - (push-data *my-ontology* 'booleans (make-instance 'boolean-category :id 'yes :bool t)) - (push-data *my-ontology* 'booleans (make-instance 'boolean-category :id 'no :bool nil)) - (loop for attribute in '(shape size material color) - do (clevr-world::add-category-to-ontology *my-ontology* attribute 'attribute))) + (let ((ontology (make-blackboard))) + (loop for pathname in (directory concepts-pathname) + do (cond ((member (pathname->conceptname pathname) + '(blue brown cyan gray green purple red yellow)) + (push-data ontology 'colors + (restore-concept pathname 'color-concept))) + ((member (pathname->conceptname pathname) '(metal rubber)) + (push-data ontology 'materials + (restore-concept pathname 'material-concept))) + ((member (pathname->conceptname pathname) '(cube cylinder sphere)) + (push-data ontology 'shapes + (restore-concept pathname 'shape-concept))) + ((member (pathname->conceptname pathname) '(large small)) + (push-data ontology 'sizes + (restore-concept pathname 'size-concept))) + ((member (pathname->conceptname pathname) '(left right)) + (push-data ontology 'spatial-relations + (restore-concept pathname 'spatial-concept))) + ((eql (pathname->conceptname pathname) 'front) + (push-data ontology 'spatial-relations + (let ((concept (cl-store:restore pathname))) + (make-instance 'spatial-concept + :id 'behind + :form "behind" + :meaning (copy-object (meaning concept)))))) + ((eql (pathname->conceptname pathname) 'behind) + (push-data ontology 'spatial-relations + (let ((concept (cl-store:restore pathname))) + (make-instance 'spatial-concept + :id 'front + :form "front" + :meaning (copy-object (meaning concept)))))))) + (set-data ontology 'thing + (list (make-instance 'shape-concept + :id 'thing + :form "thing" + :meaning nil))) + (push-data ontology 'booleans (make-instance 'boolean-category :id 'yes :bool t)) + (push-data ontology 'booleans (make-instance 'boolean-category :id 'no :bool nil)) + (loop for attribute in '(shape size material color) + do (clevr-world::add-category-to-ontology ontology attribute 'attribute)) + ontology)) diff --git a/applications/clevr/mwm-evaluation/mwm-utils.lisp b/applications/clevr/mwm-evaluation/mwm-utils.lisp index 0c242bcc5..e5e05cd6f 100644 --- a/applications/clevr/mwm-evaluation/mwm-utils.lisp +++ b/applications/clevr/mwm-evaluation/mwm-utils.lisp @@ -4,15 +4,18 @@ ;; similarity and category matching ;; ;;----------------------------------;; -;; weighted similarity method that can be used to compare the prototypical values of an object and a concept (see: "Babel/experiments/multidimensional-word-meanings/concept.lisp" for the original method) +;; weighted similarity method that can be used to +;; compare the prototypical values of an object +;; and a concept +;; (see: "Babel/experiments/multidimensional-word-meanings/concept.lisp" for the original method) (defmethod weighted-similarity ((object mwm-object) (concept concept-entity)) (loop for prototype in (meaning concept) for similarity = (mwm::similarity object prototype) collect (* (mwm::certainty prototype) similarity) into weighted-similarities finally (return (average weighted-similarities)))) -;; attach category to an object that yields the highest weighted similarity out of a set of categories +;; attach category to an object that yields the highest weighted similarity out of a set of categories (defun find-best-category (object categories) (loop with best-category = nil with best-similarity = nil @@ -23,7 +26,7 @@ do (setf best-category cat best-similarity similarity) finally - return best-category)) + (return best-category))) ;;-----------------------------;; ;; Utils for testing questions ;; @@ -42,9 +45,10 @@ :name "CLEVR_val_000000" :type "json") cl-user:*babel-corpora*)) -(defun test-utterance-in-first-scene (utterance) +(defun test-utterance-in-first-scene (utterance ontology) (multiple-value-bind (irl-program cipn cip) (understand utterance) + (declare (ignorable cip)) (when (find 'fcg::succeeded (fcg::statuses cipn)) (let ((scene-var (extract-scene-unit-variable cipn)) (scene-path (make-instance 'pathname-entity @@ -52,7 +56,7 @@ (evaluate-irl-program (cons `(bind pathname-entity ,scene-var ,scene-path) (substitute-categories irl-program)) - *my-ontology* :primitive-inventory *mwm-primitives*))))) + ontology :primitive-inventory *mwm-primitives*))))) ;;-----------------------------------------------------------------;; ;; substitute category names in bind statements with concept names ;; diff --git a/applications/clevr/mwm-evaluation/package.lisp b/applications/clevr/mwm-evaluation/package.lisp index 08eff9e31..b3613927c 100644 --- a/applications/clevr/mwm-evaluation/package.lisp +++ b/applications/clevr/mwm-evaluation/package.lisp @@ -1,7 +1,7 @@ (in-package :cl-user) (defpackage :mwm-evaluation - (:documentation "Integrating the multi-dimensional concepts in vqa"s) + (:documentation "Integrating the multi-dimensional concepts in vqa") (:use :common-lisp :utils :monitors diff --git a/applications/clevr/mwm-evaluation/primitives/filter.lisp b/applications/clevr/mwm-evaluation/primitives/filter.lisp index 4a1de875c..34edcddd8 100644 --- a/applications/clevr/mwm-evaluation/primitives/filter.lisp +++ b/applications/clevr/mwm-evaluation/primitives/filter.lisp @@ -9,11 +9,12 @@ ;(export '(filter)) -(defgeneric filter-by-category (set category) +(defgeneric filter-by-category (set category ontology) (:documentation "Filter the set by the given category.")) (defmethod filter-by-category ((set mwm::mwm-object-set) - (shape-category shape-concept)) + (shape-category shape-concept) + (ontology blackboard)) "Filter the set by the given shape category. If the shape is 'thing', return the entire set." (if (eq (id shape-category) 'thing) @@ -21,38 +22,41 @@ (let ((filtered-objects (loop for object in (objects set) if (equal-entity shape-category - (find-best-category object (get-data *my-ontology* 'shapes))) + (find-best-category object (get-data ontology 'shapes))) collect object))) (when filtered-objects (make-instance 'mwm::mwm-object-set :objects filtered-objects))))) (defmethod filter-by-category ((set mwm::mwm-object-set) - (size-category size-concept)) + (size-category size-concept) + (ontology blackboard)) "Filter the set by the given size category." (let ((filtered-objects (loop for object in (objects set) if (equal-entity size-category - (find-best-category object (get-data *my-ontology* 'sizes))) + (find-best-category object (get-data ontology 'sizes))) collect object))) (when filtered-objects (make-instance 'mwm::mwm-object-set :objects filtered-objects)))) (defmethod filter-by-category ((set mwm::mwm-object-set) - (color-category color-concept)) + (color-category color-concept) + (ontology blackboard)) "Filter the set by the given color category." (let ((filtered-objects (loop for object in (objects set) if (equal-entity color-category - (find-best-category object (get-data *my-ontology* 'colors))) + (find-best-category object (get-data ontology 'colors))) collect object))) (when filtered-objects (make-instance 'mwm::mwm-object-set :objects filtered-objects)))) (defmethod filter-by-category ((set mwm::mwm-object-set) - (material-category material-concept)) + (material-category material-concept) + (ontology blackboard)) "Filter the set by the given material category." (let ((filtered-objects (loop for object in (objects set) if (equal-entity material-category - (find-best-category object (get-data *my-ontology* 'materials))) + (find-best-category object (get-data ontology 'materials))) collect object))) (when filtered-objects (make-instance 'mwm::mwm-object-set :objects filtered-objects)))) @@ -65,7 +69,7 @@ (category concept-entity)) ;; first case: if given source-set and category, compute target-set ((scene source-set category => target-set) - (let ((computed-set (filter-by-category source-set category))) + (let ((computed-set (filter-by-category source-set category ontology))) (if computed-set (bind (target-set 1.0 computed-set)) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) @@ -75,24 +79,24 @@ (let ((computed-category (find-if #'(lambda (cat) (equal-entity target-set - (filter-by-category source-set cat))) + (filter-by-category source-set cat ontology))) (append - (get-data *my-ontology* 'shapes) - (get-data *my-ontology* 'sizes) - (get-data *my-ontology* 'colors) - (get-data *my-ontology* 'materials))))) + (get-data ontology 'shapes) + (get-data ontology 'sizes) + (get-data ontology 'colors) + (get-data ontology 'materials))))) (when computed-category (bind (category 1.0 computed-category))))) ;; third case: if given source-set, compute pairs of target-set and category ((scene source-set => target-set category) (let ((categories (append - (get-data *my-ontology* 'shapes) - (get-data *my-ontology* 'sizes) - (get-data *my-ontology* 'colors) - (get-data *my-ontology* 'materials)))) + (get-data ontology 'shapes) + (get-data ontology 'sizes) + (get-data ontology 'colors) + (get-data ontology 'materials)))) (loop for cat in categories - for computed-set = (filter-by-category source-set cat) + for computed-set = (filter-by-category source-set cat ontology) if computed-set do (bind (category 1.0 cat) (target-set 1.0 computed-set)) @@ -103,6 +107,6 @@ ;; fourth case: if given source-set, target-set and category, check for consistency ((scene source-set target-set category =>) - (equal-entity target-set (filter-by-category source-set category))) + (equal-entity target-set (filter-by-category source-set category ontology))) :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp b/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp index 6bbb54627..5b13299f9 100644 --- a/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp +++ b/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp @@ -1,6 +1,6 @@ (in-package :mwm-evaluation) - + (export '(*mwm-primitives*)) (def-irl-primitives mwm-primitives diff --git a/applications/clevr/mwm-evaluation/primitives/query.lisp b/applications/clevr/mwm-evaluation/primitives/query.lisp index 947d6f747..f5b2b43f2 100644 --- a/applications/clevr/mwm-evaluation/primitives/query.lisp +++ b/applications/clevr/mwm-evaluation/primitives/query.lisp @@ -14,7 +14,8 @@ get the corresponding category from the ontology")) (defmethod query-object-attribute ((object mwm::mwm-object) - (attribute-category attribute-category) ontology) + (attribute-category attribute-category) + (ontology blackboard)) "Given an object and an attribute; get the attribute from the object and create a category from it." (case (attribute attribute-category) @@ -31,7 +32,7 @@ (attribute attribute-category)) ;; first case; given attribute and source-object, compute the target category ((scene source-object attribute => target-category) - (bind (target-category 1.0 (query-object-attribute source-object attribute *my-ontology*)))) + (bind (target-category 1.0 (query-object-attribute source-object attribute ontology)))) ;; second case; given source-object and target-category, compute the attribute ((scene source-object target-category => attribute) @@ -39,15 +40,15 @@ (find-if #'(lambda (attr) (equal-entity target-category - (query-object-attribute source-object attr *my-ontology*))) - (get-data *my-ontology* 'attributes)))) + (query-object-attribute source-object attr ontology))) + (get-data ontology 'attributes)))) (when computed-attribute (bind (attribute 1.0 computed-attribute))))) ;; third case; given source-object, compute pairs of attribute and target-category ((scene source-object => target-category attribute) - (loop for attr in (get-data *my-ontology* 'attributes) - for target-cat = (query-object-attribute source-object attr *my-ontology*) + (loop for attr in (get-data ontology 'attributes) + for target-cat = (query-object-attribute source-object attr ontology) when target-cat do (bind (attribute 1.0 attr) (target-category 1.0 target-cat)))) @@ -55,7 +56,7 @@ ;; fourth case; if given source-object, attribute and target-category, check ;; for consistency ((scene source-object attribute target-category =>) - (equal-entity target-category (query-object-attribute source-object attribute *my-ontology*))) + (equal-entity target-category (query-object-attribute source-object attribute ontology))) :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/relate.lisp b/applications/clevr/mwm-evaluation/primitives/relate.lisp index cf6218a8b..41482a68b 100644 --- a/applications/clevr/mwm-evaluation/primitives/relate.lisp +++ b/applications/clevr/mwm-evaluation/primitives/relate.lisp @@ -47,13 +47,13 @@ (equal-entity target-set (apply-spatial-relation source-object relation segmented-scene))) - (get-data *my-ontology* 'spatial-relations)))) + (get-data ontology 'spatial-relations)))) (when computed-relation (bind (spatial-relation 1.0 computed-relation))))) ;; third case; given source-object, compute pairs of target-set and spatial-relation ((scene segmented-scene source-object => target-set spatial-relation) - (loop for relation in (get-data *my-ontology* 'spatial-relations) + (loop for relation in (get-data ontology 'spatial-relations) for set = (apply-spatial-relation source-object relation segmented-scene) when set do (bind (target-set 1.0 set) diff --git a/applications/clevr/mwm-evaluation/primitives/same.lisp b/applications/clevr/mwm-evaluation/primitives/same.lisp index a295945d2..1edca8fc1 100644 --- a/applications/clevr/mwm-evaluation/primitives/same.lisp +++ b/applications/clevr/mwm-evaluation/primitives/same.lisp @@ -9,17 +9,18 @@ ;(export '(same)) -(defgeneric same-set-by-object-attribute (set object attribute) +(defgeneric same-set-by-object-attribute (set object attribute ontology) (:documentation "Filter the given set by the attribute of the given object; also remove the object itself from this set.")) (defmethod same-set-by-object-attribute ((set mwm::mwm-object-set) (object mwm::mwm-object) - (attribute-category attribute-category)) - (let* ((object-attribute (query-object-attribute object attribute-category *my-ontology*)) + (attribute-category attribute-category) + (ontology blackboard)) + (let* ((object-attribute (query-object-attribute object attribute-category ontology)) (consider-set (remove (id object) (objects set) :key #'id)) (same-set (loop for obj in consider-set - when (eq object-attribute (query-object-attribute obj attribute-category *my-ontology*)) + when (eq object-attribute (query-object-attribute obj attribute-category ontology)) collect obj))) (when same-set (make-instance 'mwm::mwm-object-set :objects same-set)))) @@ -32,7 +33,7 @@ (attribute attribute-category)) ;; first case; given source-object and attribute, compute the target-set ((scene segmented-scene source-object attribute => target-set) - (let ((same-set (same-set-by-object-attribute segmented-scene source-object attribute))) + (let ((same-set (same-set-by-object-attribute segmented-scene source-object attribute ontology))) (if same-set (bind (target-set 1.0 same-set)) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) @@ -43,7 +44,7 @@ (find-if #'(lambda (attr) (equal-entity target-set - (same-set-by-object-attribute segmented-scene source-object attr))) + (same-set-by-object-attribute segmented-scene source-object attr ontology))) (get-data ontology 'attributes)))) (when computed-attribute (bind (attribute 1.0 computed-attribute))))) @@ -51,7 +52,7 @@ ;; third case; given source-object, compute pairs of attribute and target-set ((scene segmented-scene source-object => target-set attribute) (loop for attr in (get-data ontology 'attributes) - for set = (same-set-by-object-attribute segmented-scene source-object attr) + for set = (same-set-by-object-attribute segmented-scene source-object attr ontology) if set do (bind (target-set 1.0 set) (attribute 1.0 attr)) @@ -66,6 +67,7 @@ (equal-entity target-set (same-set-by-object-attribute segmented-scene source-object - attribute))) + attribute + ontology))) :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/start.lisp b/applications/clevr/mwm-evaluation/start.lisp index 4160b3dbf..8c71c33bc 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -8,7 +8,9 @@ ;; The ontology ;; ;;--------------;; -(make-mwm-ontology (babel-pathname :directory (list "experiments""multidimensional-word-meanings" "learned-concepts" "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))) +(make-mwm-ontology + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "learned-concepts" + "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))) ;; Show the ontology in the web-interface: ;; (add-element (make-html *my-ontology*)) @@ -18,18 +20,29 @@ ;;---------;; ;; Test sentences (see "Babel/grammars/clevr-grammar/start.lisp" for more examples): -;(test-utterance-in-first-scene "there is a big gray object that is the same shape as the purple rubber object; what is it made of?") -;(test-utterance-in-first-scene "What color is the large sphere?") -;(test-utterance-in-first-scene "How many things have the same shape as the large red thing?") -;(test-utterance-in-first-scene "How many things are left of the small gray sphere that is in front of the large sphere that is right of the large blue cube?") -;(test-utterance-in-first-scene "How many things are left of the purple sphere that is behind the yellow thing?") +(let ((ontology + (make-mwm-ontology + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "learned-concepts" + "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))))) + (test-utterance-in-first-scene "there is a big gray object that is the same shape as the purple rubber object; what is it made of?" + ontology) + (test-utterance-in-first-scene "What color is the large sphere?" ontology) + (test-utterance-in-first-scene "How many things have the same shape as the large red thing?" ontology) + (test-utterance-in-first-scene "How many things are left of the small gray sphere that is in front of the large sphere that is right of the large blue cube?" + ontology) + (test-utterance-in-first-scene "How many things are left of the purple sphere that is behind the yellow thing?" + ontology)) ;;------------;; ;; Evaluation ;; ;;------------;; -;; Evaluate on the ontology that is loaded manually -(evaluate-mwm-accuracy "val" "mwm-evaluation" "mwm-errors" :nr-of-scenes 1) +(let ((ontology + (make-mwm-ontology + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" + "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))))) + ;; Evaluate on the ontology that is loaded manually + (evaluate-mwm-accuracy ontology :nr-of-scenes 1)) ;; Evaluate on all series of concepts by loading the different series into the ontology (evaluate-all-series) -- GitLab From fa789b274a8fef203b0d9420bfb8fc6337876bf6 Mon Sep 17 00:00:00 2001 From: jnevens Date: Fri, 25 Mar 2022 11:24:41 +0100 Subject: [PATCH 045/157] mwm-evaluation; restricted irl search space + shortened pathnames --- .../clevr/mwm-evaluation/evaluation.lisp | 33 ++++++++++++------- .../clevr/mwm-evaluation/mwm-utils.lisp | 12 +++++++ applications/clevr/mwm-evaluation/start.lisp | 26 +++++++++++---- 3 files changed, 52 insertions(+), 19 deletions(-) diff --git a/applications/clevr/mwm-evaluation/evaluation.lisp b/applications/clevr/mwm-evaluation/evaluation.lisp index ede7eb8c9..040530164 100644 --- a/applications/clevr/mwm-evaluation/evaluation.lisp +++ b/applications/clevr/mwm-evaluation/evaluation.lisp @@ -30,12 +30,14 @@ (defun compute-answer (irl-program scene-var scene-path-entity ontology) "Given an irl-program, a variable and a scene path, compute the answer." - (let ((solutions - (evaluate-irl-program + (let* ((irl-program-with-scene (cons `(bind pathname-entity ,scene-var ,scene-path-entity) - (substitute-categories irl-program)) - ontology - :primitive-inventory *mwm-primitives*))) + (substitute-categories irl-program))) + (solutions + (evaluate-irl-program irl-program-with-scene ontology + :primitive-inventory *mwm-primitives* + :n 1 ;;; !!! + ))) (when (and solutions (length= solutions 1)) (let* ((target-var (get-target-var irl-program)) (target-value (value (find target-var (first solutions) :key #'var)))) @@ -213,21 +215,28 @@ (defun evaluate-mwm-serie (serie-number) - (let* ((serie-name (format nil "serie-~a" serie-number)) - (directory (list "experiments""multidimensional-word-meanings" "learned-concepts" - "thesis-main-results" "baseline-simulated-default-lexicon" serie-name)) + (let* ((serie-name + (format nil "serie-~a" serie-number)) + (concepts-directory + (merge-pathnames + (make-pathname :directory (list :relative serie-name)) + *simulated-concepts-path*)) + (ontology + (make-mwm-ontology concepts-directory)) (output-filename (format nil "mwm-evaluation-~a" serie-number)) (error-filename (format nil "mwm-errors-~a" serie-number))) - (make-mwm-ontology (babel-pathname :directory directory)) - (evaluate-mwm-accuracy "val" output-filename error-filename))) + (evaluate-mwm-accuracy ontology + :csv-filename output-filename + :errors-filename error-filename))) (defun evaluate-all-series () (loop for serie-nr from 1 to 10 for serie = (format nil "serie-~a" serie-nr) for ontology = (make-mwm-ontology - (babel-pathname :directory (list "experiments""multidimensional-word-meanings" "learned-concepts" - "thesis-main-results" "baseline-simulated-default-lexicon" serie))) + (merge-pathnames + (make-pathname :directory (list :relative serie)) + *simulated-concepts-path*)) do (evaluate-mwm-accuracy ontology :csv-filename (concatenate 'string serie "-evaluation") :errors-filename (concatenate 'string serie "-errors")))) diff --git a/applications/clevr/mwm-evaluation/mwm-utils.lisp b/applications/clevr/mwm-evaluation/mwm-utils.lisp index e5e05cd6f..bbd485527 100644 --- a/applications/clevr/mwm-evaluation/mwm-utils.lisp +++ b/applications/clevr/mwm-evaluation/mwm-utils.lisp @@ -1,5 +1,17 @@ (in-package :mwm-evaluation) +;;--------------------------;; +;; path to learned concepts ;; +;;--------------------------;; + +(defparameter *simulated-concepts-path* + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" + "thesis-main-results" "baseline-simulated-default-lexicon"))) + +(defparameter *extracted-concepts-path* + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" + "thesis-main-results" "baseline-extracted-default-lexicon"))) + ;;----------------------------------;; ;; similarity and category matching ;; ;;----------------------------------;; diff --git a/applications/clevr/mwm-evaluation/start.lisp b/applications/clevr/mwm-evaluation/start.lisp index 8c71c33bc..d97d1f4aa 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -9,8 +9,8 @@ ;;--------------;; (make-mwm-ontology - (babel-pathname :directory '("experiments""multidimensional-word-meanings" "learned-concepts" - "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))) + (merge-pathnames (make-pathname :directory '(:relative "serie-1")) + *simulated-concepts-path*)) ;; Show the ontology in the web-interface: ;; (add-element (make-html *my-ontology*)) @@ -22,8 +22,8 @@ ;; Test sentences (see "Babel/grammars/clevr-grammar/start.lisp" for more examples): (let ((ontology (make-mwm-ontology - (babel-pathname :directory '("experiments""multidimensional-word-meanings" "learned-concepts" - "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))))) + (merge-pathnames (make-pathname :directory '(:relative "serie-1")) + *simulated-concepts-path*)))) (test-utterance-in-first-scene "there is a big gray object that is the same shape as the purple rubber object; what is it made of?" ontology) (test-utterance-in-first-scene "What color is the large sphere?" ontology) @@ -39,10 +39,22 @@ (let ((ontology (make-mwm-ontology - (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" - "thesis-main-results" "baseline-simulated-default-lexicon" "serie-1"))))) + (merge-pathnames (make-pathname :directory '(:relative "serie-1")) + *simulated-concepts-path*)))) ;; Evaluate on the ontology that is loaded manually - (evaluate-mwm-accuracy ontology :nr-of-scenes 1)) + (evaluate-mwm-accuracy ontology :nr-of-scenes 10)) + +;; Evaluate one particular serie +(evaluate-mwm-serie 1) +(evaluate-mwm-serie 2) +(evaluate-mwm-serie 3) +(evaluate-mwm-serie 4) +(evaluate-mwm-serie 5) +(evaluate-mwm-serie 6) +(evaluate-mwm-serie 7) +(evaluate-mwm-serie 8) +(evaluate-mwm-serie 9) +(evaluate-mwm-serie 10) ;; Evaluate on all series of concepts by loading the different series into the ontology (evaluate-all-series) -- GitLab From 43d5ec1e427085b49daad9b681da4ffd3933891c Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Fri, 25 Mar 2022 12:23:22 +0100 Subject: [PATCH 046/157] working on production for intransitive topicalized cxns --- .../bidirectional_grammar_info_arg_struct.fcg | 134 ++++++------------ 1 file changed, 45 insertions(+), 89 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 7535c7baf..44c7b1a14 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -7,7 +7,7 @@ (footprints set) (case sequence)) :hierarchy-features (constituents dependents) - :fcg-configurations ((:max-nr-of-nodes . 10000) + :fcg-configurations ((:max-nr-of-nodes . 40000) (:parse-goal-tests :no-strings-in-root :connected-structure :no-applicable-cxns) (:production-goal-tests :no-applicable-cxns :connected-structure @@ -161,7 +161,7 @@ (HASH form ((string ?for-word "für"))))) :disable-automatic-footprints t) -(def-fcg-cxn für-cxn +(def-fcg-cxn ohne-cxn ((?without-word (footprints (preposition))) <- @@ -384,14 +384,11 @@ (syn-cat (lex-class noun) (case ?case))) (?contracted-prep-phrase - (HASH meaning ((contracted-preposition ?contracted-prep +))) -- (HASH form ((meets ?contracted-prep ?noun))) )) :disable-automatic-footprints t) -(comprehend "zum Mann") -;(formulate-all '((bike x))) (def-fcg-cxn prep-phrase-cxn @@ -780,18 +777,17 @@ (HASH form ((meets ?rightmost-agent-unit ?verb-unit) (meets ?verb-unit ?leftmost-receiver-unit) (meets ?rightmost-receiver-unit ?leftmost-patient-unit))) - ))) +;;;;WORKS ONLY IN COMPREHENSION - NO FORMULATION (def-fcg-cxn topicalized-ditransitive-information-structure-cxn ((?topicalized-ditransitive-information-structure-unit (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) (?arg-and-info-struct-unit (constituents (?topicalized-ditransitive-information-structure-unit ?argument-structure-unit))) <- - (?argument-structure-unit (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) -- @@ -800,7 +796,6 @@ (?verb-unit (syn-cat (lex-class verb) (type ditransitive)) - -- (syn-cat (lex-class verb) (type ditransitive))) @@ -809,20 +804,25 @@ (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) + (referent ?arg0) -- + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) + (?patient-unit (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit)) + (referent ?arg1) -- - + (referent ?arg1) (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit))) + (?receiver-unit (syn-cat (syn-role indirect-object)) @@ -846,70 +846,6 @@ -#|(def-fcg-cxn topicalized-ditransitive-information-structure-cxn - ((?topicalized-ditransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) - (?arg-and-info-struct-unit - (constituents (?topicalized-ditransitive-information-structure-unit ?argument-structure-unit))) - <- - - (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) - -- - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) - - (?verb-unit - (syn-cat (lex-class verb) - (type ditransitive)) - - -- - (syn-cat (lex-class verb) - (type ditransitive))) - - (?agent-unit - (syn-cat (syn-role subject)) - (boundaries (leftmost-unit ?leftmost-agent-unit) - (rightmost-unit ?rightmost-agent-unit)) - -- - (syn-cat (syn-role subject)) - (boundaries (leftmost-unit ?leftmost-agent-unit) - (rightmost-unit ?rightmost-agent-unit))) - - (?patient-unit - (syn-cat (syn-role direct-object)) - (boundaries (leftmost-unit ?leftmost-patient-unit) - (rightmost-unit ?rightmost-patient-unit)) - -- - - (syn-cat (syn-role direct-object)) - (boundaries (leftmost-unit ?leftmost-patient-unit) - (rightmost-unit ?rightmost-patient-unit))) - - (?receiver-unit - (syn-cat (syn-role indirect-object)) - (boundaries (leftmost-unit ?leftmost-receiver-unit) - (rightmost-unit ?rightmost-receiver-unit)) - (referent ?arg2) - -- - (referent ?arg2) - (syn-cat (syn-role indirect-object)) - (boundaries (leftmost-unit ?leftmost-receiver-unit) - (rightmost-unit ?rightmost-receiver-unit))) - - (?topicalized-ditransitive-information-structure-unit - (HASH meaning ((topicalized ?arg2 +))) - -- - (HASH form ((meets ?rightmost-patient-unit ?verb-unit) - (meets ?verb-unit ?leftmost-agent-unit) - (meets ?rightmost-agent-unit ?leftmost-patient-unit))) - ) - ))|# - - - -;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) - - ;der Mann geht zur Arbeit (def-fcg-cxn intransitive-argument-structure-cxn ((?intransitive-argument-structure-unit @@ -917,7 +853,7 @@ (?agent-unit (syn-cat (syn-role subject))) (?location-unit - (syn-cat (syn-role complement))) + (syn-cat (syn-role indirect-object))) <- (?verb-unit (syn-cat (lex-class verb) @@ -948,11 +884,19 @@ (?location-unit (syn-cat (lex-class prep-phrase) - (case ?case)) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) (referent ?arg1) -- (syn-cat (lex-class prep-phrase) - (case ?case)) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) (referent ?arg1)) (?intransitive-argument-structure-unit @@ -989,16 +933,20 @@ (rightmost-unit ?rightmost-agent-unit)) -- (syn-cat (syn-role subject)) + (referent ?arg0) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) (?location-unit - (syn-cat (syn-role complement)) + (syn-cat (syn-role indirect-object) + (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (syn-role complement)) + (syn-cat (syn-role indirect-object) + (lex-class prep-phrase)) + (referent ?arg1) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) @@ -1006,10 +954,7 @@ -- (HASH form ((meets ?rightmost-agent-unit ?verb-unit) (meets ?verb-unit ?leftmost-location-unit))) - ) - - )) - + ))) (def-fcg-cxn intransitive-information-structure-past-cxn @@ -1050,12 +995,14 @@ (rightmost-unit ?rightmost-agent-unit))) (?location-unit - (syn-cat (syn-role complement)) + (syn-cat (syn-role indirect-object) + (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (syn-role complement)) + (syn-cat (syn-role indirect-object) + (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) @@ -1101,12 +1048,14 @@ (rightmost-unit ?rightmost-agent-unit))) (?location-unit - (syn-cat (syn-role complement)) + (syn-cat (syn-role indirect-object) + (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (syn-role complement)) + (syn-cat (syn-role indirect-object) + (lex-class prep-phrase)) (referent ?arg1) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) @@ -1318,10 +1267,17 @@ (formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) ;;; der Mann schenkt dem Clown die Blumen -(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c))) +(formulate-all '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c))) -;;; der Mann schenkt dem Clown die Blumen -(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) +;;; dem Clown schenkt der Mann die Blumen +(formulate-all '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) + + +;;;der Mann geht zur Arbeit +(formulate-all '((gehen-01 g) (man m) (arg0 g m) (work w) (arg1 g w))) + +;;; zur Arbeit geht der Mann +;(formulate-all '((gehen-01 g) (man m) (arg0 g m) (work w) (arg1 g w) (topicalized arg1 +))) ;;; der Mann kommt aus dem Shop -- GitLab From 80fb9c62695e3ad4b6748d3f5190a11535138d3b Mon Sep 17 00:00:00 2001 From: jnevens Date: Sun, 27 Mar 2022 15:49:25 +0200 Subject: [PATCH 047/157] mwm-evaluation; added irl node test --- .../clevr/mwm-evaluation/irl-node-test.lisp | 25 +++++++++++++++ .../clevr/mwm-evaluation/mwm-evaluation.asd | 1 + .../clevr/mwm-evaluation/package.lisp | 3 +- .../mwm-evaluation/primitives/count.lisp | 4 ++- .../primitives/equal-less-greater.lisp | 8 ++++- .../mwm-evaluation/primitives/equal.lisp | 2 ++ .../mwm-evaluation/primitives/exist.lisp | 2 ++ .../mwm-evaluation/primitives/filter.lisp | 4 ++- .../mwm-evaluation/primitives/intersect.lisp | 2 ++ .../primitives/primitive-inventory.lisp | 1 + .../mwm-evaluation/primitives/query.lisp | 2 ++ .../mwm-evaluation/primitives/relate.lisp | 2 ++ .../clevr/mwm-evaluation/primitives/same.lisp | 2 ++ .../mwm-evaluation/primitives/union.lisp | 2 ++ .../mwm-evaluation/primitives/unique.lisp | 2 ++ applications/clevr/mwm-evaluation/start.lisp | 31 +++++++++++++++++++ 16 files changed, 88 insertions(+), 5 deletions(-) create mode 100644 applications/clevr/mwm-evaluation/irl-node-test.lisp diff --git a/applications/clevr/mwm-evaluation/irl-node-test.lisp b/applications/clevr/mwm-evaluation/irl-node-test.lisp new file mode 100644 index 000000000..c05d8b224 --- /dev/null +++ b/applications/clevr/mwm-evaluation/irl-node-test.lisp @@ -0,0 +1,25 @@ +(in-package :irl) + +;; --------------------------------------------------------- +;; single path test + +(defmethod node-test ((node irl-program-processor-node) + (mode (eql :single-path))) + ;; is there another node that has already evaluated + ;; this combination of primitive operations? + ;; this can only be the case when that node has + ;; an equal amount of more evaluated primitives. + (let* ((all-nodes (nodes (processor node))) + (all-evaluated-nodes + (remove node (find-all 'evaluated all-nodes :key #'status))) + (node-primitives + (cons (primitive-under-evaluation node) + (primitives-evaluated node))) + (test-result t)) + (loop for n in all-evaluated-nodes + for np = (cons (primitive-under-evaluation n) + (primitives-evaluated n)) + when (and (>= (length np) (length node-primitives)) + (subsetp node-primitives np :test #'equal)) + do (setf test-result nil) (return)) + test-result)) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/mwm-evaluation.asd b/applications/clevr/mwm-evaluation/mwm-evaluation.asd index 51c6ae2ab..0ee1358d8 100644 --- a/applications/clevr/mwm-evaluation/mwm-evaluation.asd +++ b/applications/clevr/mwm-evaluation/mwm-evaluation.asd @@ -22,6 +22,7 @@ (:file "mwm-ontology") (:file "mwm-utils") (:file "evaluation") + (:file "irl-node-test") (:module "primitives" :serial t :components ((:file "primitive-inventory") diff --git a/applications/clevr/mwm-evaluation/package.lisp b/applications/clevr/mwm-evaluation/package.lisp index b3613927c..769b0b00d 100644 --- a/applications/clevr/mwm-evaluation/package.lisp +++ b/applications/clevr/mwm-evaluation/package.lisp @@ -17,7 +17,6 @@ :decode-json-from-string :encode-json-to-string :encode-json-alist-to-string) - (:import-from :cl-store - :restore) + (:import-from :cl-store :restore) (:shadowing-import-from :fcg :size :attributes)) diff --git a/applications/clevr/mwm-evaluation/primitives/count.lisp b/applications/clevr/mwm-evaluation/primitives/count.lisp index 42cd578e5..429a26521 100644 --- a/applications/clevr/mwm-evaluation/primitives/count.lisp +++ b/applications/clevr/mwm-evaluation/primitives/count.lisp @@ -16,9 +16,11 @@ ;; first case; given source-set, compute target ((source-set => target-num) (bind (target-num 1.0 (length (objects source-set))))) - + + #| ;; second case; given source and target, check consistency ((source-set target-num =>) (= target-num (length (objects source-set)))) + |# :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/equal-less-greater.lisp b/applications/clevr/mwm-evaluation/primitives/equal-less-greater.lisp index b533df04a..ba67049d6 100644 --- a/applications/clevr/mwm-evaluation/primitives/equal-less-greater.lisp +++ b/applications/clevr/mwm-evaluation/primitives/equal-less-greater.lisp @@ -21,7 +21,8 @@ (if (= source-num-1 source-num-2) 'yes 'no)))) (bind (target-bool 1.0 boolean-category)))) - + + #| ((source-num-1 source-num-2 target-bool =>) (let ((boolean-category (find-entity-by-id @@ -29,6 +30,7 @@ (if (= source-num-1 source-num-2) 'yes 'no)))) (equal-entity target-bool boolean-category))) + |# :primitive-inventory *mwm-primitives*) ;; --------------------- @@ -49,6 +51,7 @@ 'yes 'no)))) (bind (target-bool 1.0 boolean-category)))) + #| ((source-num-1 source-num-2 target-bool =>) (let ((boolean-category (find-entity-by-id @@ -56,6 +59,7 @@ (if (< source-num-1 source-num-2) 'yes 'no)))) (equal-entity target-bool boolean-category))) + |# :primitive-inventory *mwm-primitives*) ;; ------------------------ @@ -76,6 +80,7 @@ 'yes 'no)))) (bind (target-bool 1.0 boolean-category)))) + #| ((source-num-1 source-num-2 target-bool =>) (let ((boolean-category (find-entity-by-id @@ -83,4 +88,5 @@ (if (> source-num-1 source-num-2) 'yes 'no)))) (equal-entity target-bool boolean-category))) + |# :primitive-inventory *mwm-primitives*) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/equal.lisp b/applications/clevr/mwm-evaluation/primitives/equal.lisp index 359b28057..d77e2d644 100644 --- a/applications/clevr/mwm-evaluation/primitives/equal.lisp +++ b/applications/clevr/mwm-evaluation/primitives/equal.lisp @@ -55,9 +55,11 @@ (let ((equal-p (equal-attribute-p source-1 source-2 attribute))) (bind (target-bool 1.0 (find-entity-by-id ontology (if equal-p 'yes 'no)))))) + #| ;; second case; given all, check for consistency ((source-1 source-2 attribute target-bool =>) (let* ((equal-p (equal-attribute-p source-1 source-2 attribute)) (bool-category (find-entity-by-id ontology (if equal-p 'yes 'no)))) (equal-entity target-bool bool-category))) + |# :primitive-inventory *mwm-primitives*) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/exist.lisp b/applications/clevr/mwm-evaluation/primitives/exist.lisp index 38afe11c7..b2c11c0ed 100644 --- a/applications/clevr/mwm-evaluation/primitives/exist.lisp +++ b/applications/clevr/mwm-evaluation/primitives/exist.lisp @@ -20,6 +20,7 @@ 'yes 'no)))) (bind (target-bool 1.0 boolean-category)))) + #| ;; second case; given source-set and target-bool, check consistency ((source-set target-bool =>) (let ((boolean-category @@ -28,4 +29,5 @@ (if (length> (objects source-set) 0) 'yes 'no)))) (equal-entity target-bool boolean-category))) + |# :primitive-inventory *mwm-primitives*) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/filter.lisp b/applications/clevr/mwm-evaluation/primitives/filter.lisp index 34edcddd8..8ecf438b0 100644 --- a/applications/clevr/mwm-evaluation/primitives/filter.lisp +++ b/applications/clevr/mwm-evaluation/primitives/filter.lisp @@ -73,7 +73,8 @@ (if computed-set (bind (target-set 1.0 computed-set)) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) - + + #| ;; second case: if given source-set and target-set, compute category ((scene source-set target-set => category) (let ((computed-category @@ -108,5 +109,6 @@ ;; fourth case: if given source-set, target-set and category, check for consistency ((scene source-set target-set category =>) (equal-entity target-set (filter-by-category source-set category ontology))) + |# :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/intersect.lisp b/applications/clevr/mwm-evaluation/primitives/intersect.lisp index f52266cac..0a04109af 100644 --- a/applications/clevr/mwm-evaluation/primitives/intersect.lisp +++ b/applications/clevr/mwm-evaluation/primitives/intersect.lisp @@ -21,6 +21,7 @@ (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :objects intersected))) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) + #| ;; second case; given a source and target set, compute the other source set ((source-set-1 target-set => source-set-2) (let ((context (get-data ontology 'clevr-context))) @@ -52,4 +53,5 @@ (equal-entity target-set (make-instance 'mwm::mwm-object-set :objects intersected)))) + |# :primitive-inventory *mwm-primitives*) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp b/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp index 5b13299f9..a74216d17 100644 --- a/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp +++ b/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp @@ -4,4 +4,5 @@ (export '(*mwm-primitives*)) (def-irl-primitives mwm-primitives + :irl-configurations ((:node-tests :no-duplicate-solutions :single-path)) :primitive-inventory *mwm-primitives*) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/query.lisp b/applications/clevr/mwm-evaluation/primitives/query.lisp index f5b2b43f2..32ef911e0 100644 --- a/applications/clevr/mwm-evaluation/primitives/query.lisp +++ b/applications/clevr/mwm-evaluation/primitives/query.lisp @@ -34,6 +34,7 @@ ((scene source-object attribute => target-category) (bind (target-category 1.0 (query-object-attribute source-object attribute ontology)))) + #| ;; second case; given source-object and target-category, compute the attribute ((scene source-object target-category => attribute) (let ((computed-attribute @@ -57,6 +58,7 @@ ;; for consistency ((scene source-object attribute target-category =>) (equal-entity target-category (query-object-attribute source-object attribute ontology))) + |# :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/relate.lisp b/applications/clevr/mwm-evaluation/primitives/relate.lisp index 41482a68b..4228bd93a 100644 --- a/applications/clevr/mwm-evaluation/primitives/relate.lisp +++ b/applications/clevr/mwm-evaluation/primitives/relate.lisp @@ -40,6 +40,7 @@ (bind (target-set 1.0 related-set)) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) + #| ;; second case; given source-object and target set, compute the spatial relation ((scene segmented-scene source-object target-set => spatial-relation) (let ((computed-relation @@ -63,4 +64,5 @@ ;; check for consistency ((scene segmented-scene source-object target-set spatial-relation =>) (equal-entity target-set (apply-spatial-relation source-object spatial-relation segmented-scene))) + |# :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/same.lisp b/applications/clevr/mwm-evaluation/primitives/same.lisp index 1edca8fc1..5f2b64826 100644 --- a/applications/clevr/mwm-evaluation/primitives/same.lisp +++ b/applications/clevr/mwm-evaluation/primitives/same.lisp @@ -38,6 +38,7 @@ (bind (target-set 1.0 same-set)) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) + #| ;; second case; given source-object and target-set, compute the attribute ((scene segmented-scene source-object target-set => attribute) (let ((computed-attribute @@ -69,5 +70,6 @@ source-object attribute ontology))) + |# :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/primitives/union.lisp b/applications/clevr/mwm-evaluation/primitives/union.lisp index 0ace89177..f505c7ae7 100644 --- a/applications/clevr/mwm-evaluation/primitives/union.lisp +++ b/applications/clevr/mwm-evaluation/primitives/union.lisp @@ -21,6 +21,7 @@ (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :objects unioned))) (bind (target-set 1.0 (make-instance 'mwm::mwm-object-set :id (make-id 'empty-set))))))) + #| ;; second case; given a source and target set, compute the other source set ;; the other source set contains at least the set-difference of the ;; target set and the given source set + all possible subsets of @@ -64,4 +65,5 @@ (equal-entity target-set (make-instance 'mwm::mwm-object-set :objects unioned)))) + |# :primitive-inventory *mwm-primitives*) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/unique.lisp b/applications/clevr/mwm-evaluation/primitives/unique.lisp index d187bd997..1e6635c88 100644 --- a/applications/clevr/mwm-evaluation/primitives/unique.lisp +++ b/applications/clevr/mwm-evaluation/primitives/unique.lisp @@ -16,10 +16,12 @@ (when (length= (objects source-set) 1) (bind (target-object 1.0 (first (objects source-set)))))) + #| ;; second case; given source set and target object ;; check for consistency ((source-set target-object =>) (and (length= (objects source-set) 1) (equal-entity target-object (first (objects source-set))))) + |# :primitive-inventory *mwm-primitives*) diff --git a/applications/clevr/mwm-evaluation/start.lisp b/applications/clevr/mwm-evaluation/start.lisp index d97d1f4aa..fe903137e 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -3,6 +3,7 @@ (activate-monitor trace-fcg) (activate-monitor trace-irl) +(deactivate-all-monitors) ;;--------------;; ;; The ontology ;; @@ -58,3 +59,33 @@ ;; Evaluate on all series of concepts by loading the different series into the ontology (evaluate-all-series) + + + + +;;---------;; +;; Testing ;; +;;---------;; + +(defparameter *ontology* + (make-mwm-ontology + (merge-pathnames (make-pathname :directory '(:relative "serie-1")) + *simulated-concepts-path*))) + +(defparameter *pathname-entity* + (make-instance 'pathname-entity + :pathname (parse-namestring "/Users/jensnevens/Babel-Corpora/CLEVR-v1.0/scenes/val/CLEVR_val_000005.json"))) + +(defparameter *program* + `((BIND PATHNAME-ENTITY CLEVR-GRAMMAR::?SCENE ,*pathname-entity*) (BIND SPATIAL-RELATION-CATEGORY ?SPATIAL-RELATION-20167 BEHIND) (FILTER ?TARGET-160246 ?TARGET-160240 CLEVR-GRAMMAR::?SCENE ?SIZE-992) (UNIQUE ?OBJECT-109914 ?TARGET-160246) (BIND ATTRIBUTE-CATEGORY ?ATTRIBUTE-33764 MATERIAL) (EQUAL? ?TARGET-160366 ?SRC-30835 ?SRC-30836 ?ATTRIBUTE-33764) (QUERY ?SRC-30835 ?OBJECT-109913 CLEVR-GRAMMAR::?SCENE ?ATTRIBUTE-33764) (QUERY ?SRC-30836 ?OBJECT-109914 CLEVR-GRAMMAR::?SCENE ?ATTRIBUTE-33764) (FILTER ?TARGET-160249 ?TARGET-160242 CLEVR-GRAMMAR::?SCENE ?SIZE-984) (UNIQUE ?OBJECT-109913 ?TARGET-160249) (BIND SIZE-CATEGORY ?SIZE-984 LARGE) (FILTER ?TARGET-160242 ?TARGET-160241 CLEVR-GRAMMAR::?SCENE ?COLOR-1281) (BIND SIZE-CATEGORY ?SIZE-992 LARGE) (FILTER ?TARGET-160240 ?SOURCE-67832 CLEVR-GRAMMAR::?SCENE ?SHAPE-4442) (BIND SHAPE-CATEGORY ?SHAPE-4441 SPHERE) (BIND SHAPE-CATEGORY ?SHAPE-4444 SPHERE) (BIND SIZE-CATEGORY ?SIZE-983 SMALL) (FILTER ?TARGET-160238 ?TARGET-160237 CLEVR-GRAMMAR::?SCENE ?COLOR-1280) (BIND MATERIAL-CATEGORY ?MATERIAL-1250 RUBBER) (FILTER ?TARGET-160236 ?SOURCE-67835 CLEVR-GRAMMAR::?SCENE ?SHAPE-4452) (BIND SHAPE-CATEGORY ?SHAPE-4452 CUBE) (FILTER ?TARGET-160237 ?TARGET-160236 CLEVR-GRAMMAR::?SCENE ?MATERIAL-1250) (BIND COLOR-CATEGORY ?COLOR-1280 YELLOW) (BIND SHAPE-CATEGORY ?SHAPE-4442 THING) (FILTER ?TARGET-160241 ?SOURCE-67833 CLEVR-GRAMMAR::?SCENE ?SHAPE-4444) (BIND COLOR-CATEGORY ?COLOR-1281 YELLOW) (FILTER ?TARGET-160243 ?SOURCE-67835 CLEVR-GRAMMAR::?SCENE ?SHAPE-4441) (BIND MATERIAL-CATEGORY ?MATERIAL-1254 METAL) (FILTER ?TARGET-160245 ?TARGET-160243 CLEVR-GRAMMAR::?SCENE ?MATERIAL-1254) (BIND COLOR-CATEGORY ?COLOR-1282 GRAY) (FILTER ?TARGET-160247 ?TARGET-160245 CLEVR-GRAMMAR::?SCENE ?COLOR-1282) (BIND SIZE-CATEGORY ?SIZE-986 LARGE) (UNIQUE ?TARGET-OBJECT-22492 ?TARGET-160250) (FILTER ?TARGET-160250 ?TARGET-160247 CLEVR-GRAMMAR::?SCENE ?SIZE-986) (UNIQUE ?TARGET-OBJECT-22500 ?TARGET-160239) (FILTER ?TARGET-160239 ?TARGET-160238 CLEVR-GRAMMAR::?SCENE ?SIZE-983) (BIND SPATIAL-RELATION-CATEGORY ?SPATIAL-RELATION-20169 FRONT) (CLEVR-GRAMMAR::SEGMENT-SCENE ?SOURCE-67835 CLEVR-GRAMMAR::?SCENE) (RELATE ?SOURCE-67832 ?TARGET-OBJECT-22492 ?SOURCE-67835 CLEVR-GRAMMAR::?SCENE ?SPATIAL-RELATION-20169) (RELATE ?SOURCE-67833 ?TARGET-OBJECT-22500 ?SOURCE-67835 CLEVR-GRAMMAR::?SCENE ?SPATIAL-RELATION-20167))) +(setf *program* (substitute-categories *program*)) + + +(loop repeat 20 + do (time + (evaluate-irl-program *program* *ontology* + :n 1 :primitive-inventory *mwm-primitives*) + + + + -- GitLab From 2fb4e9e29427bea78f41da1ddc9aa8cc5b6d6864 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Mon, 28 Mar 2022 15:11:44 +0200 Subject: [PATCH 048/157] working on production --- .../bidirectional_grammar_info_arg_struct.fcg | 238 ++++++++++++------ 1 file changed, 162 insertions(+), 76 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 44c7b1a14..017c114bc 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -1,3 +1,8 @@ +;; generation from noun meaning generates PP even with only Article +;;; ditransitive with schenken does not work in formulation for topicalized +;;; creating different constructions for verbs with different PP and argument structure? + + (def-fcg-constructions german-case-grammar :feature-types ((args sequence) (form set-of-predicates) @@ -383,6 +388,7 @@ (footprints (not determined)) (syn-cat (lex-class noun) (case ?case))) + (?contracted-prep-phrase -- (HASH form ((meets ?contracted-prep ?noun))) @@ -391,7 +397,9 @@ -(def-fcg-cxn prep-phrase-cxn +;;;; with this one prepositional phrases are generated even when there is only an article and no preposition + +(def-fcg-cxn prepositional-phrase-cxn ((?prep-phrase (referent ?x) (syn-cat (lex-class prep-phrase) @@ -400,14 +408,17 @@ (boundaries (leftmost-unit ?preposition) (rightmost-unit ?noun))) (?preposition - (part-of-prep-phrase +) - (referent ?x)) + (referent ?x) + (part-of-prep-phrase +)) + (?article (referent ?x) (part-of-noun-phrase +)) + (?noun (footprints (determined))) <- + (?preposition -- (syn-cat (lex-class preposition) @@ -421,7 +432,6 @@ (referent ?x) (syn-cat (lex-class noun) (case ?case)) - -- (footprints (not determined)) (syn-cat (lex-class noun) @@ -434,11 +444,15 @@ :disable-automatic-footprints t) + + + (def-fcg-cxn kommt-cxn ((?come-word (syn-cat (lex-class verb) (aspect non-perfect) - (type intransitive)) + (type intransitive) + (location origin-only)) (referent ?k)) <- @@ -704,16 +718,16 @@ (case ((- - - - -) (- - - - -) (- - - - -) - (?dat ?dm ?df ?dn ?dp) - (?ds ?dm ?df ?dn ?dp)))) + (+ ?dm ?df ?dn ?dp) + (?rs ?dm ?df ?dn ?dp)))) (referent ?arg2) -- (syn-cat (lex-class noun-phrase) (case ((- - - - -) (- - - - -) (- - - - -) - (?dat ?dm ?df ?dn ?dp) - (?ds ?dm ?df ?dn ?dp)))) + (+ ?dm ?df ?dn ?dp) + (?rs ?dm ?df ?dn ?dp)))) (referent ?arg2)) (?ditransitive-argument-structure-unit @@ -804,7 +818,7 @@ (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) - (referent ?arg0) + -- (referent ?arg0) (syn-cat (syn-role subject)) @@ -816,7 +830,7 @@ (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit)) - (referent ?arg1) + -- (referent ?arg1) (syn-cat (syn-role direct-object)) @@ -828,7 +842,8 @@ (syn-cat (syn-role indirect-object)) (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit)) - (referent ?arg2) + (HASH meaning ((topicalized ?arg2 +))) + -- (referent ?arg2) (syn-cat (syn-role indirect-object)) @@ -836,7 +851,6 @@ (rightmost-unit ?rightmost-receiver-unit))) (?topicalized-ditransitive-information-structure-unit - (HASH meaning ((topicalized ?arg2 +))) -- (HASH form ((meets ?rightmost-receiver-unit ?verb-unit) (meets ?verb-unit ?leftmost-agent-unit) @@ -853,7 +867,7 @@ (?agent-unit (syn-cat (syn-role subject))) (?location-unit - (syn-cat (syn-role indirect-object))) + (syn-cat (syn-role locative-complement))) <- (?verb-unit (syn-cat (lex-class verb) @@ -889,7 +903,7 @@ (- - - - -) (?dat ?dm ?df ?dn ?dp) (?ls ?m ?f ?n ?lp)))) - (referent ?arg1) + (referent ?arg4) -- (syn-cat (lex-class prep-phrase) (case ((- - - - -) @@ -897,14 +911,75 @@ (- - - - -) (?dat ?dm ?df ?dn ?dp) (?ls ?m ?f ?n ?lp)))) - (referent ?arg1)) + (referent ?arg4)) (?intransitive-argument-structure-unit (HASH meaning ((:arg0 ?v ?arg0) - (:arg1 ?v ?arg1))) + (:arg4 ?v ?arg4))) -- ))) +#|(def-fcg-cxn intransitive-come-argument-structure-cxn + ((?intransitive-argument-structure-unit + (constituents (?verb-unit ?agent-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?location-unit + (syn-cat (syn-role indirect-object))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive) + (location origin-only) + ) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive) + (location origin-only)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg3) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg3)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg4 ?v ?arg4))) + -- + )))|# + (def-fcg-cxn intransitive-information-structure-cxn ((?intransitive-information-structure-unit (constituents (?verb-unit ?agent-unit ?location-unit))) @@ -938,15 +1013,15 @@ (rightmost-unit ?rightmost-agent-unit))) (?location-unit - (syn-cat (syn-role indirect-object) + (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (syn-role indirect-object) + (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) - (referent ?arg1) + (referent ?arg4) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) @@ -956,12 +1031,11 @@ (meets ?verb-unit ?leftmost-location-unit))) ))) - -(def-fcg-cxn intransitive-information-structure-past-cxn - ((?intransitive-information-structure-past-unit +#|(def-fcg-cxn intransitive-come-information-structure-cxn + ((?intransitive-information-structure-unit (constituents (?verb-unit ?agent-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?intransitive-information-structure-past-unit ?argument-structure-unit))) + (constituents (?intransitive-information-structure-unit ?argument-structure-unit))) <- (?argument-structure-unit (constituents (?verb-unit ?agent-unit ?location-unit)) @@ -970,20 +1044,17 @@ ) (?verb-unit - (constituents (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (type intransitive) - (aspect perfect)) - (boundaries (leftmost-unit ?aux-unit) - (rightmost-unit ?participle-unit)) + (aspect ?aspect) + (location origin-only) + ) -- - (constituents (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (type intransitive) - (aspect perfect)) - (boundaries (leftmost-unit ?aux-unit) - (rightmost-unit ?participle-unit))) + (aspect ?aspect) + (location origin-only))) (?agent-unit (syn-cat (syn-role subject)) @@ -991,6 +1062,7 @@ (rightmost-unit ?rightmost-agent-unit)) -- (syn-cat (syn-role subject)) + (referent ?arg0) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) @@ -1003,23 +1075,22 @@ (syn-cat (syn-role indirect-object) (lex-class prep-phrase)) + (referent ?arg4) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) - (?intransitive-information-structure-past-unit + (?intransitive-information-structure-unit -- - (HASH form ((meets ?rightmost-agent-unit ?aux-unit) - (meets ?aux-unit ?leftmost-location-unit) - (meets ?rightmost-location-unit ?participle-unit))) - ) - - )) + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-location-unit))) + )))|# + -(def-fcg-cxn topicalized-intransitive-information-structure-cxn - ((?topicalized-intransitive-information-structure-unit +(def-fcg-cxn intransitive-information-structure-past-cxn + ((?intransitive-information-structure-past-unit (constituents (?verb-unit ?agent-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?topicalized-intransitive-information-structure-unit ?argument-structure-unit))) + (constituents (?intransitive-information-structure-past-unit ?argument-structure-unit))) <- (?argument-structure-unit (constituents (?verb-unit ?agent-unit ?location-unit)) @@ -1028,14 +1099,20 @@ ) (?verb-unit + (constituents (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (type intransitive) - (aspect ?aspect)) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) -- + (constituents (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (type intransitive) - (aspect ?aspect))) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit))) (?agent-unit (syn-cat (syn-role subject)) @@ -1043,29 +1120,31 @@ (rightmost-unit ?rightmost-agent-unit)) -- (syn-cat (syn-role subject)) - (referent ?arg0) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) (?location-unit - (syn-cat (syn-role indirect-object) + (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (syn-role indirect-object) + (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) - (referent ?arg1) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) - (?topicalized-intransitive-information-structure-unit - (HASH meaning ((topicalized ?arg1 +))) + (?intransitive-information-structure-past-unit + + -- - (HASH form ((meets ?rightmost-location-unit ?verb-unit) - (meets ?verb-unit ?leftmost-agent-unit))) - ))) + (HASH form ((meets ?rightmost-agent-unit ?aux-unit) + (meets ?aux-unit ?leftmost-location-unit) + (meets ?rightmost-location-unit ?participle-unit))) + ) + + )) @@ -1080,7 +1159,7 @@ (?ad-info-unit (syn-cat (syn-role extra-complement))) (?location-unit - (syn-cat (syn-role location-complement))) + (syn-cat (syn-role locative-complement))) <- (?verb-unit (syn-cat (lex-class verb) @@ -1111,12 +1190,13 @@ (?ad-info-unit (syn-cat (lex-class prep-phrase) (case ?case)) - (referent ?arg1) + (referent ?extra-info) -- (syn-cat (lex-class prep-phrase) (case ?case)) - (referent ?arg1) + (referent ?extra-info) ) + (?location-unit (syn-cat (lex-class prep-phrase) (case ((- - - - -) @@ -1124,7 +1204,7 @@ (- - - - -) (+ ?dm ?df ?dn ?dp) (?ls ?dm ?df ?dn ?dp)))) - (referent ?arg2) + (referent ?arg4) -- (syn-cat (lex-class prep-phrase) (case ((- - - - -) @@ -1132,12 +1212,12 @@ (- - - - -) (+ ?dm ?df ?dn ?dp) (?ls ?dm ?df ?dn ?dp)))) - (referent ?arg2)) + (referent ?arg4)) (?double-intransitive-argument-structure-unit (HASH meaning ((:arg0 ?v ?arg0) - (:arg1 ?v ?arg1) - (:arg2 ?v ?arg2))) + (:extra-info ?v ?extra-info) + (:arg4 ?v ?arg4))) -- ))) @@ -1185,9 +1265,9 @@ (syn-cat (syn-role location-complement)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) - (referent ?arg2) + (referent ?arg4) -- - (referent ?arg2) + (referent ?arg4) (syn-cat (syn-role location-complement)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) @@ -1208,6 +1288,7 @@ ;;;;;;;;VERBS' ARGUMENTS ;DITRANSITIVES (DIRECT ACC. AND INDIRECT OBJECT DATIVE) + ;;;geben (arg0 giver - arg1 thing given - arg2 entity or person given to) ;Die Frau gibt dem Mann den Apfel. @@ -1225,6 +1306,7 @@ ;TRANSITIVES + ;;;;verfolgen (arg0 follower- arg1 thing followed) ;Der Hund verfolgt den Mann. @@ -1242,14 +1324,21 @@ -;;;;fahren (arg0 driver- arg1 vehicle or path) -;Der Mann fährt mit dem Fahrrad zur Arbeit. -;Der Mann ist gegen den Baum gefahren. +;MOTION verbs + + ;;;;gehen (arg0 goer - arg1 journey - arg3 start point - arg4 end point) ;Der Junge geht zum Arzt. ;Die Mutter geht ohne den Sohn zum Laden. +;;;;kommen (arg1 entity in motion - arg2 extent - arg3 starting point -arg4 endpoint) + + +;;;;fahren (arg0 driver- arg1 vehicle or path) +;Der Mann fährt mit dem Fahrrad zur Arbeit. +;Der Mann ist gegen den Shop gefahren. + ;;;;mitbringen (arg0 bringen - arg1 thing brought - arg2 benefactive or destination - arg3 attribute - arg4 brought from) ;Die Königin hat für den König Blume mitgebracht. @@ -1258,30 +1347,27 @@ ;;; NPs with Determiners and PPs with NP+P or Contracted P -(formulate-all '((work x))) +;(formulate-all '((clown x))) ;;;; der Mann sucht den Clown -(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) +;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) ;;; den Clown sucht der Mann -(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) +;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) ;;; der Mann schenkt dem Clown die Blumen -(formulate-all '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c))) +;(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c))) ;;; dem Clown schenkt der Mann die Blumen -(formulate-all '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) +;(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) ;;;der Mann geht zur Arbeit -(formulate-all '((gehen-01 g) (man m) (arg0 g m) (work w) (arg1 g w))) - -;;; zur Arbeit geht der Mann -;(formulate-all '((gehen-01 g) (man m) (arg0 g m) (work w) (arg1 g w) (topicalized arg1 +))) +;(formulate '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s))) ;;; der Mann kommt aus dem Shop -;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg1 k s))) +;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg4 k s))) ;still same as gehen ;;; aus dem Shop kommt der Mann ;(formulate-all '((kommen-01 k) (man m) (arg1 k m) (shop s) (arg3 k s) (topicalized s +))) @@ -1294,5 +1380,5 @@ ;(formulate-all '((drove-01 ig) (man m) (arg0 ig m) (flowers f) (arg1 ig f))) ;;; der Mann geht ohne den Clown zur Arbeit -;(formulate-all '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg2 g w))) +(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) -- GitLab From bf2cc005c519a0321a29c381424af309076b7296 Mon Sep 17 00:00:00 2001 From: jnevens Date: Mon, 28 Mar 2022 16:12:00 +0200 Subject: [PATCH 049/157] mwm-evaluation; refactor using monitors --- applications/clevr/mwm-evaluation/.gitignore | 1 + .../clevr/mwm-evaluation/evaluation.lisp | 334 ++++++++++-------- .../clevr/mwm-evaluation/monitors.lisp | 268 ++++++++++++++ applications/clevr/mwm-evaluation/start.lisp | 49 ++- 4 files changed, 475 insertions(+), 177 deletions(-) create mode 100644 applications/clevr/mwm-evaluation/.gitignore create mode 100644 applications/clevr/mwm-evaluation/monitors.lisp diff --git a/applications/clevr/mwm-evaluation/.gitignore b/applications/clevr/mwm-evaluation/.gitignore new file mode 100644 index 000000000..b13359a06 --- /dev/null +++ b/applications/clevr/mwm-evaluation/.gitignore @@ -0,0 +1 @@ +raw-data/* diff --git a/applications/clevr/mwm-evaluation/evaluation.lisp b/applications/clevr/mwm-evaluation/evaluation.lisp index 040530164..a2e064102 100644 --- a/applications/clevr/mwm-evaluation/evaluation.lisp +++ b/applications/clevr/mwm-evaluation/evaluation.lisp @@ -1,48 +1,34 @@ (in-package :mwm-evaluation) -;;------------;; -;; Evaluation ;; -;;------------;; -;; Compute the accuracy on the clevr dataset using the learned concepts +;;------------------------;; +;; Default Configurations ;; +;;------------------------;; +(define-configuration-default-value :dot-interval 100) +(define-configuration-default-value :nr-of-scenes nil) +(define-configuration-default-value :nr-of-questions nil) +(define-configuration-default-value :data-split "val") +(define-configuration-default-value :world-type :simulated) -;; Make a string from the computed answer so that it can be compared to the ground-truth string -(defun answer->str (answer-value) - (case #+lispworks (type-of answer-value) - #+ccl (if (listp (type-of answer-value)) - (first (type-of answer-value)) - (type-of answer-value)) - #+sbcl (if (listp (type-of answer-value)) - (first (type-of answer-value)) - (type-of answer-value)) - (number (mkstr answer-value)) - (fixnum (mkstr answer-value)) - (integer (mkstr answer-value)) - (bit (mkstr answer-value)) - (shape-concept (mkstr (id answer-value))) - (size-concept (mkstr (id answer-value))) - (color-concept (mkstr (id answer-value))) - (material-concept (mkstr (id answer-value))) - (boolean-category (mkstr (id answer-value))))) - - -;; Compute the answer for an irl-program -(defun compute-answer (irl-program scene-var scene-path-entity ontology) - "Given an irl-program, a variable and a scene path, - compute the answer." - (let* ((irl-program-with-scene - (cons `(bind pathname-entity ,scene-var ,scene-path-entity) - (substitute-categories irl-program))) - (solutions - (evaluate-irl-program irl-program-with-scene ontology - :primitive-inventory *mwm-primitives* - :n 1 ;;; !!! - ))) - (when (and solutions (length= solutions 1)) - (let* ((target-var (get-target-var irl-program)) - (target-value (value (find target-var (first solutions) :key #'var)))) - (answer->str target-value))))) +#| +;; make an empty error-table +(defun make-error-table () + (let ((error-table (make-hash-table))) + (setf (gethash 'count! error-table) '(0 . 0)) + (setf (gethash 'equal? error-table) '(0 . 0)) + (setf (gethash 'equal-integer error-table) '(0 . 0)) + (setf (gethash 'less-than error-table) '(0 . 0)) + (setf (gethash 'greater-than error-table) '(0 . 0)) + (setf (gethash 'exist error-table) '(0 . 0)) + (setf (gethash 'filter error-table) '(0 . 0)) + (setf (gethash 'intersect error-table) '(0 . 0)) + (setf (gethash 'query error-table) '(0 . 0)) + (setf (gethash 'relate error-table) '(0 . 0)) + (setf (gethash 'same error-table) '(0 . 0)) + (setf (gethash 'union! error-table) '(0 . 0)) + (setf (gethash 'unique error-table) '(0 . 0)) + error-table)) ;; Frequencies of a primitive occurring in a question and frequencies of errors per primitive are added to a hash-table (defun adjust-primitive-errors (irl-program hash-table) @@ -109,12 +95,6 @@ (format nil "The error rate for ~a is ~,2f" key 0) stream) (force-output stream)))))) -(defun get-result (cipn answer computed-answer) - (if (and (find 'fcg::succeeded (fcg::statuses cipn)) - (string= (upcase answer) - (upcase computed-answer))) - 1 0)) - (defun write-result (log scene-name q answer computed-answer result irl-program hash-table) (if (= result 1) (progn (adjust-primitive-frequencies irl-program hash-table) @@ -124,122 +104,180 @@ (write-line (format nil "~a,~a,~a,~a,~a" scene-name q answer computed-answer result) log) (force-output log) (adjust-primitive-errors irl-program hash-table)))) +|# + +;;------------;; +;; Evaluation ;; +;;------------;; +;; Compute the accuracy on the clevr dataset using the learned concepts +(defun answer->str (answer-value) + "Make a string from the computed answer so + that it can be compared to the ground-truth string" + (case #+lispworks (type-of answer-value) + #+ccl (if (listp (type-of answer-value)) + (first (type-of answer-value)) + (type-of answer-value)) + #+sbcl (if (listp (type-of answer-value)) + (first (type-of answer-value)) + (type-of answer-value)) + (number (mkstr answer-value)) + (fixnum (mkstr answer-value)) + (integer (mkstr answer-value)) + (bit (mkstr answer-value)) + (shape-concept (mkstr (id answer-value))) + (size-concept (mkstr (id answer-value))) + (color-concept (mkstr (id answer-value))) + (material-concept (mkstr (id answer-value))) + (boolean-category (mkstr (id answer-value))))) + + +(defun compute-answer (irl-program scene-var scene-path-entity ontology) + "Given an irl-program, a variable and a scene path, + compute the answer." + (let* ((irl-program-with-scene + (cons `(bind pathname-entity ,scene-var ,scene-path-entity) + (substitute-categories irl-program))) + (solutions + (evaluate-irl-program irl-program-with-scene ontology :n 1 + :primitive-inventory *mwm-primitives*))) + (when (and solutions (length= solutions 1)) + (let* ((target-var (get-target-var irl-program)) + (target-value (value (find target-var (first solutions) :key #'var)))) + (answer->str target-value))))) + + +(defun get-result (cipn answer computed-answer) + (if (and (find 'fcg::succeeded (fcg::statuses cipn)) + (string= (upcase answer) + (upcase computed-answer))) + 1 0)) + + +(define-event question-evaluation + (scene-name string) (question string) (irl-program list) + (answer t) (computed-answer t) (result fixnum)) + ;; Compute the accuracy on a specified number of scenes or questions -(defun compute-accuracy (log clevr-world ontology hash-table - &key nr-of-scenes nr-of-questions) - (average - (remove nil - (loop with processed-questions = 0 - with processed-scenes = 0 - for scene-path in (scenes clevr-world) - for question-path in (question-sets clevr-world) - for set-of-questions = (load-clevr-question-set question-path) - for path-entity = (make-instance 'pathname-entity :pathname scene-path) - for scene-name = (pathname-name scene-path) - if (and nr-of-scenes (>= processed-scenes nr-of-scenes)) - return accuracy - else - append (loop for clevr-question in (questions set-of-questions) - for q = (question clevr-question) - for answer = (answer clevr-question) - for (irl-program cipn nil) - = (multiple-value-list - (clevr-grammar::understand q)) - for scene-var = (extract-scene-unit-variable cipn) - for computed-answer = (compute-answer irl-program scene-var path-entity ontology) - for result = (get-result cipn answer computed-answer) - do (incf processed-questions) - (format t ".") - if (and nr-of-questions (>= processed-questions nr-of-questions)) - return scene-accuracy - else if (= result 1) - collect 1 into scene-accuracy - and do (write-result log scene-name q answer computed-answer result irl-program hash-table) - else collect 0 into scene-accuracy - and do (write-result log scene-name q answer computed-answer result irl-program hash-table) - finally (return scene-accuracy)) - into accuracy - do (incf processed-scenes) - finally (return accuracy))))) +(defun compute-accuracy (clevr-world ontology configurations) + (let ((nr-of-scenes (get-configuration configurations :nr-of-scenes)) + (nr-of-questions (get-configuration configurations :nr-of-questions))) + (average + (remove nil + (loop with processed-questions = 0 + with processed-scenes = 0 + for scene-path in (scenes clevr-world) + for question-path in (question-sets clevr-world) + for set-of-questions = (load-clevr-question-set question-path) + for path-entity = (make-instance 'pathname-entity :pathname scene-path) + for scene-name = (pathname-name scene-path) + if (and nr-of-scenes (>= processed-scenes nr-of-scenes)) + return accuracy + else + append (loop for clevr-question in (questions set-of-questions) + for q = (question clevr-question) + for answer = (answer clevr-question) + for (irl-program cipn nil) + = (multiple-value-list + (clevr-grammar::understand q)) + for scene-var = (extract-scene-unit-variable cipn) + for computed-answer = (compute-answer irl-program scene-var path-entity ontology) + for result = (get-result cipn answer computed-answer) + do (incf processed-questions) + (notify interaction-started configurations t processed-questions) + (notify question-evaluation scene-name q irl-program answer computed-answer result) + (notify interaction-finished configurations t processed-questions) + collect result into scene-accuracy + when (and nr-of-questions (>= processed-questions nr-of-questions)) + return scene-accuracy + finally (return scene-accuracy)) + into accuracy + do (incf processed-scenes) + finally + (return accuracy)))))) -;; make an empty error-table -(defun make-error-table () - (let ((error-table (make-hash-table))) - (setf (gethash 'count! error-table) '(0 . 0)) - (setf (gethash 'equal? error-table) '(0 . 0)) - (setf (gethash 'equal-integer error-table) '(0 . 0)) - (setf (gethash 'less-than error-table) '(0 . 0)) - (setf (gethash 'greater-than error-table) '(0 . 0)) - (setf (gethash 'exist error-table) '(0 . 0)) - (setf (gethash 'filter error-table) '(0 . 0)) - (setf (gethash 'intersect error-table) '(0 . 0)) - (setf (gethash 'query error-table) '(0 . 0)) - (setf (gethash 'relate error-table) '(0 . 0)) - (setf (gethash 'same error-table) '(0 . 0)) - (setf (gethash 'union! error-table) '(0 . 0)) - (setf (gethash 'unique error-table) '(0 . 0)) - error-table)) - - - -(defgeneric evaluate-mwm-accuracy (ontology &key data-split csv-filename errors-filename - nr-of-scenes nr-of-questions) - (:documentation "Evaluate the accuracy of the mwm-concepts.")) - - -(defmethod evaluate-mwm-accuracy (ontology - &key (data-split "val") - (csv-filename "mwm-evaluation") - (errors-filename "mwm-errors") - nr-of-scenes nr-of-questions) - (let ((clevr-world - (make-instance 'clevr-world - :data-sets (list data-split) - :load-questions t)) - (accuracy 0) - (error-table (make-error-table)) - (logfile - (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name csv-filename :type "txt"))) - (ensure-directories-exist logfile) - (with-open-file (log logfile :direction :output - :if-does-not-exist :create - :if-exists :overwrite) - (setf accuracy (compute-accuracy log clevr-world ontology error-table - :nr-of-scenes nr-of-scenes - :nr-of-questions nr-of-questions))) - (compute-error-rate error-table errors-filename) + + + + + + +(defun evaluate-mwm-accuracy (ontology config) + (notify reset-monitors) + (let* ((clevr-world + (make-instance 'clevr-world :load-questions t + :data-sets (list (get-configuration config :data-split)))) + (accuracy + (compute-accuracy clevr-world ontology config))) + (notify series-finished 1) + (notify batch-finished (get-configuration config :experiment-name)) accuracy)) +(defparameter *default-output-dir* + (babel-pathname :directory '("applications" "clevr" "mwm-evaluation" "raw-data"))) + -(defun evaluate-mwm-serie (serie-number) - (let* ((serie-name +(defun evaluate-mwm-serie (serie-number config-entries + &key (monitors (get-all-monitors)) + (output-dir *default-output-dir*)) + (let* ((experiment-name (format nil "serie-~a" serie-number)) + (config + (make-configuration + :entries (cons (cons :experiment-name experiment-name) + config-entries))) (concepts-directory (merge-pathnames - (make-pathname :directory (list :relative serie-name)) - *simulated-concepts-path*)) + (make-pathname :directory (list :relative experiment-name)) + (case (get-configuration config :world-type) + (:simulated *simulated-concepts-path*) + (:extracted *extracted-concepts-path*)))) (ontology - (make-mwm-ontology concepts-directory)) - (output-filename (format nil "mwm-evaluation-~a" serie-number)) - (error-filename (format nil "mwm-errors-~a" serie-number))) - (evaluate-mwm-accuracy ontology - :csv-filename output-filename - :errors-filename error-filename))) + (make-mwm-ontology concepts-directory))) + ;; adapt file-writing monitors so they output in the correct output-dir + (monitors::deactivate-all-monitors) + (loop for monitor-string in monitors + for monitor = (monitors::get-monitor (read-from-string monitor-string)) + do (monitors::activate-monitor-method (read-from-string monitor-string)) + when (slot-exists-p monitor 'file-name) + do (setf (slot-value monitor 'file-name) + (ensure-directories-exist + (merge-pathnames + (make-pathname :directory + `(:relative ,(string-downcase experiment-name)) + :name (pathname-name (file-name monitor)) + :type (pathname-type (file-name monitor))) + output-dir)))) + ;; run the evaluation + (evaluate-mwm-accuracy ontology config))) -(defun evaluate-all-series () +(defun evaluate-all-series (config-entries) (loop for serie-nr from 1 to 10 - for serie = (format nil "serie-~a" serie-nr) - for ontology = (make-mwm-ontology - (merge-pathnames - (make-pathname :directory (list :relative serie)) - *simulated-concepts-path*)) - do (evaluate-mwm-accuracy ontology - :csv-filename (concatenate 'string serie "-evaluation") - :errors-filename (concatenate 'string serie "-errors")))) + do (evaluate-mwm-serie serie-nr config-entries))) + + +;;---------;; +;; Metrics ;; +;;---------;; + +(defun compute-accuracy-per-primitive (serie-number) + (let ((logfiles + (directory + (merge-pathnames + (make-pathname :directory `(:relative ,(format nil "serie-~a" serie-number)) + :name :wild :type "log") + *default-output-dir*))) + results) + (loop for file in logfiles + for primitive = (intern (upcase (pathname-name file))) + do (with-open-file (stream file :direction :input) + (let* ((data (caar (read stream))) + (accuracy (average (remove nil data)))) + (push (cons primitive accuracy) results)))) + results)) + diff --git a/applications/clevr/mwm-evaluation/monitors.lisp b/applications/clevr/mwm-evaluation/monitors.lisp new file mode 100644 index 000000000..5861fb736 --- /dev/null +++ b/applications/clevr/mwm-evaluation/monitors.lisp @@ -0,0 +1,268 @@ +(in-package :mwm-evaluation) + +(defun get-all-monitors () + '("print-a-dot-for-each-interaction" + "log-mwm-evaluation" + "export-count!-primitive" + "export-equal?-primitive" + "export-equal-integer-primitive" + "export-less-than-primitive" + "export-greater-than-primitive" + "export-exist-primitive" + "export-filter-primitive" + "export-intersect-primitive" + "export-query-primitive" + "export-relate-primitive" + "export-same-primitive" + "export-union!-primitive" + "export-unique-primitive")) + + +;;;; print a dot for each interaction + +(define-monitor print-a-dot-for-each-interaction + :documentation "Prints a '.' for each interaction + and prints the number after :dot-interval") + +(define-event-handler (print-a-dot-for-each-interaction interaction-finished) + (cond ((= interaction-number 1) (format t "~%.")) + ((= (mod interaction-number + (get-configuration experiment :dot-interval)) 0) + (format t ". (~a)~%" interaction-number)) + (t (format t ".")))) + + +;;;; log the evaluation to a stream + +(define-monitor log-mwm-evaluation + :class 'stream-monitor + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "mwm-evaluation" :type "csv") + :interaction-separator #\linefeed + :series-separator #\space) + +(define-event-handler (log-mwm-evaluation question-evaluation) + ;; scene-name question answer computed-answer result + (let ((csv-line + (format nil "~a, ~a, ~a, ~a, ~a" + scene-name question answer + computed-answer result))) + (record-value monitor csv-line))) + + +;;;; collect data per primitive +;; count! +(define-monitor record-count!-primitive + :class 'data-recorder) + +(define-event-handler (record-count!-primitive question-evaluation) + (record-value + monitor + (when (find 'count! irl-program :key #'first) + result))) + +(define-monitor export-count!-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "count!" :type "log") + :data-sources '(record-count!-primitive)) + +;; equal? +(define-monitor record-equal?-primitive + :class 'data-recorder) + +(define-event-handler (record-equal?-primitive question-evaluation) + (record-value + monitor + (when (find 'equal? irl-program :key #'first) + result))) + +(define-monitor export-equal?-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "equal?" :type "log") + :data-sources '(record-equal?-primitive)) + +;; equal-integer +(define-monitor record-equal-integer-primitive + :class 'data-recorder) + +(define-event-handler (record-equal-integer-primitive question-evaluation) + (record-value + monitor + (when (find 'equal-integer irl-program :key #'first) + result))) + +(define-monitor export-equal-integer-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "equal-integer" :type "log") + :data-sources '(record-equal-integer-primitive)) + +;; less-than +(define-monitor record-less-than-primitive + :class 'data-recorder) + +(define-event-handler (record-less-than-primitive question-evaluation) + (record-value + monitor + (when (find 'less-than irl-program :key #'first) + result))) + +(define-monitor export-less-than-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "less-than" :type "log") + :data-sources '(record-less-than-primitive)) + +;; greater-than +(define-monitor record-greater-than-primitive + :class 'data-recorder) + +(define-event-handler (record-greater-than-primitive question-evaluation) + (record-value + monitor + (when (find 'greater-than irl-program :key #'first) + result))) + +(define-monitor export-greater-than-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "greater-than" :type "log") + :data-sources '(record-greater-than-primitive)) + +;; exist +(define-monitor record-exist-primitive + :class 'data-recorder) + +(define-event-handler (record-exist-primitive question-evaluation) + (record-value + monitor + (when (find 'exist irl-program :key #'first) + result))) + +(define-monitor export-exist-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "exist" :type "log") + :data-sources '(record-exist-primitive)) + +;; filter +(define-monitor record-filter-primitive + :class 'data-recorder) + +(define-event-handler (record-filter-primitive question-evaluation) + (record-value + monitor + (when (find 'filter irl-program :key #'first) + result))) + +(define-monitor export-filter-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "filter" :type "log") + :data-sources '(record-filter-primitive)) + +;; intersect +(define-monitor record-intersect-primitive + :class 'data-recorder) + +(define-event-handler (record-intersect-primitive question-evaluation) + (record-value + monitor + (when (find 'intersect irl-program :key #'first) + result))) + +(define-monitor export-intersect-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "intersect" :type "log") + :data-sources '(record-intersect-primitive)) + +;; query +(define-monitor record-query-primitive + :class 'data-recorder) + +(define-event-handler (record-query-primitive question-evaluation) + (record-value + monitor + (when (find 'query irl-program :key #'first) + result))) + +(define-monitor export-query-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "query" :type "log") + :data-sources '(record-query-primitive)) + +;; relate +(define-monitor record-relate-primitive + :class 'data-recorder) + +(define-event-handler (record-relate-primitive question-evaluation) + (record-value + monitor + (when (find 'relate irl-program :key #'first) + result))) + +(define-monitor export-relate-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "relate" :type "log") + :data-sources '(record-relate-primitive)) + +;; same +(define-monitor record-same-primitive + :class 'data-recorder) + +(define-event-handler (record-same-primitive question-evaluation) + (record-value + monitor + (when (find 'same irl-program :key #'first) + result))) + +(define-monitor export-same-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "same" :type "log") + :data-sources '(record-same-primitive)) + +;; union! +(define-monitor record-union!-primitive + :class 'data-recorder) + +(define-event-handler (record-union!-primitive question-evaluation) + (record-value + monitor + (when (find 'union! irl-program :key #'first) + result))) + +(define-monitor export-union!-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "union!" :type "log") + :data-sources '(record-union!-primitive)) + +;; unique +(define-monitor record-unique-primitive + :class 'data-recorder) + +(define-event-handler (record-unique-primitive question-evaluation) + (record-value + monitor + (when (find 'unique irl-program :key #'first) + result))) + +(define-monitor export-unique-primitive + :class 'lisp-data-file-writer + :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") + :name "unique" :type "log") + :data-sources '(record-unique-primitive)) + + + + + + + + diff --git a/applications/clevr/mwm-evaluation/start.lisp b/applications/clevr/mwm-evaluation/start.lisp index fe903137e..baa09d0a5 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -1,10 +1,30 @@ (ql:quickload :mwm-evaluation) (in-package :mwm-evaluation) + (activate-monitor trace-fcg) (activate-monitor trace-irl) (deactivate-all-monitors) +;;------------;; +;; Evaluation ;; +;;------------;; + +;; Evaluate one particular serie +(evaluate-mwm-serie 1) +(evaluate-mwm-serie 2) +(evaluate-mwm-serie 3) +(evaluate-mwm-serie 4) +(evaluate-mwm-serie 5) +(evaluate-mwm-serie 6) +(evaluate-mwm-serie 7) +(evaluate-mwm-serie 8) +(evaluate-mwm-serie 9) +(evaluate-mwm-serie 10) + +;; Evaluate on all series of concepts by loading the different series into the ontology +(evaluate-all-series) + ;;--------------;; ;; The ontology ;; ;;--------------;; @@ -13,9 +33,6 @@ (merge-pathnames (make-pathname :directory '(:relative "serie-1")) *simulated-concepts-path*)) -;; Show the ontology in the web-interface: -;; (add-element (make-html *my-ontology*)) - ;;---------;; ;; Testing ;; ;;---------;; @@ -34,32 +51,6 @@ (test-utterance-in-first-scene "How many things are left of the purple sphere that is behind the yellow thing?" ontology)) -;;------------;; -;; Evaluation ;; -;;------------;; - -(let ((ontology - (make-mwm-ontology - (merge-pathnames (make-pathname :directory '(:relative "serie-1")) - *simulated-concepts-path*)))) - ;; Evaluate on the ontology that is loaded manually - (evaluate-mwm-accuracy ontology :nr-of-scenes 10)) - -;; Evaluate one particular serie -(evaluate-mwm-serie 1) -(evaluate-mwm-serie 2) -(evaluate-mwm-serie 3) -(evaluate-mwm-serie 4) -(evaluate-mwm-serie 5) -(evaluate-mwm-serie 6) -(evaluate-mwm-serie 7) -(evaluate-mwm-serie 8) -(evaluate-mwm-serie 9) -(evaluate-mwm-serie 10) - -;; Evaluate on all series of concepts by loading the different series into the ontology -(evaluate-all-series) - -- GitLab From 7dfa95139d3a9b5a3a843da97833e53d8d7ead5b Mon Sep 17 00:00:00 2001 From: jnevens Date: Mon, 28 Mar 2022 16:14:57 +0200 Subject: [PATCH 050/157] minor changes to text-data-file-writer --- systems/monitors/data-monitors.lisp | 37 +++++++++++++++++------------ 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/systems/monitors/data-monitors.lisp b/systems/monitors/data-monitors.lisp index 54df43aa0..c36196882 100644 --- a/systems/monitors/data-monitors.lisp +++ b/systems/monitors/data-monitors.lisp @@ -240,10 +240,14 @@ :initform nil :initarg :add-experiment-to-file-name :accessor add-experiment-to-file-name) + (add-time-to-file-name + :documentation "When t, a yyyy-mm-dd-hh-mm-ss string is added to the file name" + :initform nil :initarg :add-time-to-file-name + :accessor add-time-to-file-name) (add-time-and-experiment-to-file-name :documentation "When t, the file name is prefixed with the name of the experiment class and a yyyy-mm-dd-hh-mm-ss string." - :initform t + :initform nil :initarg :add-time-and-experiment-to-file-name :accessor add-time-and-experiment-to-file-name) (add-job-and-task-id-to-file-name @@ -279,12 +283,14 @@ (cond ((add-experiment-to-file-name monitor) (make-file-name-with-experiment-class (file-name monitor) experiment-class)) + ((add-time-to-file-name monitor) + (make-file-name-with-time (file-name monitor))) ((add-time-and-experiment-to-file-name monitor) (make-file-name-with-time-and-experiment-class (file-name monitor) experiment-class)) ((add-job-and-task-id-to-file-name monitor) (make-file-name-with-job-and-task-id (file-name monitor) - experiment-class)) + experiment-class)) (t (file-name monitor))))) (with-open-file (file file-name :direction :output :if-exists :supersede :if-does-not-exist :create) @@ -339,17 +345,19 @@ (defclass text-data-file-writer (data-file-writer) ((column-separator :initarg :column-separator :accessor column-separator - :initform " " :documentation "a string used to separate columns") + :type character :initform #\, + :documentation "a character used to separate columns") (comment-string :initarg :comment-string :accessor comment-string - :initform "#" :documentation "how to start a comment line")) + :type character :initform #\# + :documentation "how to start a comment line")) (:documentation "Writes the data in columns to a text file")) (defmethod initialize-instance :around ((monitor text-data-file-writer) &key column-separator comment-string &allow-other-keys) (setf (error-occured-during-initialization monitor) t) - (when column-separator (check-type column-separator string)) - (when comment-string (check-type comment-string string)) + (when column-separator (check-type column-separator character)) + (when comment-string (check-type comment-string character)) (setf (error-occured-during-initialization monitor) nil) (call-next-method)) @@ -362,12 +370,12 @@ for i from (- number-of-rows 1) downto 0 do (vector-push i column) finally (return column)))) - (column-names (list (format nil "~a interaction number" (comment-string monitor))))) + (column-names (list (format nil "~c interaction number" (comment-string monitor))))) (loop for source in (reverse (sources monitor)) for source-number from 0 do (loop for series-number from 0 for series in (reverse (cdar source)) ; (cdr (car - do (push (format nil "~a ~a-~a" + do (push (format nil "~c ~a-~a" (comment-string monitor) (nth source-number (reverse (monitor-ids-of-sources monitor))) series-number) column-names) @@ -376,16 +384,16 @@ for el in series do (vector-push el series-array) finally (return series-array)) columns))) - (format stream "~%~a This file was created by the~%~a text-data-file-writer ~a." + (format stream "~%~c This file was created by the~%~c text-data-file-writer ~a." (comment-string monitor) (comment-string monitor) (id monitor)) - (format stream "~%~a The columns are:~%~a ~{~%~a~}" + (format stream "~%~c The columns are:~%~c ~{~%~a~}" (comment-string monitor) (comment-string monitor) (reverse column-names)) (loop with reversed-columns = (reverse columns) for row from (- number-of-rows 1) downto 0 ; long do (format stream "~%") (loop for column in reversed-columns ;short - do (format stream "~f~a" (aref column row) (column-separator monitor)))))) + do (format stream "~f~c" (aref column row) (column-separator monitor)))))) ;; ############################################################################ @@ -405,9 +413,8 @@ (loop for source in (reverse (sources monitor)) for source-number from 0 do (loop for series-number from 0 - for series in (reverse (cdar source)) ; (cdr (car + for series in (reverse (cdar source)) for column-name = (format nil "~a-~a" - ;(comment-string monitor) (nth source-number (reverse (monitor-ids-of-sources monitor))) series-number) @@ -421,7 +428,7 @@ (vector-push column-name column-data) (push column-data columns))) - (format stream "~%~a This file was created by the~%~a csv-data-file-writer ~a." + (format stream "~%~c This file was created by the~%~c csv-data-file-writer ~a." (comment-string monitor) (comment-string monitor) (id monitor)) (loop with reversed-columns = (reverse columns) @@ -432,5 +439,5 @@ if (= i number-of-columns) do (format stream "~f" (aref column row)) else - do (format stream "~f~a" (aref column row) (column-separator monitor)))))) + do (format stream "~f~c" (aref column row) (column-separator monitor)))))) -- GitLab From d4ebe96c0a2f96b1970ddc3f4be422a7bf0d51df Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Mon, 28 Mar 2022 17:32:44 +0200 Subject: [PATCH 051/157] progress on evaluation --- .../visual-dialog/evaluation/evaluation.lisp | 104 +++++++++++++++--- 1 file changed, 87 insertions(+), 17 deletions(-) diff --git a/applications/visual-dialog/evaluation/evaluation.lisp b/applications/visual-dialog/evaluation/evaluation.lisp index b8aa54b94..cb9acf913 100644 --- a/applications/visual-dialog/evaluation/evaluation.lisp +++ b/applications/visual-dialog/evaluation/evaluation.lisp @@ -54,27 +54,26 @@ (results (loop for scene from start-scene to end-scene append (progn - (format str "evaluation of scene ~a~%" scene) (force-output str) - (format t "evaluation of scene ~a~%" scene) - (loop for dialog from 0 to number-of-dialogs - for (result-whole-dialog result-one-dialog) = (multiple-value-list - (evaluate-dialog :scene-index scene - :dialog-index dialog - :world world - :ontology ontology)) - do (progn - (format str "~a : ~a~%" dialog result-one-dialog) (force-output str)) - collect (list result-whole-dialog result-one-dialog))))) + (format t "evaluation of scene ~a~%" scene) + (loop for dialog from 0 to number-of-dialogs + for (result-whole-dialog result-one-dialog) = (multiple-value-list + (evaluate-dialog :scene-index scene + :dialog-index dialog + :world world + :ontology ontology)) + do (progn + (format str "~a, ~a : ~a~%" scene dialog result-one-dialog) (force-output str)) + collect (list result-whole-dialog result-one-dialog))))) (dialog-level-accuracy (average (loop for result in results - collect (if (eql (first result) T) - 1 0)))) + collect (if (eql (first result) T) + 1 0)))) ;;append (question-level-accuracy (average (loop for result in results - append (second result))))) - (format str "dialog-level-accuracy: ~a~%" dialog-level-accuracy) (force-output str) - (format str "question-level-accuracy: ~a~%" question-level-accuracy) (force-output str) + append (second result))))) + (format str "dialog-level-accuracy : ~a~%" dialog-level-accuracy) (force-output str) + (format str "question-level-accuracy : ~a~%" question-level-accuracy) (force-output str) question-level-accuracy)))) @@ -104,4 +103,75 @@ :entries '((:dataset . :mnist) (:datasplit . :train) (:mode . :hybrid))))) - (evaluate-dialogs start-scene end-scene world))) \ No newline at end of file + (evaluate-dialogs start-scene end-scene world))) + +(defun calculate-accuracy-from-dir (dir) + (let* ((files (directory dir)) + (results + (loop for file in files + for file-content = (open file) + append (result-file->result-list file-content)))) + (average results))) + +(defun result-file->result-list (stream &key number-of-lines) + "collect all the lines that are results" + (loop for line = (read-line stream nil nil) + while line + when (and (not (string= (first-word line) "evaluation")) + (not (string= (first-word line) "dialog-level-accuracy:")) + (not (string= (first-word line) "question-level-accuracy:"))) + append (read-from-string (last-elt (split-string line ":"))))) + +(defun collect-failed-dialogs (dir) + (let* ((files (directory dir)) + (failed-dialogs + (loop for file in files + for file-content = (open file) + for question-result = (last-elt (split-string (last-elt (stream->list file-content)) " ")) + when (not (equal question-result "1.0")) + collect file))) + failed-dialogs)) + +(defun check-failed-dialogs (failed-dialogs multiple-middles-file) + (with-open-file (str multiple-middles-file) + (loop for dialog in failed-dialogs + for file-content = (open dialog) + for lines = (stream->list file-content) + do (loop for line in lines + for split-line = (split-string line ":") + for (scene dialog) = (multiple-value-list (split-string (first split-line) ",")) + for results = (read-from-string (last-elt split-line)) + if (and (not (equal (average results) 1)) + (not (find scene (read-from-string str)))) + collect scene)))) + + +(defun collect-problematic-middle-scenes () + (let* ((ontology (build-ontology)) + (world (make-instance 'world :configuration '((:dataset . :clevr) + (:datasplit . :train) + (:mode . :symbolic)))) + (multiple-middles + (loop with i = 0 + for scene in (scenes world) + + for s = (get-scene-by-index world i) + for context = (make-context world) + for number-of-middles = (length (middle (scene-configuration (object-set (first (set-items context)))))) + if (< number-of-middles 2) + do (progn (print i) + (incf i)) + else + collect i + and do (progn (print i) + (incf i)))) + (outfile (babel-pathname :directory '("applications" "visual-dialog" "evaluation") + :name "scenes-with-multiple-middles" + :type "lisp"))) + (with-open-file (str outfile + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (format str "~a" multiple-middles) (force-output str)) + multiple-middles)) + -- GitLab From f21c8c5a20984c53ec27aaa7801f8c9d901e7252 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 29 Mar 2022 10:28:41 +0200 Subject: [PATCH 052/157] removing application order constraints for substitution by fixing unit names --- ...em-based+holistic+holistic--substitution.lisp | 16 +++++++++------- .../diagnostics-and-repairs/utils.lisp | 8 ++++---- .../tests/test-substitution-repair.lisp | 2 +- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp index fcec9d0a6..a9456a8a7 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp @@ -84,9 +84,9 @@ based on existing construction with sufficient overlap." :cxn-type 'item-based)) ;; unit names (unit-name-holistic-cxn-1 - (unit-ify (make-cxn-name non-overlapping-form-cxn cxn-inventory :add-cxn-suffix nil))) + leftmost-unit-holistic-cxn-1) (unit-name-holistic-cxn-2 - (unit-ify (make-cxn-name non-overlapping-form-observation cxn-inventory :add-cxn-suffix nil))) + leftmost-unit-holistic-cxn-2) ;; args and syn-cat (lex-class-holistic-cxn-1 @@ -166,7 +166,11 @@ based on existing construction with sufficient overlap." (syn-cat (phrase-type item-based)) (subunits (,unit-name-holistic-cxn-2))) (,unit-name-holistic-cxn-2 - (syn-cat (lex-class ,lex-class-item-based-cxn))) + (syn-cat (lex-class ,lex-class-item-based-cxn)) + (boundaries + (left ,(first rewritten-boundaries)) + (right ,(second rewritten-boundaries))) + ) <- (?item-based-unit (HASH meaning ,overlapping-meaning-observation) @@ -175,9 +179,7 @@ based on existing construction with sufficient overlap." (,unit-name-holistic-cxn-2 (args ,args-holistic-cxn-2) -- - (boundaries - (left ,(first rewritten-boundaries)) - (right ,(second rewritten-boundaries))))) + )) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic+holistic--substitution :meaning ,(loop for predicate in overlapping-meaning-observation @@ -189,7 +191,7 @@ based on existing construction with sufficient overlap." :cxn-inventory ,(copy-object cxn-inventory))))))) (existing-cxns (list holistic-cxn-2 holistic-cxn-1 existing-item-based-cxn)) - (cxns-to-apply (list new-holistic-cxn-2 new-item-based-cxn)) + (cxns-to-apply (list new-item-based-cxn new-holistic-cxn-2)) (cat-links-to-add (list categorial-link-1 categorial-link-2)) (cxns-to-consolidate (loop for cxn in (list new-holistic-cxn-1 new-holistic-cxn-2 new-item-based-cxn) when (not (member cxn existing-cxns)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 66cc8914c..1a6d99a18 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -95,10 +95,10 @@ (right-var (make-var (make-const (format nil "?RIGHT-~a-BOUNDARY" placeholder-var)))) (left-boundary (first boundaries)) (right-boundary (second boundaries)) - (matching-left-predicate (find left-boundary new-form-constraints :key #'third)) - (matching-right-predicate (find right-boundary new-form-constraints :key #'second))) - (when matching-left-predicate - (setf (nth 2 matching-left-predicate) left-var)) + ;(matching-left-predicate (find left-boundary new-form-constraints :key #'third)) + (matching-right-predicate (find right-boundary (extract-form-predicate-by-type new-form-constraints 'meets) :key #'second))) + ;(when matching-left-predicate + ; (setf (nth 2 matching-left-predicate) left-var)) (when matching-right-predicate (setf (nth 1 matching-right-predicate) right-var)) (values new-form-constraints (list left-var right-var)))) diff --git a/systems/grammar-learning/tests/test-substitution-repair.lisp b/systems/grammar-learning/tests/test-substitution-repair.lisp index 93ec6a949..8245996fc 100644 --- a/systems/grammar-learning/tests/test-substitution-repair.lisp +++ b/systems/grammar-learning/tests/test-substitution-repair.lisp @@ -1,6 +1,6 @@ (in-package :grammar-learning) -(defun test-substitution-repair-comprehension () +(deftest test-substitution-repair-comprehension () (let* ((experiment (set-up-cxn-inventory-and-repairs)) (cxn-inventory (grammar (first (agents experiment))))) (comprehend "The large gray object is what shape?" -- GitLab From 6b243490405a9385e67855ca3001bb4d7afff954 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 29 Mar 2022 10:52:44 +0200 Subject: [PATCH 053/157] updating left boundary name --- systems/grammar-learning/diagnostics-and-repairs/utils.lisp | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 1a6d99a18..387364db4 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -91,7 +91,6 @@ return both the form constraints and the new boundary list" (let* ((new-form-constraints (copy-object form-constraints)) (placeholder-var (string-upcase (if placeholder-var placeholder-var "?X"))) - (left-var (make-var (make-const (format nil "?LEFT-~a-BOUNDARY" placeholder-var)))) (right-var (make-var (make-const (format nil "?RIGHT-~a-BOUNDARY" placeholder-var)))) (left-boundary (first boundaries)) (right-boundary (second boundaries)) @@ -101,7 +100,7 @@ ; (setf (nth 2 matching-left-predicate) left-var)) (when matching-right-predicate (setf (nth 1 matching-right-predicate) right-var)) - (values new-form-constraints (list left-var right-var)))) + (values new-form-constraints (list left-boundary right-var)))) (defun get-boundary-units (form-constraints) "returns the leftmost and rightmost unit based on meets constraints, even when the meets predicates are in a random order" -- GitLab From 7ee0d9ce5d56fe93aafa01e23f36f296083a443f Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 29 Mar 2022 11:12:30 +0200 Subject: [PATCH 054/157] updated unit names and boundaries in addition repair --- ...lophrase-to-item-based+holistic--addition.lisp | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp index e37c5e747..6139c6d6d 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp @@ -80,9 +80,7 @@ overlapping-meaning cxn-inventory :cxn-type 'item-based)) - (unit-name-holistic-cxn - (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil)) - ) + (unit-name-holistic-cxn leftmost-unit-holistic-cxn) ;; lex-class (lex-class-holistic-cxn (if existing-holistic-cxn @@ -129,7 +127,10 @@ (syn-cat (phrase-type item-based)) (subunits (,unit-name-holistic-cxn))) (,unit-name-holistic-cxn - (syn-cat (lex-class ,lex-class-item-based-cxn))) + (syn-cat (lex-class ,lex-class-item-based-cxn)) + (boundaries + (left ,(first rewritten-boundaries)) + (right ,(second rewritten-boundaries)))) <- (?item-based-unit (HASH meaning ,overlapping-meaning) @@ -138,9 +139,7 @@ (,unit-name-holistic-cxn (args ,args-holistic-cxn) -- - (boundaries - (left ,(first rewritten-boundaries)) - (right ,(second rewritten-boundaries))))) + )) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic--addition :meaning ,(loop for predicate in overlapping-meaning @@ -152,7 +151,7 @@ :cxn-inventory ,(copy-object cxn-inventory))))))) (existing-cxns (list existing-holistic-cxn existing-item-based-cxn)) - (cxns-to-apply (list holistic-cxn item-based-cxn)) + (cxns-to-apply (list item-based-cxn holistic-cxn)) (cat-links-to-add (list categorial-link)) (cxns-to-consolidate (loop for cxn in (list holistic-cxn item-based-cxn) when (not (member cxn existing-cxns)) -- GitLab From 24a5247d90d3069c9b974591c9c605b50e0b8704 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 29 Mar 2022 12:02:08 +0200 Subject: [PATCH 055/157] updated unit names and boundaries in deletion repair --- ...item-based+holistic+holophrase--deletion.lisp | 16 ++++++++-------- .../tests/test-deletion-repair.lisp | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp index ff8c6a60e..e3306f4aa 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holophrase--deletion.lisp @@ -86,8 +86,7 @@ overlapping-meaning cxn-inventory :cxn-type 'item-based)) - (unit-name-holistic-cxn - (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil))) + (unit-name-holistic-cxn leftmost-unit-holistic-cxn) ;; lex-class (lex-class-holistic-cxn (if existing-holistic-cxn @@ -125,8 +124,8 @@ (args ,args-holophrase-cxn) (boundaries (left ,leftmost-unit-holophrase-cxn) - (right ,rightmost-unit-holophrase-cxn)) - ) + (right ,rightmost-unit-holophrase-cxn))) + <- (?holophrase-unit (HASH meaning ,meaning) @@ -166,7 +165,10 @@ (syn-cat (phrase-type item-based)) (subunits (,unit-name-holistic-cxn))) (,unit-name-holistic-cxn - (syn-cat (lex-class ,lex-class-item-based-cxn))) + (syn-cat (lex-class ,lex-class-item-based-cxn)) + (boundaries + (left ,(first rewritten-boundaries)) + (right ,(second rewritten-boundaries)))) <- (?item-based-unit (HASH meaning ,overlapping-meaning) @@ -175,9 +177,7 @@ (,unit-name-holistic-cxn (args ,args-holistic-cxn) -- - (boundaries - (left ,(first rewritten-boundaries)) - (right ,(second rewritten-boundaries))))) + )) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic+holophrase--deletion :meaning ,(loop for predicate in overlapping-meaning diff --git a/systems/grammar-learning/tests/test-deletion-repair.lisp b/systems/grammar-learning/tests/test-deletion-repair.lisp index f8b95dd65..4e776066a 100644 --- a/systems/grammar-learning/tests/test-deletion-repair.lisp +++ b/systems/grammar-learning/tests/test-deletion-repair.lisp @@ -124,7 +124,7 @@ (defun run-deletion-tests () (test-deletion-repair-comprehension) - (test-reordered-double-deletion-repair-comprehension) + (test-reordered-double-deletion-repair-comprehension) ; should be holophrase (test-double-deletion-repair-comprehension) ) -- GitLab From 86243c4d8e37090666299a38f89183daaeaf3534 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Tue, 29 Mar 2022 12:20:06 +0200 Subject: [PATCH 056/157] updated unit names and boundaries in holistic-to-item-based repair --- .../repair-holistic-to-item-based-cxn.lisp | 15 ++++++++------- .../tests/test-holistic-to-item-based-repair.lisp | 4 ++-- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index d0ebde803..1e4f39a2d 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -59,18 +59,19 @@ (holistic-cxn-subunit-blocks (multiple-value-list (loop for unit in resulting-units for form-constraints = (variablify-form-constraints-with-constants (unit-feature-value unit 'form)) - for holistic-cxn-unit-name = (unit-ify (make-cxn-name form-constraints original-cxn-set :add-cxn-suffix nil)) + for boundaries = (unit-feature-value unit 'boundaries) + for string-var = (first (get-boundary-units form-constraints)) for car = (get-car-for-unit unit optimal-coverage-cars) for subtracted-meaning = (get-subtracted-meaning-from-car car gold-standard-meaning) for args = (extract-args-from-irl-network subtracted-meaning) - for boundaries = (unit-feature-value unit 'boundaries) for boundary-list = (list (variablify (second (first boundaries))) (variablify (second (second boundaries)))) for holistic-slot-lex-class = (create-item-based-lex-class-with-var placeholder-var-string-predicates cxn-name-item-based-cxn string-var) ;; look up the X and Y in bindings for placeholder-var = (third (find string-var placeholder-var-string-predicates :key #'second)) for updated-form-constraints-and-boundaries = (multiple-value-list (add-boundaries-to-form-constraints item-based-cxn-form-constraints boundary-list :placeholder-var placeholder-var)) for updated-form-constraints = (first updated-form-constraints-and-boundaries) for updated-boundaries = (second updated-form-constraints-and-boundaries) + for holistic-cxn-unit-name = (first updated-boundaries) for holistic-cxn-lex-class = (unit-feature-value (unit-feature-value unit 'syn-cat) 'lex-class) for categorial-link = (cons holistic-cxn-lex-class holistic-slot-lex-class) do (setf item-based-cxn-form-constraints updated-form-constraints) @@ -78,13 +79,13 @@ collect categorial-link into categorial-links collect holistic-cxn-unit-name into holistic-subunit-names collect `(,holistic-cxn-unit-name - (syn-cat (gl::lex-class ,holistic-slot-lex-class))) into contributing-units + (syn-cat (gl::lex-class ,holistic-slot-lex-class)) + (boundaries + (left ,(first updated-boundaries)) + (right ,(second updated-boundaries)))) into contributing-units collect `(,holistic-cxn-unit-name (args ,args) -- - (boundaries - (left ,(first updated-boundaries)) - (right ,(second updated-boundaries))) ) into conditional-units finally (return (values conditional-units contributing-units holistic-subunit-names categorial-links subtracted-meanings))))) (holistic-cxn-conditional-units @@ -123,7 +124,7 @@ return (first predicate)) :string ,(third (find 'string item-based-cxn-form-constraints :key #'first))) :cxn-inventory ,(copy-object original-cxn-set))))))) - (cxns-to-apply (append (mapcar #'original-cxn (mapcar #'car-applied-cxn optimal-coverage-cars)) (list item-based-cxn))) + (cxns-to-apply (append (list item-based-cxn) (mapcar #'original-cxn (mapcar #'car-applied-cxn optimal-coverage-cars)))) (cxns-to-consolidate (unless existing-item-based-cxn (list item-based-cxn)))) (when existing-item-based-cxn ; we ordered the units, so they'll always be in the order in which they appear in the utterance diff --git a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp index 8da456dab..3909835e7 100644 --- a/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp +++ b/systems/grammar-learning/tests/test-holistic-to-item-based-repair.lisp @@ -273,9 +273,9 @@ (defun run-holistic-to-item-based-tests () (test-holistic-to-item-based-from-substitution-comprehension) - (test-holistic-to-item-based-from-double-substitution-comprehension) + (test-holistic-to-item-based-from-double-substitution-comprehension) (test-multiple-holistic-to-item-based-repair-comprehension) - (test-holistic-to-item-based-duplicates-comprehension) + (test-holistic-to-item-based-duplicates-comprehension) ; should be holophrase (test-double-holistic-to-item-based-from-substitution-repair-comprehension) (test-holistic-to-item-based-double-comprehension) -- GitLab From 46fbf43858b05d1abe4a88143170d554d6648254 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Tue, 29 Mar 2022 12:54:43 +0200 Subject: [PATCH 057/157] fixed info structure cxns --- .../bidirectional_grammar_info_arg_struct.fcg | 274 +++++++++++------- 1 file changed, 163 insertions(+), 111 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 017c114bc..bdea005b1 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -7,11 +7,9 @@ :feature-types ((args sequence) (form set-of-predicates) (meaning set-of-predicates) - (constituents sequence) - (dependents sequence) + (subunits set) (footprints set) (case sequence)) - :hierarchy-features (constituents dependents) :fcg-configurations ((:max-nr-of-nodes . 40000) (:parse-goal-tests :no-strings-in-root :connected-structure :no-applicable-cxns) (:production-goal-tests @@ -216,6 +214,7 @@ :disable-automatic-footprints t) + (def-fcg-cxn Blumen-cxn ((?flowers-word (referent ?x) ;set of values @@ -330,7 +329,7 @@ (referent ?x) (syn-cat (lex-class noun-phrase) (case ?case)) - (constituents (?article ?noun)) + (subunits (?article ?noun)) (boundaries (leftmost-unit ?article) (rightmost-unit ?noun))) (?article @@ -365,7 +364,7 @@ (referent ?x) (syn-cat (lex-class prep-phrase) (case ?case)) - (constituents (?contracted-prep ?noun)) + (subunits (?contracted-prep ?noun)) (boundaries (leftmost-unit ?contracted-prep) (rightmost-unit ?noun))) (?contracted-prep @@ -396,15 +395,17 @@ :disable-automatic-footprints t) - -;;;; with this one prepositional phrases are generated even when there is only an article and no preposition - +;;;; der twice (def-fcg-cxn prepositional-phrase-cxn ((?prep-phrase (referent ?x) (syn-cat (lex-class prep-phrase) - (case ?case)) - (constituents (?preposition ?article ?noun)) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p)))) + (subunits (?preposition ?article ?noun)) (boundaries (leftmost-unit ?preposition) (rightmost-unit ?noun))) (?preposition @@ -413,38 +414,55 @@ (?article (referent ?x) - (part-of-noun-phrase +)) + ;(part-of-noun-phrase +)) + ) (?noun - (footprints (determined))) + (footprints (determined)) + ) <- (?preposition -- (syn-cat (lex-class preposition) - (case ?case))) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) (?article -- (syn-cat (lex-class article) - (case ?case))) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) (?noun - (footprints (not determined)) + (referent ?x) + (footprints (not determined)) (syn-cat (lex-class noun) - (case ?case)) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p)))) -- (footprints (not determined)) (syn-cat (lex-class noun) - (case ?case))) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) (?prep-phrase -- (HASH form ((meets ?preposition ?article) (meets ?article ?noun))) )) - :disable-automatic-footprints t) - - - + :disable-automatic-footprints t) + (def-fcg-cxn kommt-cxn @@ -503,7 +521,7 @@ (def-fcg-cxn ist-gefahren-cxn ((?drove-word - (constituents (?aux-unit ?participle-unit)) + (subunits (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (aspect perfect) (type intransitive)) @@ -528,7 +546,7 @@ (def-fcg-cxn hat-mitgebracht-cxn ((?brought-word - (constituents (?aux-unit ?participle-unit)) + (subunits (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (aspect perfect) (type ditransitive)) @@ -553,7 +571,7 @@ (def-fcg-cxn transitive-argument-structure-cxn ((?transitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit))) <- (?verb-unit (syn-cat (lex-class verb) @@ -608,19 +626,18 @@ -- ))) - -(def-fcg-cxn topicalized-transitive-information-structure-cxn - ((?topicalized-transitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit))) - (?arg-and-info-struct-unit - (constituents (?topicalized-transitive-information-structure-unit ?argument-structure-unit))) +(def-fcg-cxn topic-arg0-arg1-information-structure-cxn + ( <- - (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit)) - -- - (constituents (?verb-unit ?agent-unit ?patient-unit)) - ) + (subunits (?verb-unit ?agent-unit ?patient-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit))) + (?verb-unit (syn-cat (lex-class verb) (type transitive) @@ -633,28 +650,73 @@ (referent ?v)) (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) -- (referent ?arg0) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) (?patient-unit + (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit)) -- - (referent ?arg1) + (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit))) - (?topicalized-transitive-information-structure-unit - (HASH meaning ((topicalized ?arg1 +))) + )) + +(def-fcg-cxn arg0-topic-arg1-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit)) + (HASH meaning ((topicalized ?arg1 +))) + -- (HASH form ((meets ?rightmost-patient-unit ?verb-unit) (meets ?verb-unit ?leftmost-agent-unit))) - ))) + (subunits (?verb-unit ?agent-unit ?patient-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type transitive) + (aspect ?aspect)) + -- + (syn-cat (lex-class verb) + (type transitive) + (aspect ?aspect))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?patient-unit + (referent ?arg1) + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + + (referent ?arg1) + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + + )) + + @@ -662,7 +724,7 @@ (def-fcg-cxn ditransitive-argument-structure-cxn ((?ditransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) (?agent-unit (syn-cat (syn-role subject))) (?patient-unit @@ -737,17 +799,18 @@ -- ))) -(def-fcg-cxn ditransitive-information-structure-cxn - ((?ditransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) - (?arg-and-info-struct-unit - (constituents (?ditransitive-information-structure-unit ?argument-structure-unit))) +(def-fcg-cxn topic-arg0-arg1-arg2-information-structure-cxn + ( <- - (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) - -- - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-receiver-unit) + (meets ?rightmost-receiver-unit ?leftmost-patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) (?verb-unit (syn-cat (lex-class verb) @@ -758,10 +821,12 @@ (type ditransitive))) (?agent-unit + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) -- + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) @@ -785,31 +850,26 @@ (syn-cat (syn-role indirect-object)) (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit))) + + )) - (?ditransitive-information-structure-unit - -- - (HASH form ((meets ?rightmost-agent-unit ?verb-unit) - (meets ?verb-unit ?leftmost-receiver-unit) - (meets ?rightmost-receiver-unit ?leftmost-patient-unit))) - ))) - - - -;;;;WORKS ONLY IN COMPREHENSION - NO FORMULATION -(def-fcg-cxn topicalized-ditransitive-information-structure-cxn - ((?topicalized-ditransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) - (?arg-and-info-struct-unit - (constituents (?topicalized-ditransitive-information-structure-unit ?argument-structure-unit))) +(def-fcg-cxn arg0-arg1-topic-arg2-information-structure-cxn + ( <- (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) - -- - (constituents (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + (HASH meaning ((topicalized ?arg2 +))) + + -- + (HASH form ((meets ?rightmost-receiver-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit) + (meets ?rightmost-agent-unit ?leftmost-patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) (?verb-unit (syn-cat (lex-class verb) (type ditransitive)) + -- (syn-cat (lex-class verb) (type ditransitive))) @@ -818,52 +878,44 @@ (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) - -- - (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) - (?patient-unit (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit)) - -- - (referent ?arg1) + (syn-cat (syn-role direct-object)) (boundaries (leftmost-unit ?leftmost-patient-unit) (rightmost-unit ?rightmost-patient-unit))) - (?receiver-unit + (referent ?arg2) (syn-cat (syn-role indirect-object)) (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit)) - (HASH meaning ((topicalized ?arg2 +))) - -- (referent ?arg2) (syn-cat (syn-role indirect-object)) (boundaries (leftmost-unit ?leftmost-receiver-unit) (rightmost-unit ?rightmost-receiver-unit))) - - (?topicalized-ditransitive-information-structure-unit - -- - (HASH form ((meets ?rightmost-receiver-unit ?verb-unit) - (meets ?verb-unit ?leftmost-agent-unit) - (meets ?rightmost-agent-unit ?leftmost-patient-unit))) - ))) + )) + + + + ;der Mann geht zur Arbeit (def-fcg-cxn intransitive-argument-structure-cxn ((?intransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?agent-unit (syn-cat (syn-role subject))) (?location-unit @@ -921,7 +973,7 @@ #|(def-fcg-cxn intransitive-come-argument-structure-cxn ((?intransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?agent-unit (syn-cat (syn-role subject))) (?location-unit @@ -982,14 +1034,14 @@ (def-fcg-cxn intransitive-information-structure-cxn ((?intransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?intransitive-information-structure-unit ?argument-structure-unit))) + (subunits (?intransitive-information-structure-unit ?argument-structure-unit))) <- (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?location-unit)) -- - (constituents (?verb-unit ?agent-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?location-unit)) ) (?verb-unit @@ -1033,14 +1085,14 @@ #|(def-fcg-cxn intransitive-come-information-structure-cxn ((?intransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?intransitive-information-structure-unit ?argument-structure-unit))) + (subunits (?intransitive-information-structure-unit ?argument-structure-unit))) <- (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?location-unit)) -- - (constituents (?verb-unit ?agent-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?location-unit)) ) (?verb-unit @@ -1088,18 +1140,18 @@ (def-fcg-cxn intransitive-information-structure-past-cxn ((?intransitive-information-structure-past-unit - (constituents (?verb-unit ?agent-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?intransitive-information-structure-past-unit ?argument-structure-unit))) + (subunits (?intransitive-information-structure-past-unit ?argument-structure-unit))) <- (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?location-unit)) -- - (constituents (?verb-unit ?agent-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?location-unit)) ) (?verb-unit - (constituents (?aux-unit ?participle-unit)) + (subunits (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (type intransitive) (aspect perfect)) @@ -1107,7 +1159,7 @@ (rightmost-unit ?participle-unit)) -- - (constituents (?aux-unit ?participle-unit)) + (subunits (?aux-unit ?participle-unit)) (syn-cat (lex-class verb) (type intransitive) (aspect perfect)) @@ -1153,7 +1205,7 @@ (def-fcg-cxn double-intransitive-argument-structure-cxn ((?double-intransitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) (?agent-unit (syn-cat (syn-role subject))) (?ad-info-unit @@ -1224,15 +1276,15 @@ (def-fcg-cxn double-intransitive-information-structure-cxn ((?double-intransitive-information-structure-unit - (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) (?arg-and-info-struct-unit - (constituents (?double-intransitive-information-structure-unit ?argument-structure-unit))) + (subunits (?double-intransitive-information-structure-unit ?argument-structure-unit))) <- (?argument-structure-unit - (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit)) + (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit)) -- - (constituents (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) (?verb-unit (syn-cat (lex-class verb) @@ -1347,23 +1399,23 @@ ;;; NPs with Determiners and PPs with NP+P or Contracted P -;(formulate-all '((clown x))) +(formulate-all '((clown x))) ;;;; der Mann sucht den Clown -;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c))) +(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized m +))) ;;; den Clown sucht der Mann -;(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) +(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) ;;; der Mann schenkt dem Clown die Blumen -;(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c))) +(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized m +))) -;;; dem Clown schenkt der Mann die Blumen -;(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) +;;; dem Clown schenkt der Mann die Blumen - stuck +(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) -;;;der Mann geht zur Arbeit -;(formulate '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s))) +;;;der Mann geht zum Shop +(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s))) ;;; der Mann kommt aus dem Shop -- GitLab From 22b7ada7446db6387968a672d5dad4e9fede2e07 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 14:31:29 +0200 Subject: [PATCH 058/157] modified conceptualise method (tutor looks for discriminative spatial relationships), changed name mwm-agent to spatial-agent and removed learner-speaks methods --- experiments/spatial-concept-game/agent.lisp | 336 +++----------------- 1 file changed, 48 insertions(+), 288 deletions(-) diff --git a/experiments/spatial-concept-game/agent.lisp b/experiments/spatial-concept-game/agent.lisp index 0901085d1..472a9afe6 100644 --- a/experiments/spatial-concept-game/agent.lisp +++ b/experiments/spatial-concept-game/agent.lisp @@ -1,38 +1,41 @@ (in-package :spatial-concepts) ;; ------------- -;; + MWM agent + +;; + SPATIAL agent + ;; ------------- -(defclass mwm-agent (agent) +(defclass spatial-agent (agent) ((lexicon :documentation "The agent's lexicon" :type list :accessor lexicon :initform nil) (concept-history :documentation "Maintaining versions of concepts" - :type list :accessor concept-history :initform nil)) + :type list :accessor concept-history :initform nil) + (pointed-object + :documentation "Id of the object the tutor points to in production" + :type (or symbol fixnum) :accessor pointed-object :initform nil)) (:documentation "The agent class")) ;; --------------------------- ;; + Agent utility functions + ;; --------------------------- -(defmethod speakerp ((agent mwm-agent)) +(defmethod speakerp ((agent spatial-agent)) (eql (discourse-role agent) 'speaker)) -(defmethod hearerp ((agent mwm-agent)) +(defmethod hearerp ((agent spatial-agent)) (eql (discourse-role agent) 'hearer)) -(defmethod learnerp ((agent mwm-agent)) +(defmethod learnerp ((agent spatial-agent)) (eql (id agent) 'learner)) -(defmethod tutorp ((agent mwm-agent)) +(defmethod tutorp ((agent spatial-agent)) (eql (id agent) 'tutor)) (defun make-tutor-agent (experiment) - (make-instance 'mwm-agent :id 'tutor + (make-instance 'spatial-agent :id 'tutor :experiment experiment)) (defun make-learner-agent (experiment) - (make-instance 'mwm-agent :id 'learner + (make-instance 'spatial-agent :id 'learner :experiment experiment)) @@ -79,245 +82,51 @@ ;; --------------------- ;; + Conceptualisation + ;; --------------------- -(define-event conceptualisation-finished (agent mwm-agent)) + +(define-event conceptualisation-finished (agent spatial-agent)) (defgeneric conceptualise (agent) (:documentation "run conceptualisation")) -(defmethod conceptualise (agent) - (case (id agent) - (tutor (tutor-conceptualise agent)) - (learner (learner-conceptualise agent)))) - - -;;;; Tutor conceptualisation -(defmethod tutor-conceptualise ((agent mwm-agent)) +(defmethod conceptualise ((agent spatial-agent)) (loop while t - for success = (run-tutor-conceptualisation agent) - if success return success + for succes = (run-conceptualisation agent) + if succes return succes else do (sample-topic (experiment agent)))) -(defun discriminative-combination? (list-of-attributes list-of-object-attributes) - "Returns t if the attribute combination in list-of-attributes - does not occur in any of the list-of-object-attributes." - (let ((unique t)) ;; unique until opposite is proven - (loop for object-attributes in list-of-object-attributes - while unique - when (loop for attribute in list-of-attributes - always (eql (rest attribute) - (rest (assoc (car attribute) object-attributes)))) - do (setf unique nil)) - unique)) - -(defun discriminate-topic (topic list-of-objects) - "Returns the minimal amount of (attr . val) conses that - discriminates object from the objects in list-of-objects. - Make sure the object is not in list-of-objects, otherwise - the functions will logically return nil." - (loop for nr-of-attr-needed from 1 to (length topic) - for attr-combinations = (shuffle (combinations-of-length topic nr-of-attr-needed)) - do (loop for attr-combination in attr-combinations - when (discriminative-combination? attr-combination list-of-objects) - do (return-from discriminate-topic attr-combination)))) - -(defmethod run-tutor-conceptualisation ((agent mwm-agent)) - "The tutor uses a symbolic representation of the context and - computes the minimal discriminative set of attributes" - (let* ((all-objects-features - (loop for object in (objects (get-data agent 'tutor-context)) - collect (cons (id object) (object->alist object)))) - (topic (get-data agent 'tutor-topic)) - (topic-features - (cdr (find (id topic) all-objects-features :key #'car))) - (context-features - (mapcar #'cdr - (remove-if #'(lambda (id) (eql id (id topic))) - all-objects-features :key #'car))) - (discriminative-features - (mapcar #'cdr (discriminate-topic topic-features context-features)))) - ;; fixed to 1 discriminative feature - (when (length= discriminative-features 1) - (set-data agent 'tutor-conceptualisation (first discriminative-features))) - (notify conceptualisation-finished agent) - ;; returns the feature or nil - (find-data agent 'tutor-conceptualisation))) - - -;;;; Learner conceptualisation -(defmethod learner-conceptualise ((agent mwm-agent)) - "In some cases, the tutor cannot even discriminate the topic. - If this is the case, the learner should not even try" - (let ((tutor (find 'tutor (population (experiment agent)) :key #'id))) - (loop while t - for possible-to-conceptualise-symbolically - = (with-disabled-monitors (run-tutor-conceptualisation tutor)) - if possible-to-conceptualise-symbolically - return (run-learner-conceptualisation agent) - else do (sample-topic (experiment agent))))) - -(defmethod run-learner-conceptualisation ((agent mwm-agent)) - "The learner conceptualises the topic using a single cxn." - (when (lexicon agent) - (let ((topic (get-data agent 'topic)) - (context (objects (get-data agent 'context)))) - (loop with most-discriminating-concept = nil - with best-similarity = 0 - with biggest-delta = 0 - for concept in (lexicon agent) - for topic-similarity = (weighted-similarity topic concept) - for best-other-similarity - = (loop for object in (remove topic context) - maximize (weighted-similarity object concept)) - for delta = (- topic-similarity best-other-similarity) - when (and (> topic-similarity best-other-similarity) - (< best-other-similarity 0) - (> delta biggest-delta) - (> topic-similarity best-similarity)) - do (setf most-discriminating-concept concept - biggest-delta delta - best-similarity topic-similarity) - finally - (set-data agent 'applied-concept most-discriminating-concept)) - (notify conceptualisation-finished agent)) - (find-data agent 'applied-concept))) - -#| -(defparameter *impossible-combinations* - (append - (combinations-of-length '("BLUE-CXN" "BROWN-CXN" "CYAN-CXN" "GRAY-CXN" - "GREEN-CXN" "PURPLE-CXN" "RED-CXN" "YELLOW-CXN") 2) - (combinations-of-length '("BEHIND-CXN" "LEFT-CXN" "RIGHT-CXN" "FRONT-CXN") 2) - (combinations-of-length '("CUBE-CXN" "CYLINDER-CXN" "SPHERE-CXN") 2) - (combinations-of-length '("METAL-CXN" "RUBBER-CXN") 2) - (combinations-of-length '("LARGE-CXN" "SMALL-CXN") 2))) - -(defun valid-combination-p (cxns) - (let ((cxn-names (mapcar (compose #'upcase #'mkstr #'name) cxns))) - (loop for (name-a name-b) in *impossible-combinations* - never (and (find name-a cxn-names :test #'string=) - (find name-b cxn-names :test #'string=))))) - -(defun get-discriminating-cxn-for-object (agent object cxns meanings) - (loop with best-cxn = nil - with best-similarity = 0 - with largest-difference = 0 - for cxn in cxns - for meaning in meanings - for object-similarity = (weighted-similarity object meaning) - for best-other-similarity - = (when (> object-similarity 0) - (loop for other in (remove object (objects (get-data agent 'context))) - maximize (weighted-similarity other meaning))) - for diff = (when best-other-similarity - (- object-similarity best-other-similarity)) - when (and object-similarity best-other-similarity - (> object-similarity best-other-similarity) - (> diff largest-difference) - (> object-similarity best-similarity)) - do (setf best-cxn cxn - best-similarity object-similarity - largest-difference diff) - finally (return best-cxn))) - -(defun get-best-cxn-for-others (agent cxns meanings) - (loop for object in (remove (get-data agent 'topic) - (objects (get-data agent 'context))) - collect (loop with best-cxn = nil - with best-similarity = 0 - for cxn in cxns - for meaning in meanings - for object-similarity = (weighted-similarity object meaning) - when (> object-similarity best-similarity) - do (setf best-cxn cxn - best-similarity object-similarity) - finally (return best-cxn)))) - -(defmethod conceptualise ((agent mwm-agent) (role (eql 'learner))) - (when (constructions (grammar agent)) - (loop for i from 1 to (get-configuration agent :max-tutor-utterance-length) - for cxns = (if (= i 1) (constructions (grammar agent)) - (remove-if-not #'valid-combination-p - (combinations-of-length - (constructions (grammar agent)) i))) - for meanings = (loop for elem in cxns - if (listp elem) - collect (reduce #'fuzzy-union - (mapcar #'(lambda (cxn) (attr-val cxn :meaning)) - elem)) - else collect (attr-val elem :meaning)) - for topic-cxn - = (get-discriminating-cxn-for-object agent (get-data agent 'topic) cxns meanings) - for other-cxns - = (when topic-cxn - (get-best-cxn-for-others agent cxns meanings)) - unless (member topic-cxn other-cxns :test #'equal) - do (progn (set-data agent 'applied-cxns - (if (listp topic-cxn) topic-cxn (list topic-cxn))) - (return)))) - (notify conceptualisation-finished agent) - (find-data agent 'applied-cxns)) - - (defmethod run-learner-conceptualisation ((agent mwm-agent)) - (when (constructions (grammar agent)) - (let* ((cxns (loop for i from 1 to (get-configuration agent :max-tutor-utterance-length) - append (if (= i 1) (constructions (grammar agent)) - (remove-if-not #'valid-combination-p - (combinations-of-length (constructions (grammar agent)) i))))) - (meanings (loop for cxn in cxns - if (listp cxn) - collect (reduce #'fuzzy-union - (mapcar #'(lambda (cxn) - (attr-val cxn :meaning)) - cxn)) - else collect (attr-val cxn :meaning))) - (topic (get-data agent 'topic)) - (context (objects (get-data agent 'context)))) - (when meanings - (loop with best-cxn = nil - with best-similarity = 0 - with largest-difference = 0 - for cxn in cxns - for meaning in meanings - for topic-similarity = (weighted-similarity topic meaning) - for best-other-similarity - = (when (> topic-similarity 0) - (loop for object in (remove topic context) - maximize (weighted-similarity object meaning))) - for diff = (when best-other-similarity - (- topic-similarity best-other-similarity)) - when (and topic-similarity best-other-similarity - (> topic-similarity best-other-similarity) - (> diff largest-difference) - (> topic-similarity best-similarity)) - do (setf best-cxn cxn - best-similarity topic-similarity - largest-difference diff) - finally (set-data agent 'applied-cxns - (if (listp best-cxn) best-cxn - (list best-cxn))))))) - (notify conceptualisation-finished agent) - (find-data agent 'applied-cxns)) -|# - - - +(defmethod run-conceptualisation ((agent spatial-agent)) + (let* ((all-objects (objects (get-data agent 'tutor-context))) + (topic (get-data agent 'tutor-topic)) + (context-objects (remove topic all-objects))) + (discriminate-topic context-objects topic agent) + (notify conceptualisation-finished agent) + ;; returns the spatial relation or nil + (find-data agent 'tutor-conceptualisation))) + + +(defun discriminate-topic (context-objects topic agent) + (loop for object in context-objects + for object-relations = (object->alist object) + for discriminative-relationship + = (loop for relationship in object-relations + if (and (member (id topic) (cdr relationship)) + (= (length (cdr relationship)) 1)) + return (car relationship)) + if discriminative-relationship + do (progn + (set-data agent 'tutor-conceptualisation discriminative-relationship) + (setf (pointed-object agent) (id object))))) + + ;; -------------- ;; + Production + ;; -------------- -(define-event production-finished (agent mwm-agent)) +(define-event production-finished (agent spatial-agent)) (defgeneric produce-word (agent) (:documentation "Produce an utterance")) -(defmethod produce-word ((agent mwm-agent)) - (case (id agent) - (tutor (tutor-produce-word agent)) - (learner (learner-produce-word agent)))) - -(defmethod tutor-produce-word ((agent mwm-agent)) - "Simply make strings from the symbols. When lexical variation is - enabled, the tutor randomly chooses one of the available - synonyms." +(defmethod produce-word ((agent spatial-agent)) (setf (utterance agent) (downcase (mkstr @@ -325,33 +134,15 @@ (notify production-finished agent) (utterance agent)) -(defmethod learner-produce-word ((agent mwm-agent)) - (when (find-data agent 'applied-concept) - (setf (utterance agent) - (form (find-data agent 'applied-concept)))) - (notify production-finished agent) - (utterance agent)) - ;; ----------- ;; + Parsing + ;; ----------- -(define-event parsing-finished (agent mwm-agent)) +(define-event parsing-finished (agent spatial-agent)) (defgeneric parse-word (agent) (:documentation "Parse an utterance")) -(defmethod parse-word ((agent mwm-agent)) - (case (id agent) - (tutor (tutor-parse-word agent)) - (learner (learner-parse-word agent)))) - -(defmethod tutor-parse-word ((agent mwm-agent)) - t) - -(defmethod learner-parse-word ((agent mwm-agent)) - "Parse as much words as possible and compute the combined meaning - using the fuzzy-union operation. Set the applied-cxns and parsed-meaning. - This is overkill since only single words are being used." +(defmethod parse-word ((agent spatial-agent)) (let ((concept (find (utterance agent) (lexicon agent) :key #'form :test #'string=))) (when concept (set-data agent 'applied-concept concept))) @@ -361,42 +152,12 @@ ;; ------------------ ;; + Interpretation + ;; ------------------ -(define-event interpretation-finished (agent mwm-agent)) +(define-event interpretation-finished (agent spatial-agent)) (defgeneric interpret (agent) (:documentation "Interpret a meaning")) -(defmethod interpret ((agent mwm-agent)) - (case (id agent) - (tutor (tutor-interpret agent)) - (learner (learner-interpret agent)))) - -(defun match-utterance-to-objects (objects utterance) - (let ((all-objects-as-alist - (loop for object in objects - collect (cons (id object) (object->alist object))))) - (loop for (id . object) in all-objects-as-alist - for object-attributes = (mapcar (compose #'downcase #'mkstr #'cdr) object) - when (member utterance object-attributes :test #'string=) - collect (find id objects :key #'id)))) - -(defmethod tutor-interpret ((agent mwm-agent)) - ;; if the learner says 'blue', the tutor will find - ;; all objects that are indeed blue. If the tutor finds more - ;; than one object, interpretation fails. - ;; there is no guessing - (let ((objects-with-utterance - (match-utterance-to-objects - (objects (get-data agent 'tutor-context)) - (utterance agent)))) - (when (and objects-with-utterance - (length= objects-with-utterance 1)) - (set-data agent 'interpreted-topic (first objects-with-utterance)))) - (notify interpretation-finished agent) - (find-data agent 'interpreted-topic)) - - -(defmethod learner-interpret ((agent mwm-agent)) +(defmethod interpret ((agent spatial-agent)) "The agent computes the weighted similarity between the parsed-meaning and each of the objects in the context. The topic is the object for which this value is maximized." @@ -420,7 +181,6 @@ (notify interpretation-finished agent) (find-data agent 'interpreted-topic)) - ;; --------------------- ;; + Determine success + ;; --------------------- @@ -428,7 +188,7 @@ (defgeneric determine-success (speaker hearer) (:documentation "Determine the success of the interaction")) -(defmethod determine-success ((speaker mwm-agent) (hearer mwm-agent)) +(defmethod determine-success ((speaker spatial-agent) (hearer spatial-agent)) (if (and (eql (id speaker) 'tutor) (eql (id hearer) 'learner)) (and (find-data hearer 'interpreted-topic) -- GitLab From 51d651b0e548864b30a7ce50a1b8e57c90a44ce2 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Tue, 29 Mar 2022 14:42:26 +0200 Subject: [PATCH 059/157] comprehension and production of perfect motion verbs cxns --- .../bidirectional_grammar_info_arg_struct.fcg | 207 ++++++------------ 1 file changed, 70 insertions(+), 137 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index bdea005b1..de107d30a 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -16,6 +16,7 @@ :no-applicable-cxns :connected-structure :no-meaning-in-root))) +;;;;DETERMINERS (def-fcg-cxn der-cxn ((?the-word @@ -215,6 +216,8 @@ +;;;;NOUNS + (def-fcg-cxn Blumen-cxn ((?flowers-word (referent ?x) ;set of values @@ -324,6 +327,8 @@ -- (HASH form ((string ?clown-word "Clown")))))) +;;;PHRASES + (def-fcg-cxn noun-phrase-cxn ((?noun-phrase (referent ?x) @@ -395,7 +400,6 @@ :disable-automatic-footprints t) -;;;; der twice (def-fcg-cxn prepositional-phrase-cxn ((?prep-phrase (referent ?x) @@ -463,7 +467,7 @@ )) :disable-automatic-footprints t) - +;;;VERBS (def-fcg-cxn kommt-cxn ((?come-word @@ -569,6 +573,12 @@ -- ))) + +;;;;;VERB CONSTRUCTIONS + + +;TRANSITIVE VERBS + (def-fcg-cxn transitive-argument-structure-cxn ((?transitive-argument-structure-unit (subunits (?verb-unit ?agent-unit ?patient-unit))) @@ -718,6 +728,7 @@ +;;;DITRANSITIVE VERBS ;der Mann schenkt dem Clown die Blumen @@ -910,9 +921,10 @@ - +;MOTION VERBS ;der Mann geht zur Arbeit + (def-fcg-cxn intransitive-argument-structure-cxn ((?intransitive-argument-structure-unit (subunits (?verb-unit ?agent-unit ?location-unit))) @@ -971,78 +983,17 @@ -- ))) -#|(def-fcg-cxn intransitive-come-argument-structure-cxn - ((?intransitive-argument-structure-unit - (subunits (?verb-unit ?agent-unit ?location-unit))) - (?agent-unit - (syn-cat (syn-role subject))) - (?location-unit - (syn-cat (syn-role indirect-object))) - <- - (?verb-unit - (syn-cat (lex-class verb) - (type intransitive) - (location origin-only) - ) - (referent ?v) - -- - (syn-cat (lex-class verb) - (type intransitive) - (location origin-only)) - (referent ?v)) - - (?agent-unit - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) - (referent ?arg0) - -- - (syn-cat (lex-class noun-phrase) - (case ((+ ?nm ?nf ?nn ?np) - (- - - - -) - (- - - - -) - (- - - - -) - (?as ?nm ?nf ?nn ?np)))) - (referent ?arg0)) - - - (?location-unit - (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (?acc ?am ?af ?an ?ap) - (- - - - -) - (?dat ?dm ?df ?dn ?dp) - (?ls ?m ?f ?n ?lp)))) - (referent ?arg3) - -- - (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (?acc ?am ?af ?an ?ap) - (- - - - -) - (?dat ?dm ?df ?dn ?dp) - (?ls ?m ?f ?n ?lp)))) - (referent ?arg3)) - - (?intransitive-argument-structure-unit - (HASH meaning ((:arg0 ?v ?arg0) - (:arg4 ?v ?arg4))) - -- - )))|# - -(def-fcg-cxn intransitive-information-structure-cxn - ((?intransitive-information-structure-unit - (subunits (?verb-unit ?agent-unit ?location-unit))) - (?arg-and-info-struct-unit - (subunits (?intransitive-information-structure-unit ?argument-structure-unit))) +(def-fcg-cxn topic-arg0-arg4-information-structure-cxn + ( <- (?argument-structure-unit (subunits (?verb-unit ?agent-unit ?location-unit)) - -- - (subunits (?verb-unit ?agent-unit ?location-unit)) - ) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?verb-unit (syn-cat (lex-class verb) @@ -1055,12 +1006,13 @@ (aspect ?aspect))) (?agent-unit + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) -- - (syn-cat (syn-role subject)) (referent ?arg0) + (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) @@ -1073,82 +1025,71 @@ (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) - (referent ?arg4) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) + )) - (?intransitive-information-structure-unit - -- - (HASH form ((meets ?rightmost-agent-unit ?verb-unit) - (meets ?verb-unit ?leftmost-location-unit))) - ))) - -#|(def-fcg-cxn intransitive-come-information-structure-cxn - ((?intransitive-information-structure-unit - (subunits (?verb-unit ?agent-unit ?location-unit))) - (?arg-and-info-struct-unit - (subunits (?intransitive-information-structure-unit ?argument-structure-unit))) +(def-fcg-cxn arg0-topic-arg4-information-structure-cxn + ( <- (?argument-structure-unit (subunits (?verb-unit ?agent-unit ?location-unit)) - -- - (subunits (?verb-unit ?agent-unit ?location-unit)) - ) + (HASH meaning ((topicalized ?arg4 +))) + + -- + (HASH form ((meets ?rightmost-location-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?verb-unit (syn-cat (lex-class verb) (type intransitive) - (aspect ?aspect) - (location origin-only) - ) + (aspect ?aspect)) -- (syn-cat (lex-class verb) (type intransitive) - (aspect ?aspect) - (location origin-only))) + (aspect ?aspect))) (?agent-unit (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) -- + (syn-cat (syn-role subject)) - (referent ?arg0) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) (?location-unit - (syn-cat (syn-role indirect-object) + (referent ?arg4) + (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - - (syn-cat (syn-role indirect-object) + (referent ?arg0) + (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) - (referent ?arg4) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) + )) - (?intransitive-information-structure-unit - -- - (HASH form ((meets ?rightmost-agent-unit ?verb-unit) - (meets ?verb-unit ?leftmost-location-unit))) - )))|# +;;;VERBS PERFECT -(def-fcg-cxn intransitive-information-structure-past-cxn - ((?intransitive-information-structure-past-unit - (subunits (?verb-unit ?agent-unit ?location-unit))) - (?arg-and-info-struct-unit - (subunits (?intransitive-information-structure-past-unit ?argument-structure-unit))) +(def-fcg-cxn topic-arg0-arg4-perfect-information-structure-cxn + ( <- (?argument-structure-unit (subunits (?verb-unit ?agent-unit ?location-unit)) - -- - (subunits (?verb-unit ?agent-unit ?location-unit)) - ) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?aux-unit) + (meets ?aux-unit ?leftmost-location-unit) + (meets ?rightmost-location-unit ?participle-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) (?verb-unit (subunits (?aux-unit ?participle-unit)) @@ -1167,10 +1108,12 @@ (rightmost-unit ?participle-unit))) (?agent-unit + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) -- + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) @@ -1181,25 +1124,21 @@ (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) + )) + + + + - (?intransitive-information-structure-past-unit - - -- - (HASH form ((meets ?rightmost-agent-unit ?aux-unit) - (meets ?aux-unit ?leftmost-location-unit) - (meets ?rightmost-location-unit ?participle-unit))) - ) - - )) +;;;VERBS WITH EXTRA INFORMATION ;der Mann geht ohne den Clown zur Arbeit @@ -1378,8 +1317,6 @@ ;MOTION verbs - - ;;;;gehen (arg0 goer - arg1 journey - arg3 start point - arg4 end point) ;Der Junge geht zum Arzt. ;Die Mutter geht ohne den Sohn zum Laden. @@ -1389,9 +1326,10 @@ ;;;;fahren (arg0 driver- arg1 vehicle or path) ;Der Mann fährt mit dem Fahrrad zur Arbeit. -;Der Mann ist gegen den Shop gefahren. +;;;PERFECT +;Der Mann ist gegen den Shop gefahren. ;;;;mitbringen (arg0 bringen - arg1 thing brought - arg2 benefactive or destination - arg3 attribute - arg4 brought from) ;Die Königin hat für den König Blume mitgebracht. @@ -1399,7 +1337,7 @@ ;;; NPs with Determiners and PPs with NP+P or Contracted P -(formulate-all '((clown x))) +(formulate-all '((baker x))) ;;;; der Mann sucht den Clown (formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized m +))) @@ -1415,21 +1353,16 @@ ;;;der Mann geht zum Shop -(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s))) - +(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized m +))) -;;; der Mann kommt aus dem Shop -;(formulate-all '((kommen-01 k) (man m) (arg0 k m) (shop s) (arg4 k s))) ;still same as gehen +; zum Shop geht der Mann +(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized s +))) -;;; aus dem Shop kommt der Mann -;(formulate-all '((kommen-01 k) (man m) (arg1 k m) (shop s) (arg3 k s) (topicalized s +))) - - -;;;der Mann schenkt dem Clown die Blumen -;(formulate '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f))) +;;; der Mann geht ohne den Clown zur Arbeit +(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) -;;; der Mann ist gegen die Blumen gefahren -;(formulate-all '((drove-01 ig) (man m) (arg0 ig m) (flowers f) (arg1 ig f))) +;;; der Mann ist gegen den Shop gefahren +(formulate '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) ;;; der Mann geht ohne den Clown zur Arbeit (formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) -- GitLab From 4ff74fa8572275a2f59f01d201e9c3f54920da72 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 14:42:48 +0200 Subject: [PATCH 060/157] Changed type-names (mwm-agent -> spatial-agent, mwm-object -> spatial-object), modified pathnames (multidimensional-word-meanings -> spatial-concept-game) and removed unnecessary experimental conditions --- .../spatial-concept-game/alignment.lisp | 6 +- experiments/spatial-concept-game/concept.lisp | 6 +- experiments/spatial-concept-game/html.lisp | 8 +- experiments/spatial-concept-game/misc.lisp | 11 ++- .../spatial-concept-game/monitors.lisp | 16 ++-- experiments/spatial-concept-game/run.lisp | 88 +++++-------------- experiments/spatial-concept-game/utils.lisp | 12 +-- .../spatial-concept-game/web-demo.lisp | 4 +- 8 files changed, 54 insertions(+), 97 deletions(-) diff --git a/experiments/spatial-concept-game/alignment.lisp b/experiments/spatial-concept-game/alignment.lisp index 66313d970..f78e0c0b5 100644 --- a/experiments/spatial-concept-game/alignment.lisp +++ b/experiments/spatial-concept-game/alignment.lisp @@ -9,7 +9,7 @@ Each feature receives an initial certainty value. The newly created concept is added to the agent's lexicon.")) -(defmethod adopt-concept ((agent mwm-agent) (topic mwm-object) word) +(defmethod adopt-concept ((agent spatial-agent) (topic spatial-object) word) (let ((new-concept (make-concept word (attributes topic) (get-configuration agent :initial-certainty)))) @@ -138,7 +138,7 @@ game.")) -(defmethod align-concept ((agent mwm-agent) (topic mwm-object) concept) +(defmethod align-concept ((agent spatial-agent) (topic spatial-object) concept) ;; 1. update the prototypical values (loop for prototype in (meaning concept) do (update-prototype prototype topic)) @@ -191,7 +191,7 @@ (define-event align-concept-started (word string)) (define-event adopt-concept-started (word string)) -(defmethod alignment ((agent mwm-agent) (topic mwm-object) applied-concept) +(defmethod alignment ((agent spatial-agent) (topic spatial-object) applied-concept) ;; applied-concept can be NIL (if applied-concept (progn (notify align-concept-started (form applied-concept)) diff --git a/experiments/spatial-concept-game/concept.lisp b/experiments/spatial-concept-game/concept.lisp index c6d9f5348..232b156a5 100644 --- a/experiments/spatial-concept-game/concept.lisp +++ b/experiments/spatial-concept-game/concept.lisp @@ -79,7 +79,7 @@ (:documentation "Update the category based on the object")) (defmethod update-prototype ((prototype prototype) - (object mwm-object)) + (object spatial-object)) ;; take the object pointed to by the tutor ;; and estimate the mean and variance of the category (incf (nr-samples prototype)) @@ -96,7 +96,7 @@ (defgeneric weighted-similarity (object concept) (:documentation "Compute the weighted similarity between an object and a concept")) -(defmethod weighted-similarity ((object mwm-object) (concept concept)) +(defmethod weighted-similarity ((object spatial-object) (concept concept)) (loop for prototype in (meaning concept) for similarity = (similarity object prototype) collect (* (certainty prototype) similarity) into weighted-similarities @@ -106,7 +106,7 @@ (defgeneric similarity (object prototype) (:documentation "Similarity on the level of a single prototype")) -(defmethod similarity ((object mwm-object) (prototype prototype)) +(defmethod similarity ((object spatial-object) (prototype prototype)) (let* ((max-z-score 2) (exemplar (get-attr-val object (attribute prototype))) (stdev (sqrt (/ (M2 prototype) (nr-samples prototype)))) diff --git a/experiments/spatial-concept-game/html.lisp b/experiments/spatial-concept-game/html.lisp index 91f410023..f0efde2bc 100644 --- a/experiments/spatial-concept-game/html.lisp +++ b/experiments/spatial-concept-game/html.lisp @@ -1,13 +1,13 @@ (in-package :spatial-concepts) -;; make html of mwm-object -(defmethod make-html-for-entity-details ((object mwm-object) &key) +;; make html of spatial-object +(defmethod make-html-for-entity-details ((object spatial-object) &key) (loop for (attr . val) in (attributes object) append `(((div :class "entity-detail") ,(format nil "~a = ~,2f" attr val))))) ;; make html of object set -(defmethod make-html-for-entity-details ((set mwm-object-set) &key) +(defmethod make-html-for-entity-details ((set spatial-object-set) &key) `(((div :class "entity-detail") ,@(loop for object in (objects set) collect (make-html object :expand-initially t))))) @@ -18,7 +18,7 @@ ,(s-dot->svg (concept->s-dot concept)))) -;; make html of mwm-category +;; make html of spatial-category (defmethod make-html-for-entity-details ((prototype prototype) &key) `(((div :class "entity-detail") ,(format nil "attribute: ~a" (attribute prototype))) diff --git a/experiments/spatial-concept-game/misc.lisp b/experiments/spatial-concept-game/misc.lisp index 1d7bce46e..814614bdb 100644 --- a/experiments/spatial-concept-game/misc.lisp +++ b/experiments/spatial-concept-game/misc.lisp @@ -4,8 +4,7 @@ (defun experiment-name-from-configurations (experiment) (let ((parts (list (mkstr (get-configuration experiment :experiment-type)) - (mkstr (get-configuration experiment :world-type)) - (mkstr (get-configuration experiment :determine-interacting-agents-mode))))) + (mkstr (get-configuration experiment :world-type))))) (when (eql (get-configuration experiment :experiment-type) :cogent) (pushend (format nil "train-~a" (get-configuration experiment :switch-conditions-after-n-interactions)) @@ -26,11 +25,11 @@ (base-path (if serie (babel-pathname - :directory `("experiments" "multidimensional-word-meanings" + :directory `("experiments" "spatial-concept-game" "graphs" ,(downcase experiment-name) ,(format nil "serie-~a" serie))) (babel-pathname - :directory `("experiments" "multidimensional-word-meanings" + :directory `("experiments" "spatial-concept-game" "graphs" ,(downcase experiment-name)))))) (ensure-directories-exist base-path) (loop for concept in (average-over-concept-history agent) @@ -48,11 +47,11 @@ (base-path (if serie (babel-pathname - :directory `("experiments" "multidimensional-word-meanings" + :directory `("experiments" "spatial-concept-game" "store" ,(downcase experiment-name) ,(format nil "serie-~a" serie))) (babel-pathname - :directory `("experiments" "multidimensional-word-meanings" + :directory `("experiments" "spatial-concept-game" "store" ,(downcase experiment-name)))))) (ensure-directories-exist base-path) (loop for concept in (average-over-concept-history agent) diff --git a/experiments/spatial-concept-game/monitors.lisp b/experiments/spatial-concept-game/monitors.lisp index c9aed1811..62b692ba6 100644 --- a/experiments/spatial-concept-game/monitors.lisp +++ b/experiments/spatial-concept-game/monitors.lisp @@ -26,7 +26,7 @@ :documentation "Exports communicative success" :data-sources '((average record-communicative-success)) :file-name (babel-pathname :name "communicative-success" :type "lisp" - :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :directory '("experiments" "spatial-concept-game" "raw-data")) :add-time-and-experiment-to-file-name nil :column-separator " " :comment-string "#") @@ -45,7 +45,7 @@ :documentation "Exports communicative success" :data-sources '((average record-communicative-success-given-conceptualisation)) :file-name (babel-pathname :name "communicative-success-given-conceptualisation" :type "lisp" - :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :directory '("experiments" "spatial-concept-game" "raw-data")) :add-time-and-experiment-to-file-name nil :column-separator " " :comment-string "#") @@ -72,7 +72,7 @@ :documentation "Exports lexicon size" :data-sources '(record-lexicon-size) :file-name (babel-pathname :name "lexicon-size" :type "lisp" - :directory '("experiments" "multidimensional-word-meanings" "raw-data")) + :directory '("experiments" "spatial-concept-game" "raw-data")) :add-time-and-experiment-to-file-name nil :column-separator " " :comment-string "#") @@ -106,7 +106,7 @@ :draw-y-1-grid t :y-label "Tutor word use" :x-label "# Games" - :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :file-name (babel-pathname :directory '("experiments" "spatial-concept-game" "graphs") :name "tutor-word-use" :type "pdf") :graphic-type "pdf") @@ -115,7 +115,7 @@ (format t "~%Running ~a interactions in order to create a tutor word use graph." nr-of-interactions) (setf *used-features* nil) (activate-monitor plot-tutor-conceptualisation-in-failed-interactions) - (run-batch 'mwm-experiment nr-of-interactions 1 + (run-batch 'spatial-experiment nr-of-interactions 1 :configuration (make-configuration :entries configurations)) (deactivate-monitor plot-tutor-conceptualisation-in-failed-interactions) (format t "~%Graphs have been created")) @@ -142,7 +142,7 @@ :draw-y-1-grid t :y-label "Learner failed conceptualisation" :x-label "# Games" - :file-name (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "graphs") + :file-name (babel-pathname :directory '("experiments" "spatial-concept-game" "graphs") :name "learner-failed-conceptualisation" :type "pdf") :graphic-type "pdf") @@ -151,7 +151,7 @@ (format t "~%Running ~a interactions in order to create a graph." nr-of-interactions) (setf *failed-conceptualisations* nil) (activate-monitor plot-learner-failed-conceptualisations) - (run-batch 'mwm-experiment nr-of-interactions 1 + (run-batch 'spatial-experiment nr-of-interactions 1 :configuration (make-configuration :entries configurations)) (deactivate-monitor plot-learner-failed-conceptualisations) (format t "~%Graphs have been created")) @@ -177,7 +177,7 @@ (when (= (series-number experiment) 1) (let* ((experiment-name (experiment-name-from-configurations experiment)) (path (babel-pathname - :directory `("experiments" "multidimensional-word-meanings" + :directory `("experiments" "spatial-concepts-game" "raw-data" ,(downcase experiment-name)) :name "experiment-configurations" :type "lisp"))) (ensure-directories-exist path) diff --git a/experiments/spatial-concept-game/run.lisp b/experiments/spatial-concept-game/run.lisp index 120fb55c6..aa29c0495 100644 --- a/experiments/spatial-concept-game/run.lisp +++ b/experiments/spatial-concept-game/run.lisp @@ -15,56 +15,21 @@ ;; -------------------- ;;;; CONFIGURATIONS -(defparameter *baseline-simulated* +(defparameter *simulated* (make-configuration - :entries '((:experiment-type . :baseline) - (:world-type . :simulated) - (:determine-interacting-agents-mode . :default) + :entries '((:world-type . :simulated) (:alignment-filter . :all)))) -(defparameter *baseline-extracted* +(defparameter *extracted* (make-configuration - :entries '((:experiment-type . :baseline) - (:world-type . :extracted) - (:determine-interacting-agents-mode . :default) + :entries '((:world-type . :extracted) (:alignment-filter . :all)))) -(defparameter *cogent-simulated* - (make-configuration - :entries '((:experiment-type . :cogent) - (:world-type . :simulated) - (:determine-interacting-agents-mode . :default) - (:alignment-filter . :all) - (:switch-conditions-after-n-interactions . 100)))) - -(defparameter *cogent-extracted* - (make-configuration - :entries '((:experiment-type . :cogent) - (:world-type . :extracted) - (:determine-interacting-agents-mode . :default) - (:alignment-filter . :all) - (:switch-conditions-after-n-interactions . 100)))) - -(defparameter *incremental-simulated* - (make-configuration - :entries '((:experiment-type . :incremental) - (:world-type . :simulated) - (:determine-interacting-agents-mode . :default) - (:alignment-filter . :all) - (:switch-conditions-after-n-interactions . 100)))) - -(defparameter *incremental-extracted* - (make-configuration - :entries '((:experiment-type . :incremental) - (:world-type . :extracted) - (:determine-interacting-agents-mode . :default) - (:alignment-filter . :all) - (:switch-conditions-after-n-interactions . 100)))) ;;;; EXPERIMENT (defparameter *experiment* - (make-instance 'mwm-experiment - :configuration *cogent-extracted*)) + (make-instance 'spatial-experiment + :configuration *simulated*)) (run-interaction *experiment*) @@ -78,9 +43,8 @@ (run-experiments `( (test - ((:experiment-type . :baseline) - (:world-type . :simulated) - (:determine-interacting-agents-mode . :default) + ((:world-type . :simulated) + (:determine-interacting-agents-mode . :default (:alignment-filter . :all))) ) :number-of-interactions 2000 @@ -112,16 +76,12 @@ (create-tutor-word-use-graph :configurations - '((:experiment-type . :baseline) - (:world-type . :extracted) - (:determine-interacting-agents-mode . :tutor-speaks)) + '((:world-type . :extracted)) :nr-of-interactions 2500) (create-learner-failed-conceptualisation-graph :configurations - '((:experiment-type . :baseline) - (:world-type . :extracted) - (:determine-interacting-agents-mode . :default)) + '((:world-type . :extracted)) :nr-of-interactions 5000) @@ -188,7 +148,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-main-results" "baseline-simulated") :name "communicative-success" :type "lisp")) @@ -196,7 +156,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-main-results" "baseline-simulated-bidirectional") :name "communicative-success" :type "lisp")) @@ -204,7 +164,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-main-results" "baseline-simulated-bidirectional") :name "communicative-success-given-conceptualisation" @@ -213,7 +173,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-main-results" "baseline-extracted") :name "communicative-success" :type "lisp")) @@ -221,7 +181,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-main-results" "baseline-extracted-bidirectional") :name "communicative-success" :type "lisp")) @@ -229,7 +189,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-main-results" "baseline-extracted-bidirectional") :name "communicative-success-given-conceptualisation" @@ -238,7 +198,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-simulated-switch-500") :name "communicative-success" @@ -247,7 +207,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-simulated-switch-1000") :name "communicative-success" @@ -256,7 +216,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-simulated-bidirectional-switch-500") :name "communicative-success" @@ -265,7 +225,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-simulated-bidirectional-switch-1000") :name "communicative-success" @@ -274,7 +234,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-extracted-switch-500") :name "communicative-success" @@ -283,7 +243,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-extracted-switch-1000") :name "communicative-success" @@ -292,7 +252,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-extracted-bidirectional-switch-500") :name "communicative-success" @@ -301,7 +261,7 @@ (with-open-file (stream (babel-pathname - :directory '("experiments" "multidimensional-word-meanings" + :directory '("experiments" "spatial-concept-game" "raw-data" "thesis-cogent" "cogent-extracted-bidirectional-switch-1000") :name "communicative-success" diff --git a/experiments/spatial-concept-game/utils.lisp b/experiments/spatial-concept-game/utils.lisp index 55cbe3b98..14f7a4e76 100644 --- a/experiments/spatial-concept-game/utils.lisp +++ b/experiments/spatial-concept-game/utils.lisp @@ -13,13 +13,13 @@ shared-configurations) (format t "~%Starting experimental runs") (run-batch-for-different-configurations - :experiment-class 'mwm-experiment + :experiment-class 'spatial-experiment :number-of-interactions number-of-interactions :number-of-series number-of-series :monitors monitors :shared-configuration shared-configurations :named-configurations strategies - :output-dir (babel-pathname :directory '("experiments" "multidimensional-word-meanings" "raw-data"))) + :output-dir (babel-pathname :directory '("experiments" "spatial-concept-game" "raw-data"))) (format t "~%Experimental runs finished and data has been generated. You can now plot graphs.")) (defun create-graph-for-single-strategy (experiment-name measure-names @@ -28,7 +28,7 @@ (format t "~%Creating graph for experiment ~a with measures ~a" experiment-name measure-names) (let* ((raw-file-paths (loop for measure-name in measure-names - collect `("experiments" "multidimensional-word-meanings" + collect `("experiments" "spatial-concept-game" "raw-data" ,experiment-name ,measure-name))) (default-plot-file-name (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) @@ -38,7 +38,7 @@ (nth (1+ (position :plot-file-name evo-plot-keyword-args)) evo-plot-keyword-args)))) (apply #'raw-files->evo-plot (append `(:raw-file-paths ,raw-file-paths - :plot-directory ("experiments" "multidimensional-word-meanings" "graphs") + :plot-directory ("experiments" "spatial-concept-game" "graphs") :plot-file-name ,(if plot-file-name plot-file-name default-plot-file-name)) evo-plot-keyword-args))) (format t "~%Graphs have been created")) @@ -48,7 +48,7 @@ ;; take some arguments, but pass along the rest to raw-files->evo-plot (let* ((raw-file-paths (loop for (experiment . measure) in experiment-measure-pairs - collect `("experiments" "multidimensional-word-meanings" + collect `("experiments" "spatial-concept-game" "raw-data" ,experiment ,measure))) (default-plot-file-name (reduce #'(lambda (str1 str2) (string-append str1 "+" str2)) @@ -63,7 +63,7 @@ (nth (1+ (position :plot-file-name evo-plot-keyword-args)) evo-plot-keyword-args)))) (apply #'raw-files->evo-plot (append `(:raw-file-paths ,raw-file-paths - :plot-directory ("experiments" "multidimensional-word-meanings" "graphs") + :plot-directory ("experiments" "spatial-concept-game" "graphs") :captions ,captions :plot-file-name ,(if plot-file-name plot-file-name default-plot-file-name)) evo-plot-keyword-args)))) diff --git a/experiments/spatial-concept-game/web-demo.lisp b/experiments/spatial-concept-game/web-demo.lisp index fb7cdbf05..9b3c70b8f 100644 --- a/experiments/spatial-concept-game/web-demo.lisp +++ b/experiments/spatial-concept-game/web-demo.lisp @@ -57,9 +57,8 @@ :entries `((:data-source . :clevr) (:scale-world . ,nil) (:category-representation . :prototype) - (:determine-interacting-agents-mode . :tutor-speaks) (:data-sets . ("val"))))) - (experiment (make-instance 'mwm-experiment :configuration config))) + (experiment (make-instance 'spatial-experiment :configuration config))) (add-element '((h3) "Baseline Simulated Experiment")) (activate-monitor trace-interaction-in-web-interface) (add-element '((p) "At the start, the learner has no repertoire of concepts. The word the tutor utters in the very first interaction is thus always unknown. The learner indicates that it does not know the word and the tutor provides feedback by pointing to the indended topic. Now, the learner creates its first concept, simply by storing an exact copy of the topic object. Indeed, the learner cannot yet know which attributes are important or what their prototypical values should be.")) @@ -84,7 +83,6 @@ :entries `((:data-source . :extracted) (:scale-world . ,nil) (:category-representation . :prototype) - (:determine-interacting-agents-mode . :tutor-speaks) (:data-path . ,(merge-pathnames (make-pathname :directory '(:relative "CLEVR" "CLEVR-v1.0" "scenes" "val-ns-vqa")) cl-user:*babel-corpora*))))) (experiment (make-instance 'mwm-experiment :configuration config))) -- GitLab From 82fd88415803a867b6c07408752029177ee6b4a4 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 14:44:43 +0200 Subject: [PATCH 061/157] Changed experiment type name to spatial-experiment and removed unnecessary experimental conditions --- .../spatial-concept-game/experiment.lisp | 88 +++---------------- 1 file changed, 13 insertions(+), 75 deletions(-) diff --git a/experiments/spatial-concept-game/experiment.lisp b/experiments/spatial-concept-game/experiment.lisp index 8b62d380f..1e06418a4 100644 --- a/experiments/spatial-concept-game/experiment.lisp +++ b/experiments/spatial-concept-game/experiment.lisp @@ -4,20 +4,10 @@ ;; + Configurations + ;; ------------------ -;; :baseline - :cogent - :incremental - :compositional -(define-configuration-default-value :experiment-type :baseline) - ;; :simulated - :extracted (define-configuration-default-value :world-type :simulated) -;; :A or :B -(define-configuration-default-value :cogent-stage :A) - -;; 1, 2, 3, 4 or 5 -(define-configuration-default-value :incremental-stage 1) - (define-configuration-default-value :dot-interval 100) -(define-configuration-default-value :determine-interacting-agents-mode :tutor-speaks) (define-configuration-default-value :initial-certainty 0.5) (define-configuration-default-value :certainty-incf 0.1) (define-configuration-default-value :certainty-decf -0.1) @@ -25,94 +15,41 @@ (define-configuration-default-value :lexical-variation nil) (define-configuration-default-value :export-lexicon-interval 500) (define-configuration-default-value :switch-conditions-after-n-interactions nil) +(define-configuration-default-value :determine-interacting-agents-mode :tutor-speaks) (define-configuration-default-value :alignment-filter :all) ; :none - :at-least-one - :all ;; -------------- ;; + Experiment + ;; -------------- -(defclass mwm-experiment (experiment) +(defclass spatial-experiment (experiment) () (:documentation "The experiment class")) - - -;; path to each variant of the CLEVR dataset -;; every variant should have a subdirectory 'scenes' -(defparameter *baseline-clevr-data-path* - *clevr-data-path*) - -(defparameter *cogent-clevr-data-path* - (merge-pathnames (make-pathname :directory '(:relative "CLEVR-CoGenT")) - cl-user:*babel-corpora*)) - -(defparameter *incremental-clevr-data-path* - (merge-pathnames (make-pathname :directory '(:relative "Frontiers-data" "CLEVR-incremental")) - cl-user:*babel-corpora*)) - - - -(defun initial-data-set (experiment) - (case (get-configuration experiment :experiment-type) - (:baseline "val") - (:cogent "valA") - (:incremental "phase_1") - (:compositional "val"))) - - -(defmethod initialize-instance :after ((experiment mwm-experiment) &key) +(defmethod initialize-instance :after ((experiment spatial-experiment) &key) "Create the population and load the scenes from file" (activate-monitor print-a-dot-for-each-interaction) ;; set the population (setf (population experiment) (list (make-tutor-agent experiment) (make-learner-agent experiment))) - ;; set the clevr-data-path + ;; reset *clevr-data-path* to root directory of clevr data ;; this will be used to load the 'clevr-world below - (setf *clevr-data-path* - (case (get-configuration experiment :experiment-type) - (:baseline *baseline-clevr-data-path*) - (:cogent *cogent-clevr-data-path*) - (:incremental *incremental-clevr-data-path*) - (:compositional *baseline-clevr-data-path*))) + (reset-clevr-data-path) ;; set the world (it uses the global variable *clevr-data-path*) (setf (world experiment) - (make-instance 'clevr-world :data-sets (list (initial-data-set experiment)))) + (make-instance 'clevr-world :data-sets (list "val"))) ;; store the data-sets and data-path in the blackboard - (set-data experiment :ns-vqa-data-path - (case (get-configuration experiment :experiment-type) - (:baseline - (merge-pathnames - (make-pathname - :directory `(:relative "Frontiers-data" "CLEVR" - ,(initial-data-set experiment))) - cl-user:*babel-corpora*)) - (:cogent - (merge-pathnames - (make-pathname - :directory `(:relative "Frontiers-data" "CoGenT" - ,(initial-data-set experiment))) - cl-user:*babel-corpora*)) - (:incremental - (merge-pathnames - (make-pathname - :directory `(:relative "Frontiers-data" "incremental" - ,(initial-data-set experiment))) - cl-user:*babel-corpora*)) - (:compositional - (merge-pathnames - (make-pathname - :directory `(:relative "Frontiers-data" "CLEVR" - ,(initial-data-set experiment))) - cl-user:*babel-corpora*))))) + (set-data experiment :ns-vqa-data-path (merge-pathnames (make-pathname + :directory `(:relative "Frontiers-data" "CLEVR" "val")) cl-user:*babel-corpora*))) -(defmethod learner ((experiment mwm-experiment)) +(defmethod learner ((experiment spatial-experiment)) (find 'learner (population experiment) :key #'id)) (defmethod learner ((interaction interaction)) (find 'learner (interacting-agents interaction) :key #'id)) -(defmethod tutor ((experiment mwm-experiment)) +(defmethod tutor ((experiment spatial-experiment)) (find 'tutor (population experiment) :key #'id)) (defmethod tutor ((interaction interaction)) @@ -123,7 +60,7 @@ ;; + Determine interacting agents + ;; -------------------------------- -(defmethod determine-interacting-agents ((experiment mwm-experiment) +(defmethod determine-interacting-agents ((experiment spatial-experiment) (interaction interaction) (mode (eql :tutor-speaks)) &key &allow-other-keys) @@ -137,7 +74,7 @@ (notify interacting-agents-determined experiment interaction))) -(defmethod determine-interacting-agents ((experiment mwm-experiment) +(defmethod determine-interacting-agents ((experiment spatial-experiment) (interaction interaction) (mode (eql :learner-speaks)) &key &allow-other-keys) @@ -149,3 +86,4 @@ (setf (discourse-role tutor) 'hearer (discourse-role learner) 'speaker) (notify interacting-agents-determined experiment interaction))) + -- GitLab From 5c7358411b3af6af8d64053e9aaf5a94810e9892 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 14:48:15 +0200 Subject: [PATCH 062/157] modified do-interaction (pointed-object passed on between tutor and learner) --- .../spatial-concept-game/interaction.lisp | 168 +++--------------- 1 file changed, 26 insertions(+), 142 deletions(-) diff --git a/experiments/spatial-concept-game/interaction.lisp b/experiments/spatial-concept-game/interaction.lisp index 9507325a4..9c5a9c4d3 100644 --- a/experiments/spatial-concept-game/interaction.lisp +++ b/experiments/spatial-concept-game/interaction.lisp @@ -10,12 +10,12 @@ (utterance agent) nil (communicated-successfully agent) nil)) -(defun closest-object (mwm-topic symbolic-clevr-context) +(defun closest-object (spatial-topic symbolic-clevr-context) "Given a topic from the 'extracted' world, find the closest object in the symbolic world using the xy-coordinates." - (let ((topic-x (get-attr-val mwm-topic 'xpos)) - (topic-y (get-attr-val mwm-topic 'ypos))) + (let ((topic-x (get-attr-val spatial-topic 'xpos)) + (topic-y (get-attr-val spatial-topic 'ypos))) (the-smallest #'(lambda (object) (abs (euclidean (list topic-x topic-y) (list (x-pos object) @@ -25,10 +25,10 @@ (defgeneric before-interaction (experiment) (:documentation "Initialize the interaction")) -(define-event context-determined (experiment mwm-experiment)) -(define-event topic-determined (experiment mwm-experiment)) +(define-event context-determined (experiment spatial-experiment)) +(define-event topic-determined (experiment spatial-experiment)) -(defmethod before-interaction ((experiment mwm-experiment)) +(defmethod before-interaction ((experiment spatial-experiment)) ;; 1. load a random scene ;; 2. pick a random topic ;; step 2 can be retried if conceptualisation fails @@ -43,17 +43,17 @@ (defun sample-scene (experiment) (let* ((world-type (get-configuration experiment :world-type)) (symbolic-clevr-context (random-scene (world experiment))) - (mwm-context + (spatial-context (case world-type (:simulated (clevr->simulated symbolic-clevr-context)) (:extracted (clevr->extracted symbolic-clevr-context :directory (find-data experiment :ns-vqa-data-path)))))) - (if (length> (objects mwm-context) 1) + (if (length> (objects spatial-context) 1) (progn (loop for agent in (interacting-agents experiment) - do (set-data agent 'context mwm-context) + do (set-data agent 'context spatial-context) do (set-data agent 'tutor-context symbolic-clevr-context)) (notify context-determined experiment)) (sample-scene experiment)))) @@ -64,23 +64,23 @@ (world-type (get-configuration experiment :world-type)) (agent (first (population experiment))) (symbolic-clevr-context (find-data agent 'tutor-context)) - (mwm-context (find-data agent 'context)) + (spatial-context (find-data agent 'context)) (tried-topics (tried-topics interaction (name symbolic-clevr-context))) - (available-topics (set-difference (objects mwm-context) tried-topics))) + (available-topics (set-difference (objects spatial-context) tried-topics))) (if (null available-topics) (progn (sample-scene experiment) (sample-topic experiment)) - (let* ((mwm-topic (random-elt available-topics)) + (let* ((spatial-topic (random-elt available-topics)) (tutor-topic (case world-type - (:simulated (find (id mwm-topic) (objects symbolic-clevr-context) :key #'id)) - (:extracted (closest-object mwm-topic symbolic-clevr-context)))) - (scene-topic-cons (cons (name symbolic-clevr-context) mwm-topic))) + (:simulated (find (id spatial-topic) (objects symbolic-clevr-context) :key #'id)) + (:extracted (closest-object spatial-topic symbolic-clevr-context)))) + (scene-topic-cons (cons (name symbolic-clevr-context) spatial-topic))) (notify topic-determined experiment) (push-data interaction 'attempted-topics scene-topic-cons) (loop for agent in (interacting-agents experiment) - do (set-data agent 'topic mwm-topic) + do (set-data agent 'topic spatial-topic) do (set-data agent 'tutor-topic tutor-topic)))))) @@ -95,7 +95,7 @@ (defgeneric do-interaction (experiment) (:documentation "Run the interaction script")) -(defmethod do-interaction ((experiment mwm-experiment)) +(defmethod do-interaction ((experiment spatial-experiment)) "The tutor conceptualises the topic and produces one or multiple words. The hearer tries to parse and interpret the utterance. If both succeed and @@ -106,8 +106,10 @@ (hearer (hearer experiment))) (conceptualise speaker) (produce-word speaker) - (when (utterance speaker) - (setf (utterance hearer) (utterance speaker)) + (when (and (utterance speaker)(pointed-object speaker)) + (progn + (setf (utterance hearer) (utterance speaker)) + (setf (pointed-object hearer) (pointed-object speaker))) (when (and (parse-word hearer) (interpret hearer) (determine-success speaker hearer)) @@ -120,135 +122,17 @@ (defgeneric after-interaction (experiment) (:documentation "Finalize the interaction")) -(defmethod after-interaction ((experiment mwm-experiment)) - ;; only in condition B of the cogent experiment, there is no alignment - (unless (and (eql (get-configuration experiment :experiment-type) :cogent) - (eql (get-configuration experiment :cogent-stage) :B)) +(defmethod after-interaction ((experiment spatial-experiment)) (let ((tutor (tutor experiment)) (learner (learner experiment))) - (if (speakerp tutor) - ;; alignment when tutor is speaker - ;; the tutor reveals the topic and - ;; the learner aligns its concept to it (when (find-data tutor 'tutor-conceptualisation) - (alignment learner (get-data learner 'topic) - (find-data learner 'applied-concept))) - ;; alignment when learner is speaker - (cond - ;; success? do alignment - ((and (communicated-successfully tutor) - (communicated-successfully learner)) - (alignment learner (get-data learner 'topic) - (find-data learner 'applied-concept))) - ;; learner could not conceptualise? do nothing - ((null (find-data learner 'applied-concept)) - nil) - ;; learner could conceptualise, but interpretation failed? - ;; do nothing - ((null (find-data tutor 'interpreted-topic)) - nil) - ;; learner could conceptualise and interpretation succeeded - ;; but incorrectly? do nothing - (t nil)))))) - - -;;;; -;;;; Experimental conditions -;;;; -(defgeneric switch-condition-p (experiment experiment-type) - (:documentation "Predicate that checks whether the experiment should - advance to the next condition")) - -(defmethod switch-condition-p ((experiment mwm-experiment) experiment-type) - "Switch when N interactions have been played." - (let ((switch-condition-interval - (get-configuration experiment :switch-conditions-after-n-interactions)) - (current-interaction-number - (interaction-number (current-interaction experiment)))) - (= (mod current-interaction-number switch-condition-interval) 0))) - -(defmethod switch-condition-p ((experiment mwm-experiment) - (experiment-type (eql :baseline))) - "Never switch conditions" - nil) - -(defmethod switch-condition-p ((experiment mwm-experiment) - (experiment-type (eql :cogent))) - "Switch when N interactions have been played - and the experiment is still in stage A." - (and (call-next-method) - (eql (get-configuration experiment :cogent-stage) :A))) - -(defmethod switch-condition-p ((experiment mwm-experiment) - (experiment-type (eql :incremental))) - "Switch when N interactions have been played - and the experiment has not reached stage 5." - (and (call-next-method) - (< (get-configuration experiment :incremental-stage) 5))) - -(defmethod switch-condition-p ((experiment mwm-experiment) - (experiment-type (eql :compositional))) - "Never switch conditions" - nil) - - -(defgeneric setup-next-condition (experiment experiment-type) - (:documentation "Setup the next experimental condition.")) - -(defmethod setup-next-condition ((experiment mwm-experiment) - (experiment-type (eql :cogent))) - ;; message - (format t "~%~%SWITCHING FROM CONDITION A TO CONDITION B. SWITCHED OFF LEARNING~%~%") - ;; set the config - (set-configuration experiment :cogent-stage :B :replace t) - ;; load the scenes - (setf (world experiment) - (make-instance 'clevr-world :data-sets '("valB"))) - ;; load the extracted scenes - (when (eql (get-configuration experiment :world-type) :extracted) - (let ((data-path (namestring (find-data experiment :ns-vqa-data-path)))) - (set-data experiment :ns-vqa-data-path - (parse-namestring - (cl-ppcre:regex-replace-all "valA" data-path "valB")))))) - -(defmethod setup-next-condition ((experiment mwm-experiment) - (experiment-type (eql :incremental))) - (let* ((current-stage (get-configuration experiment :incremental-stage)) - (next-stage (1+ current-stage)) - (next-stage-name (format nil "phase_~a" next-stage))) - ;; message - (format t "~%~%SWITCHING FROM CONDITION ~a TO CONDITION ~a~%~%" - current-stage next-stage) - ;; export the lexicon before each condition switch - (lexicon->pdf (learner experiment) :serie (series-number experiment)) - ;; set the config - (set-configuration experiment :incremental-stage next-stage :replace t) - ;; reload the world with a different dataset - (setf (world experiment) - (make-instance 'clevr-world :data-sets (list next-stage-name))) - ;; when the data-type is :extracted - ;; also changed the data-path - (when (eql (get-configuration experiment :world-type) :extracted) - (let ((data-path (namestring (find-data experiment :ns-vqa-data-path)))) - (set-data experiment :ns-vqa-data-path - (parse-namestring - (cl-ppcre:regex-replace-all (format nil "/phase_~a" current-stage) - data-path - (format nil "/phase_~a" next-stage)))))))) - - - - - - - + (alignment learner (get-data learner 'topic) + (find-data learner 'applied-concept))))) + ;;;; ;;;; interact ;;;; -(defmethod interact ((experiment mwm-experiment) interaction &key) - (let ((experiment-type (get-configuration experiment :experiment-type))) - (when (switch-condition-p experiment experiment-type) - (setup-next-condition experiment experiment-type))) +(defmethod interact ((experiment spatial-experiment) interaction &key) ;; regular interaction (before-interaction experiment) (do-interaction experiment) -- GitLab From 643f861ff4d14bbcfcdc1330e2ea4734fe9bed34 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 14:49:33 +0200 Subject: [PATCH 063/157] Changed mwm-object to spatial-object and modified object->alist --- experiments/spatial-concept-game/world.lisp | 44 ++++++++++++--------- 1 file changed, 25 insertions(+), 19 deletions(-) diff --git a/experiments/spatial-concept-game/world.lisp b/experiments/spatial-concept-game/world.lisp index 5a90e4f3a..b9ef5674d 100644 --- a/experiments/spatial-concept-game/world.lisp +++ b/experiments/spatial-concept-game/world.lisp @@ -1,11 +1,11 @@ (in-package :spatial-concepts) -(export '(mwm-object)) +(export '(spatial-object)) ;; -------------- -;; + MWM object + +;; + SPATIAL object + ;; -------------- -(defclass mwm-object (entity) +(defclass spatial-object (entity) ((attributes :documentation "the attributes of the object (a-list)" :type list :accessor attributes :initarg :attributes) @@ -14,28 +14,34 @@ :type list :accessor description :initarg :description)) (:documentation "A continuous-valued CLEVR object")) -(defmethod get-attr-val ((object mwm-object) attr) +(defmethod get-attr-val ((object spatial-object) attr) (rest (assoc attr (attributes object)))) -(defmethod set-attr-val ((object mwm-object) attr val) +(defmethod set-attr-val ((object spatial-object) attr val) (if (assoc attr (attributes object)) (setf (rest (assoc attr (attributes object))) val) (push (cons attr val) (attributes object))) nil) -(defmethod object->alist ((object clevr-object)) +#|(defmethod object->alist ((object clevr-object)) `((:color . ,(color object)) (:size . ,(clevr-world::size object)) (:shape . ,(shape object)) (:material . ,(material object)) (:xpos . ,(if (> (x-pos object) 240) 'right 'left)) (:ypos . ,(if (> (y-pos object) 160) 'front 'behind)) - )) + ))|# + +(defmethod object->alist ((object clevr-object)) + `((:left . ,(rest (assoc 'left (relationships object)))) + (:right . ,(rest (assoc 'right (relationships object)))) + (:front . ,(rest (assoc 'front (relationships object)))) + (:behind. ,(rest (assoc 'behind (relationships object)))))) ;; ------------------ -;; + MWM object set + +;; + SPATIAL object set + ;; ------------------ -(defclass mwm-object-set (entity) +(defclass spatial-object-set (entity) ((objects :documentation "the objects in the set" :type list :accessor objects :initarg :objects @@ -46,7 +52,7 @@ (:documentation "A set of mww-objects")) ;; ---------------- -;; + CLEVR -> MWM + +;; + CLEVR -> SPATIAL + ;; ---------------- (defun add-random-value-from-range (value min-var max-var @@ -125,15 +131,15 @@ (add-random-value-from-range ratio 0.0 0.25))) `((wh-ratio . ,ratio-with-variance)))) -;;;; clevr -> mwm +;;;; clevr -> spatial (defmethod clevr->simulated ((scene clevr-scene)) - (make-instance 'mwm-object-set :id (id scene) + (make-instance 'spatial-object-set :id (id scene) :image (image scene) :objects (loop for obj in (objects scene) collect (clevr->simulated obj)))) (defmethod clevr->simulated ((object clevr-object)) - (make-instance 'mwm-object :id (id object) ;; !!! + (make-instance 'spatial-object :id (id object) ;; !!! :attributes (append (to-value object 'xpos) (to-value object 'ypos) (to-value object 'area) @@ -146,11 +152,11 @@ ;; --------- ;; + NOISE + ;; --------- -(defmethod add-noise ((set mwm-object-set) probability amount) +(defmethod add-noise ((set spatial-object-set) probability amount) (loop for object in (objects set) do (add-noise object probability amount))) -(defmethod add-noise ((object mwm-object) probability amount) +(defmethod add-noise ((object spatial-object) probability amount) (loop for (attr . val) in (attributes object) unless (member attr '(nr-of-sides nr-of-corners)) do (when (< (random 1.0) probability) @@ -161,7 +167,7 @@ ;; + Continous CLEVR data + ;; ------------------------ -(defun extracted->mwm-object (alist) +(defun extracted->spatial-object (alist) "Load a single object" (let* ((mean-color (rest (assoc :color-mean alist))) (lab (hsv->lab mean-color))) @@ -184,7 +190,7 @@ (setf (cdr (assoc 'angle alist)) (- (cdr (assoc 'angle alist)))) ;; create an object - (make-instance 'mwm-object + (make-instance 'spatial-object :id (make-id 'object) :attributes alist))) @@ -198,9 +204,9 @@ directory)) (objects (with-open-file (stream path :direction :input) - (mapcar #'extracted->mwm-object + (mapcar #'extracted->spatial-object (mapcar #'decode-json-from-string (stream->list stream)))))) - (make-instance 'mwm-object-set + (make-instance 'spatial-object-set :id (make-id 'scene) :objects objects))) -- GitLab From 715d4ba794e4f49be71d2f1aef3627096c866ef8 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Tue, 29 Mar 2022 15:31:53 +0200 Subject: [PATCH 064/157] direct-and-prep-obj-ditransitive-verb-cxn info and arg structure added and bidirectionally tested --- .../bidirectional_grammar_info_arg_struct.fcg | 142 +++++++++++++++++- 1 file changed, 138 insertions(+), 4 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index de107d30a..af4ad3efd 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -1132,9 +1132,141 @@ +;der Mann hat für den Clown die Blumen mitgebracht +(def-fcg-cxn direct-and-indirect-obj-argument-structure-cxn + ((?direct-and-indirect-obj-argument-structure-cxn + (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?benefactive-unit + (syn-cat (syn-role prepositional-object))) + (?patient-unit + (syn-cat (syn-role direct-object))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect)) + (referent ?v) + -- + (referent ?v) + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect))) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?ns ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?ns ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?benefactive-unit + (syn-cat (lex-class prep-phrase)) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + ) + (referent ?arg2)) + + (?patient-unit + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1)) + + (?direct-and-indirect-obj-argument-structure-cxn + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) +(def-fcg-cxn topic-arg0-arg1-arg2-perfect-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?aux-unit) + (meets ?aux-unit ?leftmost-benefactive-unit) + (meets ?rightmost-patient-unit ?participle-unit))) + (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit))) + + (?verb-unit + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + + -- + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?benefactive-unit + (syn-cat (syn-role prepositional-object) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-benefactive-unit) + (rightmost-unit ?rightmost-benefactive-unit)) + -- + (syn-cat (syn-role prepositional-object) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-benefactive-unit) + (rightmost-unit ?rightmost-benefactive-unit))) + + (?patient-unit + (syn-cat (syn-role direct-object) + (lex-class noun-phrase)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + (syn-cat (syn-role direct-object) + (lex-class noun-phrase)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + )) @@ -1142,7 +1274,7 @@ ;der Mann geht ohne den Clown zur Arbeit -(def-fcg-cxn double-intransitive-argument-structure-cxn +#|(def-fcg-cxn double-intransitive-argument-structure-cxn ((?double-intransitive-argument-structure-unit (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) (?agent-unit @@ -1269,7 +1401,7 @@ (meets ?verb-unit ?leftmost-ad-info-unit) (meets ?rightmost-ad-info-unit ?leftmost-location-unit)))) - )) + ))|# @@ -1351,7 +1483,6 @@ ;;; dem Clown schenkt der Mann die Blumen - stuck (formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) - ;;;der Mann geht zum Shop (formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized m +))) @@ -1362,7 +1493,10 @@ (formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) ;;; der Mann ist gegen den Shop gefahren -(formulate '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) +(formulate-all '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) + +;; der Mann hat für den Clown die Blumen mitgebracht +(formulate '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) ;;; der Mann geht ohne den Clown zur Arbeit (formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) -- GitLab From e29b42d31ffccb1c3d8733c64f22c10fdd3ea116 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 16:18:06 +0200 Subject: [PATCH 065/157] changed type of pointed-object from symbol to spatial-object --- experiments/spatial-concept-game/agent.lisp | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/experiments/spatial-concept-game/agent.lisp b/experiments/spatial-concept-game/agent.lisp index 472a9afe6..cfbae9fd5 100644 --- a/experiments/spatial-concept-game/agent.lisp +++ b/experiments/spatial-concept-game/agent.lisp @@ -11,8 +11,8 @@ :documentation "Maintaining versions of concepts" :type list :accessor concept-history :initform nil) (pointed-object - :documentation "Id of the object the tutor points to in production" - :type (or symbol fixnum) :accessor pointed-object :initform nil)) + :documentation "The object the tutor points to in production" + :type spatial-object :accessor pointed-object :initform nil)) (:documentation "The agent class")) ;; --------------------------- @@ -112,10 +112,11 @@ if (and (member (id topic) (cdr relationship)) (= (length (cdr relationship)) 1)) return (car relationship)) - if discriminative-relationship + when discriminative-relationship do (progn (set-data agent 'tutor-conceptualisation discriminative-relationship) - (setf (pointed-object agent) (id object))))) + (setf (pointed-object agent) (clevr->simulated object)) + (return)))) ;; -------------- -- GitLab From f0dc2fb73b432ef836870f57b52b43ed28f9e020 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 16:19:53 +0200 Subject: [PATCH 066/157] modified adopt-concept (working) and align-concept (not yet working) --- experiments/spatial-concept-game/alignment.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/experiments/spatial-concept-game/alignment.lisp b/experiments/spatial-concept-game/alignment.lisp index f78e0c0b5..9ff23a164 100644 --- a/experiments/spatial-concept-game/alignment.lisp +++ b/experiments/spatial-concept-game/alignment.lisp @@ -12,7 +12,8 @@ (defmethod adopt-concept ((agent spatial-agent) (topic spatial-object) word) (let ((new-concept (make-concept word (attributes topic) - (get-configuration agent :initial-certainty)))) + (get-configuration agent :initial-certainty) + (pointed-object agent)))) (push new-concept (lexicon agent)) (notify new-concept-added new-concept) new-concept)) @@ -138,10 +139,10 @@ game.")) -(defmethod align-concept ((agent spatial-agent) (topic spatial-object) concept) +(defmethod align-concept ((agent spatial-agent) (topic spatial-object) (concept concept)) ;; 1. update the prototypical values (loop for prototype in (meaning concept) - do (update-prototype prototype topic)) + do (update-prototype prototype topic (pointed-object agent))) ;; 2. determine which attributes should get an increase ;; in certainty, and which should get a decrease. (let* ((similarity-table -- GitLab From 1b349f23b1e7b9d2419c8de3a99b1b8edaeb3384 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 16:22:34 +0200 Subject: [PATCH 067/157] added relate-to-pointed-object function and use it inside make-concept (working) and update-prototype (not yet working) --- experiments/spatial-concept-game/concept.lisp | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/experiments/spatial-concept-game/concept.lisp b/experiments/spatial-concept-game/concept.lisp index 232b156a5..b312dac88 100644 --- a/experiments/spatial-concept-game/concept.lisp +++ b/experiments/spatial-concept-game/concept.lisp @@ -11,13 +11,16 @@ :accessor meaning :initarg :meaning :type list)) (:documentation "a concept, or lexical item")) -(defun make-concept (form attribute-proto-cons initial-certainty) +(defun make-concept (form attribute-proto-cons initial-certainty pointed-object) (make-instance 'concept :form form :meaning (loop for (attribute . proto-value) in attribute-proto-cons - collect (make-prototype attribute proto-value + collect (make-prototype attribute (relate-to-pointed-object proto-value attribute pointed-object) initial-certainty)))) +(defun relate-to-pointed-object (proto-value attribute pointed-object) + (- proto-value (get-attr-val pointed-object attribute))) + (defmethod copy-object-content ((source entity) (destination entity)) (setf (id destination) (make-id (get-base-name (mkstr (id source)))))) @@ -75,15 +78,19 @@ :M2 0.05)) -(defgeneric update-prototype (prototype object) +(defgeneric update-prototype (prototype object pointed-object) (:documentation "Update the category based on the object")) (defmethod update-prototype ((prototype prototype) - (object spatial-object)) + (object spatial-object) + (pointed-object spatial-object)) ;; take the object pointed to by the tutor ;; and estimate the mean and variance of the category (incf (nr-samples prototype)) - (let* ((exemplar (get-attr-val object (attribute prototype))) + (let* ((attribute (attribute protoype)) + (attribute-value (get-attr-val object attribute)) + (pointed-attribute-value (get-attr-val pointed-object attribute)) + (exemplar (relate-to-pointed-object attribute-value attribute pointed-object)) (delta-1 (- exemplar (value prototype))) (new-prototypical-value (+ (value prototype) (/ delta-1 (nr-samples prototype)))) (delta-2 (- exemplar new-prototypical-value)) -- GitLab From 38ac666a4689e576ecc18f8d2bf76297c637941b Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 16:23:47 +0200 Subject: [PATCH 068/157] modified trace-interaction-in-web-interface --- experiments/spatial-concept-game/web-monitor.lisp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/experiments/spatial-concept-game/web-monitor.lisp b/experiments/spatial-concept-game/web-monitor.lisp index 4f3241783..b8b948eec 100644 --- a/experiments/spatial-concept-game/web-monitor.lisp +++ b/experiments/spatial-concept-game/web-monitor.lisp @@ -76,10 +76,10 @@ ;; tutor ((and (tutorp agent) (find-data agent 'tutor-conceptualisation)) (add-element - '((h2) "Tutor found discriminating attributes:")) + '((h2) "Tutor points to object:")) (add-element `((h3) ((i) ,(format nil "~a" - (find-data agent 'tutor-conceptualisation)))))) + (id (pointed-object agent))))))) ;; learner ((and (learnerp agent) (find-data agent 'applied-concept)) (add-element @@ -91,7 +91,7 @@ ;; failed (t (add-element - `((h2) ,(format nil "~@(~a~) did not find discriminating attributes" + `((h2) ,(format nil "~@(~a~) did not find discriminating spatial relation" (id agent))))))) -- GitLab From bf9102609f1c2944f4d18faf4e14360360c67e4a Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 16:25:52 +0200 Subject: [PATCH 069/157] modified clevr->simulated to only contain x- and y-positions as attributes --- experiments/spatial-concept-game/world.lisp | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/experiments/spatial-concept-game/world.lisp b/experiments/spatial-concept-game/world.lisp index b9ef5674d..35c42c7f4 100644 --- a/experiments/spatial-concept-game/world.lisp +++ b/experiments/spatial-concept-game/world.lisp @@ -142,11 +142,12 @@ (make-instance 'spatial-object :id (id object) ;; !!! :attributes (append (to-value object 'xpos) (to-value object 'ypos) - (to-value object 'area) - (to-value object 'wh-ratio) - (to-value object 'color) - (to-value object 'roughness) - (to-value object 'sides-and-corners)) + ;(to-value object 'area) + ;(to-value object 'wh-ratio) + ;(to-value object 'color) + ;(to-value object 'roughness) + ;(to-value object 'sides-and-corners) + ) :description (object->alist object))) ;; --------- -- GitLab From cc2ff13d8099c51eaade23970ad412d21512eb1b Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 16:57:52 +0200 Subject: [PATCH 070/157] modified update-prototype to work with values relative to pointed object (works now) --- experiments/spatial-concept-game/concept.lisp | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/experiments/spatial-concept-game/concept.lisp b/experiments/spatial-concept-game/concept.lisp index b312dac88..ae240eff2 100644 --- a/experiments/spatial-concept-game/concept.lisp +++ b/experiments/spatial-concept-game/concept.lisp @@ -87,10 +87,7 @@ ;; take the object pointed to by the tutor ;; and estimate the mean and variance of the category (incf (nr-samples prototype)) - (let* ((attribute (attribute protoype)) - (attribute-value (get-attr-val object attribute)) - (pointed-attribute-value (get-attr-val pointed-object attribute)) - (exemplar (relate-to-pointed-object attribute-value attribute pointed-object)) + (let* ((exemplar (relate-to-pointed-object (get-attr-val object (attribute prototype)) (attribute prototype) pointed-object)) (delta-1 (- exemplar (value prototype))) (new-prototypical-value (+ (value prototype) (/ delta-1 (nr-samples prototype)))) (delta-2 (- exemplar new-prototypical-value)) -- GitLab From d071deb3fe4f18fa40767aa98f98b51e9ba44bd9 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 17:24:17 +0200 Subject: [PATCH 071/157] modified arguments passed to weighted similarity function inside the interpret method --- experiments/spatial-concept-game/agent.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/experiments/spatial-concept-game/agent.lisp b/experiments/spatial-concept-game/agent.lisp index cfbae9fd5..6147a2596 100644 --- a/experiments/spatial-concept-game/agent.lisp +++ b/experiments/spatial-concept-game/agent.lisp @@ -166,7 +166,7 @@ (let* ((objects-with-similarity (loop with concept = (find-data agent 'applied-concept) for object in (objects (get-data agent 'context)) - for sim = (weighted-similarity object concept) + for sim = (weighted-similarity object concept (pointed-object agent)) collect (cons object sim))) ;; if two objects have exactly the same ;; maximum similarity, interpretation fails -- GitLab From faf092d0e611d1d1e9bcb76b2ccff23a56a3e21b Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 17:25:51 +0200 Subject: [PATCH 072/157] modified number of arguments passed to similarity in make-similarity-table --- experiments/spatial-concept-game/alignment.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/experiments/spatial-concept-game/alignment.lisp b/experiments/spatial-concept-game/alignment.lisp index 9ff23a164..cda29b11e 100644 --- a/experiments/spatial-concept-game/alignment.lisp +++ b/experiments/spatial-concept-game/alignment.lisp @@ -38,7 +38,7 @@ for objects-hash = (loop with hash = (make-hash-table) for object in (objects (get-data agent 'context)) - for s = (similarity object prototype) + for s = (similarity object prototype (pointed-object agent)) for ws = (* (certainty prototype) s) do (setf (gethash (id object) hash) (cons s ws)) finally (return hash)) -- GitLab From a80d87042c0a3902586f454e7c205c3003b07633 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 17:27:21 +0200 Subject: [PATCH 073/157] modified similarity and weighted-similarity functions to relate values to the pointed-object --- experiments/spatial-concept-game/concept.lisp | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/experiments/spatial-concept-game/concept.lisp b/experiments/spatial-concept-game/concept.lisp index ae240eff2..026f3e061 100644 --- a/experiments/spatial-concept-game/concept.lisp +++ b/experiments/spatial-concept-game/concept.lisp @@ -97,22 +97,22 @@ prototype)) -(defgeneric weighted-similarity (object concept) +(defgeneric weighted-similarity (object concept pointed-object) (:documentation "Compute the weighted similarity between an object and a concept")) -(defmethod weighted-similarity ((object spatial-object) (concept concept)) +(defmethod weighted-similarity ((object spatial-object) (concept concept) (pointed-object spatial-object)) (loop for prototype in (meaning concept) - for similarity = (similarity object prototype) + for similarity = (similarity object prototype pointed-object) collect (* (certainty prototype) similarity) into weighted-similarities finally (return (average weighted-similarities)))) -(defgeneric similarity (object prototype) +(defgeneric similarity (object prototype pointed-object) (:documentation "Similarity on the level of a single prototype")) -(defmethod similarity ((object spatial-object) (prototype prototype)) +(defmethod similarity ((object spatial-object) (prototype prototype) (pointed-object spatial-object)) (let* ((max-z-score 2) - (exemplar (get-attr-val object (attribute prototype))) + (exemplar (relate-to-pointed-object (get-attr-val object (attribute prototype)) (attribute prototype) pointed-object)) (stdev (sqrt (/ (M2 prototype) (nr-samples prototype)))) (z-score (abs (/ (- exemplar (value prototype)) stdev)))) (max (/ (+ (- z-score) max-z-score) max-z-score) -1))) -- GitLab From e36ce2f3cd25df5eac922e323695cfdceb2c7781 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Tue, 29 Mar 2022 17:28:53 +0200 Subject: [PATCH 074/157] changed number of interactions for testing --- experiments/spatial-concept-game/run.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/experiments/spatial-concept-game/run.lisp b/experiments/spatial-concept-game/run.lisp index aa29c0495..590afe378 100644 --- a/experiments/spatial-concept-game/run.lisp +++ b/experiments/spatial-concept-game/run.lisp @@ -33,7 +33,7 @@ (run-interaction *experiment*) -(run-series *experiment* 300) +(run-series *experiment* 10) (display-lexicon (find 'learner (population *experiment*) :key #'id)) -- GitLab From bbb7e6ca1bedd867daaeb76cb26a74a22d2f89d8 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Wed, 30 Mar 2022 13:33:51 +0200 Subject: [PATCH 075/157] complete grammatical cxns set --- .../german_cases/bidirectional_grammar.fcg | 1641 +++++++++++++++++ .../bidirectional_grammar_info_arg_struct.fcg | 440 ++++- 2 files changed, 2022 insertions(+), 59 deletions(-) create mode 100644 grammars/german_cases/bidirectional_grammar.fcg diff --git a/grammars/german_cases/bidirectional_grammar.fcg b/grammars/german_cases/bidirectional_grammar.fcg new file mode 100644 index 000000000..0853cc2e5 --- /dev/null +++ b/grammars/german_cases/bidirectional_grammar.fcg @@ -0,0 +1,1641 @@ +(in-package :fcg-editor) + +;; generation from noun meaning generates PP even with only Article +;;; ditransitive with schenken does not work in formulation for topicalized +;;; creating different constructions for verbs with different PP and argument structure? + + +(def-fcg-constructions german-case-grammar + :feature-types ((args sequence) + (form set-of-predicates) + (meaning set-of-predicates) + (subunits set) + (footprints set) + (case sequence)) + :fcg-configurations ((:max-nr-of-nodes . 40000) + (:parse-goal-tests :no-strings-in-root :connected-structure :no-applicable-cxns) + (:production-goal-tests + :no-applicable-cxns :connected-structure + :no-meaning-in-root))) + +;;;;DETERMINERS + +(def-fcg-cxn der-cxn + ((?the-word + (footprints (article))) + <- + (?the-word + (footprints (not article)) + (syn-cat (lex-class article) + (case ((?nm ?nm - - -) ;nom, acc, gen, dat (nom masculine) + (- - - - -) ;masc, fem, neut, plural + (?gen - ?gf - ?gp) ;genitive feminine + (?df - ?df - -) ;sing, masc, fem, neut, plural + (?s ?nm ?f - ?gp)))) ;sing, masc, fem, neut, plural + + -- + (HASH form ((string ?the-word "der"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn dem-cxn + ((?the-word + (footprints (article))) + <- + (?the-word + (footprints (not article)) + (syn-cat (lex-class article) + (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) + (- - - - -) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (+ ?dm - ?dn -) ;sing, masc, fem, neut, plural + (+ ?dm - ?dn -)))) ;sing, masc, fem, neut, plural + + -- + (HASH form ((string ?the-word "dem"))))) + :disable-automatic-footprints t) + + +(def-fcg-cxn die-cxn + ((?the-word + (footprints (article))) + <- + (?the-word + (footprints (not article)) + (syn-cat (lex-class article) + (case ((?nom - ?nf - ?np) ;nom, acc, gen, dat (nom masculine) + (?acc - ?af - ?ap) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (- - - - -) + (?s - ?f - ?p)))) ;sing, masc, fem, neut, plural + + -- + (HASH form ((string ?the-word "die"))))) + :disable-automatic-footprints t) + + +(def-fcg-cxn den-cxn + ((?the-word + (footprints (article))) + <- + (?the-word + (footprints (not article)) + (syn-cat (lex-class article) + (case ((- - - - -) + (?am ?am - - -) + (- - - - -) + (?dp - - - ?dp) + (?am ?am - - ?dp)))) ;sing, masc, fem, neut, plural + + -- + (HASH form ((string ?the-word "den"))))) + :disable-automatic-footprints t) + + +(def-fcg-cxn das-cxn + ((?the-word + (footprints (article))) + <- + (?the-word + (footprints (not article)) + (syn-cat (lex-class article) + (case ((?nn - - ?nn -) ;nom, acc, gen, dat (nom masculine) + (?an - - ?an -) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (- - - - -) + (+ - - + -)))) ;sing, masc, fem, neut, plural + + -- + (HASH form ((string ?the-word "das"))))) + :disable-automatic-footprints t) + + +(def-fcg-cxn zur-cxn + (<- + (?to-word + (syn-cat (lex-class contracted-preposition) + (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) + (- - - - -) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (+ - ?df - -) + (+ - ?df - -)))) + -- + (HASH form ((string ?to-word "zur")))))) + + +(def-fcg-cxn zum-cxn + (<- + (?to-word + (syn-cat (lex-class contracted-preposition) + (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) + (- - - - -) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (+ ?dm - ?dn -) + (+ ?dm - ?dn -)))) + -- + (HASH form ((string ?to-word "zum")))))) + + +(def-fcg-cxn gegen-cxn + ((?against-word + (footprints (preposition))) + <- + (?against-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?against-word "gegen"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn für-cxn + ((?for-word + (footprints (preposition))) + <- + (?for-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?for-word "für"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn ohne-cxn + ((?without-word + (footprints (preposition))) + <- + (?without-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?without-word "ohne"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn mit-cxn + ((?with-word + (footprints (preposition))) + <- + (?with-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?dm ?df ?dn ?dp)))) + -- + (HASH form ((string ?with-word "mit"))))) + :disable-automatic-footprints t) + + +(def-fcg-cxn aus-cxn + ((?from-word + (footprints (preposition))) + <- + (?from-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?dm ?df ?dn ?dp)))) + -- + (HASH form ((string ?from-word "aus"))))) + :disable-automatic-footprints t) + + + +;;;;NOUNS + +(def-fcg-cxn Blumen-cxn + ((?flowers-word + (referent ?x) ;set of values + (syn-cat (lex-class noun) ;sure nominative and masculine + (case ((?np - - - ?np) + (?ap - - - ?ap) + (?gp - - - ?gp) + (?dp - - - ?dp) + (- - - - +))))) + <- + (?flowers-word + (HASH meaning ((flowers ?x))) + -- + (HASH form ((string ?flowers-word "Blumen")))))) + +(def-fcg-cxn Arbeit-cxn + ((?work-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nf - ?nf - -) + (?af - ?af - -) + (?gf - ?gf - -) + (?df - ?df - -) + (+ - + - -))))) + <- + (?work-word + (HASH meaning ((work ?x))) + -- + (HASH form ((string ?work-word "Arbeit")))))) + +(def-fcg-cxn Mann-cxn + ((?man-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))))) + <- + (?man-word + (HASH meaning ((man ?x))) + -- + (HASH form ((string ?man-word "Mann")))))) + +(def-fcg-cxn Fahrrad-cxn + ((?bike-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nn - - ?nn -) + (?an - - ?an -) + (- - - - -) + (?dn - - ?dn -) + (+ - - + -))))) + <- + (?bike-word + (HASH meaning ((bike ?x))) + -- + (HASH form ((string ?bike-word "Fahrrad")))))) + + +(def-fcg-cxn Shop-cxn + ((?shop-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nom ?nm - - ?np) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (?s + - - ?np))))) + <- + (?shop-word + (HASH meaning ((shop ?x))) + -- + (HASH form ((string ?shop-word "Shop")))))) + + +(def-fcg-cxn Bäcker-cxn + ((?baker-word + (referent (?x)) + (syn-cat (lex-class noun) + (case ((?nom ?nm - - ?np) + (?acc ?am - - ?ap) + (?pg - - - ?pg) + (?dm ?dm - - -) + (?s + - - ?p))))) + <- + (?baker-word + (HASH meaning ((baker ?x))) + -- + (HASH form ((string ?baker-word "Bäcker")))))) + + + +(def-fcg-cxn Clown-cxn + ((?clown-word + (referent ?x) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))))) + <- + (?clown-word + (HASH meaning ((clown ?x))) + -- + (HASH form ((string ?clown-word "Clown")))))) + +;;;PHRASES + +(def-fcg-cxn noun-phrase-cxn + ((?noun-phrase + (referent ?x) + (syn-cat (lex-class noun-phrase) + (case ?case)) + (subunits (?article ?noun)) + (boundaries (leftmost-unit ?article) + (rightmost-unit ?noun))) + (?article + (referent ?x) + (part-of-noun-phrase +)) + + (?noun + (footprints (determined))) + <- + (?article + -- + (syn-cat (lex-class article) + (case ?case))) + (?noun + (footprints (not determined)) + (referent ?x) + (syn-cat (lex-class noun) + (case ?case)) + -- + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ?case))) + (?noun-phrase + -- + (HASH form ((meets ?article ?noun))) + )) + :disable-automatic-footprints t) + + +(def-fcg-cxn contracted-prep-phrase-cxn + ((?contracted-prep-phrase + (referent ?x) + (syn-cat (lex-class prep-phrase) + (case ?case)) + (subunits (?contracted-prep ?noun)) + (boundaries (leftmost-unit ?contracted-prep) + (rightmost-unit ?noun))) + (?contracted-prep + (part-of-prep-phrase +) + (referent ?x)) + (?noun + (footprints (determined))) + <- + (?contracted-prep + -- + (syn-cat (lex-class contracted-preposition) + (case ?case))) + (?noun + (footprints (not determined)) + (referent ?x) + (syn-cat (lex-class noun) + (case ?case)) + + -- + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ?case))) + + (?contracted-prep-phrase + -- + (HASH form ((meets ?contracted-prep ?noun))) + )) + :disable-automatic-footprints t) + + +(def-fcg-cxn prepositional-phrase-cxn + ((?prep-phrase + (referent ?x) + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p)))) + (subunits (?preposition ?article ?noun)) + (boundaries (leftmost-unit ?preposition) + (rightmost-unit ?noun))) + (?preposition + (referent ?x) + (part-of-prep-phrase +)) + + (?article + (referent ?x) + ;(part-of-noun-phrase +)) + ) + + (?noun + (footprints (determined)) + ) + <- + + (?preposition + -- + (syn-cat (lex-class preposition) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?article + -- + (syn-cat (lex-class article) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?noun + + (referent ?x) + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p)))) + -- + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?prep-phrase + -- + (HASH form ((meets ?preposition ?article) + (meets ?article ?noun))) + )) + :disable-automatic-footprints t) + +;;;VERBS + +(def-fcg-cxn kommt-cxn + ((?come-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive) + (location origin-only)) + (referent ?k)) + + <- + (?come-word + (HASH meaning ((kommen-01 ?k))) + -- + (HASH form ((string ?come-word "kommt")))))) + +(def-fcg-cxn geht-cxn + ((?go-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive)) + (referent ?g)) + + <- + (?go-word + (HASH meaning ((gehen-01 ?g))) + -- + (HASH form ((string ?go-word "geht")))))) + +(def-fcg-cxn fährt-cxn + ((?drive-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive) + (args single)) + (referent ?f)) + + <- + (?drive-word + (HASH meaning ((fahren-01 ?f))) + -- + (HASH form ((string ?drive-word "fährt")))))) + +(def-fcg-cxn sucht-cxn + ((?search-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type transitive)) + (referent ?s)) + + <- + (?search-word + (HASH meaning ((suchen-01 ?s))) + -- + (HASH form ((string ?search-word "sucht")))))) + +(def-fcg-cxn schenkt-cxn + ((?gift-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type ditransitive)) + (referent ?g)) + + <- + (?gift-word + (HASH meaning ((schenken-01 ?g))) + -- + (HASH form ((string ?gift-word "schenkt")))))) + + +(def-fcg-cxn ist-gefahren-cxn + ((?drove-word + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (aspect perfect) + (type intransitive)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?ig)) + + <- + + (?aux-unit + -- + (HASH form ((string ?aux-unit "ist")))) + + (?participle-unit + -- + (HASH form ((string ?participle-unit "gefahren")))) + + (?drove-word + (HASH meaning ((drove-01 ?ig))) + -- + ))) + +(def-fcg-cxn hat-mitgebracht-cxn + ((?brought-word + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (aspect perfect) + (type ditransitive)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?hm)) + + <- + + (?aux-unit + -- + (HASH form ((string ?aux-unit "hat")))) + + (?participle-unit + -- + (HASH form ((string ?participle-unit "mitgebracht")))) + + (?brought-word + (HASH meaning ((brought-01 ?hm))) + -- + ))) + + +;;;;;VERB CONSTRUCTIONS + + +;TRANSITIVE VERBS + +(def-fcg-cxn transitive-argument-structure-cxn + ((?transitive-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (aspect ?aspect) + (type transitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (aspect ?aspect) + (type transitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?s ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?s ?nm ?nf ?nn ?np)))) + (referent ?arg0) + ) + + (?patient-unit + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?s ?am ?af ?an ?ap)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?s ?am ?af ?an ?ap)))) + (referent ?arg1) + ) + + (?transitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1))) + -- + ))) + +(def-fcg-cxn topic-arg0-arg1-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type transitive) + (aspect ?aspect)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type transitive) + (aspect ?aspect)) + (referent ?v)) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?patient-unit + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + + )) + +(def-fcg-cxn arg0-topic-arg1-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit)) + (HASH meaning ((topicalized ?arg1 +))) + + -- + (HASH form ((meets ?rightmost-patient-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type transitive) + (aspect ?aspect)) + -- + (syn-cat (lex-class verb) + (type transitive) + (aspect ?aspect))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?patient-unit + (referent ?arg1) + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + + (referent ?arg1) + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + + )) + + + +;;;DITRANSITIVE VERBS + + +;der Mann schenkt dem Clown die Blumen + +(def-fcg-cxn ditransitive-argument-structure-cxn + ((?ditransitive-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?patient-unit + (syn-cat (syn-role direct-object))) + (?receiver-unit + (syn-cat (syn-role indirect-object))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type ditransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?patient-unit + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1) + ) + (?receiver-unit + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?rs ?dm ?df ?dn ?dp)))) + (referent ?arg2) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?rs ?dm ?df ?dn ?dp)))) + (referent ?arg2)) + + (?ditransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) + +(def-fcg-cxn topic-arg0-arg1-arg2-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-receiver-unit) + (meets ?rightmost-receiver-unit ?leftmost-patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive)) + + -- + (syn-cat (lex-class verb) + (type ditransitive))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?patient-unit + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + + (?receiver-unit + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit)) + -- + + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit))) + + )) + +(def-fcg-cxn arg0-arg1-topic-arg2-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit)) + (HASH meaning ((topicalized ?arg2 +))) + + -- + (HASH form ((meets ?rightmost-receiver-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit) + (meets ?rightmost-agent-unit ?leftmost-patient-unit))) + (subunits (?verb-unit ?agent-unit ?patient-unit ?receiver-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive)) + + -- + (syn-cat (lex-class verb) + (type ditransitive))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?patient-unit + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + + (syn-cat (syn-role direct-object)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + + (?receiver-unit + (referent ?arg2) + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit)) + -- + (referent ?arg2) + (syn-cat (syn-role indirect-object)) + (boundaries (leftmost-unit ?leftmost-receiver-unit) + (rightmost-unit ?rightmost-receiver-unit))) + + )) + + + + + +;MOTION VERBS + +;der Mann geht zur Arbeit + +(def-fcg-cxn intransitive-argument-structure-cxn + ((?intransitive-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?location-unit + (syn-cat (syn-role locative-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg4) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg4)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg4 ?v ?arg4))) + -- + ))) + +(def-fcg-cxn topic-arg0-arg4-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?location-unit + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + +(def-fcg-cxn arg0-topic-arg4-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg4 +))) + + -- + (HASH form ((meets ?rightmost-location-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive) + (aspect ?aspect))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?location-unit + (referent ?arg4) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (referent ?arg4) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + +;;;VERBS PERFECT + +(def-fcg-cxn topic-arg0-arg4-perfect-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?aux-unit) + (meets ?aux-unit ?leftmost-location-unit) + (meets ?rightmost-location-unit ?participle-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) + + (?verb-unit + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type intransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + + -- + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type intransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?location-unit + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + + +;der Mann hat für den Clown die Blumen mitgebracht + +(def-fcg-cxn direct-and-indirect-obj-argument-structure-cxn + ((?direct-and-indirect-obj-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?benefactive-unit + (syn-cat (syn-role prepositional-object))) + (?patient-unit + (syn-cat (syn-role direct-object))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect)) + (referent ?v) + -- + (referent ?v) + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect))) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?ns ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?ns ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?benefactive-unit + (syn-cat (lex-class prep-phrase)) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + ) + (referent ?arg2)) + + (?patient-unit + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?ap)))) + (referent ?arg1)) + + (?direct-and-indirect-obj-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) + + +(def-fcg-cxn topic-arg0-arg1-arg2-perfect-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?aux-unit) + (meets ?aux-unit ?leftmost-benefactive-unit) + (meets ?rightmost-patient-unit ?participle-unit))) + (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit))) + + (?verb-unit + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + + -- + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type ditransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?benefactive-unit + (syn-cat (syn-role prepositional-object) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-benefactive-unit) + (rightmost-unit ?rightmost-benefactive-unit)) + -- + (syn-cat (syn-role prepositional-object) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-benefactive-unit) + (rightmost-unit ?rightmost-benefactive-unit))) + + (?patient-unit + (syn-cat (syn-role direct-object) + (lex-class noun-phrase)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit)) + -- + (syn-cat (syn-role direct-object) + (lex-class noun-phrase)) + (boundaries (leftmost-unit ?leftmost-patient-unit) + (rightmost-unit ?rightmost-patient-unit))) + )) + + + +;;;VERBS WITH EXTRA INFORMATION + +;der Mann geht ohne den Clown zur Arbeit +;der Mann fährt mit dem Fahrrad zur Arbeit + + +(def-fcg-cxn intransitive-extra-argument-structure-cxn + ((?intransitive-extra-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?extra-info-unit + (syn-cat (syn-role extra-information))) + (?location-unit + (syn-cat (syn-role locative-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?extra-info-unit + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?extra-info) + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?extra-info)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg1)) + + (?intransitive-extra-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:extra-info ?v ?extra-info) + (:arg1 ?v ?arg1))) + -- + ))) + + + +(def-fcg-cxn topic-arg0-extra-info-arg1-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-extra-info-unit) + (meets ?rightmost-extra-info-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + -- + (syn-cat (lex-class verb) + (type intransitive))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?extra-info-unit + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit)) + -- + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit))) + + (?location-unit + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + +#|(def-fcg-cxn intransitive-extra-argument-arg4-structure-cxn + ((?intransitive-extra-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?extra-info-unit + (syn-cat (syn-role extra-information))) + (?location-unit + (syn-cat (syn-role locative-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?extra-info-unit + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?extra-info) + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?extra-info)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg4) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg4)) + + (?intransitive-extra-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:extra-info ?v ?extra-info) + (:arg4 ?v ?arg4))) + -- + ))) + + + +(def-fcg-cxn topic-arg0-extra-info-arg4-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-extra-info-unit) + (meets ?rightmost-extra-info-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type intransitive)) + -- + (syn-cat (lex-class verb) + (type intransitive))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?extra-info-unit + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit)) + -- + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit))) + + (?location-unit + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + + |# + +;;;;;;;;VERBS' ARGUMENTS + +;DITRANSITIVES (DIRECT ACC. AND INDIRECT OBJECT DATIVE) + +;;;geben (arg0 giver - arg1 thing given - arg2 entity or person given to) +;Die Frau gibt dem Mann den Apfel. + +;;;;schenken (arg0 giver- arg1 thing given- arg2 entity or person given to) +;Die Lehrerin schenkt dem Direktor die Blumen. + +;;;;zeigen (arg0 shower- arg1 thing seen or shown - arg2 seer) +;Der Vater zeigt dem Sohn die Brille. + + +;;;;verkaufen (arg0 seller- arg1 thing sold- arg2 buyer - arg3 price payed - arg4 benefactive) +;Der Doktor verkauft dem Clown das Buch. + + + + +;TRANSITIVES + +;;;;verfolgen (arg0 follower- arg1 thing followed) +;Der Hund verfolgt den Mann. + +;;;;töten (arg0 killer - arg1 corpse - arg2 instrument) +;Der Tiger tötet den Jäger. + +;;;;suchen (arg0 looker - arg1 thing looked for - arg2 attribute/complement of arg1) +;Der Polizist sucht den Bäcker. + + +;;;;rufen (arg0 caller - arg1 entity summoned/person called - arg2 benefactive/complement) +;Der König ruft der Kellner. + + + + + +;MOTION verbs + +;;;;gehen (arg0 goer - arg1 journey - arg3 start point - arg4 end point) +;Der Junge geht zum Arzt. +;Die Mutter geht ohne den Sohn zum Laden. + +;;;;kommen (arg1 entity in motion - arg2 extent - arg3 starting point -arg4 endpoint) + + +;;;;fahren (arg0 driver- arg1 vehicle or path) +;Der Mann fährt mit dem Fahrrad zur Arbeit. + + +;;;PERFECT +;Der Mann ist gegen den Shop gefahren. +;;;;mitbringen (arg0 bringen - arg1 thing brought - arg2 benefactive or destination - arg3 attribute - arg4 brought from) +;Die Königin hat für den König Blume mitgebracht. + + + + +;;; NPs with Determiners and PPs with NP+P or Contracted P +(formulate-all '((baker x))) + +;;;; der Mann sucht den Clown +(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized m +))) + +;;; den Clown sucht der Mann +(formulate-all '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized c +))) + +;;; der Mann schenkt dem Clown die Blumen +(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized m +))) + +;;; dem Clown schenkt der Mann die Blumen - stuck +(formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) + +;;;der Mann geht zum Shop +(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized m +))) + +; zum Shop geht der Mann +(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized s +))) + +;;; der Mann geht ohne den Clown zur Arbeit +(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) + +;;; der Mann ist gegen den Shop gefahren +(formulate-all '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) + +;; der Mann hat für den Clown die Blumen mitgebracht +(formulate '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) + +;;; der Mann geht ohne den Clown zur Arbeit +(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g w) (extra-info g c) (topicalized m +))) + diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index af4ad3efd..20ddac2f9 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -133,6 +133,19 @@ (HASH form ((string ?to-word "zum")))))) +(def-fcg-cxn beim-cxn + (<- + (?at-word + (syn-cat (lex-class contracted-preposition) + (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) + (- - - - -) ;masc, fem, neut, plural + (- - - - -) ;genitive feminine + (+ ?dm - ?dn -) + (+ ?dm - ?dn -)))) + -- + (HASH form ((string ?at-word "beim")))))) + + (def-fcg-cxn gegen-cxn ((?against-word (footprints (preposition))) @@ -297,7 +310,7 @@ (def-fcg-cxn Bäcker-cxn ((?baker-word - (referent (?x)) + (referent ?x) (syn-cat (lex-class noun) (case ((?nom ?nm - - ?np) (?acc ?am - - ?ap) @@ -496,6 +509,33 @@ -- (HASH form ((string ?go-word "geht")))))) +(def-fcg-cxn ist-cxn + ((?be-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type copula)) + (referent ?s)) + + <- + (?be-word + (HASH meaning ((sein-01 ?s))) + -- + (HASH form ((string ?be-word "ist")))))) + + +(def-fcg-cxn fährt-cxn + ((?drive-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type single-intransitive)) + (referent ?f)) + + <- + (?drive-word + (HASH meaning ((fahren-01 ?f))) + -- + (HASH form ((string ?drive-word "fährt")))))) + (def-fcg-cxn sucht-cxn ((?search-word (syn-cat (lex-class verb) @@ -1068,7 +1108,154 @@ (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) -- - (referent ?arg0) + (referent ?arg4) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + +(def-fcg-cxn locative-copula-argument-structure-cxn + ((?locative-copula-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?location-unit + (syn-cat (syn-role locative-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type copula)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type copula)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg1)) + + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg2)) + + (?locative-copula-argument-structure-unit + (HASH meaning ((:arg1 ?v ?arg1) + (:arg2 ?v ?arg2))) + -- + ))) + +(def-fcg-cxn topic-arg1-arg2-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg1 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type copula)) + + -- + (syn-cat (lex-class verb) + (type copula))) + + (?agent-unit + (referent ?arg1) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg1) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?location-unit + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + +(def-fcg-cxn arg1-topic-arg2-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg2 +))) + + -- + (HASH form ((meets ?rightmost-location-unit ?verb-unit) + (meets ?verb-unit ?leftmost-agent-unit))) + (subunits (?verb-unit ?agent-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type copula)) + + -- + (syn-cat (lex-class verb) + (type copula))) + + (?agent-unit + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?location-unit + (referent ?arg2) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (referent ?arg2) (syn-cat (syn-role locative-complement) (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) @@ -1135,7 +1322,7 @@ ;der Mann hat für den Clown die Blumen mitgebracht (def-fcg-cxn direct-and-indirect-obj-argument-structure-cxn - ((?direct-and-indirect-obj-argument-structure-cxn + ((?direct-and-indirect-obj-argument-structure-unit (subunits (?verb-unit ?agent-unit ?benefactive-unit ?patient-unit))) (?agent-unit (syn-cat (syn-role subject))) @@ -1197,7 +1384,7 @@ (?ps ?am ?af ?an ?ap)))) (referent ?arg1)) - (?direct-and-indirect-obj-argument-structure-cxn + (?direct-and-indirect-obj-argument-structure-unit (HASH meaning ((:arg0 ?v ?arg0) (:arg1 ?v ?arg1) (:arg2 ?v ?arg2))) @@ -1274,13 +1461,16 @@ ;der Mann geht ohne den Clown zur Arbeit -#|(def-fcg-cxn double-intransitive-argument-structure-cxn - ((?double-intransitive-argument-structure-unit - (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + +;;;this cxn applies only if intransitive-arg-structure-cxn is not included in the set - otherwise this one applies instead of intransitive-extra-arg-structure even if there is one less subunit + +(def-fcg-cxn intransitive-extra-argument-structure-cxn + ((?intransitive-extra-argument-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) (?agent-unit (syn-cat (syn-role subject))) - (?ad-info-unit - (syn-cat (syn-role extra-complement))) + (?extra-info-unit + (syn-cat (syn-role extra-information))) (?location-unit (syn-cat (syn-role locative-complement))) <- @@ -1309,35 +1499,34 @@ (- - - - -) (?as ?nm ?nf ?nn ?np)))) (referent ?arg0)) - - (?ad-info-unit + + (?extra-info-unit (syn-cat (lex-class prep-phrase) - (case ?case)) + (case ?case)) (referent ?extra-info) -- (syn-cat (lex-class prep-phrase) (case ?case)) - (referent ?extra-info) - ) - + (referent ?extra-info)) + (?location-unit (syn-cat (lex-class prep-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ls ?dm ?df ?dn ?dp)))) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) (referent ?arg4) -- (syn-cat (lex-class prep-phrase) (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?ls ?dm ?df ?dn ?dp)))) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) (referent ?arg4)) - (?double-intransitive-argument-structure-unit + (?intransitive-extra-argument-structure-unit (HASH meaning ((:arg0 ?v ?arg0) (:extra-info ?v ?extra-info) (:arg4 ?v ?arg4))) @@ -1345,66 +1534,190 @@ ))) -(def-fcg-cxn double-intransitive-information-structure-cxn - ((?double-intransitive-information-structure-unit - (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) - (?arg-and-info-struct-unit - (subunits (?double-intransitive-information-structure-unit ?argument-structure-unit))) +(def-fcg-cxn topic-arg0-extra-info-arg4-information-structure-cxn + ( <- - (?argument-structure-unit - (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit)) - -- - (subunits (?verb-unit ?agent-unit ?ad-info-unit ?location-unit))) + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-extra-info-unit) + (meets ?rightmost-extra-info-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) (?verb-unit (syn-cat (lex-class verb) - (type intransitive)) - + (type intransitive)) -- (syn-cat (lex-class verb) (type intransitive))) (?agent-unit + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit)) -- + (referent ?arg0) (syn-cat (syn-role subject)) (boundaries (leftmost-unit ?leftmost-agent-unit) (rightmost-unit ?rightmost-agent-unit))) - (?ad-info-unit - (syn-cat (syn-role extra-complement)) - (boundaries (leftmost-unit ?leftmost-ad-info-unit) - (rightmost-unit ?rightmost-ad-info-unit)) + (?extra-info-unit + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit)) -- + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit))) - (syn-cat (syn-role extra-complement)) - (boundaries (leftmost-unit ?leftmost-ad-info-unit) - (rightmost-unit ?rightmost-ad-info-unit))) - (?location-unit - (syn-cat (syn-role location-complement)) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit)) - (referent ?arg4) -- - (referent ?arg4) - (syn-cat (syn-role location-complement)) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) (boundaries (leftmost-unit ?leftmost-location-unit) (rightmost-unit ?rightmost-location-unit))) + )) + + + +;der Mann fährt mit dem Fahrrad zur Arbeit + +(def-fcg-cxn intransitive-extra-argument-arg1-structure-cxn + ((?intransitive-extra-argument-arg1-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?extra-info-unit + (syn-cat (syn-role extra-information))) + (?location-unit + (syn-cat (syn-role locative-complement))) + <- + (?verb-unit + (syn-cat (lex-class verb) + (type single-intransitive) + ) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type single-intransitive) + ) + (referent ?v)) - (?double-intransitive-information-structure-unit - -- - (HASH form ((meets ?rightmost-agent-unit ?verb-unit) - (meets ?verb-unit ?leftmost-ad-info-unit) - (meets ?rightmost-ad-info-unit ?leftmost-location-unit)))) + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0)) + + (?extra-info-unit + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?extra-info) + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?extra-info)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp)))) + (referent ?arg1)) - ))|# + (?intransitive-extra-argument-arg1-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:extra-info ?v ?extra-info) + (:arg1 ?v ?arg1))) + -- + ))) +(def-fcg-cxn topic-arg0-extra-info-arg1-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit)) + (HASH meaning ((topicalized ?arg0 +))) + + -- + (HASH form ((meets ?rightmost-agent-unit ?verb-unit) + (meets ?verb-unit ?leftmost-extra-info-unit) + (meets ?rightmost-extra-info-unit ?leftmost-location-unit))) + (subunits (?verb-unit ?agent-unit ?extra-info-unit ?location-unit))) + + (?verb-unit + (syn-cat (lex-class verb) + (type single-intransitive)) + -- + (syn-cat (lex-class verb) + (type single-intransitive))) + + (?agent-unit + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit)) + -- + (referent ?arg0) + (syn-cat (syn-role subject)) + (boundaries (leftmost-unit ?leftmost-agent-unit) + (rightmost-unit ?rightmost-agent-unit))) + + (?extra-info-unit + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit)) + -- + (syn-cat (syn-role extra-information) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit))) + + (?location-unit + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) @@ -1480,14 +1793,20 @@ ;;; der Mann schenkt dem Clown die Blumen (formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized m +))) -;;; dem Clown schenkt der Mann die Blumen - stuck +;;; dem Clown schenkt der Mann die Blumen (formulate '((schenken-01 s) (man m) (clown c) (flowers f) (arg0 s m) (arg1 s f) (arg2 s c) (topicalized c +))) ;;;der Mann geht zum Shop (formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized m +))) +;;;der Mann ist beim Bäcker +(formulate-all '((sein-01 s) (man m) (arg1 s m) (baker b) (arg2 s b) (topicalized m +))) + +;;;beim Bäcker ist der Mann +(formulate-all '((sein-01 s) (man m) (arg1 s m) (baker b) (arg2 s b) (topicalized b +))) + ; zum Shop geht der Mann -(formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized s +))) +(formulate '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized s +))) ;;; der Mann geht ohne den Clown zur Arbeit (formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) @@ -1495,9 +1814,12 @@ ;;; der Mann ist gegen den Shop gefahren (formulate-all '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) -;; der Mann hat für den Clown die Blumen mitgebracht +;; der Mann hat für den Clown die Blumen mitgebracht ------>some issues (formulate '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) -;;; der Mann geht ohne den Clown zur Arbeit -(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) +;;; der Mann geht ohne den Clown zur Arbeit ------>some issues (too general ?) +(formulate-all '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg4 g w) (extra-info g c) (topicalized m +))) + +;;der Mann fährt mit dem Fahrrad zur Arbeit +(formulate-all '((fahren-01 f) (man m) (bike b) (work w) (arg0 f m) (arg1 f w) (extra-info f b) (topicalized m +))) -- GitLab From 5db955fc4d509b711681a445296a602d1027f732 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Wed, 30 Mar 2022 15:47:20 +0200 Subject: [PATCH 076/157] fixing type error --- .../monitors/csv-monitors.lisp | 31 +++++++++++-------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/systems/grammar-learning/experiment-setup/monitors/csv-monitors.lisp b/systems/grammar-learning/experiment-setup/monitors/csv-monitors.lisp index 068d9509b..de75acd04 100644 --- a/systems/grammar-learning/experiment-setup/monitors/csv-monitors.lisp +++ b/systems/grammar-learning/experiment-setup/monitors/csv-monitors.lisp @@ -14,8 +14,8 @@ :file-name (babel-pathname :name "communicative-success" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" - :column-separator ",") + :comment-string #\# + :column-separator #\,) (define-event-handler (record-csv-communicative-success interaction-finished) (record-value monitor (if (communicated-successfully interaction) 1 0))) @@ -32,8 +32,8 @@ :file-name (babel-pathname :name "grammar-size" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" - :column-separator ",") + :comment-string #\# + :column-separator #\,) (define-event-handler (record-csv-lexicon-size interaction-finished) (record-value monitor (length (get-cxns-of-type (learner experiment) 'all)))) @@ -50,8 +50,8 @@ :file-name (babel-pathname :name "th-size" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" - :column-separator ",") + :comment-string #\# + :column-separator #\,) (define-event-handler (record-csv-th-size interaction-finished) (record-value monitor (nr-of-links (grammar (learner experiment))))) @@ -68,8 +68,8 @@ :file-name (babel-pathname :name "avg-cxn-score" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" - :column-separator ",") + :comment-string #\# + :column-separator #\,) (define-event-handler (record-csv-avg-cxn-score interaction-finished) (record-value monitor (average (mapcar #'cxn-score (get-cxns-of-type (learner experiment) 'all))))) @@ -86,7 +86,8 @@ :file-name (babel-pathname :name "grammar-size-per-type" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" :column-separator ",") + :comment-string "#" + :column-separator ",") (define-event-handler (record-csv-lexicon-size-per-type interaction-finished) (loop for cxn-type in '(gl::holophrase gl::lexical gl::item-based) @@ -106,7 +107,8 @@ :file-name (babel-pathname :name "cxn-score-per-type" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" :column-separator ",") + :comment-string "#" + :column-separator ",") (define-event-handler (record-csv-cxn-score-per-type interaction-finished) (loop for cxn-type in '(gl::holophrase gl::lexical gl::item-based) @@ -127,7 +129,8 @@ :file-name (babel-pathname :name "cxn-usage-per-type" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" :column-separator ",") + :comment-string "#" + :column-separator ",") (define-event-handler (record-csv-cxn-usage-per-type constructions-chosen) (if (find 'gl::holophrase constructions :key #'get-cxn-type) @@ -214,7 +217,8 @@ :file-name (babel-pathname :name "repair-per-type" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" :column-separator ",") + :comment-string "#" + :column-separator ",") ;; nr of item-based cxns with slots (alist monitor) (define-monitor record-csv-nr-of-slots @@ -228,7 +232,8 @@ :file-name (babel-pathname :name "item-based-nr-of-slots" :type "csv" :directory '("experiments" "clevr-grammar-learning" "raw-data")) :add-time-and-experiment-to-file-name nil - :comment-string "#" :column-separator ",") + :comment-string "#" + :column-separator ",") (define-event-handler (record-csv-nr-of-slots interaction-finished) (let* ((item-based-cxns -- GitLab From 03a4823ce2865515a79188965bd2d3bea32a6954 Mon Sep 17 00:00:00 2001 From: Jonas Doumen Date: Wed, 30 Mar 2022 15:49:01 +0200 Subject: [PATCH 077/157] reversing application order of learned cxns --- experiments/grammar-learning/clevr/test.lisp | 2 +- .../repair-holistic-to-item-based-cxn.lisp | 2 +- ...ophrase-to-item-based+holistic+holistic--substitution.lisp | 4 ++-- .../repair-holophrase-to-item-based+holistic--addition.lisp | 2 +- .../repair-item-based-to-holistic.lisp | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 072fdb101..46a7b9499 100644 --- a/experiments/grammar-learning/clevr/test.lisp +++ b/experiments/grammar-learning/clevr/test.lisp @@ -76,7 +76,7 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 10000) +;(run-series *experiment* 1000) #| QUESTIONS diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp index 1e4f39a2d..7dabe1ee7 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holistic-to-item-based-cxn.lisp @@ -124,7 +124,7 @@ return (first predicate)) :string ,(third (find 'string item-based-cxn-form-constraints :key #'first))) :cxn-inventory ,(copy-object original-cxn-set))))))) - (cxns-to-apply (append (list item-based-cxn) (mapcar #'original-cxn (mapcar #'car-applied-cxn optimal-coverage-cars)))) + (cxns-to-apply (append (mapcar #'original-cxn (mapcar #'car-applied-cxn optimal-coverage-cars)) (list item-based-cxn))) (cxns-to-consolidate (unless existing-item-based-cxn (list item-based-cxn)))) (when existing-item-based-cxn ; we ordered the units, so they'll always be in the order in which they appear in the utterance diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp index a9456a8a7..54ef8ce7f 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic+holistic--substitution.lisp @@ -159,7 +159,7 @@ based on existing construction with sufficient overlap." :string ,(third (find 'string non-overlapping-form-observation :key #'first))) :cxn-inventory ,(copy-object cxn-inventory))))))) (new-item-based-cxn - (or existing-item-based-cxn + (or existing-item-based-cxn ; todo, check if it can apply! the order of args could be different... (second (multiple-value-list (eval `(def-fcg-cxn ,cxn-name-item-based-cxn ((?item-based-unit @@ -191,7 +191,7 @@ based on existing construction with sufficient overlap." :cxn-inventory ,(copy-object cxn-inventory))))))) (existing-cxns (list holistic-cxn-2 holistic-cxn-1 existing-item-based-cxn)) - (cxns-to-apply (list new-item-based-cxn new-holistic-cxn-2)) + (cxns-to-apply (list new-holistic-cxn-2 new-item-based-cxn)) (cat-links-to-add (list categorial-link-1 categorial-link-2)) (cxns-to-consolidate (loop for cxn in (list new-holistic-cxn-1 new-holistic-cxn-2 new-item-based-cxn) when (not (member cxn existing-cxns)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp index 6139c6d6d..c46d93abf 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-holophrase-to-item-based+holistic--addition.lisp @@ -151,7 +151,7 @@ :cxn-inventory ,(copy-object cxn-inventory))))))) (existing-cxns (list existing-holistic-cxn existing-item-based-cxn)) - (cxns-to-apply (list item-based-cxn holistic-cxn)) + (cxns-to-apply (list holistic-cxn item-based-cxn)) (cat-links-to-add (list categorial-link)) (cxns-to-consolidate (loop for cxn in (list holistic-cxn item-based-cxn) when (not (member cxn existing-cxns)) diff --git a/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp index 26de8a70d..e3abcb817 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp @@ -119,7 +119,7 @@ (map 'list #'get-processing-cxn matching-holistic-cxns)) (map 'list #'get-processing-cxn applied-holistic-cxns)) categorial-links))))))))) -(defmethod handle-fix ((fix fcg::cxn-fix) (repair item-based->holistic) (problem problem) (node cip-node) &key &allow-other-keys) +#|(defmethod handle-fix ((fix fcg::cxn-fix) (repair item-based->holistic) (problem problem) (node cip-node) &key &allow-other-keys) "Apply the construction provided by fix tot the result of the node and return the construction-application-result" (push fix (fixes (problem fix))) ;;we add the current fix to the fixes slot of the problem (with-disabled-monitor-notifications @@ -156,4 +156,4 @@ (push (type-of repair) (statuses last-node)) (push 'added-by-repair (statuses last-node)) ;; enqueue only last new node; never backtrack over the first applied construction, we applied them as a block - (cip-enqueue last-node (cip node) (get-configuration node :queue-mode))))) + (cip-enqueue last-node (cip node) (get-configuration node :queue-mode))))) |# -- GitLab From f8bb3d1170c2eef8323bba26b9ce8dcb78eefaef Mon Sep 17 00:00:00 2001 From: jnevens Date: Wed, 30 Mar 2022 16:42:16 +0200 Subject: [PATCH 078/157] mwm experiment; explicitely intern in :mwm when loading objects --- experiments/multidimensional-word-meanings/world.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/experiments/multidimensional-word-meanings/world.lisp b/experiments/multidimensional-word-meanings/world.lisp index 7d22ec57b..d0ce32fc8 100644 --- a/experiments/multidimensional-word-meanings/world.lisp +++ b/experiments/multidimensional-word-meanings/world.lisp @@ -168,7 +168,7 @@ ;; create an alist (setf alist (mapcar #'(lambda (pair) - (cons (internal-symb (car pair)) + (cons (intern (upcase (mkstr (car pair))) :mwm) (cdr pair))) alist)) ;; split the color channels -- GitLab From 0453f12d086ff6953109abc8e5c767d048736fea Mon Sep 17 00:00:00 2001 From: jnevens Date: Wed, 30 Mar 2022 16:43:04 +0200 Subject: [PATCH 079/157] mwm-evaluation; added configuration for objects with extracted features --- .../clevr/mwm-evaluation/evaluation.lisp | 8 ++++-- .../clevr/mwm-evaluation/monitors.lisp | 17 ----------- .../clevr/mwm-evaluation/mwm-evaluation.asd | 1 + .../clevr/mwm-evaluation/mwm-ontology.lisp | 9 +++--- .../clevr/mwm-evaluation/mwm-utils.lisp | 28 ++++++++++++++++++- .../primitives/segment-scene.lisp | 7 ++++- applications/clevr/mwm-evaluation/start.lisp | 9 +++++- 7 files changed, 51 insertions(+), 28 deletions(-) diff --git a/applications/clevr/mwm-evaluation/evaluation.lisp b/applications/clevr/mwm-evaluation/evaluation.lisp index a2e064102..3f90c4fe8 100644 --- a/applications/clevr/mwm-evaluation/evaluation.lisp +++ b/applications/clevr/mwm-evaluation/evaluation.lisp @@ -227,16 +227,18 @@ (make-configuration :entries (cons (cons :experiment-name experiment-name) config-entries))) + (world-type + (get-configuration config :world-type)) (concepts-directory (merge-pathnames (make-pathname :directory (list :relative experiment-name)) - (case (get-configuration config :world-type) + (case world-type (:simulated *simulated-concepts-path*) (:extracted *extracted-concepts-path*)))) (ontology - (make-mwm-ontology concepts-directory))) + (make-mwm-ontology concepts-directory world-type))) ;; adapt file-writing monitors so they output in the correct output-dir - (monitors::deactivate-all-monitors) + ;(monitors::deactivate-all-monitors) (loop for monitor-string in monitors for monitor = (monitors::get-monitor (read-from-string monitor-string)) do (monitors::activate-monitor-method (read-from-string monitor-string)) diff --git a/applications/clevr/mwm-evaluation/monitors.lisp b/applications/clevr/mwm-evaluation/monitors.lisp index 5861fb736..3577de9d9 100644 --- a/applications/clevr/mwm-evaluation/monitors.lisp +++ b/applications/clevr/mwm-evaluation/monitors.lisp @@ -1,21 +1,4 @@ (in-package :mwm-evaluation) - -(defun get-all-monitors () - '("print-a-dot-for-each-interaction" - "log-mwm-evaluation" - "export-count!-primitive" - "export-equal?-primitive" - "export-equal-integer-primitive" - "export-less-than-primitive" - "export-greater-than-primitive" - "export-exist-primitive" - "export-filter-primitive" - "export-intersect-primitive" - "export-query-primitive" - "export-relate-primitive" - "export-same-primitive" - "export-union!-primitive" - "export-unique-primitive")) ;;;; print a dot for each interaction diff --git a/applications/clevr/mwm-evaluation/mwm-evaluation.asd b/applications/clevr/mwm-evaluation/mwm-evaluation.asd index 0ee1358d8..a9b83d924 100644 --- a/applications/clevr/mwm-evaluation/mwm-evaluation.asd +++ b/applications/clevr/mwm-evaluation/mwm-evaluation.asd @@ -22,6 +22,7 @@ (:file "mwm-ontology") (:file "mwm-utils") (:file "evaluation") + (:file "monitors") (:file "irl-node-test") (:module "primitives" :serial t diff --git a/applications/clevr/mwm-evaluation/mwm-ontology.lisp b/applications/clevr/mwm-evaluation/mwm-ontology.lisp index 26aa80543..74ef2d2c0 100644 --- a/applications/clevr/mwm-evaluation/mwm-ontology.lisp +++ b/applications/clevr/mwm-evaluation/mwm-ontology.lisp @@ -31,7 +31,7 @@ ;; Make an ontology (instance of #'blackboard) -(defun make-mwm-ontology (concepts-pathname) +(defun make-mwm-ontology (concepts-pathname world-type) (let ((ontology (make-blackboard))) (loop for pathname in (directory concepts-pathname) do (cond ((member (pathname->conceptname pathname) @@ -65,12 +65,11 @@ :form "front" :meaning (copy-object (meaning concept)))))))) (set-data ontology 'thing - (list (make-instance 'shape-concept - :id 'thing - :form "thing" - :meaning nil))) + (list (make-instance 'shape-concept :id 'thing :form "thing" :meaning nil))) (push-data ontology 'booleans (make-instance 'boolean-category :id 'yes :bool t)) (push-data ontology 'booleans (make-instance 'boolean-category :id 'no :bool nil)) (loop for attribute in '(shape size material color) do (clevr-world::add-category-to-ontology ontology attribute 'attribute)) + (set-data ontology 'world-type world-type) + (set-data ontology 'extracted-scenes-path *extracted-scenes-path*) ontology)) diff --git a/applications/clevr/mwm-evaluation/mwm-utils.lisp b/applications/clevr/mwm-evaluation/mwm-utils.lisp index bbd485527..c40f960a5 100644 --- a/applications/clevr/mwm-evaluation/mwm-utils.lisp +++ b/applications/clevr/mwm-evaluation/mwm-utils.lisp @@ -12,6 +12,11 @@ (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" "thesis-main-results" "baseline-extracted-default-lexicon"))) +(defparameter *extracted-scenes-path* + (merge-pathnames + (make-pathname :directory `(:relative "Frontiers-data" "CLEVR" "val")) + cl-user:*babel-corpora*)) + ;;----------------------------------;; ;; similarity and category matching ;; ;;----------------------------------;; @@ -92,4 +97,25 @@ (loop for predicate in irl-program if (eql (first predicate) 'bind) collect (substitute-category-in-bind predicate) - else collect predicate)) \ No newline at end of file + else collect predicate)) + +;;-----------------------------------------------------------------;; +;; return all monitor names +;;-----------------------------------------------------------------;; + +(defun get-all-monitors () + '("print-a-dot-for-each-interaction" + "log-mwm-evaluation" + "export-count!-primitive" + "export-equal?-primitive" + "export-equal-integer-primitive" + "export-less-than-primitive" + "export-greater-than-primitive" + "export-exist-primitive" + "export-filter-primitive" + "export-intersect-primitive" + "export-query-primitive" + "export-relate-primitive" + "export-same-primitive" + "export-union!-primitive" + "export-unique-primitive")) \ No newline at end of file diff --git a/applications/clevr/mwm-evaluation/primitives/segment-scene.lisp b/applications/clevr/mwm-evaluation/primitives/segment-scene.lisp index a1a05419f..a11e37d49 100644 --- a/applications/clevr/mwm-evaluation/primitives/segment-scene.lisp +++ b/applications/clevr/mwm-evaluation/primitives/segment-scene.lisp @@ -12,7 +12,12 @@ (scene pathname-entity)) ;; first case; read the scene file and create a clevr-scene ((scene => segmented-scene) - (bind (segmented-scene 1.0 (mwm::clevr->simulated (load-clevr-scene (pathname scene)))))) + (bind (segmented-scene + 1.0 + (case (find-data ontology 'world-type) + (:simulated (mwm::clevr->simulated (load-clevr-scene (pathname scene)))) + (:extracted (mwm::clevr->extracted (load-clevr-scene (pathname scene)) + :directory (get-data ontology 'extracted-scenes-path))))))) ;; second case; get the pathname from the segmented-scene ((segmented-scene => scene) diff --git a/applications/clevr/mwm-evaluation/start.lisp b/applications/clevr/mwm-evaluation/start.lisp index baa09d0a5..8124ffe59 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -10,8 +10,15 @@ ;; Evaluation ;; ;;------------;; +(defparameter *config-entries* + '((:dot-interval . 100) + (:nr-of-scenes . 1) + (:nr-of-questions . nil) + (:data-split . "val") + (:world-type . :extracted))) + ;; Evaluate one particular serie -(evaluate-mwm-serie 1) +(evaluate-mwm-serie 1 *config-entries*) (evaluate-mwm-serie 2) (evaluate-mwm-serie 3) (evaluate-mwm-serie 4) -- GitLab From ab1f3a591c6bfcb5de7610e4cbf2acf9e587c7c8 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 09:14:01 +0200 Subject: [PATCH 080/157] added discourse-model to tristan grammar --- .../tristan-experiment/grammar.lisp | 71 ++++++++++++------- 1 file changed, 47 insertions(+), 24 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/grammar.lisp b/applications/discourse-understanding/tristan-experiment/grammar.lisp index 317a3510f..a64b2b3cb 100644 --- a/applications/discourse-understanding/tristan-experiment/grammar.lisp +++ b/applications/discourse-understanding/tristan-experiment/grammar.lisp @@ -95,10 +95,12 @@ (syn-cat (lex-class propernoun) (phrase-type noun-phrase) (agreement (number (- - 3sg -)) - (gender (m - -))))) + (gender (m - -))) + (dm-in ?dm-in) + (dm-out ?dm-out))) <- (?tristan - (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status) + (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status ?dm-out ?dm-in) (bind discourse-status ?status identifiable))) (meaning ((entity ?ent) (tristan-frame ?ent ?ref) @@ -112,7 +114,9 @@ (def-fcg-cxn Adverbial-Clause-passive-cxn ((?adverbial-clause-unit (referent ?ev) - (syn-cat (clause-type adverbial-clause)) + (syn-cat (clause-type adverbial-clause) + (dm-in ?dm-in) + (dm-out ?dm-out-verb)) (subunits (?adverb-unit ?np-unit ?vp-unit)) ) <- @@ -126,14 +130,18 @@ (?np-unit -- (referent ?referent) - (syn-cat (phrase-type noun-phrase))) + (syn-cat (phrase-type noun-phrase) + (dm-in ?dm-in) + (dm-out ?dm-out))) (?vp-unit -- (referent ?ev) (sem-valence (actor ?mother) (undergoer ?referent)) (syn-cat (voice passive) - (phrase-type verb-phrase)))) + (phrase-type verb-phrase) + (dm-in ?dm-out) + (dm-out ?dm-out-verb)))) :cxn-set cxn :cxn-inventory *pangloss*) @@ -143,7 +151,9 @@ ((?baren (referent ?ent) (sem-valence (actor ?mother) - (undergoer ?child))) + (undergoer ?child)) + (syn-cat (dm-in ?dm-in) + (dm-out ?dm-out))) <- (?baren (meaning ((entity ?ent) @@ -151,7 +161,7 @@ (mother-role ?ev ?mother) (father-role ?ev ?father) (child-role ?ev ?child))) - (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status) + (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status ?dm-out ?dm-in) (bind discourse-status ?status identifiable))) -- (lex-id baren) @@ -186,15 +196,16 @@ (syn-cat (lex-class verb) (voice passive) (phrase-type verb-phrase) - (finite +)) + (finite +) + (dm-in ?dm-in) + (dm-out ?dm-out)) (sem-valence (actor ?mother) (undergoer ?child)) (subunits (?aux-unit ?main-verb-unit))) <- (?vp-unit -- - (HASH form ((meets ?main-verb-unit ?aux-unit ?scope))) - ) + (HASH form ((meets ?main-verb-unit ?aux-unit ?scope)))) (?aux-unit (referent ?ref) -- @@ -207,11 +218,12 @@ (sem-valence (actor ?mother) (undergoer ?child)) (syn-cat (lex-class verb) - (verb-form past-participle)))) + (verb-form past-participle) + (dm-in ?dm-in) + (dm-out ?dm-out)))) :cxn-set cxn :cxn-inventory *pangloss*) - (def-fcg-cxn was-morph ((?was (referent ?ev) @@ -248,8 +260,7 @@ -- (hash form ((string ?vader "vader"))))) :cxn-set morph-lex - :cxn-inventory *pangloss* - ) + :cxn-inventory *pangloss*) (def-fcg-cxn zijn-morph ((?zijn @@ -262,7 +273,10 @@ (lex-subclass possessive-pronoun) (agreement (number (- - 3sg -)) (gender (?m - ?o)))) - ;(meaning ((gender ?man male))) + (meaning ((entity ?man) + (person-frame ?man ?pf) + (name-role ?pf ?name) + (gender-role ?pf male))) -- (hash form ((string ?zijn "zijn"))))) @@ -271,14 +285,16 @@ (def-fcg-cxn possessive-NP-cxn ((?poss-pronoun-unit - (discourse-meaning ((handle-referent ?owner ?list-of-facts ?status) - (bind discourse-status ?status identifiable)))) + (discourse-meaning ((handle-referent ?owner ?list-of-facts-1 ?status-1 ?dm-out-1 ?dm-in-1) + (bind discourse-status ?status-1 identifiable)))) (?noun-unit - (discourse-meaning ((handle-referent ?ent ?list-of-facts ?status) - (bind discourse-status ?status identifiable)))) + (discourse-meaning ((handle-referent ?ent ?list-of-facts-2 ?status-2 ?dm-out-2 ?dm-out-1) + (bind discourse-status ?status-2 identifiable)))) (?possessive-np-unit (referent ?ent) - (syn-cat (phrase-type noun-phrase)) + (syn-cat (phrase-type noun-phrase) + (dm-in ?dm-in-1) + (dm-out ?dm-out-2)) (subunits (?poss-pronoun-unit ?noun-unit))) <- (?possessive-np-unit @@ -340,7 +356,9 @@ (def-fcg-cxn adverbial-clause-front-field-cxn ((?matrix-clause (referent ?ev) - (syn-cat (clause-type main-clause)) + (syn-cat (clause-type main-clause) + (dm-in ?dm-in) + (dm-out ?dm-out-verb)) (fields (front-field ?adverbial-clause) (left-bracket ?finite-verb) (midfield ?midfield)) @@ -359,8 +377,9 @@ (?adverbial-clause ;(parent ?matrix-clause) -- - (syn-cat (clause-type adverbial-clause))) - + (syn-cat (clause-type adverbial-clause) + (dm-in ?dm-in) + (dm-out ?dm-out))) (?finite-verb -- (referent ?ev) @@ -369,8 +388,12 @@ (?subject-np -- (referent ?subject-ref) - (syn-cat (phrase-type noun-phrase))) + (syn-cat (phrase-type noun-phrase) + (dm-in ?dm-out) + (dm-out ?dm-out-subject))) (?adjective + (discourse-meaning ((handle-referent ?ref ?list-of-facts ?status ?dm-out-verb ?dm-out-subject) + (bind discourse-status ?status identifiable))) -- (referent ?ref) (sem-valence (undergoer ?subject-ref)) -- GitLab From ba72ebc0c22f866557199d3a559fb2d6b1e8c61c Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 09:14:57 +0200 Subject: [PATCH 081/157] added frames, roles and fulfills-roles slot to list-of-facts + copy-objects --- .../tristan-experiment/discourse-model.lisp | 22 +++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/discourse-model.lisp b/applications/discourse-understanding/tristan-experiment/discourse-model.lisp index 1df2e3c88..db5a67fbf 100644 --- a/applications/discourse-understanding/tristan-experiment/discourse-model.lisp +++ b/applications/discourse-understanding/tristan-experiment/discourse-model.lisp @@ -8,7 +8,7 @@ :documentation "The referents introduced in the discourse memory") (entities-in-focus :type list :accessor entities-in-focus - :initarg entities-in-focus + :initarg :entities-in-focus :initform nil :documentation "The referents in focus in the discourse memory"))) @@ -38,7 +38,21 @@ :initform nil))) (defclass list-of-facts (entity) - ((facts :accessor facts - :initarg :facts + ((ent :accessor ent + :initarg :ent + :initform nil) + (frames :accessor frames + :initarg :frames + :initform nil) + (roles :accessor roles + :initarg :roles + :initform nil) + (fulfills-roles :accessor fulfills-roles + :initarg :fulfills-roles :initform nil))) - \ No newline at end of file + +(defmethod copy-object ((dm discourse-model)) + (make-instance 'discourse-model + :id (id dm) + :entities (entities dm) + :entities-in-focus (entities-in-focus dm))) \ No newline at end of file -- GitLab From 2a32d4b9fd08c3733016ce20036d40e13d27395b Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 09:17:10 +0200 Subject: [PATCH 082/157] progress on handle-referent primitive, now takes discourse-model as input and makes a new referent, and finds a referent with similar frames and looks for referent with superframes --- .../primitives/handle-referent.lisp | 43 ++++++++++++++----- 1 file changed, 32 insertions(+), 11 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp b/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp index 1faabe56f..f7455f1b3 100644 --- a/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp +++ b/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp @@ -2,15 +2,36 @@ (defprimitive handle-referent ((de discourse-entity) (facts list-of-facts) - (status discourse-status)) - ((facts status => de) - (let* ((dm (get-data ontology 'discourse-model)) - (ent (make-instance 'discourse-entity :id (id facts) :facts (facts facts)))) - (bind (de 1.0 ent))))) + (status discourse-status) + (dm-out discourse-model) + (dm-in discourse-model)) + ((facts status dm-in => de dm-out) + ;; look for a referent in discourse model that has the same frame(s), if there is one increase the score. + (let* ((new-dm (copy-object dm-in))) + (loop for ent in (entities new-dm) + for frames = (assoc :frames (facts ent)) + when ;(and (frames facts) + (is-subset (frames facts) frames) + ;) + collect (bind (de 1.0 ent) + (dm-out 1.0 new-dm)))) + + ;; look for a referent in discourse model that has frames that are a subclass of the frames presented here, if there is one increase the score. + (let* ((new-dm (copy-object dm-in))) + (loop for ent in (entities new-dm) + for frames = (assoc :frames (facts ent)) + for super-classes = + when + collect (bind (de 1.0 ent) + (dm-out 1.0 new-dm)))) + + ;; make a new referent, this one gets a lower score, since we assume that referents should be in the discourse model + (let* ((new-dm (copy-object dm-in)) + (ent (make-instance 'discourse-entity + :id (id facts) + :facts (list (cons :frames (frames facts)) + (cons :roles (roles facts)))))) + (push ent (entities new-dm)) + (bind (de 0.0 ent) + (dm-out 1.0 new-dm))))) -(defun extract-relevant-facts (meaning referent) - (let* ((frame-vars - (loop for fact in meaning - when (eq (second fact) referent) - collect (third fact)))) - frame-vars)) \ No newline at end of file -- GitLab From d4833ed84added10bd8fdd5841e61372669ce73a Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 09:17:26 +0200 Subject: [PATCH 083/157] minor html + utils --- .../discourse-understanding/tristan-experiment/html.lisp | 7 +++++++ .../discourse-understanding/tristan-experiment/utils.lisp | 5 +++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/html.lisp b/applications/discourse-understanding/tristan-experiment/html.lisp index 07d391b79..db5ffdf09 100644 --- a/applications/discourse-understanding/tristan-experiment/html.lisp +++ b/applications/discourse-understanding/tristan-experiment/html.lisp @@ -32,6 +32,13 @@ ,(make-html slot-value :expand-initially expand-initially)))) +(defmethod make-html-for-entity-details ((facts list-of-facts) &key) + `(((div :class "entity-detail") ,(format nil "ID: ~a" (id facts)) + ((div :class "entity-detail") ,(format nil "Entity ~a" (ent facts))) + ((div :class "entity-detail") ,(format nil "Frames ~a" (frames facts))) + ((div :class "entity-detail") ,(format nil "Roles: ~a" (roles facts))) + ((div :class "entity-detail") ,(format nil "Fulfills roles: ~a" (fulfills-roles facts)))))) + ;; ######################################################### ;; discourse-memory - make-html diff --git a/applications/discourse-understanding/tristan-experiment/utils.lisp b/applications/discourse-understanding/tristan-experiment/utils.lisp index 3067e6991..5921fdad3 100644 --- a/applications/discourse-understanding/tristan-experiment/utils.lisp +++ b/applications/discourse-understanding/tristan-experiment/utils.lisp @@ -5,13 +5,14 @@ (meaning (loop for unit in ts for discourse-meaning = (unit-feature-value unit 'discourse-meaning) when discourse-meaning - collect discourse-meaning))) + append discourse-meaning))) meaning)) (defun extract-facts-meaning (cip) (let* ((ts (fcg-get-transient-unit-structure cip)) + ;(meaning (fcg-extract-meanings (meaning (loop for unit in ts for meaning = (unit-feature-value unit 'meaning) when meaning - collect meaning))) + append meaning))) meaning)) -- GitLab From 9c79a71750e4cb38f71d7f66f716cc98cf21938d Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 09:20:38 +0200 Subject: [PATCH 084/157] adding all relevant facts + discourse memory as bind statements to irl program --- .../tristan-experiment/start-tristan.lisp | 83 ++++++++++++++----- 1 file changed, 60 insertions(+), 23 deletions(-) diff --git a/applications/discourse-understanding/tristan-experiment/start-tristan.lisp b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp index 264152771..d49c909a0 100644 --- a/applications/discourse-understanding/tristan-experiment/start-tristan.lisp +++ b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp @@ -7,41 +7,78 @@ (comprehend "Toen Tristan geboren werd , was zijn vader dood" :cxn-inventory *pangloss*) (comprehend-all "Toen Tristan geboren werd , was zijn vader dood" :cxn-inventory *pangloss*) -(defparameter *ontology* (make-blackboard)) -(set-data *ontology* 'discourse-model (make-instance 'discourse-model)) -(set-data *ontology* 'entities (cons (make-instance 'discourse-status :id 'identifiable) - (make-instance 'list-of-facts :id 'list-of-facts))) +(progn + (defparameter *ontology* (make-blackboard)) + (set-data *ontology* 'discourse-models (list (make-instance 'discourse-model))) + (set-data *ontology* 'entities (cons (make-instance 'discourse-status :id 'identifiable) + (make-instance 'list-of-facts :id 'list-of-facts))) +) + + +(understand "Tristan" *pangloss* *ontology*) +(understand "Toen Tristan geboren werd , was zijn vader dood" *pangloss* *ontology*) + ;;collect facts and put them into the meaning (defun understand (utterance cxn-inventory ontology) - ;first comprehend + ;then comprehend (multiple-value-bind (cipn cip) (comprehend utterance :cxn-inventory cxn-inventory) ;prepare meaning network, this means extracting discourse-meaning and adding relevant facts from facts-meaning to this discourse-meaning - (let* ((discourse-meaning (first (extract-discourse-meaning cip))) - (facts-meaning (first (extract-facts-meaning cip)))) + (let* ((discourse-meaning (extract-discourse-meaning cip)) + (facts-meaning (fcg-extract-meanings cip)) + (dms (get-data ontology 'discourse-models))) + (add-element (make-html "discourse meaning")) + (add-element (irl-program->svg discourse-meaning)) (loop for primitive in discourse-meaning for prim = (first primitive) for entity-var = (second primitive) for list-of-facts-var = (third primitive) for status = (last-elt primitive) when (equal prim 'handle-referent) - do (let* ((frame (find-all entity-var facts-meaning :key 'second)) - (list-of-facts (make-instance 'list-of-facts :id entity-var :facts frame)) - (bind-statement `(bind list-of-facts ,list-of-facts-var ,list-of-facts)) - (new-entities-list (cons list-of-facts (get-data ontology 'entities)))) - (set-data ontology 'entities new-entities-list) - (push bind-statement discourse-meaning) - ; (setf (nth 3 primitive) frame) - )) - (set-data ontology 'facts-meaning facts-meaning) - (evaluate-irl-program discourse-meaning ontology) - discourse-meaning - ))) - - -(understand "Tristan" *pangloss* *ontology*) + do (let* ((meaning-with-entity-var (find-all entity-var facts-meaning :key #'second)) + (entity (find 'entity meaning-with-entity-var :key #'first)) + frames frame-vars roles list-of-facts fulfilled-roles + ) + (if entity + (progn + (setf frames (loop for meaning in meaning-with-entity-var + when (third meaning) + collect meaning)) + (setf frame-vars (loop for meaning in meaning-with-entity-var + when (third meaning) + collect (third meaning))) + (setf roles (loop for meaning in facts-meaning + when (find (second meaning) frame-vars) + collect meaning)) + (setf list-of-facts (make-instance 'list-of-facts + :id entity-var + :ent entity + :frames frames + :roles roles))) + (progn + (setf fulfilled-roles (loop for meaning in facts-meaning + when (equal (third meaning) entity-var) + collect meaning)) + (setf list-of-facts (make-instance 'list-of-facts + :id entity-var + :fulfills-roles fulfilled-roles)))) + (set-data ontology 'entities (cons list-of-facts (get-data ontology 'entities))) + (push `(bind list-of-facts ,list-of-facts-var ,list-of-facts) discourse-meaning))) + + (loop for dm in dms + for vars = (get-open-vars discourse-meaning) + ;for base-names = (loop for var in vars collect (get-base-name var)) + for dm-var = (find "DM-IN" vars :test #'string= :key #'(lambda (x) (get-base-name x))) + for bind-statement = `(bind discourse-model ,dm-var ,dm) + do (progn + (set-data ontology 'entities (cons dm (get-data ontology 'entities))) + (evaluate-irl-program (cons bind-statement discourse-meaning) ontology))) + ; (set-data ontology 'facts-meaning facts-meaning) + ; (evaluate-irl-program discourse-meaning ontology) + (loop for dm in (get-data ontology 'discourse-models) + do (add-element (make-html dm)))))) @@ -54,6 +91,6 @@ (add-element `((h2) "Entities in discourse memory:")) (loop for entity in (accessible-entities (discourse-memory *pangloss*)) do (add-element (make-html entity)))) -| +|# ;; mss moeten discourse cxns toch nog meer apart -- GitLab From bb156645909f85a16613005d29239c6a4d6e8242 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 09:21:33 +0200 Subject: [PATCH 085/157] progress on rules and checking if frame is subframe --- .../tristan-experiment/rules.lisp | 53 +++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 applications/discourse-understanding/tristan-experiment/rules.lisp diff --git a/applications/discourse-understanding/tristan-experiment/rules.lisp b/applications/discourse-understanding/tristan-experiment/rules.lisp new file mode 100644 index 000000000..ed195510d --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/rules.lisp @@ -0,0 +1,53 @@ +(in-package :discourse-understanding) + +(defclass rule (entity) + ((conditional :accessor conditional + :initarg :conditional) + (conclusion :accessor conclusion + :initarg :conclusion))) + +(setf *man-subclass-of-person* + (make-instance 'rule + :id 'man-subclass-of-person + :conditional (list (list 'man-frame '?person '?man)) + :conclusion (list (list 'person-frame '?person '?p)))) + +(setf *tristan-subclass-of-man* + (make-instance 'rule + :id 'tristan-subclass-of-man + :conditional (list (list 'tristan-frame '?person '?tristan)) + :conclusion (list (list 'man-frame '?person '?m)))) + +(defparameter *rules* (list *man-subclass-of-person* + *tristan-subclass-of-man*)) + + +#|(defun is-subframe (frame superframe rules) + (loop for rule in *rules* + for conditional = (conditional rule) + for conclusion = (conclusion rule) + do )) +|# +(defun is-subframe (frame superframe rules) + (if (is-direct-subframe frame superframe rules) + t + (let ((superrules (find-all frame rules :key #'(lambda (x) (first (first (conditional x))))))) + (loop for superrule in superrules + for s-frame = (first (first (conclusion superrule))) + when (is-subframe s-frame superframe rules) + return t)))) + +(defun is-direct-subframe (frame superframe rules) + (let ((rules-with-frame-as-conditional (find-all frame rules :key #'(lambda (x) (first (first (conditional x)))))) + direct-subframe) + (loop for rule in rules-with-frame-as-conditional + if (equal (first (first (conclusion rule))) + superframe) + do (setf direct-subframe t)) + direct-subframe)) + +(is-direct-subframe 'tristan-frame 'man-frame *rules*) +(is-subframe 'tristan-frame 'person-frame *rules*) + + ;; is-subclass tristan person rules --> yes + ;; is-subclass person tristan rules --> no \ No newline at end of file -- GitLab From d99d8721551ef86b7133b48da3401713a751f2ae Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 10:16:21 +0200 Subject: [PATCH 086/157] Minor changes for testing --- experiments/spatial-concept-game/agent.lisp | 2 ++ experiments/spatial-concept-game/run.lisp | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/experiments/spatial-concept-game/agent.lisp b/experiments/spatial-concept-game/agent.lisp index 6147a2596..6718bdf60 100644 --- a/experiments/spatial-concept-game/agent.lisp +++ b/experiments/spatial-concept-game/agent.lisp @@ -177,6 +177,8 @@ objects-with-similarity :key #'cdr :test #'=) 1))) + (when duplicatesp + (format t "stop here")) (set-data agent 'interpreted-topic (unless duplicatesp maybe-topic)))) (notify interpretation-finished agent) diff --git a/experiments/spatial-concept-game/run.lisp b/experiments/spatial-concept-game/run.lisp index 590afe378..823144f66 100644 --- a/experiments/spatial-concept-game/run.lisp +++ b/experiments/spatial-concept-game/run.lisp @@ -33,7 +33,7 @@ (run-interaction *experiment*) -(run-series *experiment* 10) +(run-series *experiment* 100) (display-lexicon (find 'learner (population *experiment*) :key #'id)) -- GitLab From c631528bde610a499b14c47d6a33f6d72717d953 Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 31 Mar 2022 11:23:50 +0200 Subject: [PATCH 087/157] minor changes --- applications/clevr/mwm-evaluation/monitors.lisp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/applications/clevr/mwm-evaluation/monitors.lisp b/applications/clevr/mwm-evaluation/monitors.lisp index 3577de9d9..b2a08f8c9 100644 --- a/applications/clevr/mwm-evaluation/monitors.lisp +++ b/applications/clevr/mwm-evaluation/monitors.lisp @@ -47,7 +47,7 @@ (define-monitor export-count!-primitive :class 'lisp-data-file-writer :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name "count!" :type "log") + :name "count" :type "log") :data-sources '(record-count!-primitive)) ;; equal? @@ -63,7 +63,7 @@ (define-monitor export-equal?-primitive :class 'lisp-data-file-writer :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name "equal?" :type "log") + :name "equal" :type "log") :data-sources '(record-equal?-primitive)) ;; equal-integer @@ -223,7 +223,7 @@ (define-monitor export-union!-primitive :class 'lisp-data-file-writer :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name "union!" :type "log") + :name "union" :type "log") :data-sources '(record-union!-primitive)) ;; unique -- GitLab From ce9611e48769c48b8f77021657fbc10ba6967625 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 11:36:52 +0200 Subject: [PATCH 088/157] fix for sbcl --- applications/visual-dialog/execution/execution-utils.lisp | 4 ++-- applications/visual-dialog/execution/update-memory.lisp | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/applications/visual-dialog/execution/execution-utils.lisp b/applications/visual-dialog/execution/execution-utils.lisp index 5fa6ae50d..316e64316 100644 --- a/applications/visual-dialog/execution/execution-utils.lisp +++ b/applications/visual-dialog/execution/execution-utils.lisp @@ -136,8 +136,8 @@ (defun get-target-primitive (irl-program) "returns primitive of the open variable in irl-program" - (let* ((variable (get-target-var irl-program)) - (target-primitive (first (find variable irl-program :test #'equal :key #'second)))) + (let* ((var (get-target-var irl-program)) + (target-primitive (first (find var irl-program :test #'equal :key #'second)))) target-primitive)) (defun get-third-value-target-primitive (irl-program list-of-bindings) diff --git a/applications/visual-dialog/execution/update-memory.lisp b/applications/visual-dialog/execution/update-memory.lisp index a31c97d5b..97301b90e 100644 --- a/applications/visual-dialog/execution/update-memory.lisp +++ b/applications/visual-dialog/execution/update-memory.lisp @@ -45,8 +45,8 @@ ;in case of mnist, attribute needs to found as input of set-diff instead of output (if mnist (progn - (setf variable (third (find 'set-diff irl-program :test #'equal :key #'first))) - (setf attributes (find-input-attributes-of-set-diff irl-program variable)))) + (setf var (third (find 'set-diff irl-program :test #'equal :key #'first))) + (setf attributes (find-input-attributes-of-set-diff irl-program var)))) ;otherwise, find attributes (setf attributes (find-attributes-of-unique irl-program target-variable))) "add attributes to objects" -- GitLab From 643bc37e00dc4b9eb547ea6c32be0b54d4873912 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 11:37:13 +0200 Subject: [PATCH 089/157] bugfix in evaluation --- applications/visual-dialog/evaluation/evaluation.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/applications/visual-dialog/evaluation/evaluation.lisp b/applications/visual-dialog/evaluation/evaluation.lisp index cb9acf913..92bbeb3d8 100644 --- a/applications/visual-dialog/evaluation/evaluation.lisp +++ b/applications/visual-dialog/evaluation/evaluation.lisp @@ -118,8 +118,8 @@ (loop for line = (read-line stream nil nil) while line when (and (not (string= (first-word line) "evaluation")) - (not (string= (first-word line) "dialog-level-accuracy:")) - (not (string= (first-word line) "question-level-accuracy:"))) + (not (string= (first-word line) "dialog-level-accuracy")) + (not (string= (first-word line) "question-level-accuracy"))) append (read-from-string (last-elt (split-string line ":"))))) (defun collect-failed-dialogs (dir) -- GitLab From 984e7f58b20f8d8e97de83e910e2752be067cbd0 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Thu, 31 Mar 2022 12:00:39 +0200 Subject: [PATCH 090/157] working on formulation --- .../bidirectional_grammar_info_arg_struct.fcg | 45 +++++++++++++------ 1 file changed, 32 insertions(+), 13 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 20ddac2f9..74ab368e8 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -162,6 +162,23 @@ (HASH form ((string ?against-word "gegen"))))) :disable-automatic-footprints t) +(def-fcg-cxn durch-cxn + ((?through-word + (footprints (preposition))) + <- + (?through-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (HASH form ((string ?through-word "durch"))))) + :disable-automatic-footprints t) + + (def-fcg-cxn für-cxn ((?for-word (footprints (preposition))) @@ -622,6 +639,10 @@ (def-fcg-cxn transitive-argument-structure-cxn ((?transitive-argument-structure-unit (subunits (?verb-unit ?agent-unit ?patient-unit))) + (?agent-unit + (syn-cat (syn-role subject))) + (?patient-unit + (syn-cat (syn-role direct-object))) <- (?verb-unit (syn-cat (lex-class verb) @@ -640,7 +661,7 @@ (- - - - -) (- - - - -) (- - - - -) - (?s ?nm ?nf ?nn ?np)))) + (?as ?nm ?nf ?nn ?np)))) (referent ?arg0) -- (syn-cat (lex-class noun-phrase) @@ -648,7 +669,7 @@ (- - - - -) (- - - - -) (- - - - -) - (?s ?nm ?nf ?nn ?np)))) + (?as ?nm ?nf ?nn ?np)))) (referent ?arg0) ) @@ -658,7 +679,7 @@ (+ ?am ?af ?an ?ap) (- - - - -) (- - - - -) - (?s ?am ?af ?an ?ap)))) + (?ps ?am ?af ?an ?ap)))) (referent ?arg1) -- (syn-cat (lex-class noun-phrase) @@ -666,7 +687,7 @@ (+ ?am ?af ?an ?ap) (- - - - -) (- - - - -) - (?s ?am ?af ?an ?ap)))) + (?ps ?am ?af ?an ?ap)))) (referent ?arg1) ) @@ -1360,11 +1381,12 @@ (referent ?arg0)) (?benefactive-unit - (syn-cat (lex-class prep-phrase)) + (syn-cat (lex-class prep-phrase) + (case ?case)) (referent ?arg2) -- (syn-cat (lex-class prep-phrase) - ) + (case ?case)) (referent ?arg2)) (?patient-unit @@ -1799,23 +1821,20 @@ ;;;der Mann geht zum Shop (formulate-all '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized m +))) +; zum Shop geht der Mann +(formulate '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized s +))) + ;;;der Mann ist beim Bäcker (formulate-all '((sein-01 s) (man m) (arg1 s m) (baker b) (arg2 s b) (topicalized m +))) ;;;beim Bäcker ist der Mann (formulate-all '((sein-01 s) (man m) (arg1 s m) (baker b) (arg2 s b) (topicalized b +))) -; zum Shop geht der Mann -(formulate '((gehen-01 g) (man m) (arg0 g m) (shop s) (arg4 g s) (topicalized s +))) - -;;; der Mann geht ohne den Clown zur Arbeit -(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg1 g c) (arg4 g w))) - ;;; der Mann ist gegen den Shop gefahren (formulate-all '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) ;; der Mann hat für den Clown die Blumen mitgebracht ------>some issues -(formulate '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) +(formulate-all '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) ;;; der Mann geht ohne den Clown zur Arbeit ------>some issues (too general ?) (formulate-all '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg4 g w) (extra-info g c) (topicalized m +))) -- GitLab From 29b1bc4c54349eebf27d827486b249eed080b62d Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 31 Mar 2022 12:20:13 +0200 Subject: [PATCH 091/157] corpus-processing; minor update for LW8 --- .../corpus-processing/corpus-processing-with-subprocesses.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/systems/corpus-processing/corpus-processing-with-subprocesses.lisp b/systems/corpus-processing/corpus-processing-with-subprocesses.lisp index b6bcebeda..bb3e06ecc 100644 --- a/systems/corpus-processing/corpus-processing-with-subprocesses.lisp +++ b/systems/corpus-processing/corpus-processing-with-subprocesses.lisp @@ -280,7 +280,7 @@ when #+sbcl(not (equal (sb-ext:process-status p) :running)) #+ccl(not (equal (ccl:external-process-status p) :running)) - #+lispworks7 (loop for stream in output-streams + #+lispworks7+ (loop for stream in output-streams when (eql (system::pipe-stream-pid stream) p) return (sys:pipe-exit-status stream :wait nil)) collect p into processes-finished -- GitLab From 5d5fb65948878ce41e4cae8dae71bd40841a97d8 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:21:23 +0200 Subject: [PATCH 092/157] Changed filename equal?.log to equal.log --- applications/clevr/mwm-evaluation/monitors.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/applications/clevr/mwm-evaluation/monitors.lisp b/applications/clevr/mwm-evaluation/monitors.lisp index 3577de9d9..e589fdeab 100644 --- a/applications/clevr/mwm-evaluation/monitors.lisp +++ b/applications/clevr/mwm-evaluation/monitors.lisp @@ -63,7 +63,7 @@ (define-monitor export-equal?-primitive :class 'lisp-data-file-writer :file-name (babel-pathname :directory '("applications" "clevr" "mwm-evaluation") - :name "equal?" :type "log") + :name "equal" :type "log") :data-sources '(record-equal?-primitive)) ;; equal-integer -- GitLab From d84e52d9247ab63fd28db99221a6aa6875c63ab6 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:22:00 +0200 Subject: [PATCH 093/157] modified pathname to learned concepts --- applications/clevr/mwm-evaluation/mwm-utils.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/applications/clevr/mwm-evaluation/mwm-utils.lisp b/applications/clevr/mwm-evaluation/mwm-utils.lisp index c40f960a5..c1ea35dfe 100644 --- a/applications/clevr/mwm-evaluation/mwm-utils.lisp +++ b/applications/clevr/mwm-evaluation/mwm-utils.lisp @@ -5,11 +5,11 @@ ;;--------------------------;; (defparameter *simulated-concepts-path* - (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "learned-concepts" "thesis-main-results" "baseline-simulated-default-lexicon"))) (defparameter *extracted-concepts-path* - (babel-pathname :directory '("experiments""multidimensional-word-meanings" "store" + (babel-pathname :directory '("experiments""multidimensional-word-meanings" "learned-concepts" "thesis-main-results" "baseline-extracted-default-lexicon"))) (defparameter *extracted-scenes-path* -- GitLab From 876a4ec1906136d0ef9bd93943d5ce65dde9c31e Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:22:34 +0200 Subject: [PATCH 094/157] Changed testing settings --- applications/clevr/mwm-evaluation/start.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/applications/clevr/mwm-evaluation/start.lisp b/applications/clevr/mwm-evaluation/start.lisp index 8124ffe59..ea48b27a3 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -12,10 +12,10 @@ (defparameter *config-entries* '((:dot-interval . 100) - (:nr-of-scenes . 1) + (:nr-of-scenes . 5) (:nr-of-questions . nil) (:data-split . "val") - (:world-type . :extracted))) + (:world-type . :simulated))) ;; Evaluate one particular serie (evaluate-mwm-serie 1 *config-entries*) -- GitLab From 370b6ee79a5d6a983dd1a6cc8b526960efcb6146 Mon Sep 17 00:00:00 2001 From: Veronica Juliana Schmalz Date: Thu, 31 Mar 2022 12:22:51 +0200 Subject: [PATCH 095/157] added footprints to contracted PP cxns --- .../bidirectional_grammar_info_arg_struct.fcg | 21 +++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 74ab368e8..13e38ed26 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -108,8 +108,11 @@ (def-fcg-cxn zur-cxn - (<- + ((?to-word + (footprints (article))) + <- (?to-word + (footprints (not article)) (syn-cat (lex-class contracted-preposition) (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) (- - - - -) ;masc, fem, neut, plural @@ -121,8 +124,11 @@ (def-fcg-cxn zum-cxn - (<- + ((?to-word + (footprints (article))) + <- (?to-word + (footprints (not article)) (syn-cat (lex-class contracted-preposition) (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) (- - - - -) ;masc, fem, neut, plural @@ -134,8 +140,11 @@ (def-fcg-cxn beim-cxn - (<- + ((?at-word + (footprints (article))) + <- (?at-word + (footprints (not article)) (syn-cat (lex-class contracted-preposition) (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) (- - - - -) ;masc, fem, neut, plural @@ -1834,11 +1843,11 @@ (formulate-all '((drove-01 ig) (man m) (arg0 ig m) (shop s) (arg4 ig s) (topicalized m +))) ;; der Mann hat für den Clown die Blumen mitgebracht ------>some issues -(formulate-all '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) +(formulate '((brought-01 hm) (man m) (arg0 hm m) (clown c) (arg2 hm c) (flowers f) (arg1 hm f) (topicalized m +))) ;;; der Mann geht ohne den Clown zur Arbeit ------>some issues (too general ?) -(formulate-all '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg4 g w) (extra-info g c) (topicalized m +))) +(formulate '((gehen-01 g) (man m) (clown c) (work w) (arg0 g m) (arg4 g w) (extra-info g c) (topicalized m +))) ;;der Mann fährt mit dem Fahrrad zur Arbeit -(formulate-all '((fahren-01 f) (man m) (bike b) (work w) (arg0 f m) (arg1 f w) (extra-info f b) (topicalized m +))) +(formulate '((fahren-01 f) (man m) (bike b) (work w) (arg0 f m) (arg1 f w) (extra-info f b) (topicalized m +))) -- GitLab From 480f2c052ac991f24f15a347f9763e5178e6876c Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:23:33 +0200 Subject: [PATCH 096/157] Added shuffle to disciminate-topic --- experiments/spatial-concept-game/agent.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/experiments/spatial-concept-game/agent.lisp b/experiments/spatial-concept-game/agent.lisp index 6718bdf60..304e15089 100644 --- a/experiments/spatial-concept-game/agent.lisp +++ b/experiments/spatial-concept-game/agent.lisp @@ -108,7 +108,7 @@ (loop for object in context-objects for object-relations = (object->alist object) for discriminative-relationship - = (loop for relationship in object-relations + = (loop for relationship in (shuffle object-relations) if (and (member (id topic) (cdr relationship)) (= (length (cdr relationship)) 1)) return (car relationship)) -- GitLab From 2cf48cb29fca40b3f2655b3bb6bf5d410987b980 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:24:12 +0200 Subject: [PATCH 097/157] Changed pathname to CLEVR-scenes in experiment settings --- experiments/spatial-concept-game/experiment.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/experiments/spatial-concept-game/experiment.lisp b/experiments/spatial-concept-game/experiment.lisp index 1e06418a4..fd5f71189 100644 --- a/experiments/spatial-concept-game/experiment.lisp +++ b/experiments/spatial-concept-game/experiment.lisp @@ -40,7 +40,7 @@ (make-instance 'clevr-world :data-sets (list "val"))) ;; store the data-sets and data-path in the blackboard (set-data experiment :ns-vqa-data-path (merge-pathnames (make-pathname - :directory `(:relative "Frontiers-data" "CLEVR" "val")) cl-user:*babel-corpora*))) + :directory `(:relative "CLEVR-v1.0" "scenes" "val")) cl-user:*babel-corpora*))) (defmethod learner ((experiment spatial-experiment)) -- GitLab From 4af67fc322bb48c8b7c5137b2a974f65efd98fc7 Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:24:38 +0200 Subject: [PATCH 098/157] Changed some settings for testing --- experiments/spatial-concept-game/run.lisp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/experiments/spatial-concept-game/run.lisp b/experiments/spatial-concept-game/run.lisp index 823144f66..91d02ff66 100644 --- a/experiments/spatial-concept-game/run.lisp +++ b/experiments/spatial-concept-game/run.lisp @@ -33,7 +33,7 @@ (run-interaction *experiment*) -(run-series *experiment* 100) +(run-series *experiment* 300) (display-lexicon (find 'learner (population *experiment*) :key #'id)) @@ -44,10 +44,10 @@ (run-experiments `( (test ((:world-type . :simulated) - (:determine-interacting-agents-mode . :default + (:determine-interacting-agents-mode . :default) (:alignment-filter . :all))) ) - :number-of-interactions 2000 + :number-of-interactions 2500 :number-of-series 1 :monitors (list "export-communicative-success" "export-lexicon-size" @@ -76,12 +76,12 @@ (create-tutor-word-use-graph :configurations - '((:world-type . :extracted)) + '((:world-type . :simulated)) :nr-of-interactions 2500) (create-learner-failed-conceptualisation-graph :configurations - '((:world-type . :extracted)) + '((:world-type . :simulated)) :nr-of-interactions 5000) -- GitLab From 99d91efc1fe7019d29e2de9e9ad50f4cf287198f Mon Sep 17 00:00:00 2001 From: Liesbet De Vos Date: Thu, 31 Mar 2022 12:25:32 +0200 Subject: [PATCH 099/157] Uncommented other attributes besides x- and y-positions --- experiments/spatial-concept-game/world.lisp | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/experiments/spatial-concept-game/world.lisp b/experiments/spatial-concept-game/world.lisp index 35c42c7f4..05fa37718 100644 --- a/experiments/spatial-concept-game/world.lisp +++ b/experiments/spatial-concept-game/world.lisp @@ -36,7 +36,7 @@ `((:left . ,(rest (assoc 'left (relationships object)))) (:right . ,(rest (assoc 'right (relationships object)))) (:front . ,(rest (assoc 'front (relationships object)))) - (:behind. ,(rest (assoc 'behind (relationships object)))))) + (:behind . ,(rest (assoc 'behind (relationships object)))))) ;; ------------------ ;; + SPATIAL object set + @@ -142,11 +142,11 @@ (make-instance 'spatial-object :id (id object) ;; !!! :attributes (append (to-value object 'xpos) (to-value object 'ypos) - ;(to-value object 'area) - ;(to-value object 'wh-ratio) - ;(to-value object 'color) - ;(to-value object 'roughness) - ;(to-value object 'sides-and-corners) + (to-value object 'area) + (to-value object 'wh-ratio) + (to-value object 'color) + (to-value object 'roughness) + (to-value object 'sides-and-corners) ) :description (object->alist object))) -- GitLab From 2b13f6adef6fc790a4e16a5113b61d903f9b2b1c Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 31 Mar 2022 12:34:27 +0200 Subject: [PATCH 100/157] propbank grammar - updates for LW8 + switch type-hierarchies to categorial-network in utils subdir --- grammars/propbank-english/package.lisp | 2 +- .../propbank-english/propbank-english.asd | 13 +++++++--- grammars/propbank-english/run-parallel.lisp | 2 +- .../propbank-english/utils/cxn-supplier.lisp | 23 +++++++++-------- grammars/propbank-english/utils/utils.lisp | 25 +++++++++---------- .../propbank-english/utils/visualisation.lisp | 2 +- 6 files changed, 38 insertions(+), 29 deletions(-) diff --git a/grammars/propbank-english/package.lisp b/grammars/propbank-english/package.lisp index 8bbbdf466..b0af462b4 100644 --- a/grammars/propbank-english/package.lisp +++ b/grammars/propbank-english/package.lisp @@ -4,4 +4,4 @@ (:documentation "A large propbank-based construction grammar for English") (:shadowing-import-from :cl-propbank :id) (:shadowing-import-from :fcg :size) - (:use :common-lisp :cl-user :utils :monitors :fcg :type-hierarchies :irl :web-interface :cl-propbank :cl-store)) + (:use :common-lisp :cl-user :utils :monitors :fcg :irl :web-interface :cl-propbank :cl-store)) diff --git a/grammars/propbank-english/propbank-english.asd b/grammars/propbank-english/propbank-english.asd index d70876a33..bb7cad25e 100644 --- a/grammars/propbank-english/propbank-english.asd +++ b/grammars/propbank-english/propbank-english.asd @@ -9,7 +9,6 @@ :monitors :irl :fcg - :category-hierarchies :nlp-tools :web-interface :cl-propbank @@ -27,9 +26,17 @@ (:file "utils") (:file "de-render") (:file "cxn-supplier"))) + + ;;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ;; TO DO; the following files need to be updated + ;; to the categorial network that is integrated in FCG + ;; instead of using the separate type-hierarchies package (:module learning :serial t :components ((:file "evaluation") (:file "learn-propbank-constructions"))) - (:file "categorial-network-metrics") - (:file "grammar-analysis"))) + ;(:file "categorial-network-metrics") + ;(:file "grammar-analysis") + ;;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + )) diff --git a/grammars/propbank-english/run-parallel.lisp b/grammars/propbank-english/run-parallel.lisp index 8eb3dcace..4f2586343 100644 --- a/grammars/propbank-english/run-parallel.lisp +++ b/grammars/propbank-english/run-parallel.lisp @@ -163,7 +163,7 @@ This script makes the following assumptions: For example, if you have 20 threads available and a corpus of 100000 lines, you could specify 20 threads and 5000 lines per thread. However, you could also specify 20 threads and 1000 lines per thread, - or even 100 lines per thread. + or even 20 threads and 100 lines per thread. By reducing the number of lines per thread, you create more batches, but the memory requirement per thread will be reduced, as all results of these X lines per thread must be stored until the thread is done. diff --git a/grammars/propbank-english/utils/cxn-supplier.lisp b/grammars/propbank-english/utils/cxn-supplier.lisp index a2e58ce59..3a566bb2c 100644 --- a/grammars/propbank-english/utils/cxn-supplier.lisp +++ b/grammars/propbank-english/utils/cxn-supplier.lisp @@ -66,9 +66,11 @@ ((or (equal label 'argument-structure-cxn) (equal label 'argm-phrase-cxn)) (let* ((lex-categories-node (lex-categories node)) - (neighbours (remove-duplicates (loop for lex-category in lex-categories-node - append (graph-utils::neighbors (type-hierarchies::graph (get-type-hierarchy (construction-inventory node))) lex-category - :return-ids? nil)))) + (categorial-network (categorial-network (construction-inventory node))) + (neighbours + (remove-duplicates + (loop for lex-category in lex-categories-node + append (neighbouring-categories lex-category categorial-network)))) (constructions (loop for cxn in (if (equal label 'argument-structure-cxn) (gethash nil (constructions-hash-table (construction-inventory node))) (append @@ -92,10 +94,11 @@ ;; Word sense constructions ((equal label 'word-sense-cxn) (let* ((gram-categories-node (gram-categories node)) - (neighbours (remove-duplicates (loop for gram-category in gram-categories-node - append (graph-utils::neighbors (type-hierarchies::graph (get-type-hierarchy (construction-inventory node))) - gram-category - :return-ids? nil)))) + (categorial-network (categorial-network (construction-inventory node))) + (neighbours + (remove-duplicates + (loop for gram-category in gram-categories-node + append (neighbouring-categories gram-category categorial-network)))) (constructions (loop for cxn in (loop for hash in (hash node (get-configuration node :hash-mode)) append (gethash hash (constructions-hash-table (construction-inventory node)))) for cxn-category = (attr-val cxn :sense-category) @@ -114,12 +117,12 @@ (defun find-highest-edge-weight (category-list cxn node) - (loop with graph = (graph-utils::graph (get-type-hierarchy (construction-inventory node))) + (loop with th = (categorial-network (construction-inventory node)) with gram-category = (or (attr-val cxn :gram-category) (attr-val cxn :sense-category)) for cat in category-list - if (graph-utils:edge-exists? graph cat gram-category) - maximize (graph-utils:edge-weight graph cat gram-category))) + if (link-exists-p cat gram-category th) + maximize (link-weight cat gram-category th))) diff --git a/grammars/propbank-english/utils/utils.lisp b/grammars/propbank-english/utils/utils.lisp index 618755ce9..14509ce3d 100644 --- a/grammars/propbank-english/utils/utils.lisp +++ b/grammars/propbank-english/utils/utils.lisp @@ -109,11 +109,11 @@ frame-element filler occurs in more than one slot). " thereis (subconstituent-p (fourth fe) (mapcar #'fourth other-fes) (left-pole-structure (car-resulting-cfs (cipn-car node)))))) do (push frame-var double-role-assignments) finally - return - (if double-role-assignments - ;;some frames contain frame-elements that have identical slot fillers - (and (push 'double-role-assignment (statuses node)) nil) - t)))) + (return + (if double-role-assignments + ;;some frames contain frame-elements that have identical slot fillers + (and (push 'double-role-assignment (statuses node)) nil) + t))))) (defun subconstituent-p (frame-element other-frame-elements unit-structure) (loop for ofe in other-frame-elements @@ -319,7 +319,7 @@ grammar on the list-of-sentences" (loop with freq-table = (make-hash-table) for cxn in (constructions-list hashed-cxn-inventory) do (setf (gethash (name cxn) freq-table) 0) - finally return freq-table)) + finally (return freq-table))) (nr-of-time-outs 0)) (loop for sentence in list-of-sentences @@ -382,7 +382,7 @@ grammar on the list-of-sentences" (loop for cxn in (constructions-list cxn-inventory) when (< (attr-val cxn :frequency) cutoff-frequency) do (with-disabled-monitor-notifications (delete-cxn cxn cxn-inventory)) - finally return cxn-inventory))) + finally (return cxn-inventory)))) #| (defun clean-grammar (grammar &key @@ -417,17 +417,16 @@ grammar on the list-of-sentences" (remove-edges-with-freq-smaller-than 2.0)) "Cleans the type hierarchy of a learned grammar by removing edges that have a weight smaller than a given frequency." - (let* ((graph (type-hierarchies::graph type-hierarchy)) - (edges (graph-utils:list-edges graph :edge-type nil))) + (let ((edges (fcg::links type-hierarchy))) - (format t "Edge count before cleaning: ~a ~%" (type-hierarchies::edge-count graph)) + (format t "Edge count before cleaning: ~a ~%" (fcg::nr-of-links type-hierarchy)) (loop for (n1 n2) in edges - when (< (graph-utils:edge-weight graph n1 n2 nil) + when (< (fcg::link-weight n1 n2 type-hierarchy) remove-edges-with-freq-smaller-than) - do (graph-utils:delete-edge graph n1 n2 nil)) + do (fcg::remove-link n1 n2 type-hierarchy)) - (format t "Edge count after cleaning: ~a ~%" (type-hierarchies::edge-count graph)) + (format t "Edge count after cleaning: ~a ~%" (fcg::nr-of-links type-hierarchy)) type-hierarchy)) diff --git a/grammars/propbank-english/utils/visualisation.lisp b/grammars/propbank-english/utils/visualisation.lisp index 01861bb98..022137f4c 100644 --- a/grammars/propbank-english/utils/visualisation.lisp +++ b/grammars/propbank-english/utils/visualisation.lisp @@ -123,7 +123,7 @@ :frame-elements (find-frame-elements unit unit-list)) into frames finally - return (make-instance 'frame-set :frames frames))) + (return (make-instance 'frame-set :frames frames)))) (defun find-frame-name (unit) "Find frame name in unit." -- GitLab From 7060b742aca65c00d4c9a408332f2e2565f71724 Mon Sep 17 00:00:00 2001 From: laraverheyen Date: Thu, 31 Mar 2022 15:07:00 +0200 Subject: [PATCH 101/157] fix in get-last-topic: recursively find topic of previous turns if no topic in last turn, necessary for mnist --- applications/visual-dialog/primitives/get-last-topic.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/applications/visual-dialog/primitives/get-last-topic.lisp b/applications/visual-dialog/primitives/get-last-topic.lisp index 077076469..cc5c55261 100644 --- a/applications/visual-dialog/primitives/get-last-topic.lisp +++ b/applications/visual-dialog/primitives/get-last-topic.lisp @@ -6,7 +6,7 @@ (multiple-value-bind (last-set last-timestamp) (the-biggest #'timestamp (set-items source-set)) - (let* ((last-topic (find-last-topic source-set)) + (let* ((last-topic (find-last-topic (set-items source-set))) (last-topic-object-set (loop for obj in (objects (object-set last-set)) when (member (id obj) last-topic) @@ -18,13 +18,13 @@ :objects last-topic-object-set))))))))) :primitive-inventory *symbolic-primitives*) -(defun find-last-topic (source-set) +(defun find-last-topic (lst) (multiple-value-bind (last-set last-timestamp) - (the-biggest #'timestamp (set-items source-set)) + (the-biggest #'timestamp lst) (let ((last-topic (topic-list last-set))) (if last-topic last-topic - (find-last-topic (rest (set-items source-set))))))) + (find-last-topic (rest lst)))))) \ No newline at end of file -- GitLab From 8ddc94085db921e213dabfbf83774ddd885a6d70 Mon Sep 17 00:00:00 2001 From: jnevens Date: Thu, 31 Mar 2022 17:04:04 +0200 Subject: [PATCH 102/157] (temporarily) added named-readtables library; future quicklisp release will contain fixed version --- libraries/named-readtables/.gitignore | 4 + libraries/named-readtables/LICENSE | 61 ++ libraries/named-readtables/README | 380 ++++++++++++ libraries/named-readtables/README.md | 450 ++++++++++++++ .../named-readtables/named-readtables.asd | 55 ++ libraries/named-readtables/src/cruft.lisp | 517 ++++++++++++++++ .../named-readtables/src/define-api.lisp | 64 ++ libraries/named-readtables/src/doc.lisp | 222 +++++++ .../src/named-readtables.lisp | 555 ++++++++++++++++++ libraries/named-readtables/src/package.lisp | 37 ++ libraries/named-readtables/src/utils.lisp | 245 ++++++++ libraries/named-readtables/test/package.lisp | 10 + libraries/named-readtables/test/tests.lisp | 336 +++++++++++ 13 files changed, 2936 insertions(+) create mode 100644 libraries/named-readtables/.gitignore create mode 100644 libraries/named-readtables/LICENSE create mode 100644 libraries/named-readtables/README create mode 100644 libraries/named-readtables/README.md create mode 100644 libraries/named-readtables/named-readtables.asd create mode 100644 libraries/named-readtables/src/cruft.lisp create mode 100644 libraries/named-readtables/src/define-api.lisp create mode 100644 libraries/named-readtables/src/doc.lisp create mode 100644 libraries/named-readtables/src/named-readtables.lisp create mode 100644 libraries/named-readtables/src/package.lisp create mode 100644 libraries/named-readtables/src/utils.lisp create mode 100644 libraries/named-readtables/test/package.lisp create mode 100644 libraries/named-readtables/test/tests.lisp diff --git a/libraries/named-readtables/.gitignore b/libraries/named-readtables/.gitignore new file mode 100644 index 000000000..7d26dc4c9 --- /dev/null +++ b/libraries/named-readtables/.gitignore @@ -0,0 +1,4 @@ +*~ +*.fasl +*.*fsl +doc/ diff --git a/libraries/named-readtables/LICENSE b/libraries/named-readtables/LICENSE new file mode 100644 index 000000000..8785f1f05 --- /dev/null +++ b/libraries/named-readtables/LICENSE @@ -0,0 +1,61 @@ + +Copyright (c) 2007 - 2009 Tobias C. Rittweiler +Copyright (c) 2007, Robert P. Goldman and SIFT, LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the names of Tobias C. Rittweiler, Robert P. Goldman, + SIFT, LLC nor the names of its contributors may be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert +P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert +P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +---------------------------------------------------------------------------- +LICENSE for the test/rt.lisp test framework + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + diff --git a/libraries/named-readtables/README b/libraries/named-readtables/README new file mode 100644 index 000000000..ddcc471bb --- /dev/null +++ b/libraries/named-readtables/README @@ -0,0 +1,380 @@ +# Named Readtables Manual + +###### \[in package EDITOR-HINTS.NAMED-READTABLES with nicknames NAMED-READTABLES\] +## NAMED-READTABLES ASDF System + +- Version: 0.9 +- Description: Library that creates a namespace for readtables akin + to the namespace of packages. +- Licence: BSD, see LICENSE +- Author: Tobias C. Rittweiler +- Maintainer: Gábor Melis +- Mailto: [mega@retes.hu](mailto:mega@retes.hu) +- Homepage: [http://melisgl.github.io/named-readtables](http://melisgl.github.io/named-readtables) +- Bug tracker: [https://github.com/melisgl/named-readtables/issues](https://github.com/melisgl/named-readtables/issues) +- Source control: [GIT](https://github.com/melisgl/named-readtables.git) + +## Introduction + +Named-Readtables is a library that provides a namespace for +readtables akin to the already-existing namespace of packages. In +particular: + +- you can associate readtables with names, and retrieve + readtables by names; + +- you can associate source files with readtable names, and be + sure that the right readtable is active when compiling/loading + the file; + +- similiarly, your development environment now has a chance to + automatically determine what readtable should be active while + processing source forms on interactive commands. (E.g. think of + `C-c C-c` in Slime (yet to be done)) + +It follows that Named-Readtables is a facility for using readtables in +a localized way. + +Additionally, it also attempts to become a facility for using +readtables in a *modular* way. In particular: + +- it provides a macro to specify the content of a readtable at a + glance; + +- it makes it possible to use multiple inheritance between readtables. + + +### Links + +Here is the [official repository][named-readtables-repo] and the +[HTML documentation][named-readtables-doc] for the latest version. + +[named-readtables-repo]: https://github.com/melisgl/named-readtables + +[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html + + +### Acknowledgements + +Thanks to Robert Goldman for making me want to write this library. + +Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart +Botta, David Crawford, and Pascal Costanza for being early adopters, +providing comments and bugfixes. + +## Overview + +### Notes on the API + +The API heavily imitates the API of packages. This has the nice +property that any experienced Common Lisper will take it up without +effort. + + DEFREADTABLE - DEFPACKAGE + + IN-READTABLE - IN-PACKAGE + + MERGE-READTABLES-INTO - USE-PACKAGE + + MAKE-READTABLE - MAKE-PACKAGE + + UNREGISTER-READTABLE - DELETE-PACKAGE + + RENAME-READTABLE - RENAME-PACKAGE + + FIND-READTABLE - FIND-PACKAGE + + READTABLE-NAME - PACKAGE-NAME + + LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES + + +### Important API idiosyncrasies + +There are three major differences between the API of Named-Readtables, +and the API of packages. + +1. Readtable names are symbols not strings. + + Time has shown that the fact that packages are named by strings + causes severe headache because of the potential of package names + colliding with each other. + + Hence, readtables are named by symbols lest to make the + situation worse than it already is. Consequently, readtables + named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can + happily coexist next to each other. Or, taken to an extreme, + `SCHEME:SYNTAX` and `ELISP:SYNTAX`. + + If, for example to duly signify the importance of your cool + readtable hack, you really think it deserves a global name, you + can always resort to keywords. + +2. The inheritance is resolved statically, not dynamically. + + A package that uses another package will have access to all the + other package's exported symbols, even to those that will be + added after its definition. I.e. the inheritance is resolved at + run-time, that is dynamically. + + Unfortunately, we cannot do the same for readtables in a + portable manner. + + Therefore, we do not talk about "using" another readtable but + about "merging" the other readtable's definition into the + readtable we are going to define. I.e. the inheritance is + resolved once at definition time, that is statically. + + (Such merging can more or less be implemented portably albeit at + a certain cost. Most of the time, this cost manifests itself at + the time a readtable is defined, i.e. once at compile-time, so + it may not bother you. Nonetheless, we provide extra support for + Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your + implementation of choice are welcome, of course.) + +3. DEFREADTABLE does not have compile-time effects. + + If you define a package via DEFPACKAGE, you can make that + package the currently active package for the subsequent + compilation of the same file via IN-PACKAGE. The same is, + however, not true for DEFREADTABLE and IN-READTABLE for the + following reason: + + It's unlikely that the need for special reader-macros arises for + a problem which can be solved in just one file. Most often, + you're going to define the reader macro functions, and set up + the corresponding readtable in an extra file. + + If DEFREADTABLE had compile-time effects, you'd have to wrap + each definition of a reader-macro function in an EVAL-WHEN to + make its definition available at compile-time. Because that's + simply not the common case, DEFREADTABLE does not have a + compile-time effect. + + If you want to use a readtable within the same file as its + definition, wrap the DEFREADTABLE and the reader-macro function + definitions in an explicit EVAL-WHEN. + + +### Preregistered Readtables + +- NIL, :STANDARD, and :COMMON-LISP designate the +*standard readtable*. + +- :MODERN designates a *case-preserving* *standard-readtable*. + +- :CURRENT designates the *current readtable*. + + +### Examples + +```commonlisp +(defreadtable elisp:syntax + (:merge :standard) + (:macro-char #\? #'elisp::read-character-literal t) + (:macro-char #\[ #'elisp::read-vector-literal t) + ... + (:case :preserve)) + +(defreadtable scheme:syntax + (:merge :standard) + (:macro-char #\[ #'(lambda (stream char) + (read-delimited-list #\] stream))) + (:macro-char #\# :dispatch) + (:dispatch-macro-char #\# #\t #'scheme::read-#t) + (:dispatch-macro-char #\# #\f #'scheme::read-#f) + ... + (:case :preserve)) + +(in-readtable elisp:syntax) + +... + +(in-readtable scheme:syntax) + +... +``` + + +## Reference + +- [macro] DEFREADTABLE NAME &BODY OPTIONS + + Define a new named readtable, whose name is given by the symbol NAME. + Or, if a readtable is already registered under that name, redefine + that one. + + The readtable can be populated using the following OPTIONS: + + - If the first element of OPTIONS is a string then it is associated + with the readtable as in `(SETF (DOCUMENTATION NAME 'READTABLE) + DOCSTRING)`. + + - `(:MERGE READTABLE-DESIGNATORS+)` + + Merge the macro character definitions from the readtables + designated into the new readtable being defined as per + MERGE-READTABLES-INTO. The copied options are + :DISPATCH-MACRO-CHAR, :MACRO-CHAR and :SYNTAX-FROM, but not + READTABLE-CASE. + + If no :MERGE clause is given, an empty readtable is used. See + MAKE-READTABLE. + + - `(:FUSE READTABLE-DESIGNATORS+)` + + Like :MERGE except: + + Error conditions of type READER-MACRO-CONFLICT that are signaled + during the merge operation will be silently *continued*. It + follows that reader macros in earlier entries will be + overwritten by later ones. For backward compatibility, :FUZE is + accepted as an alias of :FUSE. + + - `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)` + + Define a new sub character `SUB-CHAR` for the dispatching macro + character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You + probably have to define `MACRO-CHAR` as a dispatching macro + character by the following option first. + + - `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])` + + Define a new macro character in the readtable, per + SET-MACRO-CHARACTER. If [FUNCTION][argument] is the keyword + :DISPATCH, `MACRO-CHAR` is made a dispatching macro character, + per MAKE-DISPATCH-MACRO-CHARACTER. + + - `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)` + + Set the character syntax of TO-CHAR in the readtable being + defined to the same syntax as FROM-CHAR as per + SET-SYNTAX-FROM-CHAR. + + - `(:CASE CASE-MODE)` + + Defines the *case sensitivity mode* of the resulting readtable. + + Any number of option clauses may appear. The options are grouped by + their type, but in each group the order the options appeared + textually is preserved. The following groups exist and are executed + in the following order: :MERGE and :FUSE (one group), :CASE, + :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally + :SYNTAX-FROM. + + Notes: + + The readtable is defined at load-time. If you want to have it + available at compilation time -- say to use its reader-macros in the + same file as its definition -- you have to wrap the DEFREADTABLE + form in an explicit EVAL-WHEN. + + On redefinition, the target readtable is made empty first before + it's refilled according to the clauses. + + NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are + preregistered readtable names. + +- [macro] IN-READTABLE NAME + + Set *READTABLE* to the readtable referred to by the symbol NAME. + Return the readtable. + +- [function] MAKE-READTABLE &OPTIONAL (NAME NIL NAME-SUPPLIED-P) &KEY MERGE + + Creates and returns a new readtable under the specified + NAME. + + MERGE takes a list of NAMED-READTABLE-DESIGNATORs and specifies the + readtables the new readtable is created from. (See the :MERGE clause + of DEFREADTABLE for details.) + + If MERGE is NIL, an empty readtable is used instead. + + If NAME is not given, an anonymous empty readtable is returned. + + Notes: + + An empty readtable is a readtable where each character's syntax is + the same as in the *standard readtable* except that each macro + character has been made a constituent. Basically: whitespace stays + whitespace, everything else is constituent. + +- [function] MERGE-READTABLES-INTO RESULT-READTABLE &REST NAMED-READTABLES + + Copy macro character definitions of each readtable in + NAMED-READTABLES into RESULT-READTABLE. + + If a macro character appears in more than one of the readtables, + i.e. if a conflict is discovered during the merge, an error of type + READER-MACRO-CONFLICT is signaled. + + The copied options are :DISPATCH-MACRO-CHAR, :MACRO-CHAR and + :SYNTAX-FROM, but not READTABLE-CASE. + +- [function] FIND-READTABLE NAME + + Looks for the readtable specified by NAME and returns it if it is + found. Returns NIL otherwise. + +- [function] ENSURE-READTABLE NAME &OPTIONAL (DEFAULT NIL DEFAULT-P) + + Looks up the readtable specified by NAME and returns it if it's found. + If it is not found, it registers the readtable designated by DEFAULT + under the name represented by NAME; or if no default argument is + given, it signals an error of type READTABLE-DOES-NOT-EXIST + instead. + +- [function] RENAME-READTABLE OLD-NAME NEW-NAME + + Replaces the associated name of the readtable designated by + OLD-NAME with NEW-NAME. If a readtable is already registered under + NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is + signaled. + +- [function] READTABLE-NAME NAMED-READTABLE + + Returns the name of the readtable designated by NAMED-READTABLE, + or NIL. + +- [function] REGISTER-READTABLE NAME READTABLE + + Associate READTABLE with NAME. Returns the readtable. + +- [function] UNREGISTER-READTABLE NAMED-READTABLE + + Remove the association of NAMED-READTABLE. Returns T if successfull, + NIL otherwise. + +- [function] COPY-NAMED-READTABLE NAMED-READTABLE + + Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument. + +- [function] LIST-ALL-NAMED-READTABLES + + Returns a list of all registered readtables. The returned list is + guaranteed to be fresh, but may contain duplicates. + +- [type] NAMED-READTABLE-DESIGNATOR + + Either a symbol or a readtable itself. + +- [condition] READTABLE-ERROR ERROR + +- [condition] READER-MACRO-CONFLICT READTABLE-ERROR + + Continuable. + + This condition is signaled during the merge process if a reader + macro (be it a macro character or the sub character of a dispatch + macro character) is present in the both source and the target + readtable and the two respective reader macro functions differ. + +- [condition] READTABLE-DOES-ALREADY-EXIST READTABLE-ERROR + + Continuable. + +- [condition] READTABLE-DOES-NOT-EXIST READTABLE-ERROR + +* * * +###### \[generated by [MGL-PAX](https://github.com/melisgl/mgl-pax)\] diff --git a/libraries/named-readtables/README.md b/libraries/named-readtables/README.md new file mode 100644 index 000000000..944415cf4 --- /dev/null +++ b/libraries/named-readtables/README.md @@ -0,0 +1,450 @@ + +# Named Readtables Manual + +## Table of Contents + +- [1 `NAMED-READTABLES` ASDF System][718a] +- [2 Introduction][480f] + - [2.1 Links][a61b] + - [2.2 Acknowledgements][ebdc] +- [3 Overview][c1e9] + - [3.1 Notes on the API][f800] + - [3.2 Important API idiosyncrasies][398b] + - [3.3 Preregistered Readtables][c5dc] + - [3.4 Examples][aae8] +- [4 Reference][4d56] + +###### \[in package EDITOR-HINTS.NAMED-READTABLES with nicknames NAMED-READTABLES\] + +## 1 `NAMED-READTABLES` ASDF System + +- Version: 0.9 +- Description: Library that creates a namespace for readtables akin + to the namespace of packages. +- Licence: BSD, see LICENSE +- Author: Tobias C. Rittweiler +- Maintainer: Gábor Melis +- Mailto: [mega@retes.hu](mailto:mega@retes.hu) +- Homepage: [http://melisgl.github.io/named-readtables](http://melisgl.github.io/named-readtables) +- Bug tracker: [https://github.com/melisgl/named-readtables/issues](https://github.com/melisgl/named-readtables/issues) +- Source control: [GIT](https://github.com/melisgl/named-readtables.git) + + +## 2 Introduction + +Named-Readtables is a library that provides a namespace for +readtables akin to the already-existing namespace of packages. In +particular: + +- you can associate readtables with names, and retrieve + readtables by names; + +- you can associate source files with readtable names, and be + sure that the right readtable is active when compiling/loading + the file; + +- similiarly, your development environment now has a chance to + automatically determine what readtable should be active while + processing source forms on interactive commands. (E.g. think of + `C-c C-c` in Slime (yet to be done)) + +It follows that Named-Readtables is a facility for using readtables in +a localized way. + +Additionally, it also attempts to become a facility for using +readtables in a *modular* way. In particular: + +- it provides a macro to specify the content of a readtable at a + glance; + +- it makes it possible to use multiple inheritance between readtables. + + + +### 2.1 Links + +Here is the [official repository][named-readtables-repo] and the +[HTML documentation][named-readtables-doc] for the latest version. + +[named-readtables-repo]: https://github.com/melisgl/named-readtables + +[named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html + + + +### 2.2 Acknowledgements + +Thanks to Robert Goldman for making me want to write this library. + +Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart +Botta, David Crawford, and Pascal Costanza for being early adopters, +providing comments and bugfixes. + + +## 3 Overview + + +### 3.1 Notes on the API + +The API heavily imitates the API of packages. This has the nice +property that any experienced Common Lisper will take it up without +effort. + + DEFREADTABLE - DEFPACKAGE + + IN-READTABLE - IN-PACKAGE + + MERGE-READTABLES-INTO - USE-PACKAGE + + MAKE-READTABLE - MAKE-PACKAGE + + UNREGISTER-READTABLE - DELETE-PACKAGE + + RENAME-READTABLE - RENAME-PACKAGE + + FIND-READTABLE - FIND-PACKAGE + + READTABLE-NAME - PACKAGE-NAME + + LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES + + + +### 3.2 Important API idiosyncrasies + +There are three major differences between the API of Named-Readtables, +and the API of packages. + +1. Readtable names are symbols not strings. + + Time has shown that the fact that packages are named by strings + causes severe headache because of the potential of package names + colliding with each other. + + Hence, readtables are named by symbols lest to make the + situation worse than it already is. Consequently, readtables + named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can + happily coexist next to each other. Or, taken to an extreme, + `SCHEME:SYNTAX` and `ELISP:SYNTAX`. + + If, for example to duly signify the importance of your cool + readtable hack, you really think it deserves a global name, you + can always resort to keywords. + +2. The inheritance is resolved statically, not dynamically. + + A package that uses another package will have access to all the + other package's exported symbols, even to those that will be + added after its definition. I.e. the inheritance is resolved at + run-time, that is dynamically. + + Unfortunately, we cannot do the same for readtables in a + portable manner. + + Therefore, we do not talk about "using" another readtable but + about "merging" the other readtable's definition into the + readtable we are going to define. I.e. the inheritance is + resolved once at definition time, that is statically. + + (Such merging can more or less be implemented portably albeit at + a certain cost. Most of the time, this cost manifests itself at + the time a readtable is defined, i.e. once at compile-time, so + it may not bother you. Nonetheless, we provide extra support for + Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your + implementation of choice are welcome, of course.) + +3. [`DEFREADTABLE`][6a02] does not have compile-time effects. + + If you define a package via [`DEFPACKAGE`][42d7], you can make that + package the currently active package for the subsequent + compilation of the same file via [`IN-PACKAGE`][a603]. The same is, + however, not true for `DEFREADTABLE` and [`IN-READTABLE`][ee2d] for the + following reason: + + It's unlikely that the need for special reader-macros arises for + a problem which can be solved in just one file. Most often, + you're going to define the reader macro functions, and set up + the corresponding readtable in an extra file. + + If `DEFREADTABLE` had compile-time effects, you'd have to wrap + each definition of a reader-macro function in an [`EVAL-WHEN`][09f3] to + make its definition available at compile-time. Because that's + simply not the common case, `DEFREADTABLE` does not have a + compile-time effect. + + If you want to use a readtable within the same file as its + definition, wrap the `DEFREADTABLE` and the reader-macro function + definitions in an explicit `EVAL-WHEN`. + + + +### 3.3 Preregistered Readtables + +- `NIL`, `:STANDARD`, and `:COMMON-LISP` designate the +*standard readtable*. + +- `:MODERN` designates a *case-preserving* *standard-readtable*. + +- `:CURRENT` designates the *current readtable*. + + + +### 3.4 Examples + +```commonlisp +(defreadtable elisp:syntax + (:merge :standard) + (:macro-char #\? #'elisp::read-character-literal t) + (:macro-char #\[ #'elisp::read-vector-literal t) + ... + (:case :preserve)) + +(defreadtable scheme:syntax + (:merge :standard) + (:macro-char #\[ #'(lambda (stream char) + (read-delimited-list #\] stream))) + (:macro-char #\# :dispatch) + (:dispatch-macro-char #\# #\t #'scheme::read-#t) + (:dispatch-macro-char #\# #\f #'scheme::read-#f) + ... + (:case :preserve)) + +(in-readtable elisp:syntax) + +... + +(in-readtable scheme:syntax) + +... +``` + + + +## 4 Reference + + +- [macro] **DEFREADTABLE** *NAME &BODY OPTIONS* + + Define a new named readtable, whose name is given by the symbol `NAME`. + Or, if a readtable is already registered under that name, redefine + that one. + + The readtable can be populated using the following `OPTIONS`: + + - If the first element of `OPTIONS` is a string then it is associated + with the readtable as in `(SETF (DOCUMENTATION NAME 'READTABLE) + DOCSTRING)`. + + - `(:MERGE READTABLE-DESIGNATORS+)` + + Merge the macro character definitions from the readtables + designated into the new readtable being defined as per + [`MERGE-READTABLES-INTO`][1625]. The copied options are + `:DISPATCH-MACRO-CHAR`, `:MACRO-CHAR` and `:SYNTAX-FROM`, but not + [`READTABLE-CASE`][a328]. + + If no `:MERGE` clause is given, an empty readtable is used. See + [`MAKE-READTABLE`][fd4c]. + + - `(:FUSE READTABLE-DESIGNATORS+)` + + Like `:MERGE` except: + + Error conditions of type [`READER-MACRO-CONFLICT`][eab7] that are signaled + during the merge operation will be silently *continued*. It + follows that reader macros in earlier entries will be + overwritten by later ones. For backward compatibility, `:FUZE` is + accepted as an alias of `:FUSE`. + + - `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)` + + Define a new sub character `SUB-CHAR` for the dispatching macro + character `MACRO-CHAR`, per [`SET-DISPATCH-MACRO-CHARACTER`][bd1d]. You + probably have to define `MACRO-CHAR` as a dispatching macro + character by the following option first. + + - `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])` + + Define a new macro character in the readtable, per + [`SET-MACRO-CHARACTER`][b146]. If [`FUNCTION`][argument] is the keyword + `:DISPATCH`, `MACRO-CHAR` is made a dispatching macro character, + per [`MAKE-DISPATCH-MACRO-CHARACTER`][1bea]. + + - `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)` + + Set the character syntax of `TO-CHAR` in the readtable being + defined to the same syntax as `FROM-CHAR` as per + [`SET-SYNTAX-FROM-CHAR`][20d1]. + + - `(:CASE CASE-MODE)` + + Defines the *case sensitivity mode* of the resulting readtable. + + Any number of option clauses may appear. The options are grouped by + their type, but in each group the order the options appeared + textually is preserved. The following groups exist and are executed + in the following order: `:MERGE` and `:FUSE` (one group), `:CASE`, + `:MACRO-CHAR` and `:DISPATCH-MACRO-CHAR` (one group), finally + `:SYNTAX-FROM`. + + Notes: + + The readtable is defined at load-time. If you want to have it + available at compilation time -- say to use its reader-macros in the + same file as its definition -- you have to wrap the `DEFREADTABLE` + form in an explicit [`EVAL-WHEN`][09f3]. + + On redefinition, the target readtable is made empty first before + it's refilled according to the clauses. + + `NIL`, `:STANDARD`, `:COMMON-LISP`, `:MODERN`, and `:CURRENT` are + preregistered readtable names. + + +- [macro] **IN-READTABLE** *NAME* + + Set [`*READTABLE*`][a916] to the readtable referred to by the symbol `NAME`. + Return the readtable. + + +- [function] **MAKE-READTABLE** *&OPTIONAL (NAME NIL NAME-SUPPLIED-P) &KEY MERGE* + + Creates and returns a new readtable under the specified + `NAME`. + + `MERGE` takes a list of [`NAMED-READTABLE-DESIGNATOR`][4e61]s and specifies the + readtables the new readtable is created from. (See the `:MERGE` clause + of [`DEFREADTABLE`][6a02] for details.) + + If `MERGE` is `NIL`, an empty readtable is used instead. + + If `NAME` is not given, an anonymous empty readtable is returned. + + Notes: + + An empty readtable is a readtable where each character's syntax is + the same as in the *standard readtable* except that each macro + character has been made a constituent. Basically: whitespace stays + whitespace, everything else is constituent. + + +- [function] **MERGE-READTABLES-INTO** *RESULT-READTABLE &REST NAMED-READTABLES* + + Copy macro character definitions of each readtable in + `NAMED-READTABLES` into `RESULT-READTABLE`. + + If a macro character appears in more than one of the readtables, + i.e. if a conflict is discovered during the merge, an error of type + [`READER-MACRO-CONFLICT`][eab7] is signaled. + + The copied options are `:DISPATCH-MACRO-CHAR`, `:MACRO-CHAR` and + `:SYNTAX-FROM`, but not [`READTABLE-CASE`][a328]. + + +- [function] **FIND-READTABLE** *NAME* + + Looks for the readtable specified by `NAME` and returns it if it is + found. Returns `NIL` otherwise. + + +- [function] **ENSURE-READTABLE** *NAME &OPTIONAL (DEFAULT NIL DEFAULT-P)* + + Looks up the readtable specified by `NAME` and returns it if it's found. + If it is not found, it registers the readtable designated by `DEFAULT` + under the name represented by NAME; or if no default argument is + given, it signals an error of type [`READTABLE-DOES-NOT-EXIST`][02bf] + instead. + + +- [function] **RENAME-READTABLE** *OLD-NAME NEW-NAME* + + Replaces the associated name of the readtable designated by + `OLD-NAME` with `NEW-NAME`. If a readtable is already registered under + `NEW-NAME`, an error of type [`READTABLE-DOES-ALREADY-EXIST`][78ad] is + signaled. + + +- [function] **READTABLE-NAME** *NAMED-READTABLE* + + Returns the name of the readtable designated by `NAMED-READTABLE`, + or `NIL`. + + +- [function] **REGISTER-READTABLE** *NAME READTABLE* + + Associate `READTABLE` with `NAME`. Returns the readtable. + + +- [function] **UNREGISTER-READTABLE** *NAMED-READTABLE* + + Remove the association of `NAMED-READTABLE`. Returns `T` if successfull, + `NIL` otherwise. + + +- [function] **COPY-NAMED-READTABLE** *NAMED-READTABLE* + + Like [`COPY-READTABLE`][efc8] but takes a [`NAMED-READTABLE-DESIGNATOR`][4e61] as argument. + + +- [function] **LIST-ALL-NAMED-READTABLES** + + Returns a list of all registered readtables. The returned list is + guaranteed to be fresh, but may contain duplicates. + + +- [type] **NAMED-READTABLE-DESIGNATOR** + + Either a symbol or a readtable itself. + + +- [condition] **READTABLE-ERROR** *ERROR* + + +- [condition] **READER-MACRO-CONFLICT** *READTABLE-ERROR* + + Continuable. + + This condition is signaled during the merge process if a reader + macro (be it a macro character or the sub character of a dispatch + macro character) is present in the both source and the target + readtable and the two respective reader macro functions differ. + + +- [condition] **READTABLE-DOES-ALREADY-EXIST** *READTABLE-ERROR* + + Continuable. + + +- [condition] **READTABLE-DOES-NOT-EXIST** *READTABLE-ERROR* + + [02bf]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADTABLE-DOES-NOT-EXIST-20CONDITION-29 "EDITOR-HINTS.NAMED-READTABLES:READTABLE-DOES-NOT-EXIST CONDITION" + [09f3]: http://www.lispworks.com/documentation/HyperSpec/Body/s_eval_w.htm "EVAL-WHEN MGL-PAX:MACRO" + [1625]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AMERGE-READTABLES-INTO-20FUNCTION-29 "EDITOR-HINTS.NAMED-READTABLES:MERGE-READTABLES-INTO FUNCTION" + [1bea]: http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_dis.htm "MAKE-DISPATCH-MACRO-CHARACTER FUNCTION" + [20d1]: http://www.lispworks.com/documentation/HyperSpec/Body/f_set_sy.htm "SET-SYNTAX-FROM-CHAR FUNCTION" + [398b]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-API-IDIOSYNCRASIES-20MGL-PAX-3ASECTION-29 "Important API idiosyncrasies" + [42d7]: http://www.lispworks.com/documentation/HyperSpec/Body/m_defpkg.htm "DEFPACKAGE MGL-PAX:MACRO" + [480f]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-INTRODUCTION-20MGL-PAX-3ASECTION-29 "Introduction" + [4d56]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-REFERENCE-20MGL-PAX-3ASECTION-29 "Reference" + [4e61]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3ANAMED-READTABLE-DESIGNATOR-20TYPE-29 "EDITOR-HINTS.NAMED-READTABLES:NAMED-READTABLE-DESIGNATOR TYPE" + [6a02]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3ADEFREADTABLE-20MGL-PAX-3AMACRO-29 "EDITOR-HINTS.NAMED-READTABLES:DEFREADTABLE MGL-PAX:MACRO" + [718a]: #x-28-22named-readtables-22-20ASDF-2FSYSTEM-3ASYSTEM-29 '"named-readtables" ASDF/SYSTEM:SYSTEM' + [78ad]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADTABLE-DOES-ALREADY-EXIST-20CONDITION-29 "EDITOR-HINTS.NAMED-READTABLES:READTABLE-DOES-ALREADY-EXIST CONDITION" + [a328]: http://www.lispworks.com/documentation/HyperSpec/Body/f_rdtabl.htm "READTABLE-CASE FUNCTION" + [a603]: http://www.lispworks.com/documentation/HyperSpec/Body/m_in_pkg.htm "IN-PACKAGE MGL-PAX:MACRO" + [a61b]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-LINKS-20MGL-PAX-3ASECTION-29 "Links" + [a916]: http://www.lispworks.com/documentation/HyperSpec/Body/v_rdtabl.htm "*READTABLE* VARIABLE" + [aae8]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-EXAMPLES-20MGL-PAX-3ASECTION-29 "Examples" + [b146]: http://www.lispworks.com/documentation/HyperSpec/Body/f_set_ma.htm "SET-MACRO-CHARACTER FUNCTION" + [bd1d]: http://www.lispworks.com/documentation/HyperSpec/Body/f_set__1.htm "SET-DISPATCH-MACRO-CHARACTER FUNCTION" + [c1e9]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-OVERVIEW-20MGL-PAX-3ASECTION-29 "Overview" + [c5dc]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-PREREGISTERED-20MGL-PAX-3ASECTION-29 "Preregistered Readtables" + [eab7]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AREADER-MACRO-CONFLICT-20CONDITION-29 "EDITOR-HINTS.NAMED-READTABLES:READER-MACRO-CONFLICT CONDITION" + [ebdc]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-ACKNOWLEDGEMENTS-20MGL-PAX-3ASECTION-29 "Acknowledgements" + [ee2d]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AIN-READTABLE-20MGL-PAX-3AMACRO-29 "EDITOR-HINTS.NAMED-READTABLES:IN-READTABLE MGL-PAX:MACRO" + [efc8]: http://www.lispworks.com/documentation/HyperSpec/Body/f_cp_rdt.htm "COPY-READTABLE FUNCTION" + [f800]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3A-40NAMED-READTABLES-API-NOTES-20MGL-PAX-3ASECTION-29 "Notes on the API" + [fd4c]: #x-28EDITOR-HINTS-2ENAMED-READTABLES-3AMAKE-READTABLE-20FUNCTION-29 "EDITOR-HINTS.NAMED-READTABLES:MAKE-READTABLE FUNCTION" + +* * * +###### \[generated by [MGL-PAX](https://github.com/melisgl/mgl-pax)\] diff --git a/libraries/named-readtables/named-readtables.asd b/libraries/named-readtables/named-readtables.asd new file mode 100644 index 000000000..d85f6b13a --- /dev/null +++ b/libraries/named-readtables/named-readtables.asd @@ -0,0 +1,55 @@ +;;;; -*- mode: Lisp -*- + +(in-package :asdf) + +(defclass named-readtables-source-file (cl-source-file) ()) + +#+sbcl +(defmethod perform :around ((o compile-op) + (c named-readtables-source-file)) + (let ((sb-ext:*derive-function-types* t)) + (call-next-method))) + +;;; See NAMED-READTABLES:@NAMED-READTABLES-MANUAL for the user guide +;;; (if NAMED-READTABLES/DOC is loaded). +(defsystem "named-readtables" + :description "Library that creates a namespace for readtables akin + to the namespace of packages." + :author "Tobias C. Rittweiler " + :maintainer "Gábor Melis " + :mailto "mega@retes.hu" + :homepage "http://melisgl.github.io/named-readtables" + :bug-tracker "https://github.com/melisgl/named-readtables/issues" + :source-control (:git "https://github.com/melisgl/named-readtables.git") + :version "0.9" + :licence "BSD, see LICENSE" + :default-component-class named-readtables-source-file + :pathname "src" + :serial t + :components ((:file "package") + (:file "utils") + (:file "define-api") + (:file "cruft") + (:file "named-readtables")) + :in-order-to ((test-op (test-op "named-readtables/test")))) + +(defsystem "named-readtables/test" + :description "Test suite for the Named-Readtables library." + :author "Tobias C. Rittweiler " + :maintainer "Gábor Melis " + :mailto "mega@retes.hu" + :depends-on ("named-readtables" "try") + :pathname "test" + :serial t + :default-component-class named-readtables-source-file + :components + ((:file "package") + (:file "tests")) + :perform (test-op (o c) (symbol-call :named-readtables-test '#:test))) + +;;; MGL-PAX depends on NAMED-READTABLES so we must put documentation +;;; in a separate system in order to be able to use MGL-PAX. +(defsystem "named-readtables/doc" + :depends-on ("named-readtables" "mgl-pax") + :pathname "src" + :components ((:file "doc"))) diff --git a/libraries/named-readtables/src/cruft.lisp b/libraries/named-readtables/src/cruft.lisp new file mode 100644 index 000000000..4cd89cb03 --- /dev/null +++ b/libraries/named-readtables/src/cruft.lisp @@ -0,0 +1,517 @@ +;;;; +;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler +;;;; +;;;; All rights reserved. +;;;; +;;;; See LICENSE for details. +;;;; + +(in-package :editor-hints.named-readtables) + +(defmacro define-cruft (name lambda-list &body (docstring . alternatives)) + (assert (typep docstring 'string) (docstring) "Docstring missing!") + (assert (not (null alternatives))) + `(progn + (declaim (inline ,name)) + (defun ,name ,lambda-list ,docstring ,(first alternatives)))) + +(eval-when (:compile-toplevel :execute) + #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE" + (find-package "SB-IMPL")) + (pushnew :sbcl+safe-standard-readtable *features*))) + + + +;;;; Mapping between a readtable object and its readtable-name. + +(defvar *readtable-names* (make-hash-table :test 'eq)) + +(define-cruft %associate-readtable-with-name (name readtable) + "Associate READTABLE with NAME for READTABLE-NAME to work." + #+ :common-lisp (setf (gethash readtable *readtable-names*) name)) + +(define-cruft %unassociate-readtable-from-name (name readtable) + "Remove the association between READTABLE and NAME." + #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*))) + (remhash readtable *readtable-names*))) + +(define-cruft %readtable-name (readtable) + "Return the name associated with READTABLE." + #+ :common-lisp (values (gethash readtable *readtable-names*))) + +(define-cruft %list-all-readtable-names () + "Return a list of all available readtable names." + #+ :common-lisp (list* :standard :current :modern + (loop for name being each hash-value of *readtable-names* + collect name))) + +;;;; Mapping READTABLE objects to docstrings. + +(defvar *readtable-to-docstring* (make-hash-table :test 'eq)) + +(defun %associate-docstring-with-readtable (readtable docstring) + (setf (gethash readtable *readtable-to-docstring*) docstring)) + +(defun %unassociate-docstring-from-readtable (readtable) + (prog1 (gethash readtable *readtable-to-docstring*) + (remhash readtable *readtable-to-docstring*))) + +;;;; Specialized DOCUMENTATION for named readtables. + +;;; Lispworks, at least, forbids defining methods on DOCUMENTATION. +;;; Wrapping these forms with WITHOUT-PACKAGE-LOCK (as for PRINT-OBJECT, +;;; see below) allows this to compile on Lispworks. + +(without-package-lock (:common-lisp #+lispworks :implementation) + + (defmethod documentation ((name symbol) (doc-type (eql 'readtable))) + (let ((readtable (find-readtable name))) + (and readtable (gethash readtable *readtable-to-docstring*)))) + + (defmethod documentation ((readtable readtable) (doc-type (eql 'readtable))) + (gethash readtable *readtable-to-docstring*)) + + (defmethod (setf documentation) (docstring (name symbol) + (doc-type (eql 'readtable))) + (let ((readtable (find-readtable name))) + (unless readtable + (error 'readtable-does-not-exist :readtable-name name)) + (setf (gethash readtable *readtable-to-docstring*) docstring))) + + (defmethod (setf documentation) (docstring (readtable readtable) + (doc-type (eql 'readtable))) + (setf (gethash readtable *readtable-to-docstring*) docstring))) + + +;;;; Mapping between a readtable-name and the actual readtable object. + +;;; On Allegro we reuse their named-readtable support so we work +;;; nicely on their infrastructure. + +#-allegro +(defvar *named-readtables* (make-hash-table :test 'eq)) + +#+allegro +(defun readtable-name-for-allegro (symbol) + (multiple-value-bind (kwd status) + (if (keywordp symbol) + (values symbol nil) + ;; Kludge: ACL uses keywords to name readtables, we allow + ;; arbitrary symbols. + (intern (format nil "~A.~A" + (package-name (symbol-package symbol)) + (symbol-name symbol)) + :keyword)) + (prog1 kwd + (assert (or (not status) (get kwd 'named-readtable-designator))) + (setf (get kwd 'named-readtable-designator) t)))) + +(define-cruft %associate-name-with-readtable (name readtable) + "Associate NAME with READTABLE for FIND-READTABLE to work." + #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable) + #+ :common-lisp (setf (gethash name *named-readtables*) readtable)) + +(define-cruft %unassociate-name-from-readtable (name readtable) + "Remove the association between NAME and READTABLE" + #+ :allegro (let ((n (readtable-name-for-allegro name))) + (assert (eq readtable (excl:named-readtable n))) + (setf (excl:named-readtable n) nil)) + #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*))) + (remhash name *named-readtables*))) + +(define-cruft %find-readtable (name) + "Return the readtable named NAME." + #+ :allegro (excl:named-readtable (readtable-name-for-allegro name) nil) + #+ :common-lisp (values (gethash name *named-readtables* nil))) + + +;;;; Reader-macro related predicates + +;;; CLISP creates new function objects for standard reader macros on +;;; each readtable copy. +(define-cruft function= (fn1 fn2) + "Are reader-macro function-designators FN1 and FN2 the same?" + #+ :clisp + (let* ((fn1 (ensure-function fn1)) + (fn2 (ensure-function fn2)) + (n1 (system::function-name fn1)) + (n2 (system::function-name fn2))) + (if (and (eq n1 :lambda) (eq n2 :lambda)) + (eq fn1 fn2) + (equal n1 n2))) + #+ :sbcl + (let ((fn1 (ensure-function fn1)) + (fn2 (ensure-function fn2))) + (or (eq fn1 fn2) + ;; After SBCL 1.1.18, for dispatch macro characters + ;; GET-MACRO-CHARACTER returns closures whose name is: + ;; + ;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR) + ;; + ;; Treat all these closures equivalent. + (flet ((internal-dispatch-macro-closure-name-p (name) + (find "SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR" name + :key #'prin1-to-string :test #'string-equal))) + (let ((n1 (sb-impl::%fun-name fn1)) + (n2 (sb-impl::%fun-name fn2))) + (and (listp n1) (listp n2) + (internal-dispatch-macro-closure-name-p n1) + (internal-dispatch-macro-closure-name-p n2)))))) + #+ :common-lisp + (eq (ensure-function fn1) (ensure-function fn2))) + +;;; CLISP will incorrectly fold the call to G-D-M-C away +;;; if not declared inline. +(define-cruft dispatch-macro-char-p (char rt) + "Is CHAR a dispatch macro character in RT?" + #+ :common-lisp + (handler-case (locally + #+clisp (declare (notinline get-dispatch-macro-character)) + (get-dispatch-macro-character char #\x rt) + t) + (error () nil))) + +;; (defun macro-char-p (char rt) +;; (let ((reader-fn (%get-macro-character char rt))) +;; (and reader-fn t))) + +;; (defun standard-macro-char-p (char rt) +;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt) +;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*) +;; (and (eq rt-fn std-fn) +;; (eq rt-flag std-flag))))) + +;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt) +;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt)))) +;; (and (eq (non-terminating-p disp-char rt) +;; (non-terminating-p disp-char *standard-readtable*)) +;; (eq (get-dispatch-macro-character disp-char sub-char rt) +;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*))))) + + +;;;; Readtables Iterators + +(defmacro with-readtable-iterator ((name readtable) &body body) + (let ((it (gensym))) + `(let ((,it (%make-readtable-iterator ,readtable))) + (macrolet ((,name () `(funcall ,',it))) + ,@body)))) + +(defun funcall-or (package-and-name-list &rest args) + (loop for (package name) in package-and-name-list + do (let ((symbol (find-symbol (string name) package))) + (when symbol + (return-from funcall-or (apply symbol args)))))) + +#+sbcl +(defun %make-readtable-iterator (readtable) + (let ((char-macro-array (funcall-or '((sb-impl base-char-macro-array) + (sb-impl character-macro-array)) + readtable)) + (char-macro-ht (funcall-or '((sb-impl extended-char-table) + (sb-impl character-macro-hash-table)) + readtable)) + (dispatch-tables (sb-impl::dispatch-tables readtable)) + (char-code 0)) + (with-hash-table-iterator (ht-iterator char-macro-ht) + (labels ((grovel-base-chars () + (if (>= char-code sb-int:base-char-code-limit) + (grovel-unicode-chars) + (let ((reader-fn (svref char-macro-array char-code)) + (char (code-char (shiftf char-code (1+ char-code))))) + (if reader-fn + (yield char) + (grovel-base-chars))))) + (grovel-unicode-chars () + (multiple-value-bind (more? char) (ht-iterator) + (if (not more?) + (values nil nil nil nil nil) + (yield char)))) + (yield (char) + (let ((disp-fn (get-macro-character char readtable)) + (disp-ht)) + (cond + ((setq disp-ht (cdr (assoc char dispatch-tables))) + (let ((sub-char-alist)) + (maphash (lambda (k v) + (push (cons k v) sub-char-alist)) + disp-ht) + (values t char disp-fn t sub-char-alist))) + (t + (values t char disp-fn nil nil)))))) + #'grovel-base-chars)))) +#+clozure +(defun %make-readtable-iterator (readtable) + (flet ((ensure-alist (x) + #.`(etypecase x + (list x) + ,@(uiop:if-let (sv (uiop:find-symbol* '#:sparse-vector :ccl nil)) + `((,sv + (let ((table (uiop:symbol-call :ccl '#:sparse-vector-table x))) + (uiop:while-collecting (c) + (loop for i below (length table) do + (uiop:if-let ((v (svref table i))) + (loop with i8 = (ash i 8) + for j below (length v) do + (uiop:if-let ((datum (svref v j))) + (c (cons (code-char (+ i8 j)) datum)))))))))))))) + (let ((char-macros + (ensure-alist + (#.(or (uiop:find-symbol* '#:rdtab.macros :ccl nil) (uiop:find-symbol* '#:rdtab.alist :ccl)) readtable)))) + (lambda () + (if char-macros + (destructuring-bind (char . defn) (pop char-macros) + (if (consp defn) + (values t char (car defn) t (ensure-alist (cdr defn))) + (values t char defn nil nil))) + (values nil nil nil nil nil)))))) + +;;; Written on ACL 8.0. +#+allegro +(defun %make-readtable-iterator (readtable) + (declare (optimize speed)) ; for TCO + (check-type readtable readtable) + (let* ((macro-table (first (excl::readtable-macro-table readtable))) + (dispatch-tables (excl::readtable-dispatch-tables readtable)) + (table-length (length macro-table)) + (idx 0)) + (labels ((grovel-macro-chars () + (if (>= idx table-length) + (grovel-dispatch-chars) + (let ((read-fn (svref macro-table idx)) + (oidx idx)) + (incf idx) + (if (or (eq read-fn #'excl::read-token) + (eq read-fn #'excl::read-dispatch-char) + (eq read-fn #'excl::undefined-macro-char)) + (grovel-macro-chars) + (values t (code-char oidx) read-fn nil nil))))) + (grovel-dispatch-chars () + (if (null dispatch-tables) + (values nil nil nil nil nil) + (destructuring-bind (disp-char sub-char-table) + (first dispatch-tables) + (setf dispatch-tables (rest dispatch-tables)) + ;;; Kludge. We can't fully clear dispatch tables + ;;; in %CLEAR-READTABLE. + (when (eq (svref macro-table (char-code disp-char)) + #'excl::read-dispatch-char) + (values t + disp-char + (svref macro-table (char-code disp-char)) + t + (loop for subch-fn across sub-char-table + for subch-code from 0 + when subch-fn + collect (cons (code-char subch-code) + subch-fn)))))))) + #'grovel-macro-chars))) + +;;; This is really only needed for CMUCL with unicode support. Without +;;; unicode, the default implementation is probably fast enough. +#+cmucl +(defun %make-readtable-iterator (readtable) + (let ((char-macro-ht (lisp::character-macro-hash-table readtable)) + (dispatch-tables (lisp::dispatch-tables readtable)) + (char-code 0)) + (with-hash-table-iterator (ht-iterator char-macro-ht) + (labels + ((grovel-base-chars () + (if (>= char-code lisp::attribute-table-limit) + (grovel-unicode-chars) + (let* ((char (code-char (shiftf char-code (1+ char-code)))) + ;; Need %GET-MACRO-CHARACTER here, not + ;; GET-MACRO-CHARACTER because we want NIL to + ;; be returned instead of #'LISP::READ-TOKEN. + (reader-fn (%get-macro-character char readtable))) + (if reader-fn + (yield char reader-fn) + (grovel-base-chars))))) + (grovel-unicode-chars () + (multiple-value-bind (more? char reader-fn) + (ht-iterator) + (if (not more?) + (values nil nil nil nil nil) + (yield char reader-fn)))) + (yield (char reader-fn) + (let ((disp-ht)) + (cond + ((setq disp-ht (cdr (assoc char dispatch-tables))) + (let ((disp-fn (get-macro-character char readtable)) + (sub-char-alist)) + (if (< (char-code char) lisp::attribute-table-limit) + (let ((disp (lisp::char-dispatch-table-table disp-ht))) + (dotimes (k lisp::attribute-table-limit) + (let ((f (aref disp k))) + (unless (eq f #'lisp::dispatch-char-error) + (push (cons (code-char k) f) + sub-char-alist))))) + (let ((disp-ht (lisp::char-dispatch-table-hash-table + disp-ht))) + (maphash (lambda (k v) + (push (cons k v) sub-char-alist)) + disp-ht))) + (values t char disp-fn t sub-char-alist))) + (t + (values t char reader-fn nil nil)))))) + #'grovel-base-chars)))) + +#-(or sbcl clozure allegro cmucl) +(eval-when (:compile-toplevel) + (let ((*print-pretty* t)) + (simple-style-warn + "~&~@< ~@;~A has not been ported to ~A. ~ + We fall back to a portable implementation of readtable iterators. ~ + This implementation has to grovel through all available characters. ~ + On Unicode-aware implementations this may come with some costs.~@:>" + (package-name '#.*package*) (lisp-implementation-type)))) + +#-(or sbcl clozure allegro cmucl) +(defun %make-readtable-iterator (readtable) + (check-type readtable readtable) + (let ((char-code 0)) + #'(lambda () + (prog () + :GROVEL + (when (< char-code char-code-limit) + (let ((char (code-char char-code))) + (incf char-code) + (when (not char) (go :GROVEL)) + (let ((fn (get-macro-character char readtable))) + (when (not fn) (go :GROVEL)) + (multiple-value-bind (disp? alist) + (handler-case ; grovel dispatch macro characters. + (values + t + ;; Only grovel upper case characters to + ;; avoid duplicates. + (loop for code from 0 below char-code-limit + for subchar = (non-lowercase-code-char code) + for disp-fn = (and subchar + (get-dispatch-macro-character + char subchar readtable)) + when disp-fn + collect (cons subchar disp-fn))) + (error () nil)) + (return (values t char fn disp? alist)))))))))) + +#-(or sbcl clozure allegro) +(defun non-lowercase-code-char (code) + (let ((ch (code-char code))) + (when (and ch (or (not (alpha-char-p ch)) + (upper-case-p ch))) + ch))) + +(defmacro do-readtable ((entry-designator readtable &optional result) + &body body) + "Iterate through a readtable's macro characters, and dispatch macro characters." + (destructuring-bind (char &optional reader-fn non-terminating-p disp? table) + (if (symbolp entry-designator) + (list entry-designator) + entry-designator) + (let ((iter (gensym "ITER+")) + (more? (gensym "MORE?+")) + (rt (gensym "READTABLE+"))) + `(let ((,rt ,readtable)) + (with-readtable-iterator (,iter ,rt) + (loop + (multiple-value-bind (,more? + ,char + ,@(when reader-fn (list reader-fn)) + ,@(when disp? (list disp?)) + ,@(when table (list table))) + (,iter) + (unless ,more? (return ,result)) + (let ,(when non-terminating-p + ;; FIXME: N-T-P should be incorporated in iterators. + `((,non-terminating-p + (nth-value 1 (get-macro-character ,char ,rt))))) + ,@body)))))))) + +;;;; Misc + +;;; This should return an implementation's actual standard readtable +;;; object only if the implementation makes the effort to guard against +;;; modification of that object. Otherwise it should better return a +;;; copy. +(define-cruft %standard-readtable () + "Return the standard readtable." + #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable* + #+ :common-lisp (copy-readtable nil)) + +;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a +;;; readtable's dispatch table properly. +;;; Same goes for Allegro but that does not seem to provide a +;;; setter for their readtable's dispatch tables. Hence this ugly +;;; workaround. +(define-cruft %clear-readtable (readtable) + "Make all macro characters in READTABLE be constituents." + #+ :sbcl + (prog1 readtable + (do-readtable (char readtable) + (set-syntax-from-char char #\A readtable)) + (setf (sb-impl::dispatch-tables readtable) nil)) + #+ :allegro + (prog1 readtable + (do-readtable (char readtable) + (set-syntax-from-char char #\A readtable)) + (let ((dispatch-tables (excl::readtable-dispatch-tables readtable))) + (setf (cdr dispatch-tables) nil) + (setf (caar dispatch-tables) #\Backspace) + (setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil)))) + #+ :cmucl + (prog1 readtable + (do-readtable (char readtable) + (set-syntax-from-char char #\A readtable)) + (setf (lisp::dispatch-tables readtable) nil)) + #+ :common-lisp + (do-readtable (char readtable readtable) + (set-syntax-from-char char #\A readtable))) + +;;; See Clozure Trac Ticket 601. This is supposed to be removed at +;;; some point in the future. +(define-cruft %get-dispatch-macro-character (char subchar rt) + "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER." + #+ :ccl (ignore-errors + (get-dispatch-macro-character char subchar rt)) + #+ :cmucl + (let ((f (get-dispatch-macro-character char subchar rt))) + ;; CMUCL returns #'LISP::DISPATCH-CHAR-ERROR, and named-readtables + ;; wants NIL in those cases. + (unless (eq f #'lisp::dispatch-char-error) + f)) + #+ :common-lisp (get-dispatch-macro-character char subchar rt)) + +;;; Allegro stores READ-TOKEN as reader macro function of each +;;; constituent character. +(define-cruft %get-macro-character (char rt) + "Ensure ANSI behaviour for GET-MACRO-CHARACTER." + #+ :allegro (let ((fn (get-macro-character char rt))) + (cond ((not fn) nil) + ((function= fn #'excl::read-token) nil) + (t fn))) + #+ :cmucl + (let ((fn (get-macro-character char rt))) + (cond ((not fn) nil) + ((function= fn #'lisp::read-token) nil) + (t fn))) + #+ :common-lisp (get-macro-character char rt)) + + +;;;; Specialized PRINT-OBJECT for named readtables. + +;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT +;;; that specializes on READTABLE is actually forbidden. It's quite +;;; likely to work (modulo package-locks) on most implementations, +;;; though. + +;;; We don't need this on Allegro CL's as we hook into their +;;; named-readtable facility, and they provide such a method already. +#-allegro +(without-package-lock (:common-lisp #+lispworks :implementation) + (defmethod print-object :around ((rt readtable) stream) + (let ((name (readtable-name rt))) + (if name + (print-unreadable-object (rt stream :type nil :identity t) + (format stream "~A ~S" :named-readtable name)) + (call-next-method))))) diff --git a/libraries/named-readtables/src/define-api.lisp b/libraries/named-readtables/src/define-api.lisp new file mode 100644 index 000000000..6686073cf --- /dev/null +++ b/libraries/named-readtables/src/define-api.lisp @@ -0,0 +1,64 @@ +(in-package :named-readtables) + +(defmacro define-api (name lambda-list type-list &body body) + (flet ((parse-type-list (type-list) + (let ((pos (position '=> type-list))) + (assert pos () "You forgot to specify return type (`=>' missing.)") + (values (subseq type-list 0 pos) + `(values ,@(nthcdr (1+ pos) type-list) &optional))))) + (multiple-value-bind (body decls docstring) + (parse-body body :documentation t :whole `(define-api ,name)) + (multiple-value-bind (arg-typespec value-typespec) + (parse-type-list type-list) + (multiple-value-bind (reqs opts rest keys) + (parse-ordinary-lambda-list lambda-list) + (declare (ignorable reqs opts rest keys)) + `(progn + (declaim (ftype (function ,arg-typespec ,value-typespec) ,name)) + (locally + ;; Muffle the annoying "&OPTIONAL and &KEY found in + ;; the same lambda list" style-warning + #+sbcl (declare (sb-ext:muffle-conditions style-warning)) + (defun ,name ,lambda-list + ,docstring + ,@decls + (locally + #+sbcl (declare (sb-ext:unmuffle-conditions style-warning)) + + ;; SBCL will interpret the ftype declaration as + ;; assertion and will insert type checks for us. + #-sbcl + (progn + ;; CHECK-TYPE required parameters + ,@(loop for req-arg in reqs + for req-type = (pop type-list) + do (assert req-type) + collect `(check-type ,req-arg ,req-type)) + + ;; CHECK-TYPE optional parameters + ,@(progn + (assert (or (null opts) + (eq (pop type-list) '&optional))) + (loop for (opt-arg . nil) in opts + for opt-type = (pop type-list) + do (assert opt-type) + collect `(check-type ,opt-arg ,opt-type))) + + ;; CHECK-TYPE rest parameter + ,@(when rest + (assert (eq (pop type-list) '&rest)) + (let ((rest-type (pop type-list))) + (assert rest-type) + `((dolist (x ,rest) + (check-type x ,rest-type))))) + + ;; CHECK-TYPE key parameters + ,@(progn + (assert (or (null keys) + (eq (pop type-list) '&key))) + (loop for ((keyword key-arg) . nil) in keys + for (nil key-type) = (find keyword type-list + :key #'car) + collect `(check-type ,key-arg ,key-type)))) + + ,@body))))))))) diff --git a/libraries/named-readtables/src/doc.lisp b/libraries/named-readtables/src/doc.lisp new file mode 100644 index 000000000..9fab7bde3 --- /dev/null +++ b/libraries/named-readtables/src/doc.lisp @@ -0,0 +1,222 @@ +(in-package :named-readtables) + +(pax:defsection @named-readtables-manual (:title "Named Readtables Manual") + (named-readtables asdf:system) + (@named-readtables-introduction pax:section) + (@named-readtables-overview pax:section) + (@named-readtables-reference pax:section)) + +(pax:defsection @named-readtables-introduction (:title "Introduction") + "Named-Readtables is a library that provides a namespace for + readtables akin to the already-existing namespace of packages. In + particular: + + * you can associate readtables with names, and retrieve + readtables by names; + + * you can associate source files with readtable names, and be + sure that the right readtable is active when compiling/loading + the file; + + * similiarly, your development environment now has a chance to + automatically determine what readtable should be active while + processing source forms on interactive commands. (E.g. think of + `C-c C-c` in Slime (yet to be done)) + + It follows that Named-Readtables is a facility for using readtables in + a localized way. + + Additionally, it also attempts to become a facility for using + readtables in a _modular_ way. In particular: + + * it provides a macro to specify the content of a readtable at a + glance; + + * it makes it possible to use multiple inheritance between readtables." + (@named-readtables-links pax:section) + (@named-readtables-acknowledgements pax:section)) + +(pax:defsection @named-readtables-links (:title "Links") + "Here is the [official repository][named-readtables-repo] and the + [HTML documentation][named-readtables-doc] for the latest version. + + [named-readtables-repo]: https://github.com/melisgl/named-readtables + [named-readtables-doc]: http://melisgl.github.io/mgl-pax-world/named-readtables-manual.html") + +(pax:defsection @named-readtables-acknowledgements (:title "Acknowledgements") + "Thanks to Robert Goldman for making me want to write this library. + + Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart + Botta, David Crawford, and Pascal Costanza for being early adopters, + providing comments and bugfixes.") + +(pax:defsection @named-readtables-overview (:title "Overview") + (@named-readtables-api-notes pax:section) + (@named-readtables-api-idiosyncrasies pax:section) + (@named-readtables-preregistered pax:section) + (@named-readtables-examples pax:section)) + +(pax:defsection @named-readtables-api-notes + (:title "Notes on the API" :export nil) + "The API heavily imitates the API of packages. This has the nice + property that any experienced Common Lisper will take it up without + effort. + + DEFREADTABLE - DEFPACKAGE + + IN-READTABLE - IN-PACKAGE + + MERGE-READTABLES-INTO - USE-PACKAGE + + MAKE-READTABLE - MAKE-PACKAGE + + UNREGISTER-READTABLE - DELETE-PACKAGE + + RENAME-READTABLE - RENAME-PACKAGE + + FIND-READTABLE - FIND-PACKAGE + + READTABLE-NAME - PACKAGE-NAME + + LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES") + +(pax:defsection @named-readtables-api-idiosyncrasies + (:title "Important API idiosyncrasies" :export nil) + "There are three major differences between the API of Named-Readtables, + and the API of packages. + + 1. Readtable names are symbols not strings. + + Time has shown that the fact that packages are named by strings + causes severe headache because of the potential of package names + colliding with each other. + + Hence, readtables are named by symbols lest to make the + situation worse than it already is. Consequently, readtables + named `CL-ORACLE:SQL-SYNTAX` and `CL-MYSQL:SQL-SYNTAX` can + happily coexist next to each other. Or, taken to an extreme, + `SCHEME:SYNTAX` and `ELISP:SYNTAX`. + + If, for example to duly signify the importance of your cool + readtable hack, you really think it deserves a global name, you + can always resort to keywords. + + 2. The inheritance is resolved statically, not dynamically. + + A package that uses another package will have access to all the + other package's exported symbols, even to those that will be + added after its definition. I.e. the inheritance is resolved at + run-time, that is dynamically. + + Unfortunately, we cannot do the same for readtables in a + portable manner. + + Therefore, we do not talk about \"using\" another readtable but + about \"merging\" the other readtable's definition into the + readtable we are going to define. I.e. the inheritance is + resolved once at definition time, that is statically. + + (Such merging can more or less be implemented portably albeit at + a certain cost. Most of the time, this cost manifests itself at + the time a readtable is defined, i.e. once at compile-time, so + it may not bother you. Nonetheless, we provide extra support for + Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your + implementation of choice are welcome, of course.) + + 3. DEFREADTABLE does not have compile-time effects. + + If you define a package via DEFPACKAGE, you can make that + package the currently active package for the subsequent + compilation of the same file via IN-PACKAGE. The same is, + however, not true for DEFREADTABLE and IN-READTABLE for the + following reason: + + It's unlikely that the need for special reader-macros arises for + a problem which can be solved in just one file. Most often, + you're going to define the reader macro functions, and set up + the corresponding readtable in an extra file. + + If DEFREADTABLE had compile-time effects, you'd have to wrap + each definition of a reader-macro function in an EVAL-WHEN to + make its definition available at compile-time. Because that's + simply not the common case, DEFREADTABLE does not have a + compile-time effect. + + If you want to use a readtable within the same file as its + definition, wrap the DEFREADTABLE and the reader-macro function + definitions in an explicit EVAL-WHEN.") + +(pax:defsection @named-readtables-preregistered + (:title "Preregistered Readtables" :export nil) + "- NIL, :STANDARD, and :COMMON-LISP designate the + _standard readtable_. + + - :MODERN designates a _case-preserving_ _standard-readtable_. + + - :CURRENT designates the _current readtable_.") + +(pax:defsection @named-readtables-examples (:title "Examples" :export nil) + "```commonlisp + (defreadtable elisp:syntax + (:merge :standard) + (:macro-char #\\? #'elisp::read-character-literal t) + (:macro-char #\\[ #'elisp::read-vector-literal t) + ... + (:case :preserve)) + + (defreadtable scheme:syntax + (:merge :standard) + (:macro-char #\\[ #'(lambda (stream char) + (read-delimited-list #\\] stream))) + (:macro-char #\\# :dispatch) + (:dispatch-macro-char #\\# #\\t #'scheme::read-#t) + (:dispatch-macro-char #\\# #\\f #'scheme::read-#f) + ... + (:case :preserve)) + + (in-readtable elisp:syntax) + + ... + + (in-readtable scheme:syntax) + + ... + ```") + +(pax:defsection @named-readtables-reference (:title "Reference") + (defreadtable pax:macro) + (in-readtable pax:macro) + (make-readtable function) + (merge-readtables-into function) + (find-readtable function) + (ensure-readtable function) + (rename-readtable function) + (readtable-name function) + (register-readtable function) + (unregister-readtable function) + (copy-named-readtable function) + (list-all-named-readtables function) + (named-readtable-designator type) + (readtable-error condition) + (reader-macro-conflict condition) + (readtable-does-already-exist condition) + (readtable-does-not-exist condition)) + + +;;;; Register in PAX World + +(defun pax-sections () + (list @named-readtables-manual)) +(defun pax-pages () + `((:objects + (, @named-readtables-manual) + :source-uri-fn ,(pax:make-github-source-uri-fn + :named-readtables + "https://github.com/melisgl/named-readtables")))) +(pax:register-doc-in-pax-world :named-readtables (pax-sections) (pax-pages)) + +#+nil +(progn + (pax:update-asdf-system-readmes @named-readtables-manual :named-readtables) + (pax:update-asdf-system-html-docs @named-readtables-manual :named-readtables + :pages (pax-pages))) diff --git a/libraries/named-readtables/src/named-readtables.lisp b/libraries/named-readtables/src/named-readtables.lisp new file mode 100644 index 000000000..00ddb6b5f --- /dev/null +++ b/libraries/named-readtables/src/named-readtables.lisp @@ -0,0 +1,555 @@ +;;;; -*- Mode:Lisp -*- +;;;; +;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler +;;;; Copyright (c) 2007, Robert P. Goldman and SIFT, LLC +;;;; +;;;; All rights reserved. +;;;; +;;;; See LICENSE for details. +;;;; + +(in-package :editor-hints.named-readtables) + +;;; +;;; ``This is enough of a foothold to implement a more elaborate +;;; facility for using readtables in a localized way.'' +;;; +;;; (X3J13 Cleanup Issue IN-SYNTAX) +;;; + +;;;;;; DEFREADTABLE &c. + +(defmacro defreadtable (name &body options) + "Define a new named readtable, whose name is given by the symbol NAME. + Or, if a readtable is already registered under that name, redefine + that one. + + The readtable can be populated using the following OPTIONS: + + - If the first element of OPTIONS is a string then it is associated + with the readtable as in `(SETF (DOCUMENTATION NAME 'READTABLE) + DOCSTRING)`. + + - `(:MERGE READTABLE-DESIGNATORS+)` + + Merge the macro character definitions from the readtables + designated into the new readtable being defined as per + MERGE-READTABLES-INTO. The copied options are + :DISPATCH-MACRO-CHAR, :MACRO-CHAR and :SYNTAX-FROM, but not + READTABLE-CASE. + + If no :MERGE clause is given, an empty readtable is used. See + MAKE-READTABLE. + + - `(:FUSE READTABLE-DESIGNATORS+)` + + Like :MERGE except: + + Error conditions of type READER-MACRO-CONFLICT that are signaled + during the merge operation will be silently _continued_. It + follows that reader macros in earlier entries will be + overwritten by later ones. For backward compatibility, :FUZE is + accepted as an alias of :FUSE. + + - `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)` + + Define a new sub character `SUB-CHAR` for the dispatching macro + character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You + probably have to define `MACRO-CHAR` as a dispatching macro + character by the following option first. + + - `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])` + + Define a new macro character in the readtable, per + SET-MACRO-CHARACTER. If [FUNCTION][argument] is the keyword + :DISPATCH, `MACRO-CHAR` is made a dispatching macro character, + per MAKE-DISPATCH-MACRO-CHARACTER. + + - `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)` + + Set the character syntax of TO-CHAR in the readtable being + defined to the same syntax as FROM-CHAR as per + SET-SYNTAX-FROM-CHAR. + + - `(:CASE CASE-MODE)` + + Defines the _case sensitivity mode_ of the resulting readtable. + + Any number of option clauses may appear. The options are grouped by + their type, but in each group the order the options appeared + textually is preserved. The following groups exist and are executed + in the following order: :MERGE and :FUSE (one group), :CASE, + :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally + :SYNTAX-FROM. + + Notes: + + The readtable is defined at load-time. If you want to have it + available at compilation time -- say to use its reader-macros in the + same file as its definition -- you have to wrap the DEFREADTABLE + form in an explicit EVAL-WHEN. + + On redefinition, the target readtable is made empty first before + it's refilled according to the clauses. + + NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are + preregistered readtable names." + (check-type name symbol) + (when (reserved-readtable-name-p name) + (error "~A is the designator for a predefined readtable. ~ + Not acceptable as a user-specified readtable name." name)) + (flet ((process-option (option var) + (destructure-case option + ((:merge &rest readtable-designators) + `(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x) + readtable-designators))) + ((:fuse &rest readtable-designators) + `(handler-bind ((reader-macro-conflict #'continue)) + (merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x) + readtable-designators)))) + ;; alias for :FUSE + ((:fuze &rest readtable-designators) + `(handler-bind ((reader-macro-conflict #'continue)) + (merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x) + readtable-designators)))) + ((:dispatch-macro-char disp-char sub-char function) + `(set-dispatch-macro-character ,disp-char ,sub-char + ,function ,var)) + ((:macro-char char function &optional non-terminating-p) + (if (eq function :dispatch) + `(make-dispatch-macro-character ,char ,non-terminating-p ,var) + `(set-macro-character ,char ,function + ,non-terminating-p ,var))) + ((:syntax-from from-rt-designator from-char to-char) + `(set-syntax-from-char ,to-char ,from-char + ,var (find-readtable ,from-rt-designator))) + ((:case mode) + `(setf (readtable-case ,var) ,mode)))) + (remove-clauses (clauses options) + (setq clauses (if (listp clauses) clauses (list clauses))) + (remove-if-not #'(lambda (x) (member x clauses)) + options :key #'first))) + (let* ((docstring (when (stringp (first options)) + (pop options))) + (merge-clauses (remove-clauses '(:merge :fuze :fuse) options)) + (case-clauses (remove-clauses :case options)) + (macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char) + options)) + (syntax-clauses (remove-clauses :syntax-from options)) + (other-clauses + (set-difference options + (append merge-clauses case-clauses + macro-clauses syntax-clauses)))) + (cond + ((not (null other-clauses)) + (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses)) + (t + `(eval-when (:load-toplevel :execute) + ;; The (FIND-READTABLE ...) is important for proper + ;; redefinition semantics, as redefining has to modify the + ;; already existing readtable object. + (let ((readtable (find-readtable ',name))) + (cond ((not readtable) + (setq readtable (make-readtable ',name))) + (t + (setq readtable (%clear-readtable readtable)) + (simple-style-warn + "Overwriting already existing readtable ~S." + readtable))) + (setf (documentation readtable 'readtable) ,docstring) + ,@(loop for option in merge-clauses + collect (process-option option 'readtable)) + ,@(loop for option in case-clauses + collect (process-option option 'readtable)) + ,@(loop for option in macro-clauses + collect (process-option option 'readtable)) + ,@(loop for option in syntax-clauses + collect (process-option option 'readtable)) + readtable))))))) + +(defmacro in-readtable (name) + "Set *READTABLE* to the readtable referred to by the symbol NAME. + Return the readtable." + (check-type name symbol) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO* + ;; (GET-MACRO-CHARACTER #\")) + (setf *readtable* (ensure-readtable ',name)) + (when (find-package :swank) + (%frob-swank-readtable-alist *package* *readtable*)) + *readtable*)) + +;;; KLUDGE: [interim solution] +;;; +;;; We need support for this in Slime itself, because we want IN-READTABLE +;;; to work on a per-file basis, and not on a per-package basis. +;;; +(defun %frob-swank-readtable-alist (package readtable) + (let ((readtable-alist (find-symbol (string '#:*readtable-alist*) + (find-package :swank)))) + (when (boundp readtable-alist) + (let ((new-item (cons (package-name package) readtable))) + (setf (symbol-value readtable-alist) + (cons + new-item + (remove new-item (symbol-value readtable-alist) + :test (lambda (entry1 entry2) + (string= (car entry1) (car entry2)))))))))) + +(deftype readtable-designator () + `(or null readtable)) + +(deftype named-readtable-designator () + "Either a symbol or a readtable itself." + `(or readtable-designator symbol)) + +;;;;; Compiler macros + +;;; Since the :STANDARD readtable is interned, and we can't enforce +;;; its immutability, we signal a style-warning for suspicious uses +;;; that may result in strange behaviour: + +;;; Modifying the standard readtable would, obviously, lead to a +;;; propagation of this change to all places which use the :STANDARD +;;; readtable (and thus rendering this readtable to be non-standard, +;;; in fact.) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun constant-standard-readtable-expression-p (thing) + (or (null thing) + (eq thing :standard) + (and (consp thing) + (find thing + '((find-readtable nil) + (find-readtable :standard) + (ensure-readtable nil) + (ensure-readtable :standard)) + :test #'equal)))) + + (defun signal-suspicious-registration-warning (name-expr readtable-expr) + (when (constant-standard-readtable-expression-p readtable-expr) + (simple-style-warn + "Caution: ~~% ~S" + (list name-expr name-expr) readtable-expr)))) + +(define-compiler-macro register-readtable (&whole form name readtable) + (signal-suspicious-registration-warning name readtable) + form) + +(define-compiler-macro ensure-readtable (&whole form name &optional + (default nil default-p)) + (when default-p + (signal-suspicious-registration-warning name default)) + form) + +(declaim (special *standard-readtable* *empty-readtable*)) + +(define-api make-readtable + (&optional (name nil name-supplied-p) &key merge) + (&optional named-readtable-designator &key (:merge list) => readtable) + "Creates and returns a new readtable under the specified + NAME. + + MERGE takes a list of NAMED-READTABLE-DESIGNATORs and specifies the + readtables the new readtable is created from. (See the :MERGE clause + of DEFREADTABLE for details.) + + If MERGE is NIL, an empty readtable is used instead. + + If NAME is not given, an anonymous empty readtable is returned. + + Notes: + + An empty readtable is a readtable where each character's syntax is + the same as in the _standard readtable_ except that each macro + character has been made a constituent. Basically: whitespace stays + whitespace, everything else is constituent." + (cond ((not name-supplied-p) + (copy-readtable *empty-readtable*)) + ((reserved-readtable-name-p name) + (error "~A is the designator for a predefined readtable. ~ + Not acceptable as a user-specified readtable name." name)) + ((let ((rt (find-readtable name))) + (and rt (prog1 nil + (cerror "Overwrite existing entry." + 'readtable-does-already-exist :readtable-name name) + ;; Explicitly unregister to make sure that we do + ;; not hold on of any reference to RT. + (unregister-readtable rt))))) + (t (let ((result (apply #'merge-readtables-into + ;; The first readtable specified in + ;; the :merge list is taken as the + ;; basis for all subsequent + ;; (destructive!) modifications (and + ;; hence it's copied.) + (copy-readtable (if merge + (ensure-readtable + (first merge)) + *empty-readtable*)) + (rest merge)))) + + (register-readtable name result))))) + +(define-api rename-readtable + (old-name new-name) + (named-readtable-designator symbol => readtable) + "Replaces the associated name of the readtable designated by + OLD-NAME with NEW-NAME. If a readtable is already registered under + NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is + signaled." + (when (find-readtable new-name) + (cerror "Overwrite existing entry." + 'readtable-does-already-exist :readtable-name new-name)) + (let* ((readtable (ensure-readtable old-name)) + (readtable-name (readtable-name readtable))) + ;; We use the internal functions directly to omit repeated + ;; type-checking. + (%unassociate-name-from-readtable readtable-name readtable) + (%unassociate-readtable-from-name readtable-name readtable) + (%associate-name-with-readtable new-name readtable) + (%associate-readtable-with-name new-name readtable) + (%associate-docstring-with-readtable + readtable (%unassociate-docstring-from-readtable readtable)) + readtable)) + +(define-api merge-readtables-into + (result-readtable &rest named-readtables) + (named-readtable-designator &rest named-readtable-designator => readtable) + "Copy macro character definitions of each readtable in + NAMED-READTABLES into RESULT-READTABLE. + + If a macro character appears in more than one of the readtables, + i.e. if a conflict is discovered during the merge, an error of type + READER-MACRO-CONFLICT is signaled. + + The copied options are :DISPATCH-MACRO-CHAR, :MACRO-CHAR and + :SYNTAX-FROM, but not READTABLE-CASE." + (flet ((merge-into (to from) + (do-readtable ((char reader-fn non-terminating-p disp? table) from) + (check-reader-macro-conflict from to char) + (cond ((not disp?) + (set-macro-character char reader-fn non-terminating-p to)) + (t + (ensure-dispatch-macro-character char non-terminating-p to) + (loop for (subchar . subfn) in table do + (check-reader-macro-conflict from to char subchar) + (set-dispatch-macro-character char subchar + subfn to))))) + to)) + (let ((result-table (ensure-readtable result-readtable))) + (dolist (table (mapcar #'ensure-readtable named-readtables)) + (merge-into result-table table)) + result-table))) + +(defun ensure-dispatch-macro-character (char &optional non-terminating-p + (readtable *readtable*)) + (if (dispatch-macro-char-p char readtable) + t + (make-dispatch-macro-character char non-terminating-p readtable))) + +(define-api copy-named-readtable + (named-readtable) + (named-readtable-designator => readtable) + "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument." + (copy-readtable (ensure-readtable named-readtable))) + +(define-api list-all-named-readtables () (=> list) + "Returns a list of all registered readtables. The returned list is + guaranteed to be fresh, but may contain duplicates." + (mapcar #'ensure-readtable (%list-all-readtable-names))) + + +(define-condition readtable-error (error) ()) + +(define-condition readtable-does-not-exist (readtable-error) + ((readtable-name :initarg :readtable-name + :initform (required-argument) + :accessor missing-readtable-name + :type named-readtable-designator)) + (:report (lambda (condition stream) + (format stream "A readtable named ~S does not exist." + (missing-readtable-name condition))))) + +(define-condition readtable-does-already-exist (readtable-error) + ((readtable-name :initarg :readtable-name + :initform (required-argument) + :accessor existing-readtable-name + :type named-readtable-designator)) + (:report (lambda (condition stream) + (format stream "A readtable named ~S already exists." + (existing-readtable-name condition)))) + (:documentation "Continuable.")) + +(define-condition reader-macro-conflict (readtable-error) + ((macro-char + :initarg :macro-char + :initform (required-argument) + :accessor conflicting-macro-char + :type character) + (sub-char + :initarg :sub-char + :initform nil + :accessor conflicting-dispatch-sub-char + :type (or null character)) + (from-readtable + :initarg :from-readtable + :initform (required-argument) + :accessor from-readtable + :type readtable) + (to-readtable + :initarg :to-readtable + :initform (required-argument) + :accessor to-readtable + :type readtable)) + (:report + (lambda (condition stream) + (format stream "~@" + (conflicting-dispatch-sub-char condition) + (conflicting-macro-char condition) + (conflicting-dispatch-sub-char condition) + (from-readtable condition) + (to-readtable condition)))) + (:documentation "Continuable. + + This condition is signaled during the merge process if a reader + macro (be it a macro character or the sub character of a dispatch + macro character) is present in the both source and the target + readtable and the two respective reader macro functions differ.")) + +(defun check-reader-macro-conflict (from to char &optional subchar) + (flet ((conflictp (from-fn to-fn) + (assert from-fn () + "Bug in readtable iterators or concurrent access?") + (and to-fn (not (function= to-fn from-fn))))) + (when (if subchar + (conflictp (%get-dispatch-macro-character char subchar from) + (%get-dispatch-macro-character char subchar to)) + (conflictp (%get-macro-character char from) + (%get-macro-character char to))) + (cerror (format nil "Overwrite ~@C in ~A." char to) + 'reader-macro-conflict + :from-readtable from + :to-readtable to + :macro-char char + :sub-char subchar)))) + + +;;; Although there is no way to get at the standard readtable in +;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make +;;; up the perception of its existence by interning a copy of it. +;;; +;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for +;;; +;;; (equal (readtable-name (find-readtable :standard)) "STANDARD") +;;; +;;; holding true. +;;; +;;; We, however, inherit the restriction that the :STANDARD +;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd +;;; technically be feasible (as *STANDARD-READTABLE* will contain a +;;; mutable copy of the implementation-internal standard readtable.) +;;; We cannot enforce this restriction without shadowing +;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which +;;; is out of scope of this library, though. So we just threaten +;;; with nasal demons. +;;; +(defvar *standard-readtable* + (%standard-readtable)) + +(defvar *empty-readtable* + (%clear-readtable (copy-readtable nil))) + +(defvar *case-preserving-standard-readtable* + (let ((readtable (copy-readtable nil))) + (setf (readtable-case readtable) :preserve) + readtable)) + +(defparameter *reserved-readtable-names* + '(nil :standard :common-lisp :modern :current)) + +(defun reserved-readtable-name-p (name) + (and (member name *reserved-readtable-names*) t)) + +;;; In principle, we could DEFREADTABLE some of these. But we do +;;; reserved readtable lookup seperately, since we can't register a +;;; readtable for :CURRENT anyway. + +(defun find-reserved-readtable (reserved-name) + (cond ((eq reserved-name nil) *standard-readtable*) + ((eq reserved-name :standard) *standard-readtable*) + ((eq reserved-name :common-lisp) *standard-readtable*) + ((eq reserved-name :modern) *case-preserving-standard-readtable*) + ((eq reserved-name :current) *readtable*) + (t (error "Bug: no such reserved readtable: ~S" reserved-name)))) + +(define-api find-readtable + (name) + (named-readtable-designator => (or readtable null)) + "Looks for the readtable specified by NAME and returns it if it is + found. Returns NIL otherwise." + (cond ((readtablep name) name) + ((reserved-readtable-name-p name) + (find-reserved-readtable name)) + ((%find-readtable name)))) + +;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a +;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler +;;; macros below.) +(defsetf find-readtable register-readtable) + +(define-api ensure-readtable + (name &optional (default nil default-p)) + (named-readtable-designator &optional (or named-readtable-designator null) + => readtable) + "Looks up the readtable specified by NAME and returns it if it's found. + If it is not found, it registers the readtable designated by DEFAULT + under the name represented by NAME; or if no default argument is + given, it signals an error of type READTABLE-DOES-NOT-EXIST + instead." + (cond ((find-readtable name)) + ((not default-p) + (error 'readtable-does-not-exist :readtable-name name)) + (t (setf (find-readtable name) (ensure-readtable default))))) + + +(define-api register-readtable + (name readtable) + (symbol readtable => readtable) + "Associate READTABLE with NAME. Returns the readtable." + (assert (typep name '(not (satisfies reserved-readtable-name-p)))) + (%associate-readtable-with-name name readtable) + (%associate-name-with-readtable name readtable) + readtable) + +(define-api unregister-readtable + (named-readtable) + (named-readtable-designator => boolean) + "Remove the association of NAMED-READTABLE. Returns T if successfull, + NIL otherwise." + (let* ((readtable (find-readtable named-readtable)) + (readtable-name (and readtable (readtable-name readtable)))) + (if (not readtable-name) + nil + (prog1 t + (check-type readtable-name + (not (satisfies reserved-readtable-name-p))) + (%unassociate-readtable-from-name readtable-name readtable) + (%unassociate-name-from-readtable readtable-name readtable) + (%unassociate-docstring-from-readtable readtable))))) + +(define-api readtable-name + (named-readtable) + (named-readtable-designator => symbol) + "Returns the name of the readtable designated by NAMED-READTABLE, + or NIL." + (let ((readtable (ensure-readtable named-readtable))) + (cond ((%readtable-name readtable)) + ((eq readtable *readtable*) :current) + ((eq readtable *standard-readtable*) :common-lisp) + ((eq readtable *case-preserving-standard-readtable*) :modern) + (t nil)))) diff --git a/libraries/named-readtables/src/package.lisp b/libraries/named-readtables/src/package.lisp new file mode 100644 index 000000000..089dc0f28 --- /dev/null +++ b/libraries/named-readtables/src/package.lisp @@ -0,0 +1,37 @@ +(in-package :common-lisp-user) + +;;; This is is basically MGL-PAX:DEFINE-PACKAGE, but we don't have it +;;; defined yet. The package variance stuff is because we export +;;; documentation from the NAMED-READTABLES/DOC system. +(eval-when (:compile-toplevel :load-toplevel :execute) + (locally + (declare #+sbcl + (sb-ext:muffle-conditions sb-int:package-at-variance)) + (handler-bind + (#+sbcl (sb-int:package-at-variance #'muffle-warning)) + (defpackage :editor-hints.named-readtables + (:use :common-lisp) + (:nicknames :named-readtables) + (:export + #:defreadtable + #:in-readtable + #:make-readtable + #:merge-readtables-into + #:find-readtable + #:ensure-readtable + #:rename-readtable + #:readtable-name + #:register-readtable + #:unregister-readtable + #:copy-named-readtable + #:list-all-named-readtables + ;; Types + #:named-readtable-designator + ;; Conditions + #:readtable-error + #:reader-macro-conflict + #:readtable-does-already-exist + #:readtable-does-not-exist) + (:documentation "See NAMED-READTABLES:@NAMED-READTABLES-MANUAL."))))) + +(pushnew :named-readtables *features*) diff --git a/libraries/named-readtables/src/utils.lisp b/libraries/named-readtables/src/utils.lisp new file mode 100644 index 000000000..09b5d31ca --- /dev/null +++ b/libraries/named-readtables/src/utils.lisp @@ -0,0 +1,245 @@ +;;;; +;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler +;;;; +;;;; All rights reserved. +;;;; +;;;; See LICENSE for details. +;;;; + +(in-package :editor-hints.named-readtables) + +(defmacro without-package-lock ((&rest package-names) &body body) + (declare (ignorable package-names)) + #+clisp + (return-from without-package-lock + `(ext:without-package-lock (,@package-names) ,@body)) + #+lispworks + (return-from without-package-lock + `(let ((hcl:*packages-for-warn-on-redefinition* + (set-difference hcl:*packages-for-warn-on-redefinition* + '(,@package-names) + :key (lambda (package-designator) + (if (packagep package-designator) + (package-name package-designator) + package-designator)) + :test #'string=))) + ,@body)) + `(progn ,@body)) + +;;; Taken from SWANK (which is Public Domain.) + +(defmacro destructure-case (value &body patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: ~S" ,tmp)))))))) + +;;; Taken from Alexandria (which is Public Domain, or BSD.) + +(define-condition simple-style-warning (simple-warning style-warning) + ()) + +(defun simple-style-warn (format-control &rest format-args) + (warn 'simple-style-warning + :format-control format-control + :format-arguments format-args)) + +(define-condition simple-program-error (simple-error program-error) + ()) + +(defun simple-program-error (message &rest args) + (error 'simple-program-error + :format-control message + :format-arguments args)) + +(defun required-argument (&optional name) + "Signals an error for a missing argument of NAME. Intended for +use as an initialization form for structure and class-slots, and +a default value for required keyword arguments." + (error "Required argument ~@[~S ~]missing." name)) + +(defun ensure-list (list) + "If LIST is a list, it is returned. Otherwise returns the list +designated by LIST." + (if (listp list) + list + (list list))) + +(declaim (inline ensure-function)) ; to propagate return type. +(declaim (ftype (function (t) (values function &optional)) + ensure-function)) +(defun ensure-function (function-designator) + "Returns the function designated by FUNCTION-DESIGNATOR: +if FUNCTION-DESIGNATOR is a function, it is returned, otherwise +it must be a function name and its FDEFINITION is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + +(defun parse-body (body &key documentation whole) + "Parses BODY into (values remaining-forms declarations doc-string). +Documentation strings are recognized only if DOCUMENTATION is true. +Syntax errors in body are signalled and WHOLE is used in the signal +arguments when given." + (let ((doc nil) + (decls nil) + (current nil)) + (tagbody + :declarations + (setf current (car body)) + (when (and documentation (stringp current) (cdr body)) + (if doc + (error "Too many documentation strings in ~S." (or whole body)) + (setf doc (pop body))) + (go :declarations)) + (when (and (listp current) (eql (first current) 'declare)) + (push (pop body) decls) + (go :declarations))) + (values body (nreverse decls) doc))) + +(defun parse-ordinary-lambda-list (lambda-list) + "Parses an ordinary lambda-list, returning as multiple values: + + 1. Required parameters. + 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP) + where SUPPLIEDP is NIL if not present. + 3. Name of the rest parameter, or NIL. + 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP) + where SUPPLIEDP is NIL if not present. + 5. Boolean indicating &ALLOW-OTHER-KEYS presence. + 6. &AUX parameter specifications, normalized into form (NAME INIT). + +Signals a PROGRAM-ERROR is the lambda-list is malformed." + (let ((state :required) + (allow-other-keys nil) + (auxp nil) + (required nil) + (optional nil) + (rest nil) + (keys nil) + (aux nil)) + (labels ((simple-program-error (format-string &rest format-args) + (error 'simple-program-error + :format-control format-string + :format-arguments format-args)) + (fail (elt) + (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (check-variable (elt what) + (unless (and (symbolp elt) (not (constantp elt))) + (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" + what elt lambda-list))) + (check-spec (spec what) + (destructuring-bind (init suppliedp) spec + (declare (ignore init)) + (check-variable suppliedp what))) + (make-keyword (name) + "Interns the string designated by NAME in the KEYWORD package." + (intern (string name) :keyword))) + (dolist (elt lambda-list) + (case elt + (&optional + (if (eq state :required) + (setf state elt) + (fail elt))) + (&rest + (if (member state '(:required &optional)) + (setf state elt) + (progn + (break "state=~S" state) + (fail elt)))) + (&key + (if (member state '(:required &optional :after-rest)) + (setf state elt) + (fail elt))) + (&allow-other-keys + (if (eq state '&key) + (setf allow-other-keys t + state elt) + (fail elt))) + (&aux + (cond ((eq state '&rest) + (fail elt)) + (auxp + (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (t + (setf auxp t +