diff --git a/README.md b/README.md index 89b3693b0ad4659ac4996deac13002e21b9745d7..20f4d14d91c9ec0c7b622f52d2431d48085d941e 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,20 @@ # Babel -The all-in-one toolkit for multi-agent experiments on emergent communication! +_The all-in-one toolkit for multi-agent experiments on emergent communication!_ + +*** + +Babel is a flexible toolkit for implementing and running agent-based experiments on emergent communication. The Babel system includes advanced modules for constructional language processing and learning ([Fluid Construction Grammar](https://fcg-net.org)), conceptualising and interpreting procedural semantic structures (Incremental Recruitment Language), and conducting multi-agent experiments in simulated environments or using physical robots. + +An extensive monitoring system opens up every detail of Babel’s intermediate representations and underlying dynamics. A modular design ensures that the system can be used in a wide variety of scenarios. It is therefore possible to use each component individually, according to your needs. + +Babel is written in Common Lisp and runs in most major Lisp implementations (CCL, SBCL and LispWorks) on all major platforms (Linux, Mac OS, Windows). It is jointly developed by [Sony Computer Science Laboratories Paris](https://csl.sony.fr/), [Vrije Universiteit Brussel](https://ehai.ai.vub.ac.be/), [KU Leuven](https://itec.kuleuven-kulak.be/) and [UNamur](https://www.unamur.be/info) under an Apache 2.0 license. + +## Installation + +If you only wish to use Fluid Construction Grammar or Incremental Recruitment Language, we offer a user-friendly alternative through the [FCG Editor](https://www.fcg-net.org/download/). The FCG Editor offers all functionality of Babel's Fluid Construction Grammar and Incremental Recruitment Language systems through a powerful integrated development environment that can be installed in a single click. + +If you want the full Babel experience, detailed installation instructions for all major operating systems can be found on the [wiki](https://gitlab.ai.vub.ac.be/ehai/babel/-/wikis/home). ## License diff --git a/applications/clevr/clevr-evaluation/accuracy.lisp b/applications/clevr/clevr-evaluation/accuracy.lisp index 500d685adaeb39397930c695ab7a39e45a88868d..da81f5f2d8028db736cf0ab74f830774277dd944 100644 --- a/applications/clevr/clevr-evaluation/accuracy.lisp +++ b/applications/clevr/clevr-evaluation/accuracy.lisp @@ -26,7 +26,7 @@ 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)) + if (and nr-of-scenes (> processed-scenes nr-of-scenes)) return accuracy else append (loop for clevr-question in (questions set-of-questions) @@ -38,7 +38,7 @@ for scene-var = (extract-scene-unit-variable cipn) do (incf processed-questions) (format t ".") - if (and nr-of-questions (>= processed-questions nr-of-questions)) + if (and nr-of-questions (> processed-questions nr-of-questions)) return scene-accuracy else if (and (find 'fcg::succeeded (fcg::statuses cipn)) (string= (upcase answer) @@ -47,10 +47,10 @@ else collect 0 into scene-accuracy and do (progn (write-line (format nil "~a - ~a" scene-name q) log) (force-output log)) - finally return scene-accuracy) + finally (return scene-accuracy)) into accuracy do (incf processed-scenes) - finally return accuracy)))))) + finally (return accuracy))))))) (defun understand-utterance-in-scene (utterance scene-name data-split) diff --git a/applications/clevr/clevr-evaluation/coverage.lisp b/applications/clevr/clevr-evaluation/coverage.lisp index c95f2bc1a4c230ad3c59f8833ac00c4b832e5c78..e9be975b0129460c4087a48c60fe5a2045383c96 100644 --- a/applications/clevr/clevr-evaluation/coverage.lisp +++ b/applications/clevr/clevr-evaluation/coverage.lisp @@ -40,9 +40,9 @@ collect 1 into question-set-coverage else collect 0 into question-set-coverage and do (write-line q log) - finally return question-set-coverage) + finally (return question-set-coverage)) into coverage - finally return coverage)))))) + finally (return coverage))))))) (defmethod evaluate-clevr-coverage (data-split (direction (eql '->)) @@ -79,6 +79,6 @@ collect 1 into question-set-coverage else collect 0 into question-set-coverage and do (write-line q log) - finally return question-set-coverage) + finally (return question-set-coverage)) into coverage - finally return coverage)))))) \ No newline at end of file + finally (return coverage))))))) \ No newline at end of file diff --git a/applications/clevr/clevr-evaluation/demo.lisp b/applications/clevr/clevr-evaluation/demo.lisp index 134297be5264457b3224092c51b1f6f0c5187670..925132d7aa83e793b259ff30b27fdeeab3a1d716 100644 --- a/applications/clevr/clevr-evaluation/demo.lisp +++ b/applications/clevr/clevr-evaluation/demo.lisp @@ -7,14 +7,13 @@ (activate-monitor trace-fcg) ;; IRL MONITORS (activate-monitor trace-irl) +(activate-monitor trace-irl-verbose) ;; CLEVR MONITOR (activate-monitor clevr-web-monitor) (comprehend (preprocess-sentence "what material is the red cube?")) -(evaluate-clevr - (make-instance 'clevr-world :data-sets '("val") :load-questions t) - :nr-of-contexts 1 :nr-of-questions 1) +(evaluate-clevr-accuracy "val" :nr-of-scenes 1 :nr-of-questions 1) ;;;; Manually create a scene for in the paper (defparameter *scene-from-paper* diff --git a/applications/clevr/clevr-evaluation/package.lisp b/applications/clevr/clevr-evaluation/package.lisp index 501c635ce4b53fd46931dee64792509989911eb9..65e466ceace38c4842aaa7fe874601ec38031958 100644 --- a/applications/clevr/clevr-evaluation/package.lisp +++ b/applications/clevr/clevr-evaluation/package.lisp @@ -24,7 +24,8 @@ :evaluate-irl-program :irl-program->svg :get-target-var - :trace-irl) + :trace-irl + :trace-irl-verbose) (:import-from :cl-json :decode-json-from-source :decode-json-from-string diff --git a/applications/clevr/clevr-evaluation/start.lisp b/applications/clevr/clevr-evaluation/start.lisp index ce0dd24d665c4153d3fdc4e56810d0c0dff6aabd..90d326aca493799eb56779b696ab7e9ab9d8bf6a 100644 --- a/applications/clevr/clevr-evaluation/start.lisp +++ b/applications/clevr/clevr-evaluation/start.lisp @@ -4,13 +4,14 @@ ;; FCG MONITORS ;(activate-monitor trace-fcg) ;; IRL MONITORS -;(activate-monitor trace-irl) +;(activate-monitor trace-irl-verbose) ;; CLEVR EVALUATION MONITOR ;(activate-monitor trace-clevr-evaluation) +(deactivate-all-monitors) -(evaluate-clevr-accuracy "val") +(evaluate-clevr-accuracy "val" :nr-of-scenes 1 :nr-of-questions 1) (understand-utterance-in-scene "is there a metallic object left of the gray object that is behind the large cylinder that is in front of the green matte object?" diff --git a/applications/clevr/clevr-primitives/package.lisp b/applications/clevr/clevr-primitives/package.lisp index 5600c1d7a9a7b0d11322cbd46d38da73f699ad65..8dcb6ea06e84d0b17e75e88ef7c3ba62a26032ae 100644 --- a/applications/clevr/clevr-primitives/package.lisp +++ b/applications/clevr/clevr-primitives/package.lisp @@ -8,5 +8,7 @@ (export '(*clevr-primitives*)) +(defparameter *clevr-primitives* nil) + (def-irl-primitives clevr-primitives :primitive-inventory *clevr-primitives*) diff --git a/applications/clevr/mwm-evaluation/.gitignore b/applications/clevr/mwm-evaluation/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..b13359a0619d560643af43e432715cbf3e4e373e --- /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 14fc9fa4355770bf1f87198782657cde4afd991a..3f90c4fe83cc32ab76780f5c9147ec6be108e5d9 100644 --- a/applications/clevr/mwm-evaluation/evaluation.lisp +++ b/applications/clevr/mwm-evaluation/evaluation.lisp @@ -1,13 +1,118 @@ (in-package :mwm-evaluation) +;;------------------------;; +;; 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 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) + (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)))))))) + +(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)))))))) + + +;; 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"))) + (ensure-directories-exist logfile) + (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 (= 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 + (write-line + (format nil "The error rate for ~a is ~,2f" key 0) stream) + (force-output stream)))))) + +(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) + (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)))) +|# + ;;------------;; ;; Evaluation ;; ;;------------;; ;; Compute the accuracy on the clevr dataset using the learned concepts - -;; Make a string from the computed answer so that it can be compared to the ground-truth string (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)) @@ -26,99 +131,37 @@ (boolean-category (mkstr (id answer-value))))) -;; 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*))) + (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))))) -;; 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)))))))) - -(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)))))))) - -;; 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"))) - (ensure-directories-exist logfile) - (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)))) - 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 - (write-line - (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)) + + +(define-event question-evaluation + (scene-name string) (question string) (irl-program list) + (answer t) (computed-answer t) (result fixnum)) -(defun write-result (log scene-name q answer computed-answer result irl-program hash-table) - (if (eql 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)) - (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)))) ;; 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) +(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 @@ -129,83 +172,114 @@ 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 + 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) - 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 (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 + 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))))) + 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 (data-split csv-filename errors-filename &key 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)) - (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 nr-of-scenes nr-of-questions error-table))) - (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)) -(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)) - (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))) + +(defparameter *default-output-dir* + (babel-pathname :directory '("applications" "clevr" "mwm-evaluation" "raw-data"))) + + +(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))) + (world-type + (get-configuration config :world-type)) + (concepts-directory + (merge-pathnames + (make-pathname :directory (list :relative experiment-name)) + (case world-type + (:simulated *simulated-concepts-path*) + (:extracted *extracted-concepts-path*)))) + (ontology + (make-mwm-ontology concepts-directory world-type))) + ;; 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 (config-entries) + (loop for serie-nr from 1 to 10 + 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)) + + -(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 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 0000000000000000000000000000000000000000..c05d8b2246b1e5adcb1aa942fa74979e164ad6a7 --- /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/monitors.lisp b/applications/clevr/mwm-evaluation/monitors.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b2a08f8c9ee8cca99aaf0b8665114fcd77144492 --- /dev/null +++ b/applications/clevr/mwm-evaluation/monitors.lisp @@ -0,0 +1,251 @@ +(in-package :mwm-evaluation) + + +;;;; 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/mwm-evaluation.asd b/applications/clevr/mwm-evaluation/mwm-evaluation.asd index 24cadd1407d9da4637cbe19554036ec11c2da460..a9b83d9244d18d526950cec423679b9c2d9608a6 100644 --- a/applications/clevr/mwm-evaluation/mwm-evaluation.asd +++ b/applications/clevr/mwm-evaluation/mwm-evaluation.asd @@ -16,13 +16,14 @@ :fcg :clevr-world :clevr-grammar - :mwm - ) + :mwm) :serial t :components ((:file "package") (:file "mwm-ontology") (:file "mwm-utils") (:file "evaluation") + (:file "monitors") + (:file "irl-node-test") (:module "primitives" :serial t :components ((:file "primitive-inventory") @@ -37,5 +38,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 9fbd850efeec83e742038401069a941f87dd931c..74ef2d2c0c2b08a024b4e8880ba069d9d3b5f525 100644 --- a/applications/clevr/mwm-evaluation/mwm-ontology.lisp +++ b/applications/clevr/mwm-evaluation/mwm-ontology.lisp @@ -24,41 +24,52 @@ ;;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))) +(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) + '(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)) + (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 0c242bcc56a8e8321094171a9ef070e4a3504bec..c1ea35dfe22b611bc5aa72b7959894ed03472ca7 100644 --- a/applications/clevr/mwm-evaluation/mwm-utils.lisp +++ b/applications/clevr/mwm-evaluation/mwm-utils.lisp @@ -1,18 +1,38 @@ (in-package :mwm-evaluation) +;;--------------------------;; +;; path to learned concepts ;; +;;--------------------------;; + +(defparameter *simulated-concepts-path* + (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" "learned-concepts" + "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 ;; ;;----------------------------------;; -;; 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 +43,7 @@ do (setf best-category cat best-similarity similarity) finally - return best-category)) + (return best-category))) ;;-----------------------------;; ;; Utils for testing questions ;; @@ -42,9 +62,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 +73,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 ;; @@ -76,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/package.lisp b/applications/clevr/mwm-evaluation/package.lisp index 08eff9e31672557842d2f317d269b4d1e71b027f..769b0b00d114f0af6b76ad8c95d885d87e00115c 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 @@ -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 42cd578e5e31ee3f85cf03d7ef80e67a023c2b83..429a26521ab86606cb90fc8a50addabb6cac7b70 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 b533df04ab8dcef79233cbef8cd0fbac948c053e..ba67049d6c873e717f7e2c647d2ed3d3205905a1 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 359b28057fe8e05636d9afc91f535b8cd4ede25f..d77e2d644a2977e7c04e145d84a053a83516b04f 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 38afe11c7d3d85bb9d1c5a2c557a15339e9e635a..b2c11c0ed827973883c7457ecc8dc44abceb3305 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 4a1de875c82b580ea3c5a23c8a364e9ab2e74806..8ecf438b0a66ac9a2e7e96600e681475decd4a52 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,34 +69,35 @@ (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))))))) - + + #| ;; second case: if given source-set and target-set, compute category ((scene source-set target-set => category) (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 +108,7 @@ ;; 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/intersect.lisp b/applications/clevr/mwm-evaluation/primitives/intersect.lisp index f52266caccbff0c36600b3847dda8a7dd78556c2..0a04109aff467f344c8c1ff97786d77c3d817b91 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 6bbb5462756ae0803178c298370fd67f461eaac5..a74216d17d641d25ee1aa42be00143a8053af19a 100644 --- a/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp +++ b/applications/clevr/mwm-evaluation/primitives/primitive-inventory.lisp @@ -1,7 +1,8 @@ (in-package :mwm-evaluation) - + (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 947d6f747a7d8a2c7b13ac0727a6636e8aba894c..32ef911e03447c16aac75ce61a0e8e4bcae7edcd 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,23 +32,24 @@ (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) (let ((computed-attribute (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 +57,8 @@ ;; 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 cf6218a8b472f568a295c79a30d1e4f1f2d362df..4228bd93a62ffb071754a33a4445732812fad1f4 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 @@ -47,13 +48,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) @@ -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 a295945d2c42c266d2c97de07d50dcbdb3d0eac9..5f2b64826ef12c43b1cb610a319cf931208d2dff 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,18 +33,19 @@ (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))))))) + #| ;; second case; given source-object and target-set, compute the attribute ((scene segmented-scene source-object target-set => attribute) (let ((computed-attribute (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 +53,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 +68,8 @@ (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/primitives/segment-scene.lisp b/applications/clevr/mwm-evaluation/primitives/segment-scene.lisp index a1a05419fc3d6aa74415d7c5629cc2a0c39a37c1..a11e37d49b814e4a3b71a25aa777f2b736bc4037 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/primitives/union.lisp b/applications/clevr/mwm-evaluation/primitives/union.lisp index 0ace891770a268e5084fc7641131ba49b690577c..f505c7ae7c71121827335aaaec0a7b4e88c76649 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 d187bd997f6e7a4ce3306075a4704460dfcf86b4..1e6635c8826bcca9dc9dd54e47c5d9c3c63a7b12 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 4160b3dbf0458b130a136ee28cac24228f0531ca..ea48b27a36aaf33711a41dcff3c0d85e045bb05b 100644 --- a/applications/clevr/mwm-evaluation/start.lisp +++ b/applications/clevr/mwm-evaluation/start.lisp @@ -1,35 +1,89 @@ (ql:quickload :mwm-evaluation) (in-package :mwm-evaluation) + (activate-monitor trace-fcg) (activate-monitor trace-irl) +(deactivate-all-monitors) + +;;------------;; +;; Evaluation ;; +;;------------;; + +(defparameter *config-entries* + '((:dot-interval . 100) + (:nr-of-scenes . 5) + (:nr-of-questions . nil) + (:data-split . "val") + (:world-type . :simulated))) + +;; Evaluate one particular serie +(evaluate-mwm-serie 1 *config-entries*) +(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 ;; ;;--------------;; -(make-mwm-ontology (babel-pathname :directory (list "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*)) +(make-mwm-ontology + (merge-pathnames (make-pathname :directory '(:relative "serie-1")) + *simulated-concepts-path*)) ;;---------;; ;; Testing ;; ;;---------;; ;; 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 + (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) + (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)) + + + + +;;---------;; +;; 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*) + -;;------------;; -;; Evaluation ;; -;;------------;; -;; Evaluate on the ontology that is loaded manually -(evaluate-mwm-accuracy "val" "mwm-evaluation" "mwm-errors" :nr-of-scenes 1) -;; Evaluate on all series of concepts by loading the different series into the ontology -(evaluate-all-series) diff --git a/applications/discourse-understanding/discourse-understanding.asd b/applications/discourse-understanding/discourse-understanding.asd index 4c136e0987e0b49b1eb911cce4ef08c2a920b913..6fe9e3b1f1a83701d3114e81a2e3bfbafaed8ac9 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 @@ -18,7 +18,17 @@ ) :serial t :components ((:file "package") - (:module "matilda-experiment" + (:module "tristan-experiment" + :serial t + :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") @@ -35,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 5a60f4c2b819a42ff942cc47e6ff22894feaa01d..06e3105598e751179b96f8c3075d6ee2c0be975d 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 diff --git a/applications/discourse-understanding/start-tristan.lisp b/applications/discourse-understanding/start-tristan.lisp deleted file mode 100644 index 3c7e77a73bcc890ab5d9318c513e2040adc1993e..0000000000000000000000000000000000000000 --- a/applications/discourse-understanding/start-tristan.lisp +++ /dev/null @@ -1,17 +0,0 @@ -(ql:quickload :discourse-understanding) -(in-package :discourse-understanding) - -(activate-monitor trace-fcg) -(activate-monitor trace-irl) - - -;; Do this after loading the file: -#| -(progn - (setf *pangloss* (make-pangloss-grammar-cxns)) - ;(read-story *document* *pangloss*) - (read-story '("Toen Tristan geboren werd , was zijn vader al twee maanden dood") *pangloss*) - (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 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 0000000000000000000000000000000000000000..db5a67fbf4d4ae5054f91d48aa96f92e2c97c5e4 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/discourse-model.lisp @@ -0,0 +1,58 @@ +(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) + ((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))) + +(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 diff --git a/applications/discourse-understanding/tristan-experiment/grammar.lisp b/applications/discourse-understanding/tristan-experiment/grammar.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a64b2b3cb34348541adf8eca92e5df4bda49da2a --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/grammar.lisp @@ -0,0 +1,549 @@ +(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 - -))) + (dm-in ?dm-in) + (dm-out ?dm-out))) + <- + (?tristan + (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) + (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) + (dm-in ?dm-in) + (dm-out ?dm-out-verb)) + (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) + (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) + (dm-in ?dm-out) + (dm-out ?dm-out-verb)))) + :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)) + (syn-cat (dm-in ?dm-in) + (dm-out ?dm-out))) + <- + (?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 ?list-of-facts ?status ?dm-out ?dm-in) + (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 +) + (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)))) + (?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) + (dm-in ?dm-in) + (dm-out ?dm-out)))) + :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 ((entity ?man) + (person-frame ?man ?pf) + (name-role ?pf ?name) + (gender-role ?pf 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 ?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-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) + (dm-in ?dm-in-1) + (dm-out ?dm-out-2)) + (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) + (dm-in ?dm-in) + (dm-out ?dm-out-verb)) + (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) + (dm-in ?dm-in) + (dm-out ?dm-out))) + (?finite-verb + -- + (referent ?ev) + (syn-cat (lex-class verb) + (finite +))) + (?subject-np + -- + (referent ?subject-ref) + (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)) + (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/tristan-experiment/html.lisp b/applications/discourse-understanding/tristan-experiment/html.lisp new file mode 100644 index 0000000000000000000000000000000000000000..db5ffdf0907bdae7d4d148d425be9bbaa5c1e8c9 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/html.lisp @@ -0,0 +1,128 @@ +(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)))) + + +(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 +;; --------------------------------------------------------- + +(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))))) + 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 0000000000000000000000000000000000000000..f7455f1b36b25b10fda98d9fc31d5186dc500dca --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/primitives/handle-referent.lisp @@ -0,0 +1,37 @@ +(in-package :discourse-understanding) + +(defprimitive handle-referent ((de discourse-entity) + (facts list-of-facts) + (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))))) + diff --git a/applications/discourse-understanding/tristan-experiment/rules.lisp b/applications/discourse-understanding/tristan-experiment/rules.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ed195510dba96933061b0d6ddc0d06ccd254c019 --- /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 diff --git a/applications/discourse-understanding/tristan-experiment/start-tristan.lisp b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d49c909a05121717a8484cf2932b3fe55211ece3 --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/start-tristan.lisp @@ -0,0 +1,96 @@ +(ql:quickload :discourse-understanding) +(in-package :discourse-understanding) + +(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*) + +(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) + ;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 (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* ((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)))))) + + + +;; Do this after loading the file: +#| +(progn + (setf *pangloss* (make-pangloss-grammar-cxns)) + ;(read-story *document* *pangloss*) + (read-story '("Toen Tristan geboren werd , was zijn vader al twee maanden dood") *pangloss*) + (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 diff --git a/applications/discourse-understanding/tristan-experiment/utils.lisp b/applications/discourse-understanding/tristan-experiment/utils.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5921fdad32de6604e32523f06c1ebc6df2b23d2e --- /dev/null +++ b/applications/discourse-understanding/tristan-experiment/utils.lisp @@ -0,0 +1,18 @@ +(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 + 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 + append meaning))) + meaning)) diff --git a/applications/muhai-cookingbot/muhai-cookingbot.asd b/applications/muhai-cookingbot/muhai-cookingbot.asd index ff66d693ec70cf429f6baf6adcdd2e6e589b2a74..f9627535587a0364dac044d6a16860f3cbb78ff6 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 034b87d7d859fcd328a9fafa0c23b2804700e159..22f3efb61c7503c25e1729cee4c3a5e13c8977e5 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)))) ) -|# + diff --git a/applications/visual-dialog/evaluation/evaluation.lisp b/applications/visual-dialog/evaluation/evaluation.lisp index f944c2f1adb4232775d0d622f5845fb43fc3e224..4d912d002ccc29dff1d7fb2760aa71d731cf9bce 100644 --- a/applications/visual-dialog/evaluation/evaluation.lisp +++ b/applications/visual-dialog/evaluation/evaluation.lisp @@ -3,6 +3,10 @@ (defun evaluate-dialog (&key scene-index dialog-index world ontology (silent t)) "run dialog with specific scene and a specific dialog (1-5), check result with gold-answers" "returns T if whole dialog succeeded otherwise nil and the success list per question" + (if (equal (get-configuration world :mode) :hybrid) + (progn + (clear-scenes (get-configuration world :server-address) (get-configuration world :cookie-jar)) + (clear-attentions (get-configuration world :server-address) (get-configuration world :cookie-jar)))) (let* ((scene-pathname (get-scene-pathname-by-index scene-index world)) (dataset (get-configuration world :dataset)) (dialog (get-dialog-by-index scene-index dialog-index world dataset)) @@ -14,8 +18,8 @@ (progn (add-element `((h1) ,(format nil "Dialog ~a" dialog-index))) (if (eq dataset :clevr) - (add-element `((h3) ,(format nil "Caption: ~a" (caption (nth dialog-index (dialogs (current-dialog-set world)))))))) - (loop for question in (questions (nth dialog-index (dialogs (current-dialog-set world)))) + (add-element `((h3) ,(format nil "Caption: ~a" (first dialog))))) + (loop for question in (rest dialog) for answer in computed-answers for gold-answer in gold-answers for a in correct-answers @@ -31,14 +35,18 @@ ;; return success of whole dialog and detailed success of questions (values (loop for a in correct-answers always a) correct-answers))) -(defun evaluate-dialogs (start-scene end-scene world ) +(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") - :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) @@ -48,31 +56,35 @@ (number-of-dialogs (compute-number-of-dialogs world)) (results - (first (loop for scene from start-scene to end-scene - collect (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 - (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)))))) + append (progn + (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)))) +(define-configuration-default-value :dataset :clevr) +(define-configuration-default-value :datasplit :train) +(define-configuration-default-value :mode :symbolic) +(define-configuration-default-value :server-address "http://127.0.0.1:2560/") +(define-configuration-default-value :cookie-jar (make-instance 'drakma:cookie-jar)) (defun evaluate-clevr-dialogs-symbolic (start-scene end-scene) (let ((world (make-instance 'world @@ -92,7 +104,8 @@ (let ((world (make-instance 'world :entries '((:dataset . :clevr) (:datasplit . :train) - (:mode . :hybrid))))) + (:mode . :hybrid) + )))) (evaluate-dialogs start-scene end-scene world))) (defun evaluate-mnist-dialogs-hybrid (start-scene end-scene) @@ -100,4 +113,80 @@ :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 + do (close file-content)))) + failed-dialogs)) + +(defun check-failed-dialogs (failed-dialogs multiple-middles-file) + (with-open-file (str multiple-middles-file) + (let ((middles-list (read-from-string (read-line str)))) + (loop for dialog in failed-dialogs + do (with-open-file (dialog-file dialog) + (let ((lines (stream->list dialog-file))) + (loop for line in lines + when (and (not (string= (first-word line) "dialog-level-accuracy")) + (not (string= (first-word line) "question-level-accuracy"))) + do (let* ((split-line (split-string line ":")) + (scene (parse-integer (first (split-string (first split-line) ",")))) + (results (read-from-string (last-elt split-line)))) + (if (and (not (equal (average results) 1.0)) + (not (find scene middles-list))) + (format t "~a~%" line)))))))))) + + + +(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)) + 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 0000000000000000000000000000000000000000..71cef5c24ca7e7956f087afd4559c39d71e20f2a --- /dev/null +++ b/applications/visual-dialog/evaluation/job_scripts/evaluation-clevr-symbolic.lisp @@ -0,0 +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 end)))) + +(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 new file mode 100644 index 0000000000000000000000000000000000000000..8a088bd67b6dfb7e5e3cd614ca4ce91c0027f91f --- /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.err +#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/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-clevr-symbolic.lisp --quit \ + start $START \ + end $END \ 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 0000000000000000000000000000000000000000..742d6637e3264587c9d76b949491713edaf1ddcc --- /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 0000000000000000000000000000000000000000..eb296ff06355456649a90d7f87a7a57f461bd5ab --- /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 \ diff --git a/applications/visual-dialog/evaluation/scenes-with-multiple-middles.lisp b/applications/visual-dialog/evaluation/scenes-with-multiple-middles.lisp new file mode 100644 index 0000000000000000000000000000000000000000..107a38480261ba8149eee13478416a5a6ea18a1e --- /dev/null +++ b/applications/visual-dialog/evaluation/scenes-with-multiple-middles.lisp @@ -0,0 +1 @@ +(72 75 109 284 436 475 530 558 640 667 744 930 959 1037 1087 1473 1518 1548 2074 2159 2184 2338 2559 2839 2953 3081 3133 3237 3317 3591 3668 3970 4222 4918 4978 5477 5679 5858 6131 6273 6486 6567 6617 6749 6760 7318 7520 7559 7588 7716 7778 7951 8409 8858 8906 9251 9780 9984 10241 10257 10329 10598 10683 10743 10948 11028 11275 11569 11844 12000 12025 12559 12874 12898 13149 13169 13366 13489 13626 13728 14178 14517 14743 14841 14920 14956 15058 15614 15838 16413 16538 16691 16882 17053 17568 17593 17973 18160 18235 18292 18403 18648 18913 19455 19519 19544 19570 19801 19832 19833 20006 20227 20325 20388 21002 21047 21161 21228 21558 21768 22351 22390 22766 22983 23290 23706 23741 23822 23830 23855 23987 24254 24432 24549 24699 24803 24818 25074 25167 25272 25550 25751 25784 25976 26191 26439 26558 26594 26605 26863 26944 27776 28064 28221 28240 28242 28487 28866 28996 29205 29300 29346 29403 29474 29583 29709 30052 30383 30392 30598 30677 30701 30755 31236 31551 31736 31870 31890 32211 32315 32394 32619 32868 33197 33422 33477 33482 33693 33851 33954 34268 34409 34411 34555 34751 34795 34882 34929 34949 35001 35006 35122 35188 35292 35410 35695 35757 36000 36494 36742 36986 37200 37306 37411 37569 37609 37630 38248 38539 38627 38756 38774 39003 39144 39334 39599 39893 40232 40714 40729 40928 40990 41291 41559 41721 41941 42308 42365 43205 43238 43240 43241 43398 43707 43915 43979 44105 44169 44369 44452 44478 44575 44637 45127 45160 45686 45741 46275 46384 47050 47142 47380 47514 47896 47955 48311 48506 48515 48573 48668 48807 48940 49022 49208 49257 49474 49518 49660 49791 49949 50004 50115 50278 50422 50569 50924 51000 51003 51096 51160 51298 51398 51544 51748 51850 51870 51910 52161 52196 52291 52350 52373 52658 52667 52832 53096 53385 53545 53676 53773 53917 54240 54289 54358 54401 54479 55136 55362 55449 55450 55605 55614 55847 55965 56202 56357 56451 57010 57150 57273 57468 57525 57531 58110 58210 58338 58656 58927 59071 59481 59521 59649 60076 60247 60495 60556 60739 61037 61423 61662 61746 61833 61906 62169 62190 62342 62418 62522 62940 62954 62988 63406 64846 65141 65181 65196 65355 65443 65590 65756 65800 65937 65965 66177 66333 66355 66705 66963 67438 67498 67611 67671 67972 68511 68535 68560 68670 68862 68906 69055 69239 69348 69365 69541 69842) \ No newline at end of file diff --git a/applications/visual-dialog/execution/execution-utils.lisp b/applications/visual-dialog/execution/execution-utils.lisp index 5fa6ae50d6d8ab37a1023f26a17b7de2150d1b68..dade3372d0a8b18a350a0e69d888ba86567c6ef6 100644 --- a/applications/visual-dialog/execution/execution-utils.lisp +++ b/applications/visual-dialog/execution/execution-utils.lisp @@ -1,11 +1,14 @@ (in-package :visual-dialog) -(defun initialize-agent-ontology-and-world (ontology world) +(defun initialize-agent-ontology-and-world (ontology world silent) "sets the world and ontology of an agent in ontology" (let ((agent-ontology (make-instance 'blackboard))) (loop for field in (data-fields ontology) do (set-data agent-ontology (first field) (rest field))) (set-data agent-ontology 'world world) + (set-data agent-ontology 'silent silent) + (set-data agent-ontology 'server-address (get-configuration world :server-address)) + (set-data agent-ontology 'cookie-jar (get-configuration world :cookie-jar)) agent-ontology)) (defun get-scene-pathname-by-index (index world) @@ -114,18 +117,20 @@ (attr-cat (intern (string-replace attribute-category "-category" "") "KEYWORD"))) (cons attr-cat attribute))) -(defun make-new-object-with-attributes (object-id attributes) +(defun make-new-object-with-attributes (object-id attributes attention) (make-instance 'object :id object-id :attributes (loop for (category . attribute) in attributes for cat = category for attr = (intern (symbol-name attribute)) when (not (equal attribute (or 'thing 'digit))) - collect (cons cat attribute)))) + collect (cons cat attribute)) + :attention attention)) -(defun make-new-object-without-attributes (object-id attributes) +(defun make-new-object-without-attributes (object-id attributes attention) (make-instance 'object - :id object-id)) + :id object-id + :attention attention)) (defun get-target-value (irl-program list-of-bindings) "returns the value/binding of the open variable in irl-program" @@ -136,8 +141,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) @@ -156,7 +161,7 @@ (if (equal (type-of source-value) 'object-set) (loop for object in (objects source-value) collect (id object)) - (loop for object in (objects (object-set (first (set-items source-value)))) + (loop for object in (collect-objects-from-world-model source-value) collect (id object)))) (defun add-conversation-memory (memory) @@ -165,10 +170,10 @@ (defun get-primitive-inventory (world) (let ((mode (get-configuration world :mode))) - (if (eql mode :hybrid) - *hybrid-primitives*) - (if (eql mode :symbolic) - *symbolic-primitives*))) + (cond ((eql mode :hybrid) + *subsymbolic-primitives*) + ((eql mode :symbolic) + *symbolic-primitives*)))) ;;;;;;;; EVALUATION UTILS @@ -235,3 +240,21 @@ (t 0)))) +(defun collect-objects-from-world-model (world-model) + (let* ((set-items (set-items world-model)) + (object-set (if set-items + (object-set (first set-items)))) + (objects (if object-set (objects object-set)))) + (if (and set-items object-set objects) + (loop for object in objects + collect object)))) + +(defun collect-objects-id-from-world-model (world-model) + (let* ((set-items (set-items world-model)) + (object-set (if set-items + (object-set (first set-items)))) + (objects (if object-set (objects object-set)))) + (if (and set-items object-set objects) + (loop for object in objects + collect (id object))))) + diff --git a/applications/visual-dialog/execution/initialize-memory.lisp b/applications/visual-dialog/execution/initialize-memory.lisp index ed41af1889bfb978042f0b0ffe538e9e3fdd4595..61948991f25fcf7252355a0b7080e9f9bd75c880 100644 --- a/applications/visual-dialog/execution/initialize-memory.lisp +++ b/applications/visual-dialog/execution/initialize-memory.lisp @@ -5,11 +5,15 @@ "information that is stored: attributes of two unique inputs + relation between them" (let* ((relate-primitive (find 'immediate-relate irl-program :test #'equal :key #'first)) (first-unique-variable (third relate-primitive)) - (first-unique-binding (first (objects (value (find first-unique-variable list-of-bindings :key #'var))))) - + (first-unique-binding (first (objects (object-set (first (set-items (value (find first-unique-variable list-of-bindings :key #'var)))))))) + (first-unique-attention (if (attention first-unique-binding) + (attention first-unique-binding))) + (exist-primitive (find 'exist irl-program :test #'equal :key #'first)) (second-unique-variable (third exist-primitive)) - (second-unique-binding (first (objects (value (find second-unique-variable list-of-bindings :key #'var))))) + (second-unique-binding (first (objects (object-set (first (set-items (value (find second-unique-variable list-of-bindings :key #'var)))))))) + (second-unique-attention (if (attention second-unique-binding) + (attention second-unique-binding))) (attribute-first-unique-variable-list (find-attributes-of-unique irl-program first-unique-variable)) (attribute-second-unique-variable-list (find-attributes-of-unique irl-program second-unique-variable)) @@ -17,8 +21,8 @@ (relation-binding (spatial-relation (value (find relation-variable list-of-bindings :key #'var)))) new-object-list new-world-model left-right-relations front-behind-relations) - (push (make-new-object-with-attributes (id second-unique-binding) attribute-second-unique-variable-list) new-object-list) - (push (make-new-object-with-attributes (id first-unique-binding) attribute-first-unique-variable-list) new-object-list) + (push (make-new-object-with-attributes (id second-unique-binding) attribute-second-unique-variable-list second-unique-attention) new-object-list) + (push (make-new-object-with-attributes (id first-unique-binding) attribute-first-unique-variable-list first-unique-attention) new-object-list) (setf new-world-model (make-instance 'world-model @@ -43,10 +47,13 @@ (let* ((unique-primitive (find 'unique irl-program :test #'equal :key #'first)) (exist-primitive (find 'exist irl-program :test #'equal :key #'first)) (unique-object (third exist-primitive)) - (unique-object-binding (first (objects (value (find unique-object list-of-bindings :key #'var))))) + (unique-object-binding (first (objects (object-set (first (set-items (value (find unique-object list-of-bindings :key #'var)))))))) + (unique-attention (if (attention unique-object-binding) + (attention unique-object-binding))) + (attribute-unique-variable-list (find-attributes-of-unique irl-program unique-object)) new-object-list new-world-model) - (setf new-object-list (list (make-new-object-with-attributes (id unique-object-binding) attribute-unique-variable-list))) + (setf new-object-list (list (make-new-object-with-attributes (id unique-object-binding) attribute-unique-variable-list unique-attention))) (setf new-world-model (make-instance 'world-model :id 'conversation-memory :set-items (list (make-instance 'turn @@ -74,7 +81,7 @@ new-object-list new-world-model) (setf new-object-list (loop for object in (objects (object-set (first (set-items source-value)))) - collect (make-new-object-without-attributes (id object) attribute-variable-list))) + collect (make-new-object-without-attributes (id object) attribute-variable-list (attention object)))) ;(setf new-object-list (find-attributes-of-several-object attribute-variable-list context-binding new-object-list list-of-bindings)) (setf new-world-model (make-instance 'world-model :id 'conversation-memory :set-items (list (make-instance 'turn @@ -96,14 +103,17 @@ (exist-primitive (find 'exist irl-program :test #'equal :key #'first)) (extreme-object-variable (third exist-primitive)) - (extreme-object-binding (first (objects (value (find extreme-object-variable list-of-bindings :key #'var))))) + (extreme-object-binding (first (objects (object-set (first (set-items (value (find extreme-object-variable list-of-bindings :key #'var)))))))) + (extreme-attention (if (attention extreme-object-binding) + (attention extreme-object-binding))) + - (relation-variable (fourth extreme-relate-primitive)) + (relation-variable (last-elt extreme-relate-primitive)) (relation-binding (spatial-relation (value (find relation-variable list-of-bindings :key #'var)))) (attributes (find-attributes-of-unique irl-program extreme-object-variable)) new-object-list) - (setf new-object-list (list (make-new-object-with-attributes (id extreme-object-binding) attributes))) + (setf new-object-list (list (make-new-object-with-attributes (id extreme-object-binding) attributes extreme-attention))) (setf new-world-model (make-instance 'world-model :id 'conversation-memory :set-items (list (make-instance 'turn diff --git a/applications/visual-dialog/execution/run-dialogs.lisp b/applications/visual-dialog/execution/run-dialogs.lisp index 2574569d0d2344ec98df031781fa1d507f1ebebd..e9c84898b7ae8d635b4e651fce94a4d69ac3295b 100644 --- a/applications/visual-dialog/execution/run-dialogs.lisp +++ b/applications/visual-dialog/execution/run-dialogs.lisp @@ -8,7 +8,7 @@ &key (silent t)) "Running a whole dialog, this means understanding, executing and remembering caption, then understanding and executing each question" "Returns list of answers" - (let* ((ontology (initialize-agent-ontology-and-world ontology world)) + (let* ((ontology (initialize-agent-ontology-and-world ontology world silent)) (caption (first list-of-sentences)) (questions (rest list-of-sentences)) (memory (understand-execute-remember-caption scene-pathname caption ontology :silent silent)) @@ -27,7 +27,7 @@ &key (silent t)) "Running a whole dialog, this means understanding, executing and remembering first question in case of mnist, then understanding and executing each question" "Returns list of answers" - (let* ((ontology (initialize-agent-ontology-and-world ontology world)) + (let* ((ontology (initialize-agent-ontology-and-world ontology world silent)) (caption (first list-of-sentences)) (questions (rest list-of-sentences)) (memory (understand-execute-remember-first-question scene-pathname caption ontology :silent silent)) @@ -42,4 +42,3 @@ - diff --git a/applications/visual-dialog/execution/server-utils.lisp b/applications/visual-dialog/execution/server-utils.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2480866791787f1e57095cc434c94a13f40c0788 --- /dev/null +++ b/applications/visual-dialog/execution/server-utils.lisp @@ -0,0 +1,170 @@ + +(in-package :visual-dialog) + +(export '(load-image request-attn)) + +(defun do-irl-request (server-address endpoint data cookie-jar) + (multiple-value-bind (response code headers + uri stream must-close + reason-phrase) + (http-request (mkstr server-address endpoint) + :method :post :content-type "application/json" + :content (replace-char (downcase (to-json data)) #\- #\_) + :connection-timeout 10 + :cookie-jar cookie-jar) + (declare (ignorable headers uri stream must-close reason-phrase)) + (values (parse (upcase (replace-char response #\_ #\-))) code))) + + +(defun load-image (server-address cookie-jar image-name) + "Load a CLEVR image before starting + the IRL program evaluation" + (multiple-value-bind (response code) + (do-irl-request server-address + "init-image" + `(:name ,image-name) + cookie-jar) + (declare (ignorable response)) + (unless (= code 200) + (error "Something went wrong while loading ~a" image-name)))) + +(defun clear-session (server-address cookie-jar) + (multiple-value-bind (response code) + (do-irl-request server-address + "clear_session" + nil cookie-jar) + (declare (ignorable response)) + (unless (= code 200) + (error "Something went wrong while clearing the session")) + (when (= code 200) + ;; the session is cleared on the server and the + ;; cookie is set to expired and sent back. + ;; Drakma detects this and removes the cookie + ;; from the jar. Amazing! + (drakma:delete-old-cookies cookie-jar)))) + + +(defun clear-attentions (server-address cookie-jar) + (multiple-value-bind (response code) + (do-irl-request server-address + "clear-attentions" + nil cookie-jar) + (declare (ignorable response)) + (unless (= code 200) + (error "Something went wrong while clearing the attentions")) + t)) + + +(defun clear-scenes (server-address cookie-jar) + (multiple-value-bind (response code) + (do-irl-request server-address + "clear-scenes" + nil cookie-jar) + (declare (ignorable response)) + (unless (= code 200) + (error "Something went wrong while clearing the attentions")) + t)) + +(defun evaluate-neural-primitive (primitive server-address cookie-jar data) + "Evaluate a neural primitive. Check if the response + status code is ok and return the relevant data" + (multiple-value-bind (response code) + (do-irl-request server-address + primitive + data cookie-jar) + (cond + ((= code 400) ; something went wrong + (let ((error-type (getf response :error-type)) + (error-msg (getf response :message))) + (error "~a error: ~a" error-type error-msg))) + ((= code 200) ; status normal + (cond + ;; if bindings, return them + ((getf response :bindings) + (process-bindings (getf response :bindings))) + ;; if consistent, return it + ((getf response :consistent) + (getf response :consistent))))))) + +(defun compare-attentions (server-address cookie-jar data) + (multiple-value-bind (response code) + (do-irl-request server-address + "compare_attentions" + data cookie-jar) + ;(print response) + (getf response :same-attention))) + +(defun process-bindings (bindings) + "Process the new binding such that they are easier + to handle in the primitive definition. The variable + should always refer to some internal symbol (i.e. + a slot spec of the primitive), the score is always + a float between 0 and 1 and the value can be anything, + so it is left as is. Is is up to the primitive definition + to further process the value. + The new bindings are returned as a list of lists of dictionaries. + This is because multiple variables can be bound in 1 go and + the same variable can be bound multiple times." + (let ((bind-scores + (loop for bind-set in bindings + collect (loop for bind-statement in bind-set + append (list + (intern (getf bind-statement :variable) + :visual-dialog) + (getf bind-statement :score))))) + (bind-values + (loop for bind-set in bindings + collect (loop for bind-statement in bind-set + append (list + (intern (getf bind-statement :variable) + :visual-dialog) + (getf bind-statement :value)))))) + (values bind-scores bind-values))) + + +(defun request-attn (server-address cookie-jar attention) + (multiple-value-bind (byte-array code headers + uri stream must-close + reason-phrase) + (http-request (replace-char + (downcase + (mkstr server-address + (format nil "attn/~a" + (id attention)))) + #\- #\_) + :method :get + :cookie-jar cookie-jar) + (declare (ignorable headers uri stream must-close reason-phrase)) + (when (= code 200) + (let ((filepath (babel-pathname :directory '(".tmp" "attn") :type "png" + :name (downcase (mkstr (id attention))) + ))) + (ensure-directories-exist filepath) + (with-open-file (stream filepath :direction :output + :element-type 'unsigned-byte + :if-exists :overwrite :if-does-not-exist :create) + (loop for byte across byte-array + do (write-byte byte stream))) + (setf (img-path attention) filepath) + filepath)))) + +(defmethod irl::handle-evaluate-irl-program-finished-event + :before ((monitor monitors::monitor) + (monitor-id (eql 'irl::trace-irl)) + (event-id (eql 'irl::evaluate-irl-program-finished)) + solutions solution-nodes + processor primitive-inventory) + ;; when the monitor is active + ;; download all attention images + ;; also check if the slot is bound + ;; such that the same attention is not downloaded twice + (when (monitors::active monitor) + (loop for solution in solutions + do (loop for binding in solution + when (and (eql (type-of (value binding)) 'attention) + (null (img-path (value binding)))) + do (request-attn (get-data (ontology processor) 'visual-dialog::server-address) + (get-data (ontology processor) 'visual-dialog::cookie-jar) + (value binding)))))) + + diff --git a/applications/visual-dialog/execution/understand-execute-remember.lisp b/applications/visual-dialog/execution/understand-execute-remember.lisp index 587fc7c21b54540a24426b5d9bfea49eb56dbd8f..a7b7665e1d7649214d3dcdb9c3a1c828b9386626 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)) @@ -87,11 +87,14 @@ (solutions (evaluate-irl-program irl-program ontology :silent (if silent silent) :primitive-inventory (get-primitive-inventory (get-data ontology 'world))))) (if solutions (let* ((target-value (get-target-value irl-program (first solutions))) - (source-value (get-third-value-target-primitive irl-program (first solutions))) - (target-primitive (get-target-primitive irl-program)) - (new-object-set (make-instance 'object-set - :objects (loop for object in (objects (object-set last-set)) - collect (copy-object object)) + (source-value (get-third-value-target-primitive irl-program (first solutions))) + (target-primitive (get-target-primitive irl-program)) + (new-object-set + (if (object-set last-set) + (make-instance 'object-set + :objects (loop for object in (objects (object-set last-set)) + collect (copy-object object))) + (make-instance 'object-set) ; :scene-configuration (copy-scene-configuration (object-set last-set)) )) items-list question) @@ -101,14 +104,14 @@ (cond ((eq target-primitive 'QUERY) (update-memory-query irl-program solutions source-value target-value new-object-set)) ((eq target-primitive 'count-objects) - (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions last-set)) + (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions )) ((eq target-primitive 'EXIST) - (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions last-set)) + (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions )) ((eq target-primitive 'EXIST-OR-COUNT) (if (equal (question-type last-set) 'exist) - (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions last-set)) - (if (equal (question-type last-set) 'count) - (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions last-set)))) + (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions )) + (if (equal (question-type last-set) 'count-objects) + (update-memory-count-or-exist irl-program target-primitive source-value new-object-set solutions )))) (setf new-item (make-instance 'turn :timestamp (+ last-timestamp 1) :object-set new-object-set diff --git a/applications/visual-dialog/execution/update-memory.lisp b/applications/visual-dialog/execution/update-memory.lisp index a31c97d5b63aad4fbafbb8ac60d21fece7bc9743..ccff6a11c3a49dedbe5c7a1c22ebfbf65b325fd7 100644 --- a/applications/visual-dialog/execution/update-memory.lisp +++ b/applications/visual-dialog/execution/update-memory.lisp @@ -4,7 +4,7 @@ "updates history when question type is query" "adds attributes of the queried object and also searches for relate primitive if that exists" (let* ((attribute-value (attribute (get-fourth-value-target-primitive irl-program (first solutions)))) - (source-value (first (objects source-value-set))) + (source-value (first (collect-objects-from-world-model source-value-set))) (object-in-memory (if source-value (find (id source-value) (objects new-object-set) :test #'equal :key #'id))) (category-and-attribute (cons (intern (symbol-name attribute-value) "KEYWORD") @@ -19,11 +19,12 @@ (push category-and-attribute (attributes object-in-memory)))) (progn (let ((new-object (make-instance 'object :id (id source-value) - :attributes (list category-and-attribute)))) + :attributes (list category-and-attribute) + :attention (attention source-value)))) (push new-object (objects new-object-set)))))) new-object-set)) -(defun update-memory-count-or-exist (irl-program target-primitive source-value new-object-set solutions last-set) +(defun update-memory-count-or-exist (irl-program target-primitive source-value new-object-set solutions ) "updates history when question type is count or exist" "sets mentioned object of the queried object to T" (let* ((id-list (loop for obj in (objects new-object-set) @@ -38,15 +39,15 @@ "add objects from target set in new-object-set, if they are not yet in there" (loop for object in (objects (object-set (first (set-items source-value)))) do (if (not (member (id object) id-list)) - (push (make-instance 'object :id (id object)) + (push (make-instance 'object :id (id object) :attention (attention object)) (objects new-object-set)))) "find attributes but when set-diff is in irl-program; don't add attributes" (if other-objects ;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" diff --git a/applications/visual-dialog/html.lisp b/applications/visual-dialog/html.lisp index eb028d945c39af010a2681d025bc51ea980b0d0c..6fd247eb52c50ef6b6f4df65a41585c0fcca577a 100644 --- a/applications/visual-dialog/html.lisp +++ b/applications/visual-dialog/html.lisp @@ -9,7 +9,7 @@ ;; maybe we need to find a way to visualize the spatial relationships as well (defmethod make-html-for-entity-details ((object object) &key) `(((div :class "entity-detail") ,(format nil "Attributes: ~a" (attributes object))) - + ((div :class "entity-detail") ,(make-html (attention object) )) ;((div :class "entity-detail") ,(format nil "Topic: ~a" (mentioned-object object))) )) @@ -51,3 +51,17 @@ (defmethod make-html-for-entity-details ((attr-category attribute-category) &key) `(((div :class "entity-detail") ,(format nil "~a" (attribute attr-category))))) + + +(defmethod make-html-for-entity-details ((attn attention) &key) + (when (img-path attn) + (copy-file (img-path attn) (pathname "~/Sites/")) + + (if (null cl-user:*localhost-user-dir*) + (warn "Set your *localhost-user-dir* in init-babel") + `(((img :src ,(string-append cl-user:*localhost-user-dir* + (format nil "~a.png" (id attn))) + :width "480" + :height "320" + + )))))) diff --git a/applications/visual-dialog/ontology/classes.lisp b/applications/visual-dialog/ontology/classes.lisp index 3499dc40c13859a889d500f158bccf450b5c640e..4ea2c83ab3f6eefb2dcf8911c9d2e724c78e27d1 100644 --- a/applications/visual-dialog/ontology/classes.lisp +++ b/applications/visual-dialog/ontology/classes.lisp @@ -6,6 +6,7 @@ (defclass object (object-or-set) ((attributes :type (or symbol list) :initarg :attributes :initform '() :accessor attributes) + (attention :type attention :initarg :attention :initform nil :accessor attention) (relationships :type (or symbol list) :initarg :relationships :initform (make-var 'relationships) :accessor relationships) (topic :type symbol :initarg :topic :initform 'no :accessor topic) (coordinates :type list :initarg :coordinates :initform nil :accessor coordinates) @@ -102,8 +103,11 @@ (error "Keyword argument :data-sets should be a list of strings")) ;; load the scenes (let ((scenes-path - (merge-pathnames (make-pathname :directory '(:relative "scenes")) - data-path))) + (if (eql (get-configuration world :mode) :symbolic) + (merge-pathnames (make-pathname :directory '(:relative "scenes")) + data-path) + (merge-pathnames (make-pathname :directory '(:relative "images")) + data-path)))) (unless (probe-file scenes-path) (error "Could not find a 'scenes' subdirectory in ~a~%" data-path)) (setf (slot-value world 'scenes) @@ -114,7 +118,7 @@ do (error "~a is not a subdirectory of ~%~a" data-set scenes-path) append (sort (directory (make-pathname :directory (pathname-directory set-directory) - :name :wild :type "json")) + :name :wild :type (if (eql (get-configuration world :mode) :symbolic) "json" "png"))) #'string< :key #'namestring)))) ;; load the dialogs, if requested (let ((dialogs-path @@ -158,13 +162,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 +214,13 @@ ;; ################################ (defclass pathname-entity (entity) - ((pathname :type pathname :initarg :pathname :accessor pathname))) + ((path :type pathname :initarg :path :accessor path))) + +;; ################################ +;; attention +;; ################################ + +(defclass attention (object-or-set) + ((img-path :type (or null pathname) :initarg :img-path + :accessor img-path :initform nil)) + (:documentation "A symbolic representation of an intermediate attention")) diff --git a/applications/visual-dialog/ontology/utils.lisp b/applications/visual-dialog/ontology/utils.lisp index 23f2bd7bce727257c3de4d602ec5025591fb0ee1..6979b11b6fe96189d8e34c4773e94e924ddc33f9 100644 --- a/applications/visual-dialog/ontology/utils.lisp +++ b/applications/visual-dialog/ontology/utils.lisp @@ -271,6 +271,7 @@ (defmethod copy-object ((object object)) (make-instance 'object :id (id object) :attributes (attributes object) + :attention (attention object) :relationships (copy-object (relationships object)) :coordinates (copy-object (coordinates object)) :rotation (copy-object (rotation object)))) @@ -304,7 +305,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 @@ -423,4 +424,34 @@ (= (id entity) id)) entity)) -;(find-entity-by-id *ontology* '0) \ No newline at end of file +;(find-entity-by-id *ontology* '0) + + + + + +(defgeneric category-value (category) + (:documentation "Obtain the value of the category")) + +(defmethod category-value ((shape-category shape-category)) + (shape shape-category)) +(defmethod category-value ((size-category size-category)) + (size size-category)) +(defmethod category-value ((color-category color-category)) + (color color-category)) +(defmethod category-value ((material-category material-category)) + (material material-category)) +(defmethod category-value ((spatial-relation-category spatial-relation-category)) + (spatial-relation spatial-relation-category)) +(defmethod category-value ((boolean-category boolean-category)) + (bool boolean-category)) +(defmethod category-value ((attribute-category attribute-category)) + (attribute attribute-category)) +(defmethod category-value ((attention attention)) + (id attention)) +(defmethod category-value ((digit-category digit-category)) + (digit digit-category)) +(defmethod category-value ((style-category style-category)) + (style style-category)) +(defmethod category-value ((bgcolor-category bgcolor-category)) + (check-if-bgcolor (bgcolor bgcolor-category))) \ No newline at end of file diff --git a/applications/visual-dialog/package.lisp b/applications/visual-dialog/package.lisp index f38841c3beea4fbc38691c23b545c5c53775539d..30450202a8141fcd3bcb536686717f0cb14b6144 100644 --- a/applications/visual-dialog/package.lisp +++ b/applications/visual-dialog/package.lisp @@ -3,16 +3,24 @@ (defpackage :visual-dialog (:documentation "Visual Dialog") (:use :common-lisp :utils :web-interface :irl :fcg - :clevr-dialog-grammar :nao-interface :robot-interface) + :clevr-dialog-grammar ) (:import-from :monitors :activate-monitor) (:import-from :cl-json :decode-json-from-source - :encode-json)) + :encode-json) + (:shadowing-import-from :jonathan + :to-json :parse) + (:import-from :drakma + :http-request) + ) (in-package :visual-dialog) -(export '(*visual-dialog-primitives*)) +(export '(*symbolic-primitives* *hybrid-primitives*)) (def-irl-primitives symbolic-primitives - :primitive-inventory *symbolic-primitives*) \ No newline at end of file + :primitive-inventory *symbolic-primitives*) + +(def-irl-primitives hybrid-primitives + :primitive-inventory *subsymbolic-primitives*) \ No newline at end of file diff --git a/applications/visual-dialog/primitives/count-objects.lisp b/applications/visual-dialog/primitives/both/count-objects.lisp similarity index 86% rename from applications/visual-dialog/primitives/count-objects.lisp rename to applications/visual-dialog/primitives/both/count-objects.lisp index 8bdaa4da9f7eb493083cefbb08635b78d482337d..e6ea18840d46c5e502f248ac7266a54a5e2b2220 100644 --- a/applications/visual-dialog/primitives/count-objects.lisp +++ b/applications/visual-dialog/primitives/both/count-objects.lisp @@ -10,11 +10,11 @@ ((source-set => target-num) (let ((count (length (objects (object-set (first (reverse (set-items source-set)))))))) (bind (target-num 1.0 ;(make-instance 'digit-category :id count :digit count) - (find-entity-by-id (get-data ontology 'digits) (internal-symb (upcase (format nil "~r" count)))) - )))) + (find-entity-by-id (get-data ontology 'digits) (internal-symb (upcase (format nil "~r" count)))))))) + ;; second case; given source and target, check consistency ((source-set target-num =>) (let ((count (length (objects (object-set (first (reverse (set-items source-set)))))))) (equal-entity target-num (find-entity-by-id (get-data ontology 'digits) (internal-symb (upcase (format nil "~r" count))))))) - :primitive-inventory *symbolic-primitives*) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) diff --git a/applications/visual-dialog/primitives/exist-or-count.lisp b/applications/visual-dialog/primitives/both/exist-or-count.lisp similarity index 55% rename from applications/visual-dialog/primitives/exist-or-count.lisp rename to applications/visual-dialog/primitives/both/exist-or-count.lisp index 00bdf1c4fb5ec42729a6c714b809b7dc6d701459..5395219138c970841aec557d8d439975e487a146 100644 --- a/applications/visual-dialog/primitives/exist-or-count.lisp +++ b/applications/visual-dialog/primitives/both/exist-or-count.lisp @@ -4,34 +4,30 @@ ;; EXIST-OR-COUNT primitive ;; ----------------- -(defgeneric get-length (object) - (:documentation "Gets the length of the thing")) - -(defmethod get-length ((object object)) 1) -(defmethod get-length ((set world-model)) - (length (objects (object-set (first (set-items set)))))) - - (defprimitive exist-or-count ((target entity) - (source-set object-or-set)) + (source-world-model world-model)) ;; first case; give source-set, compute target-bool - ((source-set => target) + ((source-world-model => target) (let ((history (get-data ontology 'conversation-memory))) (multiple-value-bind (last-set last-timestamp) (the-biggest #'timestamp (set-items history)) (if (equal (question-type last-set) 'exist) (let ((boolean-category - (find-entity-by-id - ontology - (if (> (get-length source-set) 0) - 'yes 'no)))) + (find-entity-by-id + ontology + (if (> (get-length (object-set (first (set-items source-world-model)))) 0) + 'yes 'no)))) (bind (target 1.0 boolean-category)))) (if (equal (question-type last-set) 'count-objects) - (let ((count (length (objects (object-set (first (reverse (set-items source-set)))))))) - (bind (target 1.0 (find-entity-by-id (get-data ontology 'digits) - (internal-symb (upcase (format nil "~r" count))))))))))) - :primitive-inventory *symbolic-primitives*) - - - + (let ((count (length (objects (object-set (first (reverse (set-items source-world-model)))))))) + (bind (target 1.0 (find-entity-by-id (get-data ontology 'digits) + (internal-symb (upcase (format nil "~r" count))))))))))) +:primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) + + +(defgeneric get-length (object) + (:documentation "Gets the length of the thing")) +(defmethod get-length ((object object)) 1) +(defmethod get-length ((set world-model)) + (length (objects (object-set (first (set-items set)))))) \ No newline at end of file diff --git a/applications/visual-dialog/primitives/exists.lisp b/applications/visual-dialog/primitives/both/exists.lisp similarity index 57% rename from applications/visual-dialog/primitives/exists.lisp rename to applications/visual-dialog/primitives/both/exists.lisp index d8c8df3f87fdb655d4c73d6cb82c3dede94025a8..1515e160ff0d6d9b2185a6cdedf5f5e0989abb78 100644 --- a/applications/visual-dialog/primitives/exists.lisp +++ b/applications/visual-dialog/primitives/both/exists.lisp @@ -7,25 +7,27 @@ ;; ----------------- (defprimitive exist ((target-bool boolean-category) - (source-set object-or-set)) + (source-world-model world-model)) ;; first case; give source-set, compute target-bool - ((source-set => target-bool) + ((source-world-model => target-bool) (let ((boolean-category (find-entity-by-id ontology - (if (> (get-length source-set) 0) + (if (> (get-length source-world-model) 0) '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 - (find-entity-by-id - ontology - (if (> (get-length source-set) 0) - 'yes 'no)))) - (equal-entity target-bool boolean-category))) - :primitive-inventory *symbolic-primitives*) + ((source-world-model target-bool =>) + (if (set-items source-world-model) + (let ((boolean-category + (find-entity-by-id + ontology + (if (> (get-length source-world-model) 0) + 'yes 'no)))) + (equal-entity target-bool boolean-category)) + )) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) (defgeneric get-length (object) diff --git a/applications/visual-dialog/primitives/find-in-context.lisp b/applications/visual-dialog/primitives/both/find-in-context.lisp similarity index 68% rename from applications/visual-dialog/primitives/find-in-context.lisp rename to applications/visual-dialog/primitives/both/find-in-context.lisp index 6f299952696aae98311414dc3656b4ace1f4bd3f..a080c55f4770be6eebd304a3eae2b051a1487f46 100644 --- a/applications/visual-dialog/primitives/find-in-context.lisp +++ b/applications/visual-dialog/primitives/both/find-in-context.lisp @@ -13,9 +13,11 @@ do (if (eq id (id object)) (push object object-set)))) (when object-set - (bind (target-set 1.0 (make-instance 'world-model :set-items (list (make-instance 'turn :object-set (make-instance 'object-set :objects object-set))))))))) + (bind (target-set 1.0 (make-instance 'world-model + :id 'context + :set-items (list (make-instance 'turn :object-set (make-instance 'object-set :objects object-set))))))))) ) - :primitive-inventory *symbolic-primitives*) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) \ No newline at end of file diff --git a/applications/visual-dialog/primitives/get-last-attribute-category.lisp b/applications/visual-dialog/primitives/both/get-last-attribute-category.lisp similarity index 75% rename from applications/visual-dialog/primitives/get-last-attribute-category.lisp rename to applications/visual-dialog/primitives/both/get-last-attribute-category.lisp index c252bf12f701d18c27e1f64bc5930b069c908e04..ffc23bac11364c16aafaee289d7e26e45b29e5db 100644 --- a/applications/visual-dialog/primitives/get-last-attribute-category.lisp +++ b/applications/visual-dialog/primitives/both/get-last-attribute-category.lisp @@ -1,11 +1,40 @@ (in-package :visual-dialog) +(defun answer-to-attribute-category (answer) + (cond ((or (equal answer 'cube) + (equal answer 'cylinder) + (equal answer 'sphere)) + 'shape) + ((or (equal answer 'large) + (equal answer 'small)) + 'size) + ((or (equal answer 'metal) + (equal answer 'rubber)) + 'material) + ((or (equal answer 'yellow) + (equal answer 'gray) + (equal answer 'blue) + (equal answer 'brown) + (equal answer 'red) + (equal answer 'green) + (equal answer 'purple) + (equal answer 'cyan)) + 'color) + ((equal answer 'none) + (random-elt (list 'color 'shape 'size 'material))) + )) + (defprimitive get-last-attribute-category ((attribute attribute-category) (source-set world-model)) ;; first case ((source-set => attribute) (multiple-value-bind (last-set last-timestamp) (the-biggest #'timestamp (set-items source-set)) - (let* ((last-set-objects (objects (object-set last-set))) + (let* ((answer (answer last-set)) + (attribute-category (answer-to-attribute-category answer))) + (bind (attribute 1.0 (make-instance 'attribute-category + :attribute attribute-category)))))) + + #|(let* ((last-set-objects (objects (object-set last-set))) (second-last-set-objects (objects (object-set (find (- last-timestamp 1) (set-items source-set) @@ -30,11 +59,11 @@ unless (member (id object) second-last-set-objects :key #'id) do (setf last-topic-attribute (car (first (attributes object))))))) (bind (attribute 1.0 (make-instance 'attribute-category - :attribute (intern (symbol-name last-topic-attribute)))))))) + :attribute (intern (symbol-name last-topic-attribute))))))|# ;; second case: given attribute, compute source-set ((attribute source-set => ) (equal-entity-last-attr attribute source-set)) - :primitive-inventory *symbolic-primitives*) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) (defun equal-entity-last-attr (attribute source-set) diff --git a/applications/visual-dialog/primitives/get-last-topic.lisp b/applications/visual-dialog/primitives/both/get-last-topic.lisp similarity index 72% rename from applications/visual-dialog/primitives/get-last-topic.lisp rename to applications/visual-dialog/primitives/both/get-last-topic.lisp index 07707646960d918f8bf6c9b2c6b0cb852aac13fa..e16714598c6db6694e8a9bbe665ffa897df7dc6f 100644 --- a/applications/visual-dialog/primitives/get-last-topic.lisp +++ b/applications/visual-dialog/primitives/both/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) @@ -16,15 +16,16 @@ :set-items (list (make-instance 'turn :object-set (make-instance 'object-set :objects last-topic-object-set))))))))) - :primitive-inventory *symbolic-primitives*) + :primitive-inventory (*symbolic-primitives* *subsymbolic-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)) - (let ((last-topic (topic-list last-set))) - (if last-topic - last-topic - (find-last-topic (rest (set-items source-set))))))) + (the-biggest #'timestamp lst) + (if last-set + (let ((last-topic (topic-list last-set))) + (if last-topic + last-topic + (find-last-topic (rest lst))))))) \ No newline at end of file diff --git a/applications/visual-dialog/primitives/get-penultimate-topic.lisp b/applications/visual-dialog/primitives/both/get-penultimate-topic.lisp similarity index 91% rename from applications/visual-dialog/primitives/get-penultimate-topic.lisp rename to applications/visual-dialog/primitives/both/get-penultimate-topic.lisp index 23ece2e9f161456a3be60613953492c5259d6de3..12ca5e386703aa959116e28982785a8b611725ee 100644 --- a/applications/visual-dialog/primitives/get-penultimate-topic.lisp +++ b/applications/visual-dialog/primitives/both/get-penultimate-topic.lisp @@ -20,7 +20,7 @@ :set-items (list (make-instance 'turn :object-set (make-instance 'object-set :objects last-topic-object-set))))))))) - :primitive-inventory *symbolic-primitives*) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) (defun find-penultimate-topic (source-set) diff --git a/applications/visual-dialog/primitives/more-than-one.lisp b/applications/visual-dialog/primitives/both/more-than-one.lisp similarity index 84% rename from applications/visual-dialog/primitives/more-than-one.lisp rename to applications/visual-dialog/primitives/both/more-than-one.lisp index ceae71d638e28ff9cd9b6af14531a05af8c82240..fdcad8a7ad7f8ec90e5811250bfae1cd134c6ae6 100644 --- a/applications/visual-dialog/primitives/more-than-one.lisp +++ b/applications/visual-dialog/primitives/both/more-than-one.lisp @@ -8,8 +8,8 @@ (:documentation "Gets the length of the thing")) (defmethod get-length ((object object)) 1) -(defmethod get-length ((set world-model)) - (length (objects (object-set (first (set-items set)))))) +;(defmethod get-length ((set world-model)) + ; (length (objects (object-set (first (set-items set)))))) (defprimitive more-than-1 ((target-bool boolean-category) (source-set world-model)) @@ -31,4 +31,4 @@ (if (> (get-length source-set) 1) 'yes 'no)))) (equal-entity target-bool boolean-category))) - :primitive-inventory *symbolic-primitives*) \ No newline at end of file + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) \ No newline at end of file diff --git a/applications/visual-dialog/primitives/both/select-one.lisp b/applications/visual-dialog/primitives/both/select-one.lisp new file mode 100644 index 0000000000000000000000000000000000000000..4cae15fa1fbebaa8b0400e7cdebd95d629cc04d8 --- /dev/null +++ b/applications/visual-dialog/primitives/both/select-one.lisp @@ -0,0 +1,36 @@ +(in-package :visual-dialog) + +;; ------------------ +;; SELECT-ONE primitive ;; +;; ------------------ + +(defprimitive select-one ((target-world-model world-model) + (source-set world-model)) + ;; first case; given source set, compute target object + ((source-set => target-world-model) + (let ((object-list (collect-objects-from-world-model source-set))) + (cond ((length= object-list 0) + (bind (target-world-model 1.0 (make-instance 'world-model :id (id source-set))))) + + ((length= object-list 1) + (bind (target-world-model 1.0 (make-instance 'world-model + :id (id source-set) + :set-items (list (make-instance 'turn + :object-set (make-instance 'object-set + :objects (list (first (collect-objects-from-world-model source-set)))))))))) + (t + (loop for object in object-list + do (bind (target-world-model 1.0 (make-instance 'world-model + :id (id source-set) + :set-items + (list (make-instance 'turn + :object-set (make-instance 'object-set + :objects (list object)))))))))))) + + ;; second case; given source set and target object + ;; check for consistency + ((source-set target-world-model =>) + (and (length= (objects (object-set (first (set-items source-set)))) 1) + (equal-entity target-world-model (first (objects (object-set (first (set-items source-set)))))))) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) + diff --git a/applications/visual-dialog/primitives/set-diff.lisp b/applications/visual-dialog/primitives/both/set-diff.lisp similarity index 69% rename from applications/visual-dialog/primitives/set-diff.lisp rename to applications/visual-dialog/primitives/both/set-diff.lisp index 06ad2b6bfd5d3684b008e16b932ae7fb62b3615a..cccc770fc64b175603b24f306044a32c8a214fcd 100644 --- a/applications/visual-dialog/primitives/set-diff.lisp +++ b/applications/visual-dialog/primitives/both/set-diff.lisp @@ -5,22 +5,25 @@ (history-set world-model) (scene pathname-entity)) ((context-set history-set scene => target-set) - (let* ((ids (loop for object in (objects (object-set (first (set-items history-set)))) - collect (id object))) + (let* ((ids (collect-objects-id-from-world-model history-set)) + (objects (collect-objects-from-world-model context-set)) (object-set nil)) - (loop for object in (objects (object-set (first (set-items context-set)))) + (loop for object in objects do (if (not (member (id object) ids)) (push object object-set))) (if object-set - (bind (target-set 1.0 (make-instance 'world-model :set-items (list (make-instance 'turn + (bind (target-set 1.0 (make-instance 'world-model + :id (id context-set) + :set-items (list (make-instance 'turn :object-set (make-instance 'object-set :objects object-set)))))) (bind (target-set 1.0 (make-instance 'world-model + :id (id context-set) :set-items (list (make-instance 'turn :object-set (make-instance 'object-set :id 'empty-set))))))))) - :primitive-inventory *symbolic-primitives*) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) diff --git a/applications/visual-dialog/primitives/both/unique.lisp b/applications/visual-dialog/primitives/both/unique.lisp new file mode 100644 index 0000000000000000000000000000000000000000..51258c41f00151cd65b45c9c94987abeb0ec58be --- /dev/null +++ b/applications/visual-dialog/primitives/both/unique.lisp @@ -0,0 +1,24 @@ +(in-package :visual-dialog) + +;; ------------------ +;; UNIQUE primitive ;; +;; ------------------ + +(defprimitive unique ((target-set world-model) + (source-set world-model)) + ;; first case; given source set, compute target object + ((source-set => target-set) + (if (length= (objects (object-set (first (set-items source-set)))) 1) + (bind (target-set 1.0 (make-instance 'world-model + :set-items (list (make-instance 'turn + :object-set + (make-instance 'object-set :objects (list (first (objects (object-set (first (set-items source-set)))))))))))))) + + ;; second case; given source set and target object + ;; check for consistency + ((source-set target-set =>) + (and (length= (objects (object-set (first (set-items source-set)))) 1) + (equal-entity target-set (first (objects (object-set (first (set-items source-set)))))))) + :primitive-inventory (*symbolic-primitives* *subsymbolic-primitives*)) + + diff --git a/applications/visual-dialog/primitives/select-one.lisp b/applications/visual-dialog/primitives/select-one.lisp deleted file mode 100644 index 2978803fd9a89068c92603c252958935b6447cfc..0000000000000000000000000000000000000000 --- a/applications/visual-dialog/primitives/select-one.lisp +++ /dev/null @@ -1,24 +0,0 @@ -(in-package :visual-dialog) - -;; ------------------ -;; SELECT-ONE primtive ;; -;; ------------------ - -(defprimitive select-one ((target-object-set object-set) - (source-set world-model)) - ;; first case; given source set, compute target object - ((source-set => target-object-set) - (if (length= (objects (object-set (first (set-items source-set)))) 0) - (bind (target-object-set 1.0 (make-instance 'object-set :objects '() :id 'empty-set)))) - - (if (length= (objects (object-set (first (set-items source-set)))) 1) - (bind (target-object-set 1.0 (make-instance 'object-set :objects (list (first (objects (object-set (first (set-items source-set))))))))) - (loop for object in (objects (object-set (first (set-items source-set)))) - do (bind (target-object-set 1.0 (make-instance 'object-set :objects (list object))))))) - - ;; second case; given source set and target object - ;; check for consistency - ((source-set target-object-set =>) - (and (length= (objects (object-set (first (set-items source-set)))) 1) - (equal-entity target-object-set (first (objects (object-set (first (set-items source-set)))))))) - :primitive-inventory *symbolic-primitives*) \ No newline at end of file diff --git a/applications/visual-dialog/primitives/subsymbolic/extreme-relate.lisp b/applications/visual-dialog/primitives/subsymbolic/extreme-relate.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e5bfced4eebc3ca5838e7819206694198dc88938 --- /dev/null +++ b/applications/visual-dialog/primitives/subsymbolic/extreme-relate.lisp @@ -0,0 +1,98 @@ +(in-package :visual-dialog) + +;; ------------------ +;; RELATE primitive ;; +;; ------------------ + +(defprimitive extreme-relate ((target world-model) + (source world-model) + (scene pathname-entity) + (spatial-relation spatial-relation-category)) + ;; first case; given source-object and spatial relation, compute the target set + ((source spatial-relation scene => target) + (let ((source-object-id-list (collect-objects-id-from-world-model source)) + (source-object-list (collect-objects-from-world-model source))) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "extreme-relate" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:target nil + :source ,source-object-id-list + :scene ,(namestring (path scene)) + :spatial-relation ,(spatial-relation spatial-relation))) + (loop for scores in bind-scores + for values in bind-values + do (let ((objects-with-attn + (loop for attn in (getf values 'target) + for attn-id = (intern attn :visual-dialog) + for object = (copy-object (find attn-id source-object-list :key #'id)) + collect object))) + (bind (target (getf scores 'target) + (make-instance 'world-model + :id 'context + :path scene + :set-items + (list + (make-instance 'turn + :timestamp 'permanent + :object-set + (make-instance 'object-set + :objects objects-with-attn))))))))))) + + ;; second case; given source-object and target set, compute the spatial relation + ((source target scene => spatial-relation) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:primitive extreme-relate + :slots (:source-attn ,(id source-attn) + :spatial-relation nil + :target-attn ,(id target-attn)))) + (loop for scores in bind-scores + for values in bind-values + do (bind (spatial-relation + (getf scores 'spatial-relation) + (find (intern (getf values 'spatial-relation) + :hybrid-dialog) + (get-data ontology 'spatial-relation) + :key #'spatial-relation)))))) + + ;; third case; given source-object, compute pairs of target-set and spatial-relation + ((source scene => target spatial-relation) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:primitive extreme-relate + :slots (:source-attn ,(id source-attn) + :spatial-relation nil + :target-attn nil))) + (loop for scores in bind-scores + for values in bind-values + do (bind (target + (getf scores 'target-attn) + (make-instance 'attention + :id (intern (getf values 'target-attn) + :hybrid-dialog))) + (spatial-relation + (getf scores 'spatial-relation) + (find (intern (getf values 'spatial-relation) + :hybrid-dialog) + (get-data ontology 'spatial-relation) + :key #'spatial-relation)))))) + + ;; fourth case; given source-object, target-set and spatial-relation + ;; check for consistency + ((source target spatial-relation scene =>) + (let ((consistentp + (evaluate-neural-primitive + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:primitive extreme-relate + :slots (:source-attn ,(id source-attn) + :spatial-relation ,(spatial-relation spatial-relation) + :target-attn ,(id target-attn)))))) + consistentp)) + :primitive-inventory *subsymbolic-primitives*) diff --git a/applications/visual-dialog/primitives/subsymbolic/filter.lisp b/applications/visual-dialog/primitives/subsymbolic/filter.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ed68171b38a8a4c3e30107e0fb4774fe15c77e46 --- /dev/null +++ b/applications/visual-dialog/primitives/subsymbolic/filter.lisp @@ -0,0 +1,86 @@ +(in-package :visual-dialog) + +;; ------------------ +;; FILTER primitive ;; +;; ------------------ + +(defprimitive filter-by-attribute ((target-set world-model) + (source-set world-model) + (scene pathname-entity) + (category attribute)) + ;; first case: if given source-set and category, compute target-set + ((source-set category scene => target-set) + ;symbolic case + (if (not (equal (id source-set) 'context)) + (let ((computed-set (filter-by-category source-set category))) + (if computed-set + (bind (target-set 1.0 computed-set)) + (bind (target-set 1.0 + (make-instance 'world-model + :id (id source-set) + :set-items (list + (make-instance 'turn + :object-set (make-instance 'object-set :id 'empty-set)))))))) + (let ((source-object-id-list (collect-objects-id-from-world-model source-set)) + (source-object-list (collect-objects-from-world-model source-set))) + (cond ((= (length source-object-id-list) 0) + (bind (target-set 1.0 (make-instance 'world-model :id 'context :path scene :set-items (list (make-instance 'turn )))))) + ((or (eql (category-value category) 'thing) + (eql (category-value category) 'number)) + (bind (target-set 1.0 (copy-object source-set)))) + (t + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "filter" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:target nil + :source ,source-object-id-list + :scene ,(namestring (path scene)) + :concept ,(category-value category))) + (loop for scores in bind-scores + for values in bind-values + do (let ((objects-with-attn + (loop for attn in (getf values 'target) + for attn-id = (intern attn :visual-dialog) + for object = (copy-object (find attn-id source-object-list :key #'id)) + collect object))) + (bind (target-set (getf scores 'target) + (make-instance 'world-model + :id 'context + :path scene + :set-items + (list + (make-instance 'turn + :timestamp 'permanent + :object-set + (make-instance 'object-set + :objects objects-with-attn)))))))))))))) + :primitive-inventory *subsymbolic-primitives*) + +(defgeneric filter-by-category (set category) + (:documentation "Filter the set by the given category.")) + +(defmethod filter-by-category ((set world-model) + (attribute-category attribute)) + (multiple-value-bind (last-set last-timestamp) (the-biggest #'timestamp (set-items set)) + (if (or (equal (id attribute-category) + 'thing) + (equal (id attribute-category) + 'number)) + ;if thing or number, return new world model with same object-set + (make-instance 'world-model + :set-items (list (make-instance 'turn + :object-set (copy-object (object-set last-set))))) + ;else filter objects on attribute-category and return new world model with filtered-objects + (let ((filtered-objects + (loop for object in (objects (object-set last-set)) + for attr-cat = (intern (string-replace (type-of attribute-category) "-category" "") "KEYWORD") + if (and (listp (attributes object)) + (equal (id attribute-category) + (cdr (assoc attr-cat (attributes object))))) + collect object))) + (when filtered-objects + (make-instance 'world-model + :set-items (list (make-instance 'turn + :object-set (make-instance 'object-set :objects filtered-objects))))))))) diff --git a/applications/visual-dialog/primitives/subsymbolic/immediate-relate.lisp b/applications/visual-dialog/primitives/subsymbolic/immediate-relate.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1a35438bd395628b44ee7855fe40d17260d5f1cc --- /dev/null +++ b/applications/visual-dialog/primitives/subsymbolic/immediate-relate.lisp @@ -0,0 +1,59 @@ +(in-package :visual-dialog) + +;; ------------------ +;; RELATE primitive ;; +;; ------------------ + +(defprimitive immediate-relate ((target world-model) + (source world-model) + (segmented-scene world-model) + (scene pathname-entity) + (spatial-relation category)) + ;; first case; given source-object and spatial relation, compute the target set + ((source segmented-scene scene spatial-relation => target) + (let ((rel (cond ((eq (type-of spatial-relation) '2D-relation-category) + (convert-relation spatial-relation)) + ((eq (type-of spatial-relation) 'spatial-relation-category) + (spatial-relation spatial-relation)))) + (scene-objects-id-list (loop for obj in (objects (object-set (first (set-items segmented-scene)))) + collect (id obj))) + (scene-objects-list (collect-objects-from-world-model segmented-scene)) + (source-object-list (loop for obj in (objects (object-set (first (set-items source)))) + collect (id obj)))) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "immediate-relate" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:target nil + :source ,source-object-list + :segmented-scene ,scene-objects-id-list + :scene ,(namestring (path scene)) + :spatial-relation ,(spatial-relation spatial-relation))) + (loop for scores in bind-scores + for values in bind-values + do (if (getf values 'target) + (let ((objects-with-attn + (loop for attn in (getf values 'target) + for attn-id = (intern attn :visual-dialog) + for object = (copy-object (find attn-id scene-objects-list :key #'id)) + collect object))) + (bind (target (getf scores 'target) + (make-instance 'world-model + :id (id source) + :set-items (list (make-instance 'turn + :object-set (make-instance 'object-set :objects objects-with-attn))))))) + (bind (target 1.0 (make-instance 'world-model + :id (id source) + :set-items (list (make-instance 'turn + :object-set (make-instance 'object-set :id 'empty-set))))))))))) + + :primitive-inventory *subsymbolic-primitives*) + +(defmethod convert-relation ((spatial-relation 2D-relation-category)) + (let* ((relation (2D-relation spatial-relation)) + (rel (cond ((eq relation 'below) 'below) + ((eq relation 'above) 'above) + ((eq relation '2D-right) 'right) + ((eq relation '2D-left) 'left)))) + rel)) diff --git a/applications/visual-dialog/primitives/subsymbolic/query.lisp b/applications/visual-dialog/primitives/subsymbolic/query.lisp new file mode 100644 index 0000000000000000000000000000000000000000..204278690474a0849c5b7d52482be7b66c1c3235 --- /dev/null +++ b/applications/visual-dialog/primitives/subsymbolic/query.lisp @@ -0,0 +1,136 @@ +(in-package :visual-dialog) + +;; ----------------- +;; QUERY primtive ;; +;; ----------------- + +(defmethod attribute-none ((attribute-category attribute-category) + ontology) + (let ((none nil)) + (if (equal (attribute attribute-category) 'shape) + (loop for attr in (get-data ontology 'shapes) + do (if (equal (id attr) 'none) + (setf none attr))) + ) + + (if (equal (attribute attribute-category) 'size) + (loop for attr in (get-data ontology 'sizes) + do (if (equal (id attr) 'none) + (setf none attr))) + ) + (if (equal (attribute attribute-category) 'color) + (loop for attr in (get-data ontology 'colors) + do (if (equal (id attr) 'none) + (setf none attr))) + ) + + (if (equal (attribute attribute-category) 'material) + (loop for attr in (get-data ontology 'materials) + do (if (equal (id attr) 'none) + (setf none attr)))) + none)) + +(defprimitive query ((target-category attribute) + (source-object-set world-model) + (scene pathname-entity) + (attribute attribute-category)) + ;; first case; given attribute and source-object, compute the target category + ((source-object-set scene attribute => target-category) + (let ((source-object-list (loop for obj in (collect-objects-from-world-model source-object-set) + collect (id obj)))) + (if source-object-list + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "query" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:source ,source-object-list + :attribute ,(let ((attr + (if (eq (attribute attribute) 'digit) + 'number + (attribute attribute)))) + attr) + :scene ,(namestring (path scene)) + :target nil)) + (loop for scores in bind-scores + for values in bind-values + do + (bind (target-category + (getf scores 'target) + (if (not (equal (getf values 'target) "NONE")) + (find-entity-by-id + ontology + (intern (getf values 'target) + :visual-dialog)) + (attribute-none attribute ontology) ) + )))) + (bind (target-category 1.0 (attribute-none attribute ontology)))))) + + ;; second case; given source-object and target-category, compute the attribute + ((source-object-set scene target-category => attribute) + (let ((source-object-list (loop for obj in (collect-objects-from-world-model source-object-set) + collect (id obj)))) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "query" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:source ,source-object-list + :target ,(category-value target-category) + :scene ,(namestring (path scene)) + :attribute nil))) + (loop for scores in bind-scores + for values in bind-values + do (bind (attribute + (getf scores 'attribute) + (find (intern (getf values 'attribute) + :visual-dialog) + (get-data ontology 'attributes) + :key #'id)))))) + + ;; third case; given source-object, compute pairs of attribute and target-category + ((source-object-set scene => attribute target-category) + (let ((source-object-list (loop for obj in (collect-objects-from-world-model source-object-set) + collect (id obj)))) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "query" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:source ,source-object-list + :target nil + :scene ,(namestring (path scene)) + :attribute nil)) + (loop for scores in bind-scores + for values in bind-values + do (bind (attribute + (getf scores 'attribute) + (find (intern (getf values 'attribute) + :visual-dialog) + (get-data ontology 'attributes) + :key #'id)) + (target-category + (getf scores 'target) + (find-entity-by-id + ontology + (intern (getf values 'target) + :visual-dialog)))))))) + + ;; fourth case; if given source-object, attribute and target-category, check + ;; for consistency + ((source-object-set attribute target-category scene =>) + (let* ((source-object-list (loop for obj in (collect-objects-from-world-model source-object-set) + collect (id obj))) + (consistentp + (evaluate-neural-primitive + "query" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:source ,source-object-list + :target ,(category-value target-category) + :scene ,(namestring (path scene)) + :attribute ,(attribute attribute)))))) + consistentp) + :primitive-inventory *subsymbolic-primitives*) + + diff --git a/applications/visual-dialog/primitives/subsymbolic/relate.lisp b/applications/visual-dialog/primitives/subsymbolic/relate.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ec1cf5de36ee05236b31476b0b3b94df96204605 --- /dev/null +++ b/applications/visual-dialog/primitives/subsymbolic/relate.lisp @@ -0,0 +1,41 @@ +(in-package :visual-dialog) + +;; ------------------ +;; RELATE primtive ;; +;; ------------------ + +(defprimitive relate ((target world-model) + (source world-model) + (segmented-scene world-model) + (scene pathname-entity) + (spatial-relation category)) + ;; first case; given source-object and spatial relation, compute the target set + ((source segmented-scene scene spatial-relation => target) + (let ((scene-object-id-list (loop for obj in (objects (object-set (first (set-items segmented-scene)))) + collect (id obj))) + (source-object-id-list (loop for obj in (objects (object-set (first (set-items source)))) + collect (id obj))) + (scene-object-list (collect-objects-from-world-model segmented-scene))) + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "relate" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:target nil + :source ,source-object-id-list + :segmented-scene ,scene-object-id-list + :scene ,(namestring (path scene)) + :spatial-relation ,(spatial-relation spatial-relation))) + (loop for scores in bind-scores + for values in bind-values + do (let ((objects-with-attn + (loop for attn in (getf values 'target) + for attn-id = (intern attn :visual-dialog) + for object = (copy-object (find attn-id scene-object-list :key #'id)) + collect object))) + (bind (target (getf scores 'target) + (make-instance 'world-model + :set-items (list (make-instance 'turn + :object-set (make-instance 'object-set :objects objects-with-attn))))))))))) + + :primitive-inventory *subsymbolic-primitives*) diff --git a/applications/visual-dialog/primitives/subsymbolic/segment-scene.lisp b/applications/visual-dialog/primitives/subsymbolic/segment-scene.lisp new file mode 100644 index 0000000000000000000000000000000000000000..64ae2998a00e2189b98d65a939287adb281841b9 --- /dev/null +++ b/applications/visual-dialog/primitives/subsymbolic/segment-scene.lisp @@ -0,0 +1,51 @@ +(in-package :visual-dialog) + +;; ----------------------- +;; SEGMENT-SCENE primitive ;; +;; ----------------------- + +(defprimitive segment-scene ((segmented-scene world-model) + (scene-pathname pathname-entity)) + ;; first case; given scene-pathname compute segmented-scene + ;; 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) + ;;do stuff --> call to server etc + (multiple-value-bind (bind-scores bind-values) + (evaluate-neural-primitive + "segment-scene" + (get-data ontology 'server-address) + (get-data ontology 'cookie-jar) + `(:segmented-scene nil + :scene ,(namestring (path scene-pathname)))) + (loop for scores in bind-scores + for values in bind-values + do (let ((objects-with-attn + (loop for attn in (getf values 'segmented-scene) + for attention = (make-instance 'attention :id (intern attn :visual-dialog)) + do (when (not (get-data ontology 'silent)) + (request-attn (get-data ontology 'server-address) (get-data ontology 'cookie-jar) attention)) + collect (make-instance 'object + :id (intern attn :visual-dialog) + :attention attention)))) + (bind (segmented-scene (getf scores 'segmented-scene) + (make-instance 'world-model + :id 'context + :path scene-pathname + :set-items + (list + (make-instance 'turn + :timestamp 'permanent + :object-set + (make-instance 'object-set + :objects objects-with-attn)))))))))) + + ;; second case; given segmented-scene compute scene-pathname + ((segmented-scene => scene-pathname) + ) + + ;; third case; check consistency + ((segmented-scene scene-pathname =>) + ) + :primitive-inventory *subsymbolic-primitives*) + + \ No newline at end of file diff --git a/applications/visual-dialog/primitives/extreme-relate.lisp b/applications/visual-dialog/primitives/symbolic/extreme-relate.lisp similarity index 90% rename from applications/visual-dialog/primitives/extreme-relate.lisp rename to applications/visual-dialog/primitives/symbolic/extreme-relate.lisp index ea237c3f9a4d5ccc97ec689c65bef67bea43055a..1e69a297c100ce7255da62ba03f2b2bc42fdfb64 100644 --- a/applications/visual-dialog/primitives/extreme-relate.lisp +++ b/applications/visual-dialog/primitives/symbolic/extreme-relate.lisp @@ -5,10 +5,11 @@ ;; ----------------- (defprimitive extreme-relate ((target-set world-model) - (source-set world-model) - (spatial-relation spatial-relation-category)) + (source-set world-model) + (scene pathname-entity) + (spatial-relation spatial-relation-category)) ;; first case; given source-object and spatial relation, compute the target set - ((source-set spatial-relation => target-set) + ((source-set spatial-relation scene => target-set) (let* ( (relation-list nil) (id-right nil) diff --git a/applications/visual-dialog/primitives/filter.lisp b/applications/visual-dialog/primitives/symbolic/filter.lisp similarity index 78% rename from applications/visual-dialog/primitives/filter.lisp rename to applications/visual-dialog/primitives/symbolic/filter.lisp index 871e2e17304a8efba7be71f05c3d2cd19672304f..89ab0fed713c64ef18c778b537d3c0d508bc743a 100644 --- a/applications/visual-dialog/primitives/filter.lisp +++ b/applications/visual-dialog/primitives/symbolic/filter.lisp @@ -10,15 +10,17 @@ (category attribute)) ;; first case: if given source-set and category, compute target-set ((source-set category scene => target-set) - (let ((computed-set (filter-by-category source-set category))) - (if computed-set - (bind (target-set 1.0 computed-set)) - (bind (target-set 1.0 - (make-instance 'world-model - :set-items (list - (make-instance 'turn - :object-set (make-instance 'object-set :id 'empty-set))))))))) - :primitive-inventory *symbolic-primitives*) + ;symbolic case + (let ((computed-set (filter-by-category source-set category))) + (if computed-set + (bind (target-set 1.0 computed-set)) + (bind (target-set 1.0 + (make-instance 'world-model + :id (id source-set) + :set-items (list + (make-instance 'turn + :object-set (make-instance 'object-set :id 'empty-set))))))))) + :primitive-inventory *symbolic-primitives* ) (defgeneric filter-by-category (set category) (:documentation "Filter the set by the given category.")) diff --git a/applications/visual-dialog/primitives/immediate-relate.lisp b/applications/visual-dialog/primitives/symbolic/immediate-relate.lisp similarity index 93% rename from applications/visual-dialog/primitives/immediate-relate.lisp rename to applications/visual-dialog/primitives/symbolic/immediate-relate.lisp index a7fd1b8261b599c29628ec8f78e78655892aee97..e3ec5820dc8da8b01377a9b46a63c38706d1405c 100644 --- a/applications/visual-dialog/primitives/immediate-relate.lisp +++ b/applications/visual-dialog/primitives/symbolic/immediate-relate.lisp @@ -5,16 +5,16 @@ ;; ------------------ (defprimitive immediate-relate ((target-set world-model) - (source-object-set object-set) + (source-world-model world-model) (segmented-scene world-model) (scene pathname-entity) (spatial-relation category)) ;; first case; given source-object and spatial relation, compute the target set - ((source-object-set spatial-relation segmented-scene scene => target-set) + ((source-world-model spatial-relation segmented-scene scene => target-set) (let* (;(context (get-data ontology 'context)) ;(context (cdr (find (pathname scene) (get-data ontology 'segmented-scene) :test #'equal :key #'first))) (context segmented-scene) - (source-object (first (objects source-object-set))) + (source-object (first (objects (object-set (first (set-items source-world-model)))))) relation-list id-right object-right) (if (eq (type-of spatial-relation) 'spatial-relation-category) (cond ((eql (spatial-relation spatial-relation) 'right) diff --git a/applications/visual-dialog/primitives/query.lisp b/applications/visual-dialog/primitives/symbolic/query.lisp similarity index 86% rename from applications/visual-dialog/primitives/query.lisp rename to applications/visual-dialog/primitives/symbolic/query.lisp index 54ea6545b17faecd34f9bfa0fc5aba1ee00abb8a..8abb9b8b1da36c8e8db4a74a3de050cdabb9bc7f 100644 --- a/applications/visual-dialog/primitives/query.lisp +++ b/applications/visual-dialog/primitives/symbolic/query.lisp @@ -6,6 +6,46 @@ ;(export '(query)) + + +(defprimitive query ((target-category attribute) + (source-object-set world-model) + (scene pathname-entity) + (attribute attribute-category)) + ;; first case; given attribute and source-object, compute the target category + ((source-object-set attribute scene => target-category) + + (if (equal (length (collect-objects-from-world-model source-object-set)) 0) + (bind (target-category 1.0 (attribute-none attribute ontology))) + (bind (target-category 1.0 (query-object-attribute (first (collect-objects-from-world-model source-object-set)) attribute ontology))))) + + ;; second case; given source-object and target-category, compute the attribute + ((source-object-set target-category scene => attribute) + (let ((computed-attribute + (find-if #'(lambda (attr) + (equal-entity + target-category + (query-object-attribute (first (objects source-object-set)) 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 + ((source-object-set scene => target-category attribute) + (loop for attr in (get-data ontology 'attributes) + for target-cat = (query-object-attribute (first (objects source-object-set)) attr ontology) + when target-cat + do (bind (attribute 1.0 attr) + (target-category 1.0 target-cat)))) + + ;; fourth case; if given source-object, attribute and target-category, check + ;; for consistency + ((source-object-set attribute target-category scene =>) + (equal-entity target-category (query-object-attribute (first (objects source-object-set)) attribute ontology))) + :primitive-inventory *symbolic-primitives*) + + + (defgeneric query-object-attribute (object attribute ontology) (:documentation "Extract the attribute from the object and get the corresponding category from the ontology")) @@ -18,18 +58,12 @@ (let* ((attr (attribute attribute-category)) (spec-attr (cdr (assoc (intern (string attr) "KEYWORD") (attributes object))))) "yellow and cyan are bgcolors AND colors, so make sure that the right attribute-category is made" - ;(type-of spec-attr) (if (not (and (or (eq spec-attr 'yellow) (eq spec-attr 'cyan)) (eq attr 'bgcolor))) (find-entity-by-id ontology spec-attr) (make-instance 'bgcolor-category :id spec-attr :bgcolor spec-attr)))) - #|(case (attribute attribute-category) - - (shape (find-entity-by-id ontology (cdr (assoc :shape (attributes object))))) - (size (find-entity-by-id ontology (cdr (assoc :size (attributes object))))) - (color (find-entity-by-id ontology (cdr (assoc :color (attributes object))))) - (material (find-entity-by-id ontology (cdr (assoc :material (attributes object))))))|# + (defmethod attribute-none ((attribute-category attribute-category) @@ -57,41 +91,4 @@ do (if (equal (id attr) 'none) (setf none attr)))) none)) - - -(defprimitive query ((target-category attribute) - (source-object-set object-set) - (scene pathname-entity) - (attribute attribute-category)) - ;; first case; given attribute and source-object, compute the target category - ((source-object-set attribute scene => target-category) - (if (equal (length (objects source-object-set)) 0) - (bind (target-category 1.0 (attribute-none attribute ontology))) - (bind (target-category 1.0 (query-object-attribute (first (objects source-object-set)) attribute ontology))))) - - ;; second case; given source-object and target-category, compute the attribute - ((source-object-set target-category scene => attribute) - (let ((computed-attribute - (find-if #'(lambda (attr) - (equal-entity - target-category - (query-object-attribute (first (objects source-object-set)) 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 - ((source-object-set scene => target-category attribute) - (loop for attr in (get-data ontology 'attributes) - for target-cat = (query-object-attribute (first (objects source-object-set)) attr ontology) - when target-cat - do (bind (attribute 1.0 attr) - (target-category 1.0 target-cat)))) - - ;; fourth case; if given source-object, attribute and target-category, check - ;; for consistency - ((source-object-set attribute target-category scene =>) - (equal-entity target-category (query-object-attribute (first (objects source-object-set)) attribute ontology))) - :primitive-inventory *symbolic-primitives*) - diff --git a/applications/visual-dialog/primitives/relate.lisp b/applications/visual-dialog/primitives/symbolic/relate.lisp similarity index 93% rename from applications/visual-dialog/primitives/relate.lisp rename to applications/visual-dialog/primitives/symbolic/relate.lisp index f8e9569fc35174356be375c67a5da9f8d7d40e27..d10301d28e51cfd431d7717fcaa2af6cfe3cdbab 100644 --- a/applications/visual-dialog/primitives/relate.lisp +++ b/applications/visual-dialog/primitives/symbolic/relate.lisp @@ -5,12 +5,12 @@ ;; ------------------ (defprimitive relate ((target-set world-model) - (source-object-set object-set) + (source-world-model world-model) (segmented-scene world-model) (scene pathname-entity) (spatial-relation spatial-relation-category)) ;; first case; given source-object and spatial relation, compute the target set - ((source-object-set spatial-relation segmented-scene scene => target-set) + ((source-world-model spatial-relation segmented-scene scene => target-set) (let* (;(context (get-data ontology 'context)) ;(context (cdr (find (pathname scene) (get-data ontology 'segmented-scene) :test #'equal :key #'first))) (context segmented-scene) @@ -19,8 +19,7 @@ (id-right nil) (object-right nil) (object-list) - (source-object (first (objects source-object-set)))) - + (source-object (first (collect-objects-from-world-model source-world-model)))) (cond ((eql (spatial-relation spatial-relation) 'right) (setf relation-list (immediate-right (scene-configuration (object-set (first (set-items context))))))) ((eql (spatial-relation spatial-relation) 'left) diff --git a/applications/visual-dialog/primitives/segment-scene.lisp b/applications/visual-dialog/primitives/symbolic/segment-scene.lisp similarity index 56% rename from applications/visual-dialog/primitives/segment-scene.lisp rename to applications/visual-dialog/primitives/symbolic/segment-scene.lisp index 452500a32312b11e40c8d23095ae3989bc6055e2..7beae4785f43632f719b52bf82d273518ef93cfb 100644 --- a/applications/visual-dialog/primitives/segment-scene.lisp +++ b/applications/visual-dialog/primitives/symbolic/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/primitives/unique.lisp b/applications/visual-dialog/primitives/unique.lisp deleted file mode 100644 index 9d1bc036301977e7b7f82994315b65ecd853feb5..0000000000000000000000000000000000000000 --- a/applications/visual-dialog/primitives/unique.lisp +++ /dev/null @@ -1,21 +0,0 @@ -(in-package :visual-dialog) - -;; ------------------ -;; UNIQUE primtive ;; -;; ------------------ - -(defprimitive unique ((target-object-set object-set) - (source-set world-model)) - ;; first case; given source set, compute target object - ((source-set => target-object-set) - (if (length= (objects (object-set (first (set-items source-set)))) 1) - (bind (target-object-set 1.0 (make-instance 'object-set :objects (list (first (objects (object-set (first (set-items source-set))))))))))) - - ;; second case; given source set and target object - ;; check for consistency - ((source-set target-object-set =>) - (and (length= (objects (object-set (first (set-items source-set)))) 1) - (equal-entity target-object-set (first (objects (object-set (first (set-items source-set)))))))) - :primitive-inventory *symbolic-primitives*) - - diff --git a/applications/visual-dialog/start.lisp b/applications/visual-dialog/start.lisp index a0301beb54a3fcd1adcf5af3ac7659a9bedf03ba..cec6a081707698d16fbd637e8d663a81ae10fde7 100644 --- a/applications/visual-dialog/start.lisp +++ b/applications/visual-dialog/start.lisp @@ -1,7 +1,7 @@ ;(ql:quickload :visual-dialog) (in-package :visual-dialog) -(activate-monitor trace-fcg) +(monitors:activate-monitor trace-fcg) (activate-monitor trace-irl) (monitors::deactivate-all-monitors) @@ -16,12 +16,10 @@ ;; evaluation experiments -(evaluate-mnist-dialogs-symbolic 10 20) +(evaluate-mnist-dialogs-symbolic 41 41) (evaluate-clevr-dialogs-symbolic 50 60) -(evaluate-clevr-dialogs-symbolic 75 75) - -(understand "does the earlier brown object have objects to its right") +(evaluate-clevr-dialogs-symbolic 250 250) ;; evaluate one dialog @@ -35,8 +33,49 @@ (:datasplit . :train) (:mode . :symbolic)))) -(evaluate-dialog :scene-index 75 :dialog-index 2 :world *world* :ontology *ontology* :silent nil) -(evaluate-dialog :scene-index 0 :dialog-index 0 :world *world* :ontology *ontology* :silent nil) +(evaluate-dialog :scene-index 66796 :dialog-index 0 :world *world* :ontology *ontology* :silent nil) +(evaluate-dialog :scene-index 31538 :dialog-index 4 :world *world* :ontology *ontology* :silent nil) +(evaluate-dialog :scene-index 20204 :dialog-index 0 :world *world* :ontology *ontology* :silent nil) +(evaluate-dialog :scene-index 25070 :dialog-index 2 :world *world* :ontology *ontology* :silent nil) + +(evaluate-dialog :scene-index 35111 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 16681 :dialog-index 3 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 57455 :dialog-index 1 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 57466 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 32286 :dialog-index 3 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 18195 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 58387 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 17239 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 17262 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 39916 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 54623 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 65088 :dialog-index 1 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 44965 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 6302 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 62849 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 55271 :dialog-index 1 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 6404 :dialog-index 3 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 42805 :dialog-index 0 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 4569 :dialog-index 0 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 28384 :dialog-index 4 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 31418 :dialog-index 0 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 36944 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 36973 :dialog-index 0 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 30415 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 35839 :dialog-index 0 :world *world* :ontology *ontology* :silent nil); + +(evaluate-dialog :scene-index 61079 :dialog-index 2 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 2376 :dialog-index 1 :world *world* :ontology *ontology* :silent nil); +(evaluate-dialog :scene-index 43943 :dialog-index 3 :world *world* :ontology *ontology* :silent nil) + + (average '((1 1 1) (0 1 1))) (understand "how about that sphere") @@ -48,14 +87,54 @@ (understand "the picture has multiple cyan things") (understand "what number of things behind that metal thing") +` + +(setf *scene-pathname* (get-scene-pathname-by-index 0 *world*)) +(setf *ont* (initialize-agent-ontology-and-world *ontology* *world*)) +(setf *caption* (first *dialog*)) +(setf *questions* (rest *dialog*)) +(setf *memory* (understand-execute-remember-first-question *scene-pathname* *caption* *ont* :silent nil)) +(setf *answers* + (loop for question in *questions* + collect (understand-execute-remember *scene-pathname* question *memory* *ont* :silent nil))) + +(eql 1.0 1.0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; EVALUATION + +(collect-problematic-middle-scenes) + +(calculate-accuracy-from-dir "/Users/laraverheyen/Projects/Babel3/applications/visual-dialog/evaluation/results/CLEVR-SYMBOLIC/*") +(calculate-accuracy-from-dir "/Users/laraverheyen/Projects/Babel3/applications/visual-dialog/evaluation/results/MNIST-SYMBOLIC/*") +(collect-failed-dialogs "/Users/laraverheyen/Projects/Babel3/applications/visual-dialog/evaluation/results/CLEVR-SYMBOLIC/*") +(check-failed-dialogs (collect-failed-dialogs "/Users/laraverheyen/Projects/Babel3/applications/visual-dialog/evaluation/results/CLEVR-SYMBOLIC/*") + "/Users/laraverheyen/Projects/Babel3/applications/visual-dialog/evaluation/scenes-with-multiple-middles.lisp") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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)))) + (define-configuration-default-value :world :clevr) diff --git a/applications/visual-dialog/visual-dialog.asd b/applications/visual-dialog/visual-dialog.asd index 6778607b8dfc3bd17b79359d38340d0a7400596b..5e4faba89b5070b6ce405a12be384de4107f0274 100644 --- a/applications/visual-dialog/visual-dialog.asd +++ b/applications/visual-dialog/visual-dialog.asd @@ -12,8 +12,9 @@ :cl-json :trivial-timeout :clevr-dialog-grammar - :nao-interface - :robot-interface) + :jonathan + :drakma + ) :serial t :components ((:file "package") (:module "ontology" @@ -27,27 +28,40 @@ (:file "initialize-memory") (:file "run-dialogs") (:file "understand-execute-remember") - (:file "update-memory"))) + (:file "update-memory") + (:file "server-utils"))) (:module "primitives" :serial t - :components ((:file "count-objects") - (:file "exist-or-count") - (:file "exists") - (:file "extreme-relate") - (:file "filter") - (:file "find-in-context") - (:file "get-last-attribute-category") - (:file "get-last-topic") - (:file "get-penultimate-topic") - (:file "immediate-relate") - (:file "more-than-one") - (:file "query") - (:file "relate") - (:file "segment-scene") - (:file "select-one") - (:file "set-diff") - (:file "unique"))) - (:module "evaluation" + :components ((:module "both" + :serial t + :components ((:file "count-objects") + (:file "exist-or-count") + (:file "exists") + (:file "find-in-context") + (:file "get-last-attribute-category") + (:file "get-last-topic") + (:file "get-penultimate-topic") + (:file "more-than-one") + (:file "select-one") + (:file "set-diff") + (:file "unique"))) + (:module "subsymbolic" + :serial t + :components ((:file "extreme-relate") + (:file "filter") + (:file "immediate-relate") + (:file "query") + (:file "relate") + (:file "segment-scene"))) + (:module "symbolic" + :serial t + :components ((:file "extreme-relate") + (:file "filter") + (:file "immediate-relate") + (:file "query") + (:file "relate") + (:file "segment-scene"))))) + (:module "evaluation" :serial t :components ((:file "evaluation"))) (:file "html"))) \ No newline at end of file diff --git a/experiments/grammar-learning/clevr/test.lisp b/experiments/grammar-learning/clevr/test.lisp index 8d38f51786f589c53cbce50f7f735750dd2522fb..31ff8c77551b9f15086b9527367bf21372c39b45 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) @@ -64,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*))))) @@ -75,50 +76,13 @@ ;;; test series of interactions ;(run-series *experiment* (length (question-data *experiment*))) -;(run-series *experiment* 800) +;(run-series *experiment* 1000) + + + #| +TODO: +- optimisation: save the comprehend-all result, retrieve it if the sentence matches, see categorial-links repair + -QUESTIONS ---------- - -NOTES ------- -use original-cxn everywhere, except in fcg apply (uses processing-cxn) - -NOOIT AVERAGEN OVER SERIES! Error bars gebruiken bijv 75 25= indicatie van variantie - -ISSUES ------- - -TODO ----- -- for holistic to item-based, use fcg-apply for all holistic cxns, then create item-based cxn from whatever is in root -- get them all, then sort by longest, then look for conflicts between them: - eg. utterance: what is the shape of the yellow object? - matched: shape, yellow object, object, shape of the yellow - sort: shape of the yellow, yellow object, object, shape - number of collisions = 3: - shape of the yellow vs yellow object - shape of the yellow vs shape - yellow object vs object - - try: shape of the yellow, object ok, => remove all collisions from Q, create new Q with alternatives, break symmetry by doing set diff - shape of the yellow, ok - object: ok - uncovered = length of what is left in root = what is the = 3 - try: yellow object, shape - -voorbeeld: -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 -step 2: try longest first: - what is the color of the : uncovered = 1, collisions: what is the, color of the cube -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 -- reverse exported jsonl graph - -|# +|# \ No newline at end of file diff --git a/experiments/multidimensional-word-meanings/world.lisp b/experiments/multidimensional-word-meanings/world.lisp index 7d22ec57bd4a57debfdda1c27983b547f8a99176..d0ce32fc806b23ed43e43fc4f860124ae5dbc840 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 diff --git a/experiments/spatial-concept-game/.gitignore b/experiments/spatial-concept-game/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..8b3d46b966b344769cd0b890b12f6a3bca3fae2d --- /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 0000000000000000000000000000000000000000..304e1508987e5466541215dc6b96f5876caed590 --- /dev/null +++ b/experiments/spatial-concept-game/agent.lisp @@ -0,0 +1,204 @@ +(in-package :spatial-concepts) + +;; ------------- +;; + SPATIAL 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) + (pointed-object + :documentation "The object the tutor points to in production" + :type spatial-object :accessor pointed-object :initform nil)) + (:documentation "The agent class")) + +;; --------------------------- +;; + Agent utility functions + +;; --------------------------- +(defmethod speakerp ((agent spatial-agent)) + (eql (discourse-role agent) 'speaker)) + +(defmethod hearerp ((agent spatial-agent)) + (eql (discourse-role agent) 'hearer)) + +(defmethod learnerp ((agent spatial-agent)) + (eql (id agent) 'learner)) + +(defmethod tutorp ((agent spatial-agent)) + (eql (id agent) 'tutor)) + +(defun make-tutor-agent (experiment) + (make-instance 'spatial-agent :id 'tutor + :experiment experiment)) + +(defun make-learner-agent (experiment) + (make-instance 'spatial-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 spatial-agent)) + +(defgeneric conceptualise (agent) + (:documentation "run conceptualisation")) + +(defmethod conceptualise ((agent spatial-agent)) + (loop while t + for succes = (run-conceptualisation agent) + if succes return succes + else do (sample-topic (experiment agent)))) + +(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 (shuffle object-relations) + if (and (member (id topic) (cdr relationship)) + (= (length (cdr relationship)) 1)) + return (car relationship)) + when discriminative-relationship + do (progn + (set-data agent 'tutor-conceptualisation discriminative-relationship) + (setf (pointed-object agent) (clevr->simulated object)) + (return)))) + + +;; -------------- +;; + Production + +;; -------------- +(define-event production-finished (agent spatial-agent)) + +(defgeneric produce-word (agent) + (:documentation "Produce an utterance")) + +(defmethod produce-word ((agent spatial-agent)) + (setf (utterance agent) + (downcase + (mkstr + (get-data agent 'tutor-conceptualisation)))) + (notify production-finished agent) + (utterance agent)) + +;; ----------- +;; + Parsing + +;; ----------- +(define-event parsing-finished (agent spatial-agent)) + +(defgeneric parse-word (agent) + (:documentation "Parse an utterance")) + +(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))) + (notify parsing-finished agent) + (find-data agent 'applied-concept)) + +;; ------------------ +;; + Interpretation + +;; ------------------ +(define-event interpretation-finished (agent spatial-agent)) + +(defgeneric interpret (agent) + (:documentation "Interpret a meaning")) + +(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." + (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 (pointed-object agent)) + 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))) + (when duplicatesp + (format t "stop here")) + (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 spatial-agent) (hearer spatial-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 0000000000000000000000000000000000000000..cda29b11e5b306344ef9bc2a87012772b342e114 --- /dev/null +++ b/experiments/spatial-concept-game/alignment.lisp @@ -0,0 +1,203 @@ +(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 spatial-agent) (topic spatial-object) word) + (let ((new-concept + (make-concept word (attributes topic) + (get-configuration agent :initial-certainty) + (pointed-object agent)))) + (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 (pointed-object agent)) + 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 spatial-agent) (topic spatial-object) (concept concept)) + ;; 1. update the prototypical values + (loop for prototype in (meaning concept) + 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 + (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 spatial-agent) (topic spatial-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 0000000000000000000000000000000000000000..857765f960e9d24205337b25ef1f7e8cffc2c87f --- /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 0000000000000000000000000000000000000000..026f3e061f613aa27bf0ab58b110fbfe726e9112 --- /dev/null +++ b/experiments/spatial-concept-game/concept.lisp @@ -0,0 +1,225 @@ +(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 pointed-object) + (make-instance 'concept + :form form + :meaning (loop for (attribute . proto-value) in attribute-proto-cons + 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)))))) + + +(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 pointed-object) + (:documentation "Update the category based on the object")) + +(defmethod update-prototype ((prototype prototype) + (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 (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)) + (new-M2 (+ (M2 prototype) (* delta-1 delta-2)))) + (setf (value prototype) new-prototypical-value + (M2 prototype) new-M2) + prototype)) + + +(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) (pointed-object spatial-object)) + (loop for prototype in (meaning concept) + for similarity = (similarity object prototype pointed-object) + collect (* (certainty prototype) similarity) into weighted-similarities + finally (return (average weighted-similarities)))) + + +(defgeneric similarity (object prototype pointed-object) + (:documentation "Similarity on the level of a single prototype")) + +(defmethod similarity ((object spatial-object) (prototype prototype) (pointed-object spatial-object)) + (let* ((max-z-score 2) + (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))) + + +(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 0000000000000000000000000000000000000000..fd5f711898be36ab63aec36b310c9134b64b55a1 --- /dev/null +++ b/experiments/spatial-concept-game/experiment.lisp @@ -0,0 +1,89 @@ +(in-package :spatial-concepts) + +;; ------------------ +;; + Configurations + +;; ------------------ + +;; :simulated - :extracted +(define-configuration-default-value :world-type :simulated) + +(define-configuration-default-value :dot-interval 100) +(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 :determine-interacting-agents-mode :tutor-speaks) +(define-configuration-default-value :alignment-filter :all) ; :none - :at-least-one - :all + +;; -------------- +;; + Experiment + +;; -------------- +(defclass spatial-experiment (experiment) + () + (:documentation "The experiment class")) + +(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))) + ;; reset *clevr-data-path* to root directory of clevr data + ;; this will be used to load the 'clevr-world below + (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 "val"))) + ;; store the data-sets and data-path in the blackboard + (set-data experiment :ns-vqa-data-path (merge-pathnames (make-pathname + :directory `(:relative "CLEVR-v1.0" "scenes" "val")) cl-user:*babel-corpora*))) + + +(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 spatial-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 spatial-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 spatial-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 0000000000000000000000000000000000000000..87cdc761b0c397b9d7555119d7542fdf09e3bdc0 --- /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 0000000000000000000000000000000000000000..f0efde2bc0d47e36c06e82c1060226a8417083c0 --- /dev/null +++ b/experiments/spatial-concept-game/html.lisp @@ -0,0 +1,28 @@ +(in-package :spatial-concepts) + +;; 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 spatial-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 spatial-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 0000000000000000000000000000000000000000..9c5a9c4d3dbb8c3467ddd56d4ca46db6ee9e3ae6 --- /dev/null +++ b/experiments/spatial-concept-game/interaction.lisp @@ -0,0 +1,140 @@ +(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 (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 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) + (y-pos object))))) + (objects symbolic-clevr-context)))) + +(defgeneric before-interaction (experiment) + (:documentation "Initialize the interaction")) + +(define-event context-determined (experiment spatial-experiment)) +(define-event topic-determined (experiment spatial-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 + ;; 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))) + (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 spatial-context) 1) + (progn + (loop for agent in (interacting-agents experiment) + do (set-data agent 'context spatial-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)) + (spatial-context (find-data agent 'context)) + (tried-topics (tried-topics interaction (name symbolic-clevr-context))) + (available-topics (set-difference (objects spatial-context) tried-topics))) + (if (null available-topics) + (progn + (sample-scene experiment) + (sample-topic experiment)) + (let* ((spatial-topic (random-elt available-topics)) + (tutor-topic + (case world-type + (: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 spatial-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 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 + 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 (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)) + (setf (communicated-successfully speaker) t + (communicated-successfully hearer) t))))) + +;;;; +;;;; Alignment +;;;; +(defgeneric after-interaction (experiment) + (:documentation "Finalize the interaction")) + +(defmethod after-interaction ((experiment spatial-experiment)) + (let ((tutor (tutor experiment)) + (learner (learner experiment))) + (when (find-data tutor 'tutor-conceptualisation) + (alignment learner (get-data learner 'topic) + (find-data learner 'applied-concept))))) + +;;;; +;;;; interact +;;;; +(defmethod interact ((experiment spatial-experiment) interaction &key) + ;; 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 0000000000000000000000000000000000000000..814614bdbd43bdd98a37bf8eccf6b95fb7a6efb6 --- /dev/null +++ b/experiments/spatial-concept-game/misc.lisp @@ -0,0 +1,98 @@ +(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))))) + (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" "spatial-concept-game" + "graphs" ,(downcase experiment-name) + ,(format nil "serie-~a" serie))) + (babel-pathname + :directory `("experiments" "spatial-concept-game" + "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" "spatial-concept-game" + "store" ,(downcase experiment-name) + ,(format nil "serie-~a" serie))) + (babel-pathname + :directory `("experiments" "spatial-concept-game" + "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 0000000000000000000000000000000000000000..62b692ba65250d8a3bf4e34cc8ce5e461a75264b --- /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" "spatial-concept-game" "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" "spatial-concept-game" "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" "spatial-concept-game" "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" "spatial-concept-game" "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 '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")) + +;;;; 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" "spatial-concept-game" "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 'spatial-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" "spatial-concepts-game" + "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 0000000000000000000000000000000000000000..829df8f8b8835a113852c9e2a101b3dff25622ea --- /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 0000000000000000000000000000000000000000..91d02ff66793cf5c7891feffc094adf51e7fd260 --- /dev/null +++ b/experiments/spatial-concept-game/run.lisp @@ -0,0 +1,302 @@ + +(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 *simulated* + (make-configuration + :entries '((:world-type . :simulated) + (:alignment-filter . :all)))) + +(defparameter *extracted* + (make-configuration + :entries '((:world-type . :extracted) + (:alignment-filter . :all)))) + + +;;;; EXPERIMENT +(defparameter *experiment* + (make-instance 'spatial-experiment + :configuration *simulated*)) + +(run-interaction *experiment*) + +(run-series *experiment* 300) + +(display-lexicon (find 'learner (population *experiment*) :key #'id)) + +;; --------------------------------- +;; + Running series of experiments + +;; --------------------------------- + +(run-experiments `( + (test + ((:world-type . :simulated) + (:determine-interacting-agents-mode . :default) + (:alignment-filter . :all))) + ) + :number-of-interactions 2500 + :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 + '((:world-type . :simulated)) + :nr-of-interactions 2500) + +(create-learner-failed-conceptualisation-graph + :configurations + '((:world-type . :simulated)) + :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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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" "spatial-concept-game" + "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 0000000000000000000000000000000000000000..be395802d6c363e5d9b2bf5bb4284d7789019856 --- /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 0000000000000000000000000000000000000000..14f7a4e7671c84166689f075c6e33caf8bb40af3 --- /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 '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" "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 + &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" "spatial-concept-game" + "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" "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")) + +(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" "spatial-concept-game" + "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" "spatial-concept-game" "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 0000000000000000000000000000000000000000..9b3c70b8f9c6e9b111204d0797717d5d2a8f2e7f --- /dev/null +++ b/experiments/spatial-concept-game/web-demo.lisp @@ -0,0 +1,138 @@ +;(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) + (:data-sets . ("val"))))) + (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.")) + (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) + (: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 0000000000000000000000000000000000000000..b8b948eecdcd4121af43c5ccef4bb41c48a19249 --- /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 points to object:")) + (add-element + `((h3) ((i) ,(format nil "~a" + (id (pointed-object agent))))))) + ;; 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 spatial relation" + (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 0000000000000000000000000000000000000000..05fa3771801964074b38352ea2a377a4ee4b6c17 --- /dev/null +++ b/experiments/spatial-concept-game/world.lisp @@ -0,0 +1,213 @@ +(in-package :spatial-concepts) + +(export '(spatial-object)) + +;; -------------- +;; + SPATIAL object + +;; -------------- +(defclass spatial-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 spatial-object) attr) + (rest (assoc attr (attributes object)))) + +(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)) + `((: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)))))) + +;; ------------------ +;; + SPATIAL object set + +;; ------------------ +(defclass spatial-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 -> SPATIAL + +;; ---------------- + +(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 -> spatial +(defmethod clevr->simulated ((scene clevr-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 '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) + ) + :description (object->alist object))) + +;; --------- +;; + NOISE + +;; --------- +(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 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) + (set-attr-val object attr + (add-random-value-from-range val 0.0 amount))))) + +;; ------------------------ +;; + Continous CLEVR data + +;; ------------------------ + +(defun extracted->spatial-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 'spatial-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->spatial-object + (mapcar #'decode-json-from-string + (stream->list stream)))))) + (make-instance 'spatial-object-set + :id (make-id 'scene) + :objects objects))) diff --git a/grammars/clevr-dialog-grammar-new/relations.lisp b/grammars/clevr-dialog-grammar-new/relations.lisp index f11fd125cd84193e62a683ad48832e479731704b..a439133cab935cc684d6c982f52785f98ddd28dc 100644 --- a/grammars/clevr-dialog-grammar-new/relations.lisp +++ b/grammars/clevr-dialog-grammar-new/relations.lisp @@ -389,7 +389,7 @@ <- (?in-the-center-unit (HASH meaning ((bind spatial-relation-category ?relation center) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((string ?in-unit "in") (string ?the-unit "the") @@ -398,7 +398,10 @@ (?center-unit -- (number singular) - (lex-id center))) + (lex-id center)) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning center :string "in") :cxn-inventory *clevr-dialog*) @@ -483,7 +486,7 @@ (subunits (?relation-unit ?all-unit ?things-unit))) <- (?r-of-all-things-unit - (HASH meaning ((extreme-relate ?target ?source ?relation))) + (HASH meaning ((extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?rightmost-relation-unit ?all-unit) (meets ?all-unit ?things-unit)))) @@ -504,7 +507,10 @@ (HASH form ((string ?all-unit "all")))) (?things-unit -- - (HASH form ((string ?things-unit "things"))))) + (HASH form ((string ?things-unit "things")))) + (scene-unit + -- + (scene ?scene))) :cxn-inventory *clevr-dialog*) (def-fcg-cxn R-of-all-objects @@ -517,7 +523,7 @@ (subunits (?relation-unit ?all-unit ?things-unit))) <- (?r-of-all-things-unit - (HASH meaning ((extreme-relate ?target ?source ?relation))) + (HASH meaning ((extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?rightmost-relation-unit ?all-unit) (meets ?all-unit ?things-unit)))) @@ -538,7 +544,10 @@ (HASH form ((string ?all-unit "all")))) (?things-unit -- - (HASH form ((string ?things-unit "objects"))))) + (HASH form ((string ?things-unit "objects")))) + (scene-unit + -- + (scene ?scene))) :cxn-inventory *clevr-dialog*) (def-fcg-cxn at-the-extreme-right-cxn @@ -552,7 +561,7 @@ <- (?at-the-extreme-right-unit (HASH meaning ((bind spatial-relation-category ?relation right) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?at-unit ?the-unit) (meets ?the-unit ?extreme-unit) @@ -568,7 +577,10 @@ (HASH form ((string ?extreme-unit "extreme")))) (?right-unit -- - (HASH form ((string ?right-unit "right"))))) + (HASH form ((string ?right-unit "right")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning right :string "right") :cxn-inventory *clevr-dialog*) @@ -585,7 +597,7 @@ <- (?at-the-extreme-back-unit (HASH meaning ((bind spatial-relation-category ?relation behind) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?at-unit ?the-unit) (meets ?the-unit ?extreme-unit) @@ -601,7 +613,10 @@ (HASH form ((string ?extreme-unit "extreme")))) (?back-unit -- - (HASH form ((string ?back-unit "back"))))) + (HASH form ((string ?back-unit "back")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning behind :string "back") :cxn-inventory *clevr-dialog*) @@ -617,7 +632,7 @@ <- (?at-the-extreme-front-unit (HASH meaning ((bind spatial-relation-category ?relation front) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?at-unit ?the-unit) (meets ?the-unit ?extreme-unit) @@ -633,7 +648,10 @@ (HASH form ((string ?extreme-unit "extreme")))) (?front-unit -- - (HASH form ((string ?front-unit "front"))))) + (HASH form ((string ?front-unit "front")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning front :string "front") :cxn-inventory *clevr-dialog*) @@ -651,7 +669,7 @@ <- (?at-the-extreme-left-unit (HASH meaning ((bind spatial-relation-category ?relation left) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?at-unit ?the-unit) (meets ?the-unit ?extreme-unit) @@ -667,7 +685,10 @@ (HASH form ((string ?extreme-unit "extreme")))) (?left-unit -- - (HASH form ((string ?left-unit "left"))))) + (HASH form ((string ?left-unit "left")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning left :string "left") :cxn-inventory *clevr-dialog*) @@ -684,7 +705,7 @@ <- (?the-rightmost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation right) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?rightmost-unit) (meets ?rightmost-unit ?thing-unit)))) @@ -696,7 +717,10 @@ (HASH form ((string ?rightmost-unit "rightmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "thing"))))) + (HASH form ((string ?thing-unit "thing")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning right :string "rightmost") :cxn-inventory *clevr-dialog*) @@ -713,7 +737,7 @@ <- (?the-rearmost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation behind) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?rearmost-unit) (meets ?rearmost-unit ?thing-unit)))) @@ -725,7 +749,10 @@ (HASH form ((string ?rearmost-unit "rearmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "thing"))))) + (HASH form ((string ?thing-unit "thing")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning behind :string "rearmost") :cxn-inventory *clevr-dialog*) @@ -742,7 +769,7 @@ <- (?the-foremost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation front) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?foremost-unit) (meets ?foremost-unit ?thing-unit)))) @@ -754,7 +781,10 @@ (HASH form ((string ?foremost-unit "foremost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "thing"))))) + (HASH form ((string ?thing-unit "thing")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning front :string "foremost") :cxn-inventory *clevr-dialog*) @@ -771,7 +801,7 @@ <- (?the-leftmost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation left) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?leftmost-unit) (meets ?leftmost-unit ?thing-unit)))) @@ -783,7 +813,10 @@ (HASH form ((string ?leftmost-unit "leftmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "thing"))))) + (HASH form ((string ?thing-unit "thing")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning left :string "leftmost") :cxn-inventory *clevr-dialog*) @@ -800,7 +833,7 @@ <- (?the-rightmost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation right) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?rightmost-unit) (meets ?rightmost-unit ?thing-unit)))) @@ -812,7 +845,10 @@ (HASH form ((string ?rightmost-unit "rightmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "object"))))) + (HASH form ((string ?thing-unit "object")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning right :string "rightmost") :cxn-inventory *clevr-dialog*) @@ -829,7 +865,7 @@ <- (?the-rearmost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation behind) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?rearmost-unit) (meets ?rearmost-unit ?thing-unit)))) @@ -841,7 +877,10 @@ (HASH form ((string ?rearmost-unit "rearmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "object"))))) + (HASH form ((string ?thing-unit "object")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning behind :string "rearmost") :cxn-inventory *clevr-dialog*) @@ -858,7 +897,7 @@ <- (?the-foremost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation front) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?foremost-unit) (meets ?foremost-unit ?thing-unit)))) @@ -870,7 +909,10 @@ (HASH form ((string ?foremost-unit "foremost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "object"))))) + (HASH form ((string ?thing-unit "object")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning front :string "foremost") :cxn-inventory *clevr-dialog*) @@ -887,7 +929,7 @@ <- (?the-leftmost-thing-unit (HASH meaning ((bind spatial-relation-category ?relation left) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?leftmost-unit) (meets ?leftmost-unit ?thing-unit)))) @@ -899,7 +941,10 @@ (HASH form ((string ?leftmost-unit "leftmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "object"))))) + (HASH form ((string ?thing-unit "object")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning left :string "leftmost") :cxn-inventory *clevr-dialog*) @@ -912,12 +957,12 @@ (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 (HASH meaning ((bind spatial-relation-category ?relation center) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?midmost-unit) (meets ?midmost-unit ?thing-unit)))) (?the-unit @@ -928,7 +973,10 @@ (HASH form ((string ?midmost-unit "midmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "object"))))) + (HASH form ((string ?thing-unit "object")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning center :string "midmost") :cxn-inventory *clevr-dialog*) @@ -941,12 +989,12 @@ (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 (HASH meaning ((bind spatial-relation-category ?relation center) - (extreme-relate ?target ?source ?relation))) + (extreme-relate ?target ?source ?scene ?relation))) -- (HASH form ((meets ?the-unit ?midmost-unit) (meets ?midmost-unit ?thing-unit)))) (?the-unit @@ -957,7 +1005,10 @@ (HASH form ((string ?midmost-unit "midmost")))) (?thing-unit -- - (HASH form ((string ?thing-unit "thing"))))) + (HASH form ((string ?thing-unit "thing")))) + (scene-unit + -- + (scene ?scene))) :attributes (:meaning center :string "midmost") :cxn-inventory *clevr-dialog*) diff --git a/grammars/german_cases/bidirectional_grammar.fcg b/grammars/german_cases/bidirectional_grammar.fcg new file mode 100644 index 0000000000000000000000000000000000000000..d3de5d0a35385904d029a5e83ef4f610e9b436fa --- /dev/null +++ b/grammars/german_cases/bidirectional_grammar.fcg @@ -0,0 +1,1867 @@ +;; 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 + (footprints (article))) + <- + (?to-word + (footprints (not article)) + (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 + (footprints (article))) + <- + (?to-word + (footprints (not article)) + (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 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 + (- - - - -) ;genitive feminine + (+ ?dm - ?dn -) + (+ ?dm - ?dn -)))) + -- + (HASH form ((string ?at-word "beim")))))) + + +(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 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))) + <- + (?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) + (type contracted)) + (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)) + (type non-contracted) + (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 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) + (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))) + (?agent-unit + (syn-cat (syn-role subject))) + (?patient-unit + (syn-cat (syn-role direct-object))) + <- + (?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) + (- - - - -) + (- - - - -) + (- - - - -) + (?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) + ) + + (?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))) + )) + + +(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) + (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) + (case ?case)) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (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 + + +;;;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))) + (?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))) + (type contracted)) + (referent ?arg4) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp))) + (type contracted)) + (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) + (type contracted)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase) + (type contracted)) + (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)) + + (?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) + (type non-contracted)) + (referent ?extra-info) + -- + (syn-cat (lex-class prep-phrase) + (case ?case) + (type non-contracted)) + (referent ?extra-info)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp))) + (type contracted)) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp))) + (type contracted)) + (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) + (type non-contracted)) + (boundaries (leftmost-unit ?leftmost-extra-info-unit) + (rightmost-unit ?rightmost-extra-info-unit)) + -- + (syn-cat (syn-role extra-information) + (lex-class prep-phrase) + (type non-contracted)) + (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) + (type contracted)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase) + (type contracted)) + (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 +(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 '((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 +))) + +;;; 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 +))) + +;;; der Mann geht ohne den Clown zur Arbeit ------>some issues (too general ?) +(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 '((fahren-01 f) (man m) (bike b) (work w) (arg0 f m) (arg1 f w) (extra-info f b) (topicalized m +))) + diff --git a/grammars/german_cases/bidirectional_grammar_full_corpus.fcg b/grammars/german_cases/bidirectional_grammar_full_corpus.fcg new file mode 100644 index 0000000000000000000000000000000000000000..05d24cbc32071b5b9e89699d8baebdfcdc194d50 --- /dev/null +++ b/grammars/german_cases/bidirectional_grammar_full_corpus.fcg @@ -0,0 +1,2548 @@ +;;;intransitive verb cxn and intransitive + extra info in comprehension conflix - the first applies before the second which occasionally is not applied +;;; 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-applicable-cxns :no-strings-in-root :connected-semantic-network :connected-structure) + (: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 + (footprints (article))) + <- + (?to-word + (footprints (not article)) + (syn-cat (lex-class contracted-preposition) + (type motion-locative-contracted) + (polarity +) + (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 + (footprints (article))) + <- + (?to-word + (footprints (not article)) + (syn-cat (lex-class contracted-preposition) + (type motion-locative-contracted) + (polarity +) + (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 beim-cxn + ((?at-word + (footprints (preposition))) + <- + (?at-word + (referent ?x) + (footprints (not preposition)) + (syn-cat (lex-class contracted-preposition) + (type stative-locative) + (polarity +) + (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))) + <- + (?against-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (polarity +) + (type motion-locative-end) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (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) + (polarity +) + (type motion-locative-path) + (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))) + <- + (?for-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (polarity +) + (type benefactive) + (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 + (referent ?x) + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (type accompanying) + (polarity -) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + (HASH meaning ((accompany-01 ?x) + (polarity ?x -))) + -- + (HASH form ((string ?without-word "ohne"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn mit-cxn + ((?with-word + + (footprints (preposition))) + <- + (?with-word + (referent ?x) + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (type accompanying) + (polarity positive) ;(polarity +) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?dm ?df ?dn ?dp)))) + (HASH meaning ((accompany-01 ?x) + (polarity ?x positive))) ;(polarity ?x +) + -- + (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) + (polarity +) + (type from-motion-locative) + (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 ?fl) ;set of values + (syn-cat (lex-class noun) ;sure nominative and masculine + (case ((?np - - - ?np) + (?ap - - - ?ap) + (?gp - - - ?gp) + (?dp - - - ?dp) + (- - - - +))) + (animacy inanimate))) + <- + (?flowers-word + (HASH meaning ((flowers ?fl))) + -- + (HASH form ((string ?flowers-word "Blumen")))))) + +(def-fcg-cxn Arbeit-cxn + ((?work-word + (referent ?w) + (syn-cat (lex-class noun) + (case ((?nf - ?nf - -) + (?af - ?af - -) + (?gf - ?gf - -) + (?df - ?df - -) + (+ - + - -))) + (animacy inanimate))) + <- + (?work-word + (HASH meaning ((work ?w))) + -- + (HASH form ((string ?work-word "Arbeit")))))) + +(def-fcg-cxn Frau-cxn + ((?woman-word + (referent ?w) + (syn-cat (lex-class noun) + (case ((?nf - ?nf - -) + (?af - ?af - -) + (?gf - ?gf - -) + (?df - ?df - -) + (+ - + - -))) + (animacy animate))) + <- + (?woman-word + (HASH meaning ((woman ?w))) + -- + (HASH form ((string ?woman-word "Frau")))))) + +(def-fcg-cxn Mann-cxn + ((?man-word + (referent ?m) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy animate))) + <- + (?man-word + (HASH meaning ((man ?m))) + -- + (HASH form ((string ?man-word "Mann")))))) + +(def-fcg-cxn Doktor-cxn + ((?doctor-word + (referent ?d) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy animate))) + <- + (?doctor-word + (HASH meaning ((doctor ?d))) + -- + (HASH form ((string ?doctor-word "Doktor")))))) + + + +(def-fcg-cxn Apfel-cxn + ((?apple-word + (referent ?a) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy inanimate))) + <- + (?apple-word + (HASH meaning ((apple ?a))) + -- + (HASH form ((string ?apple-word "Apfel")))))) + +(def-fcg-cxn Tunnel-cxn + ((?tunnel-word + (referent ?t) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy inanimate))) + <- + (?tunnel-word + (HASH meaning ((tunnel ?t))) + -- + (HASH form ((string ?tunnel-word "Tunnel")))))) + +(def-fcg-cxn Baum-cxn + ((?tree-word + (referent ?b) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy inanimate))) + <- + (?tree-word + (HASH meaning ((tree ?b))) + -- + (HASH form ((string ?tree-word "Baum")))))) + + +(def-fcg-cxn Fahrrad-cxn + ((?bike-word + (referent ?b) + (syn-cat (lex-class noun) + (case ((?nn - - ?nn -) + (?an - - ?an -) + (- - - - -) + (?dn - - ?dn -) + (+ - - + -))) + (animacy inanimate))) + <- + (?bike-word + (HASH meaning ((bike ?b))) + -- + (HASH form ((string ?bike-word "Fahrrad")))))) + + +(def-fcg-cxn Buch-cxn + ((?book-word + (referent ?b) + (syn-cat (lex-class noun) + (case ((?nn - - ?nn -) + (?an - - ?an -) + (- - - - -) + (?dn - - ?dn -) + (+ - - + -))) + (animacy inanimate))) + <- + (?book-word + (HASH meaning ((book ?b))) + -- + (HASH form ((string ?book-word "Buch")))))) + + +(def-fcg-cxn Shop-cxn + ((?shop-word + (referent ?s) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy inanimate))) + <- + (?shop-word + (HASH meaning ((shop ?s))) + -- + (HASH form ((string ?shop-word "Shop")))))) + + +(def-fcg-cxn Bäcker-cxn + ((?baker-word + (referent ?b) + (syn-cat (lex-class noun) + (case ((?nom ?nm - - ?np) + (?acc ?am - - ?ap) + (?pg - - - ?pg) + (?dm ?dm - - -) + (?s + - - ?p))) + (animacy animate))) + <- + (?baker-word + (HASH meaning ((baker ?b))) + -- + (HASH form ((string ?baker-word "Bäcker")))))) + + + +(def-fcg-cxn Clown-cxn + ((?clown-word + (referent ?c) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy animate))) + <- + (?clown-word + (HASH meaning ((clown ?c))) + -- + (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) + (animacy ?animacy)) + (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) + (animacy ?animacy)) + -- + (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) + (type ?type) + (polarity ?polarity) + (form-type contracted) + (animacy ?animacy)) + (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) + (type ?type) + (polarity ?polarity) + (case ?case))) + (?noun + (footprints (not determined)) + (referent ?x) + (syn-cat (lex-class noun) + (case ?case) + (animacy ?animacy)) + + -- + (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))) + (type ?type) + (form-type extended-prep-phrase) + (polarity ?polarity) + (animacy ?animacy)) + (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) + (type ?type) + (polarity ?polarity) + (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) + + +(def-fcg-cxn accompanying-phrase-cxn + ((?accompanying-phrase + (referent ?x) + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))) + (type accompanying) + (form-type extended-accompanying-prep-phrase) + (polarity ?polarity)) + (subunits (?preposition ?article ?noun)) + (boundaries (leftmost-unit ?preposition) + (rightmost-unit ?noun))) + (?preposition + (part-of-prep-phrase +)) + + (?article + (part-of-prep-phrase +)) + + (?noun + (footprints (determined))) + <- + + (?preposition + -- + (referent ?x) + (syn-cat (lex-class preposition) + (type accompanying) + (polarity ?polarity) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?article + -- + (syn-cat (lex-class article) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?noun + (referent ?no) + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p)))) + -- + (referent ?no) + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + + (?accompanying-phrase + (HASH meaning ((arg0 ?x ?no))) + -- + (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-origin)) + (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 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 spaziert-cxn + ((?walk-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive-path) + (arg path)) + (referent ?s)) + + <- + (?walk-word + (HASH meaning ((spazieren-01 ?s))) + -- + (HASH form ((string ?walk-word "spaziert")))))) + +(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 verkauft-cxn + ((?sell-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type ditransitive)) + (referent ?v)) + + <- + (?sell-word + (HASH meaning ((verkaufen-01 ?v))) + -- + (HASH form ((string ?sell-word "verkauft")))))) + +(def-fcg-cxn gibt-cxn + ((?give-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type ditransitive)) + (referent ?g)) + + <- + (?give-word + (HASH meaning ((geben-01 ?g))) + -- + (HASH form ((string ?give-word "gibt")))))) + + +(def-fcg-cxn ist-gefahren-cxn + ((?drove-word + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (aspect perfect) + (type single-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))) + (?agent-unit + (syn-cat (syn-role subject))) + (?patient-unit + (syn-cat (syn-role direct-object))) + <- + (?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) + (- - - - -) + (- - - - -) + (- - - - -) + (?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) + ) + + (?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) + (aspect non-perfect)) + (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 + +;;;;THIS SHOULD NOT APPLY ON SENTENCES WITH ONE EXTRA ARGUMENT (ACCOMPANIER) + +(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 ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp) + )) + (type motion-locative-contracted) + (form-type contracted) + (polarity ?polarity)) + (referent ?arg4) + -- + (syn-cat (lex-class prep-phrase) + (polarity ?polarity) + (form-type contracted) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp) + ))) + (referent ?arg4)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg4 ?v ?arg4))) + -- + ))) + +(def-fcg-cxn intransitive-origin-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-origin)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive-origin)) + (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 ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp) + )) + (type from-motion-locative) + (form-type extended-prep-phrase) + (polarity ?polarity)) + (referent ?arg3) + -- + (syn-cat (lex-class prep-phrase) + (polarity ?polarity) + (form-type extended-prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp) + ))) + (referent ?arg3)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg3 ?v ?arg3))) + -- + ))) + +(def-fcg-cxn intransitive-path-argument-structure-cxn + ((?intransitive-path-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-path) + (arg path)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive-path)) + (referent ?v)) + + (?agent-unit + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np))) + (animacy animate)) + (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) + (type motion-locative-path) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp) + )) + (form-type extended-prep-phrase) + (polarity ?polarity) + (animacy inanimate)) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (polarity ?polarity) + (form-type extended-prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp) + ))) + (referent ?arg2)) + + (?intransitive-path-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg2 ?v ?arg2))) + -- + ))) + + +(def-fcg-cxn topic-arg0-arg3-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-origin) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive-origin) + (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 topic-arg0-arg2-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-path) + (arg path) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive-path) + (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 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))) + )) + + +(def-fcg-cxn arg0-topic-arg3-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg3 +))) + + -- + (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-origin) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive-origin) + (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 ?arg3) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (referent ?arg3) + (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) + (form-type contracted) + (type stative-locative) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (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) + (type stative-locative)) + (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) + (type stative-locative) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (referent ?arg2) + (syn-cat (syn-role locative-complement) + (type stative-locative) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + +;;;VERBS PERFECT + +;der Mann ist gegen den Clown gefahren + +(def-fcg-cxn intransitive-argument-structure-perfect-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 single-intransitive) + (aspect perfect)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type single-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) + (type motion-locative-end) + (form-type extended-prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp)))) + (referent ?arg1)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1))) + -- + ))) + + +(def-fcg-cxn topic-arg0-arg1-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 single-intransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + + -- + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type single-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-perfect-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) + (type benefactive) + (form-type extended-prep-phrase) + (case ((- - - - -) + (+ ?bm ?bf ?bn ?bp) + (- - - - -) + (- - - - -) + (?bs ?bm ?bf ?bn ?bp)))) + (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 ?pp)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?pp)))) + (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 + + +;;;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 + +;;footprints + +(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) + (type accompanying)) + (referent ?accompany) + -- + (syn-cat (lex-class prep-phrase) + (case ?case) + (type accompanying)) + (referent ?accompany)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (type motion-locative-contracted) + (form-type contracted) + (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) + (:manner ?v ?accompany) + (:arg1 ?accompany ?arg0) + (: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))) + )) + + + +;der Mann fährt mit dem Fahrrad zur Arbeit + +(def-fcg-cxn intransitive-extra-arg1-structure-cxn + ((?intransitive-extra-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) + (aspect non-perfect)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type single-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) + (type accompanying) + ;(form-type extended-accompanying-prep-phrase) + ;(polarity +) + ) + (referent ?manner) + + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?manner)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (type motion-locative-contracted) + (form-type contracted) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg1)) + + (?intransitive-extra-arg1-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:manner ?v ?manner) + (:arg1 ?v ?arg1) + (:arg1 ?manner ?arg0) + )) + -- + ))) + +(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))) + )) + + + + + + + + +;;;;;;;;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 '((man x))) + +(comprehend-all "dem Shop") + +(formulate '((man x) (accompany-01 a) (polarity a -) (arg0 a x))) + +;(formulate-all '((bike x) (accompany-01 a) (polarity a +) (arg0 a x))) + +(formulate-all '((bike x) (accompany-01 a) (polarity a positive) (arg0 a x))) + +(comprehend-all "der Mann geht zum Shop") + +;;;; 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 '((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 g) (man m) (clown c) (flowers f) (arg0 g m) (arg1 g f) (arg2 g 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 +))) + +;;; die Frau gibt dem Mann den Apfel +(formulate '((geben-01 g) (woman w) (man m) (apple a) (arg0 g w) (arg1 g a) (arg2 g m) (topicalized w +))) + +;;; dem Mann gibt die Frau den Apfel +(formulate '((geben-01 g) (woman w) (man m) (apple a) (arg0 g w) (arg1 g a) (arg2 g m) (topicalized m +))) + +;;;der Doktor verkauft dem Clown das Buch +(formulate '((verkaufen-01 s) (doctor d) (clown c) (book b) (arg0 s d) (arg1 s b) (arg2 s c) (topicalized d +))) + +;;;dem Clown verkauft der Doktor das Buch +(formulate '((verkaufen-01 s) (doctor d) (clown c) (book b) (arg0 s d) (arg1 s b) (arg2 s c) (topicalized c +))) + +;;;der Mann geht zur Arbeit +(formulate '((gehen-01 g) (man m) (arg0 g m) (work w) (arg4 g w) (topicalized m +))) +(formulate '((gehen-01 g) (man m) (arg0 g m) (shop w) (arg4 g w) (topicalized m +))) + +; zum Shop geht der Mann +(formulate '((gehen-01 g) (man m) (arg0 g m) (shop w) (arg4 g w) (topicalized w +))) + +;;;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 +))) + +;;; der Mann kommt aus dem Backer +(formulate-all '((kommen-01 k) (man m) (baker b) (arg0 k m) (arg3 k b) (topicalized m +))) + +;;; der Mann spaziert durch den Tunnel +(formulate-all '((MAN ?M) (TUNNEL ?T) (SPAZIEREN-01 ?S) (ARG2 ?S ?T) (ARG0 ?S ?M) (TOPICALIZED ?M +))) + +;;; der Mann ist gegen den Baum gefahren +(formulate-all '((tree b) (man m) (drove-01 ig) (arg1 ig b) (arg0 ig m) (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 '((man m) (work w) (clown c) (accompany-01 a) (polarity a -) (arg0 a c) (arg1 a m) (gehen-01 g) (arg0 g m) (arg4 g w) (manner g a) (topicalized m +))) + +;;der Mann fährt mit dem Fahrrad zur Arbeit---stuck in formulation because of + of accompany and something else... +;(formulate '((bike b) (work w) (man m) (fahren-01 f) (manner f a) (arg0 f m) (arg1 f w) (topicalized m +) (accompany-01 a) (arg0 a b) (arg1 a m) (polarity a +))) + +(formulate '((bike b) (work w) (man m) (fahren-01 f) (manner f a) (arg0 f m) (arg1 f w) (topicalized m +) (accompany-01 a) (arg0 a b) (arg1 a m) (polarity a positive))) + + +;;der Mann fährt ohne das Fahrrad zur Arbeit +(formulate '((ACCOMPANY-01 A) (POLARITY A -) (WORK W) (MAN M) (BIKE B) (ARG0 A B) (FAHREN-01 F) (ARG1 A M)(ARG1 F W) (MANNER F A) (ARG0 F M) (TOPICALIZED M +))) + + + + +;;;;;;errors formulation + +;Prepositional Dative + + + +;Indirect accusative + + +;Double Object + diff --git a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg index 85d9e11be1cfc6059eebc420e00dfe520ab41c15..d927ad9db648e0ef46dc76d8a3ecaa69d714107d 100644 --- a/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg +++ b/grammars/german_cases/bidirectional_grammar_info_arg_struct.fcg @@ -1,22 +1,21 @@ - +;;;intransitive verb cxn and intransitive + extra info in comprehension conflix - the first applies before the second which occasionally is not applied +;;; 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) - (constituents sequence) - (dependents sequence) + (subunits set) (footprints set) (case sequence)) - :hierarchy-features (constituents dependents) - :fcg-configurations ((:max-nr-of-nodes . 10000) - (:parse-goal-tests :no-strings-in-root :connected-structure :no-applicable-cxns) + :fcg-configurations ((:max-nr-of-nodes . 40000) + (:parse-goal-tests :no-applicable-cxns :no-strings-in-root :connected-semantic-network :connected-structure) (:production-goal-tests :no-applicable-cxns :connected-structure :no-meaning-in-root))) -;(comprehend "den Mann") -(formulate-all '((shop x))) - +;;;;DETERMINERS (def-fcg-cxn der-cxn ((?the-word @@ -70,6 +69,7 @@ (HASH form ((string ?the-word "die"))))) :disable-automatic-footprints t) + (def-fcg-cxn den-cxn ((?the-word (footprints (article))) @@ -87,6 +87,7 @@ (HASH form ((string ?the-word "den"))))) :disable-automatic-footprints t) + (def-fcg-cxn das-cxn ((?the-word (footprints (article))) @@ -105,12 +106,33 @@ :disable-automatic-footprints t) +(def-fcg-cxn zur-cxn + ((?to-word + (footprints (article))) + <- + (?to-word + (footprints (not article)) + (syn-cat (lex-class contracted-preposition) + (type motion-locative-contracted) + (polarity +) + (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 + (footprints (article))) + <- (?to-word - (syn-cat (lex-class contracted-preposition) + (footprints (not article)) + (syn-cat (lex-class contracted-preposition) + (type motion-locative-contracted) + (polarity +) (case ((- - - - -) ;nom, acc, gen, dat (nom masculine) (- - - - -) ;masc, fem, neut, plural (- - - - -) ;genitive feminine @@ -119,79 +141,276 @@ -- (HASH form ((string ?to-word "zum")))))) + +(def-fcg-cxn beim-cxn + ((?at-word + (footprints (preposition))) + <- + (?at-word + (referent ?x) + (footprints (not preposition)) + (syn-cat (lex-class contracted-preposition) + (type stative-locative) + (polarity +) + (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))) + <- + (?against-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (polarity +) + (type motion-locative-end) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + -- + (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) + (polarity +) + (type motion-locative-path) + (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))) + <- + (?for-word + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (polarity +) + (type benefactive) + (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 + (referent ?x) + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (type accompanying) + (polarity -) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?as ?am ?af ?an ?ap)))) + (HASH meaning ((accompany-01 ?x) + (polarity ?x -))) + -- + (HASH form ((string ?without-word "ohne"))))) + :disable-automatic-footprints t) + +(def-fcg-cxn mit-cxn + ((?with-word + + (footprints (preposition))) + <- + (?with-word + (referent ?x) + (footprints (not preposition)) + (syn-cat (lex-class preposition) + (type accompanying) + (polarity positive) ;(polarity +) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?dm ?df ?dn ?dp)))) + (HASH meaning ((accompany-01 ?x) + (polarity ?x positive))) ;(polarity ?x +) + -- + (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 +) + (polarity +) + (type from-motion-locative) (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) + + +;;;;NOUNS (def-fcg-cxn Blumen-cxn ((?flowers-word - (referent ?x) ;set of values + (referent ?fl) ;set of values (syn-cat (lex-class noun) ;sure nominative and masculine (case ((?np - - - ?np) (?ap - - - ?ap) (?gp - - - ?gp) (?dp - - - ?dp) - (- - - - +))))) + (- - - - +))) + (animacy inanimate))) <- (?flowers-word - (HASH meaning ((flowers ?x))) + (HASH meaning ((flowers ?fl))) -- (HASH form ((string ?flowers-word "Blumen")))))) +(def-fcg-cxn Arbeit-cxn + ((?work-word + (referent ?w) + (syn-cat (lex-class noun) + (case ((?nf - ?nf - -) + (?af - ?af - -) + (?gf - ?gf - -) + (?df - ?df - -) + (+ - + - -))) + (animacy inanimate))) + <- + (?work-word + (HASH meaning ((work ?w))) + -- + (HASH form ((string ?work-word "Arbeit")))))) (def-fcg-cxn Mann-cxn ((?man-word - (referent ?x) + (referent ?m) (syn-cat (lex-class noun) (case ((?nm ?nm - - -) (?am ?am - - -) (- - - - -) (?dm ?dm - - -) - (+ + - - -))))) + (+ + - - -))) + (animacy animate))) <- (?man-word - (HASH meaning ((man ?x))) + (HASH meaning ((man ?m))) -- (HASH form ((string ?man-word "Mann")))))) +(def-fcg-cxn Tunnel-cxn + ((?tunnel-word + (referent ?t) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy inanimate))) + <- + (?tunnel-word + (HASH meaning ((tunnel ?t))) + -- + (HASH form ((string ?tunnel-word "Tunnel")))))) + +(def-fcg-cxn Baum-cxn + ((?tree-word + (referent ?b) + (syn-cat (lex-class noun) + (case ((?nm ?nm - - -) + (?am ?am - - -) + (- - - - -) + (?dm ?dm - - -) + (+ + - - -))) + (animacy inanimate))) + <- + (?tree-word + (HASH meaning ((tree ?b))) + -- + (HASH form ((string ?tree-word "Baum")))))) + + +(def-fcg-cxn Fahrrad-cxn + ((?bike-word + (referent ?b) + (syn-cat (lex-class noun) + (case ((?nn - - ?nn -) + (?an - - ?an -) + (- - - - -) + (?dn - - ?dn -) + (+ - - + -))) + (animacy inanimate))) + <- + (?bike-word + (HASH meaning ((bike ?b))) + -- + (HASH form ((string ?bike-word "Fahrrad")))))) + + (def-fcg-cxn Shop-cxn ((?shop-word - (referent ?x) + (referent ?sh) (syn-cat (lex-class noun) (case ((?nom ?nm - - ?np) (?am ?am - - -) (- - - - -) (?dm ?dm - - -) - (?sm + - - ?np))))) + (?s + - - ?np)))) + (animacy inanimate)) <- (?shop-word - (HASH meaning ((shop ?x))) + (HASH meaning ((shop ?sh))) -- (HASH form ((string ?shop-word "Shop")))))) (def-fcg-cxn Bäcker-cxn ((?baker-word - (referent (?x)) + (referent ?b) (syn-cat (lex-class noun) (case ((?nom ?nm - - ?np) (?acc ?am - - ?ap) (?pg - - - ?pg) (?dm ?dm - - -) - (?s + - - ?p))))) + (?s + - - ?p))) + (animacy animate))) <- (?baker-word - (HASH meaning ((baker ?x))) + (HASH meaning ((baker ?b))) -- (HASH form ((string ?baker-word "Bäcker")))))) @@ -199,26 +418,29 @@ (def-fcg-cxn Clown-cxn ((?clown-word - (referent ?x) + (referent ?c) (syn-cat (lex-class noun) (case ((?nm ?nm - - -) (?am ?am - - -) (- - - - -) (?dm ?dm - - -) - (+ + - - -))))) + (+ + - - -))) + (animacy animate))) <- (?clown-word - (HASH meaning ((clown ?x))) + (HASH meaning ((clown ?c))) -- (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)) - (constituents (?article ?noun)) + (case ?case) + (animacy ?animacy)) + (subunits (?article ?noun)) (boundaries (leftmost-unit ?article) (rightmost-unit ?noun))) (?article @@ -229,8 +451,6 @@ (footprints (determined))) <- (?article - - -- (syn-cat (lex-class article) (case ?case))) @@ -238,8 +458,8 @@ (footprints (not determined)) (referent ?x) (syn-cat (lex-class noun) - (case ?case)) - + (case ?case) + (animacy ?animacy)) -- (footprints (not determined)) (syn-cat (lex-class noun) @@ -255,8 +475,12 @@ ((?contracted-prep-phrase (referent ?x) (syn-cat (lex-class prep-phrase) - (case ?case)) - (constituents (?contracted-prep ?noun)) + (case ?case) + (type ?type) + (polarity ?polarity) + (form-type contracted) + (animacy ?animacy)) + (subunits (?contracted-prep ?noun)) (boundaries (leftmost-unit ?contracted-prep) (rightmost-unit ?noun))) (?contracted-prep @@ -268,59 +492,245 @@ (?contracted-prep -- (syn-cat (lex-class contracted-preposition) + (type ?type) + (polarity ?polarity) (case ?case))) (?noun (footprints (not determined)) (referent ?x) (syn-cat (lex-class noun) - (case ?case)) + (case ?case) + (animacy ?animacy)) -- (footprints (not determined)) (syn-cat (lex-class noun) (case ?case))) + (?contracted-prep-phrase -- (HASH form ((meets ?contracted-prep ?noun))) )) :disable-automatic-footprints t) -;(comprehend "zum Mann") -;(formulate '((aus x))) -(def-fcg-cxn prep-phrase-cxn +(def-fcg-cxn prepositional-phrase-cxn ((?prep-phrase (referent ?x) (syn-cat (lex-class prep-phrase) - (case ?case)) - (constituents (?preposition ?noun-phrase)) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (?gen ?gm ?gf ?gn ?gp) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))) + (type ?type) + (form-type extended-prep-phrase) + (polarity ?polarity) + (animacy ?animacy)) + (subunits (?preposition ?article ?noun)) (boundaries (leftmost-unit ?preposition) - (rightmost-unit ?leftmost-noun-phrase))) + (rightmost-unit ?noun))) (?preposition - (part-of-prep-phrase +) - (referent ?x)) - (?noun-phrase - (footprints (determined))) + ;(referent ?x) + (part-of-prep-phrase +)) + + (?article + (referent ?x) + ;(part-of-noun-phrase +)) + ) + + (?noun + (footprints (determined)) + ) <- + (?preposition + -- (syn-cat (lex-class preposition) - (case ?case))) - (?noun-phrase + (type ?type) + (polarity ?polarity) + (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) + + +(def-fcg-cxn accompanying-phrase-cxn + ((?accompanying-phrase (referent ?x) - -- - (syn-cat (lex-class noun-phrase) - (case ?case)) - (boundaries (leftmost-unit ?leftmost-noun-phrase) - (rightmost-unit ?rightmost-noun-phrase))) + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))) + (type accompanying) + (form-type extended-accompanying-prep-phrase) + (polarity ?polarity)) + (subunits (?preposition ?article ?noun)) + (boundaries (leftmost-unit ?preposition) + (rightmost-unit ?noun))) + (?preposition + (part-of-prep-phrase +)) - (?prep-phrase + (?article + (part-of-prep-phrase +)) + + (?noun + (footprints (determined))) + <- + + (?preposition + -- + (referent ?x) + (syn-cat (lex-class preposition) + (type accompanying) + (polarity ?polarity) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?article + -- + (syn-cat (lex-class article) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + (?noun + (referent ?no) + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p)))) + -- + (referent ?no) + (footprints (not determined)) + (syn-cat (lex-class noun) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?s ?m ?f ?n ?p))))) + + (?accompanying-phrase + (HASH meaning ((arg0 ?x ?no))) -- - (HASH form ((meets ?preposition ?leftmost-noun-phrase))) + (HASH form ((meets ?preposition ?article) + (meets ?article ?noun))) )) - :disable-automatic-footprints t) + :disable-automatic-footprints t) + + +;;;VERBS + +(def-fcg-cxn kommt-cxn + ((?come-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive-origin)) + (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 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 spaziert-cxn + ((?walk-word + (syn-cat (lex-class verb) + (aspect non-perfect) + (type intransitive) + (arg path)) + (referent ?s)) + + <- + (?walk-word + (HASH meaning ((spazieren-01 ?s))) + -- + (HASH form ((string ?walk-word "spaziert")))))) (def-fcg-cxn sucht-cxn ((?search-word @@ -349,38 +759,96 @@ (HASH form ((string ?gift-word "schenkt")))))) -(def-fcg-cxn transitive-argument-structure-cxn ;can be both topicalized and not (make topicalized -) - ((?transitive-argument-structure-unit - (constituents (?verb-unit ?agent-unit ?patient-unit)) - - ) +(def-fcg-cxn ist-gefahren-cxn + ((?drove-word + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (aspect perfect) + (type single-intransitive)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + (referent ?ig)) + <- - (?verb-unit + + (?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) - (type transitive) - (tense ?tense)) - (referent ?v) - -- - (syn-cat (lex-class verb) - (type transitive) - (tense ?tense)) - (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) + (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))) + (?agent-unit + (syn-cat (syn-role subject))) + (?patient-unit + (syn-cat (syn-role direct-object))) + <- + (?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) + (- - - - -) + (- - - - -) + (- - - - -) + (?as ?nm ?nf ?nn ?np)))) + (referent ?arg0) + -- + (syn-cat (lex-class noun-phrase) + (case ((+ ?nm ?nf ?nn ?np) (- - - - -) (- - - - -) (- - - - -) - (?s ?nm ?nf ?nn ?np)))) + (?as ?nm ?nf ?nn ?np)))) (referent ?arg0) ) @@ -390,7 +858,7 @@ (+ ?am ?af ?an ?ap) (- - - - -) (- - - - -) - (?s ?am ?af ?an ?ap)))) + (?ps ?am ?af ?an ?ap)))) (referent ?arg1) -- (syn-cat (lex-class noun-phrase) @@ -398,7 +866,7 @@ (+ ?am ?af ?an ?ap) (- - - - -) (- - - - -) - (?s ?am ?af ?an ?ap)))) + (?ps ?am ?af ?an ?ap)))) (referent ?arg1) ) @@ -408,64 +876,106 @@ -- ))) - -(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) - (tense ?tense)) + (aspect ?aspect)) (referent ?v) -- (syn-cat (lex-class verb) (type transitive) - (tense ?tense)) + (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)) -- - (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))) + + )) -;(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 +))) +;;;DITRANSITIVE VERBS +;der Mann schenkt dem Clown die Blumen -(def-fcg-cxn ditransitive-argument-structure-cxn ;can be both topicalized and not (make topicalized -) +(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 @@ -475,7 +985,8 @@ <- (?verb-unit (syn-cat (lex-class verb) - (type ditransitive)) + (type ditransitive) + (aspect non-perfect)) (referent ?v) -- (syn-cat (lex-class verb) @@ -483,7 +994,8 @@ (referent ?v)) (?agent-unit - (syn-cat (lex-class noun-phrase) + (syn-cat + (lex-class noun-phrase) (case ((+ ?nm ?nf ?nn ?np) (- - - - -) (- - - - -) @@ -500,7 +1012,8 @@ (referent ?arg0)) (?patient-unit - (syn-cat (lex-class noun-phrase) + (syn-cat + (lex-class noun-phrase) (case ((- - - - -) (+ ?am ?af ?an ?ap) (- - - - -) @@ -514,23 +1027,23 @@ (- - - - -) (- - - - -) (?ps ?am ?af ?an ?ap)))) - (referent ?arg1) - ) + (referent ?arg1)) (?receiver-unit - (syn-cat (lex-class noun-phrase) - (case ((- - - - -) - (- - - - -) - (- - - - -) - (+ ?dm ?df ?dn ?dp) - (?rs ?dm ?df ?dn ?dp)))) + (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)))) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?rs ?dm ?df ?dn ?dp)))) (referent ?arg2)) (?ditransitive-argument-structure-unit @@ -540,26 +1053,34 @@ -- ))) - -(def-fcg-cxn topicalized-ditransitive-information-structure-cxn +(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) - (aspect non-perfect)) + (type ditransitive)) -- (syn-cat (lex-class verb) - (type ditransitive) - (aspect non-perfect))) + (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))) @@ -578,12 +1099,61 @@ (syn-cat (syn-role indirect-object)) (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) + + (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) @@ -595,6 +1165,1267 @@ -;(formulate-all '((schenken-01 g) (man m) (arg0 g m) (clown c) (arg2 g c) (flowers f) (arg1 g f) (topicalized c))) +;MOTION VERBS + +;der Mann geht zur Arbeit + +;;;;THIS SHOULD NOT APPLY ON SENTENCES WITH ONE EXTRA ARGUMENT (ACCOMPANIER) + +#|(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 (type motion-locative-contracted) + (lex-class prep-phrase) + (form-type contracted) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp))) + ) + (referent ?arg4) + -- + (syn-cat + (type motion-locative-contracted) + (lex-class prep-phrase) + (form-type contracted) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg4)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg4 ?v ?arg4))) + -- + )))|# + +(def-fcg-cxn intransitive-origin-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-origin)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type intransitive-origin)) + (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 ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp) + )) + (type from-motion-locative) + (form-type extended-prep-phrase) + (polarity ?polarity)) + (referent ?arg3) + -- + (syn-cat (lex-class prep-phrase) + (polarity ?polarity) + (form-type extended-prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?m ?f ?n ?lp) + ))) + (referent ?arg3)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg3 ?v ?arg3))) + -- + ))) + +(def-fcg-cxn intransitive-path-argument-structure-cxn + ((?intransitive-path-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) + (arg path)) + (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))) + (animacy animate)) + (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) + (type motion-locative-path) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp) + )) + (form-type extended-prep-phrase) + (polarity ?polarity) + (animacy inanimate)) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (polarity ?polarity) + (form-type extended-prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp) + ))) + (referent ?arg2)) + + (?intransitive-path-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg2 ?v ?arg2))) + -- + ))) + + +(def-fcg-cxn topic-arg0-arg3-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-origin) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive-origin) + (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 topic-arg0-arg2-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) + (arg path) + (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 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) + (type motion-locative-contracted) + (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))) + )) + + +(def-fcg-cxn arg0-topic-arg3-information-structure-cxn + ( + <- + (?argument-structure-unit + (subunits (?verb-unit ?agent-unit ?location-unit)) + (HASH meaning ((topicalized ?arg3 +))) + + -- + (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-origin) + (aspect ?aspect)) + + -- + (syn-cat (lex-class verb) + (type intransitive-origin) + (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 ?arg3) + (syn-cat (syn-role locative-complement) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (referent ?arg3) + (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) + (form-type contracted) + (type stative-locative) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (referent ?arg2) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (?dat ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?dp)))) + (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) + (type stative-locative)) + (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) + (type stative-locative) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit)) + -- + (referent ?arg2) + (syn-cat (syn-role locative-complement) + (type stative-locative) + (lex-class prep-phrase)) + (boundaries (leftmost-unit ?leftmost-location-unit) + (rightmost-unit ?rightmost-location-unit))) + )) + + +;;;VERBS PERFECT + +;der Mann ist gegen den Clown gefahren + +(def-fcg-cxn intransitive-argument-structure-perfect-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 single-intransitive) + (aspect perfect)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type single-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) + (type motion-locative-end) + (form-type extended-prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (?acc ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ls ?am ?af ?an ?lp)))) + (referent ?arg1)) + + (?intransitive-argument-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:arg1 ?v ?arg1))) + -- + ))) + + +(def-fcg-cxn topic-arg0-arg1-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 single-intransitive) + (aspect perfect)) + (boundaries (leftmost-unit ?aux-unit) + (rightmost-unit ?participle-unit)) + + -- + (subunits (?aux-unit ?participle-unit)) + (syn-cat (lex-class verb) + (type single-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-perfect-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) + (type benefactive) + (form-type extended-prep-phrase) + (case ((- - - - -) + (+ ?bm ?bf ?bn ?bp) + (- - - - -) + (- - - - -) + (?bs ?bm ?bf ?bn ?bp)))) + (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 ?pp)))) + (referent ?arg1) + -- + (syn-cat (lex-class noun-phrase) + (case ((- - - - -) + (+ ?am ?af ?an ?ap) + (- - - - -) + (- - - - -) + (?ps ?am ?af ?an ?pp)))) + (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 + + +;;;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 + +;;footprints + +(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) + (type accompanying)) + (referent ?accompany) + -- + (syn-cat (lex-class prep-phrase) + (case ?case) + (type accompanying)) + (referent ?accompany)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (type motion-locative-contracted) + (form-type contracted) + (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) + (:manner ?v ?accompany) + (:arg1 ?accompany ?arg0) + (: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))) + )) + + + +;der Mann fährt mit dem Fahrrad zur Arbeit + +(def-fcg-cxn intransitive-extra-arg1-structure-cxn + ((?intransitive-extra-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) + (aspect non-perfect)) + (referent ?v) + -- + (syn-cat (lex-class verb) + (type single-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) + (type accompanying) + ;(form-type extended-accompanying-prep-phrase) + ;(polarity +) + ) + (referent ?manner) + + -- + (syn-cat (lex-class prep-phrase) + (case ?case)) + (referent ?manner)) + + (?location-unit + (syn-cat (lex-class prep-phrase) + (type motion-locative-contracted) + (form-type contracted) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg1) + -- + (syn-cat (lex-class prep-phrase) + (case ((- - - - -) + (- - - - -) + (- - - - -) + (+ ?dm ?df ?dn ?dp) + (?ls ?dm ?df ?dn ?lp)))) + (referent ?arg1)) + + (?intransitive-extra-arg1-structure-unit + (HASH meaning ((:arg0 ?v ?arg0) + (:manner ?v ?manner) + (:arg1 ?v ?arg1) + (:arg1 ?manner ?arg0) + )) + -- + ))) + + + +(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))) + )) + + + + + + + + +;;;;;;;;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 '((man x))) + +(formulate '((man x) (accompany-01 a) (polarity a -) (arg0 a x))) +;(formulate-all '((bike x) (accompany-01 a) (polarity a +) (arg0 a x))) +(formulate-all '((bike x) (accompany-01 a) (polarity a positive) (arg0 a x))) + + + +(comprehend-all "der Mann geht zum Shop") + + + +;;;; 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 '((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 g) (man m) (clown c) (flowers f) (arg0 g m) (arg1 g f) (arg2 g 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 +))) + +;;;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 +))) + +;;; der Mann kommt aus dem Backer +(formulate-all '((kommen-01 k) (man m) (baker b) (arg0 k m) (arg3 k b) (topicalized m +))) + +;;; der Mann spaziert durch den Tunnel +(formulate-all '((MAN ?M) (TUNNEL ?T) (SPAZIEREN-01 ?S) (ARG2 ?S ?T) (ARG0 ?S ?M) (TOPICALIZED ?M +))) + +;;; der Mann ist gegen den Baum gefahren +(formulate-all '((tree b) (man m) (drove-01 ig) (arg1 ig b) (arg0 ig m) (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 '((man m) (work w) (clown c) (accompany-01 a) (polarity a -) (arg0 a c) (arg1 a m) (gehen-01 g) (arg0 g m) (arg4 g w) (manner g a) (topicalized m +))) + +;;der Mann fährt mit dem Fahrrad zur Arbeit---stuck in formulation because of + of accompany and something else... +;(formulate '((bike b) (work w) (man m) (fahren-01 f) (manner f a) (arg0 f m) (arg1 f w) (topicalized m +) (accompany-01 a) (arg0 a b) (arg1 a m) (polarity a +))) + +(formulate '((bike b) (work w) (man m) (fahren-01 f) (manner f a) (arg0 f m) (arg1 f w) (topicalized m +) (accompany-01 a) (arg0 a b) (arg1 a m) (polarity a positive))) + + +;;der Mann fährt ohne das Fahrrad zur Arbeit +(formulate '((ACCOMPANY-01 A) (POLARITY A -) (WORK W) (MAN M) (BIKE B) (ARG0 A B) (FAHREN-01 F) (ARG1 A M)(ARG1 F W) (MANNER F A) (ARG0 F M) (TOPICALIZED M +))) + diff --git a/grammars/german_cases/meaning_sentences.fcg b/grammars/german_cases/meaning_sentences.fcg new file mode 100644 index 0000000000000000000000000000000000000000..3f8db62cc45d527fa74a610ce8c820cdb29d0751 --- /dev/null +++ b/grammars/german_cases/meaning_sentences.fcg @@ -0,0 +1,213 @@ + +(in-package :fcg-editor) + +(defun equivalent-amr-predicate-networks (fcg-amr-network amr-predicates) + (print "we are here") + (equivalent-predicate-networks + fcg-amr-network + (mapcar #'(lambda (predicate) + (cons (first predicate) + (mapcar #'(lambda (symbol) + (cond ((stringp symbol) + symbol) + ((numberp symbol) + symbol) + ((or (equal symbol '-) + (equal symbol '+)) + symbol) + ((keywordp symbol) + symbol) + (t + (utils::variablify symbol)))) + (rest predicate)))) + amr-predicates))) + + +(defun equivalent-predicate-networks (network-1 network-2) + "If network-1 and network-2 are equal upto variable renamings, the renamings are returned, + otherwise nil is returned." + (cond + ;; If networks are equal, return t + ((equal network-1 network-2) t) + ;; If networks do not have the same length, return nil + ((/= (length network-1) (length network-2)) nil) + ;; The networks do not consist of the same predicates (in terms of constants), return nil + ((not (networks-with-equal-constants-p network-1 network-2)) nil) + ;; Check the networks in terms of variable bindings + ((loop with queue = (list (list network-1 network-2 +no-bindings+)) + until (not queue) + for state = (pop queue) + for n1-left = (first state) + for n2-left = (second state) + for bindings = (third state) + ;; a solution is found + when (null n1-left) + do (return bindings) + ;; no solution is found + else do + (let ((predicates-with-equal-constants (find-all (first n1-left) n2-left :test #'predicates-with-equal-constants-p))) + (loop for p in predicates-with-equal-constants + for new-bindings = (make-renamings (first n1-left) p bindings) + if new-bindings + do + (push (list (rest n1-left) (remove p n2-left :count 1) new-bindings) queue))))))) + +(defun networks-with-equal-constants-p (network-1 network-2) + "Returns t if network-1 and network-2 are equal in terms of constants." + (when (= (length network-1) (length network-2)) + (loop with predicates-left = (copy-object network-2) + for predicate in (copy-object network-1) + when (find predicate predicates-left :test #'predicates-with-equal-constants-p) + do (setf predicates-left + (remove predicate predicates-left + :test #'predicates-with-equal-constants-p + :count 1)) + else do (return nil) + finally (return t)))) + +(defun predicates-with-equal-constants-p (predicate-1 predicate-2) + "Returns t if predicate-1 and predicate-2 are equal in terms of constants." + (when (= (length predicate-1) (length predicate-2)) + (loop for el-1 in predicate-1 + for el-2 in predicate-2 + unless (or (equal el-1 el-2) + (and (variable-p el-1) + (variable-p el-2))) + do (return nil) + finally (return t)))) + +(defun make-renamings (el-1 el-2 bindings) + "Finds renamings to ensure equality between el-1 and el-2 (no unification)" + (cond ((eq bindings +fail+) + +fail+) + ((equal el-1 el-2) + bindings) + ((and (variable-p el-1) + (variable-p el-2) + (assoc el-1 bindings) + (equal el-2 (cdr (assoc el-1 bindings)))) + bindings) + ((and (variable-p el-1) + (variable-p el-2) + (not (assoc el-1 bindings)) + (not (find el-2 bindings :key #'cdr))) + (extend-bindings el-1 el-2 bindings)) + ((and (listp el-1) (listp el-2)) + (let ((new-bindings (make-renamings (first el-1) (first el-2) bindings))) + (make-renamings (rest el-1) (rest el-2) new-bindings))) + (t + +fail+))) + +(equivalent-amr-predicate-networks (comprehend "der Mann sucht den Clown") '((suchen-01 s) (man m) (clown c) (arg0 s m) (arg1 s c) (topicalized m +))) + +(equivalent-amr-predicate-networks (comprehend "der Mann") '( (man m))) + + +;;;;transitive non-topicalized sentences + +der Polizist sucht den Bäcker +((suchen-01 s) (baker b) (policeman p) (arg0 s p) (arg1 s b) (topicalized p +)) + +der Hund verfolgt den Mann +((verfolgen-01 v) (man m) (dog d) (arg0 v d) (arg1 v m) (topicalized d +)) + +der Tiger tötet den Jäger +((töten-01 t) (tiger ti) (hunter h) (arg0 t ti) (arg1 t h) (topicalized ti +)) + +der König ruft den Kellner +((rufen-01 r) (king k) (waiter w) (arg0 r k) (arg1 r w) (topicalized k +))) + + + +;;;;;transitive topicalized sentences + +den Bäcker sucht der Polizist +((suchen-01 s) (baker b) (policeman p) (arg0 s p) (arg1 s b) (topicalized b +)) + +den Mann verfolgt der Hund +((verfolgen-01 v) (man m) (dog d) (arg0 v d) (arg1 v m) (topicalized m +)) + +den Jäger tötet der Tiger +((töten-01 t) (tiger ti) (hunter h) (arg0 t ti) (arg1 t h) (topicalized h +)) + +den Kellner ruft der König +((rufen-01 r) (king k) (waiter w) (arg0 r k) (arg1 r w) (topicalized w +))) + + + +;;;ditransitives non-topicalized sentences + +die Frau gibt dem Mann den Apfel +((geben-01 g) (woman w) (man m) (apple a) (arg0 g w) (arg1 g a) (arg2 g m) (topicalized w +)) + +der Clown verkauft dem Doktor das Buch +((verkaufen-01 v) (clown c) (doctor d) (book b) (arg0 v c) (arg1 v b) (arg2 v d) (topicalized c +)) + +die Lehrerin schenkt dem Direktor die Blumen +((schenken-01 s) (teacher t) (director d) (flowers f) (arg0 s t) (arg1 s f) (arg2 s d) (topicalized t +)) + +der Vater zeigt dem Sohn die Brille +((zeigen-01 z) (father f) (son s) (glasses g) (arg0 z f) (arg1 z g) (arg2 z s) (topicalized f +)) + + + +;;;;ditransitive topicalized sentences + +dem Mann gibt die Frau den Apfel +((geben-01 g) (woman w) (man m) (apple a) (arg0 g w) (arg1 g a) (arg2 g m) (topicalized m +)) + +dem Doktor verkauft der Clown das Buch +((verkaufen-01 v) (clown c) (doctor d) (book b) (arg0 v c) (arg1 v b) (arg2 v d) (topicalized d +)) + +dem Direktor schenkt die Lehrerin die Blumen +((schenken-01 s) (teacher t) (director d) (flowers f) (arg0 s t) (arg1 s f) (arg2 s d) (topicalized d +)) + +dem Sohn zeigt der Vater die Brille +((zeigen-01 z) (father f) (son s) (glasses g) (arg0 z f) (arg1 z g) (arg2 z s) (topicalized s +)) + + + + +;;;;intransitive movement verbs + +der Junge geht zum Bäcker +((gehen-01 g) (boy b) (baker ba) (arg0 g b) (arg4 g ba) (topicalized b +)) + + +die Frau ist beim Bäcker +((sein-01 s) (woman m) (baker b) (arg1 s w) (arg2 s b) (topicalized w +)) ;exception + + +der Mann spaziert durch den Tunnel +((spazieren-01 s) (man m) (tunnel t) (arg0 s m) (arg2 s t)) ;;;exception like fahren only arg0 and arg1 + +der Mann ist gegen den Baum gefahren +((drove-01 ig) (man m) (arg0 ig m) (tree t) (arg1 ig t) (topicalized m +)) + +das Mädchen kommt aus dem Bäcker +((kommen-01 k) (girl g) (baker b) (arg0 k g) (arg3 k b) (topicalized g +)) + + + +;;;;intransitive movement verbs topicalized + +zum Bäcker geht der Junge +((gehen-01 g) (boy b) (baker ba) (arg0 g b) (arg4 g ba) (topicalized ba +)) + +beim Bäcker ist die Frau +((sein-01 s) (woman m) (baker b) (arg1 s w) (arg2 s b) (topicalized b +)) + + + +;;;intransitive with double complement + +die Mutter geht ohne den Sohn zum Laden +((gehen-01 g) (mother m) (son s) (shop sh) (arg0 g m) (arg4 g sh) (accompany-01 a) (polarity a -) (manner g a) (arg0 a s) (arg1 a m) (topicalized m +)) + +der Mann fährt mit dem Fahrrad zur Arbeit +(formulate '((bike b) (work w) (man m) (fahren-01 f) (manner f a) (arg0 f m) (arg1 f w) (topicalized m +) (accompany-01 a) (arg0 a b) (arg1 a m) (polarity a +))) + + + + + diff --git a/grammars/propbank-english/package.lisp b/grammars/propbank-english/package.lisp index 8bbbdf46689a974ac0eb63454e2f9fb3081ed4ba..b0af462b4dd02f77dc34b3e056deeca90fa015d6 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 d70876a33de1835c2aef4f2f1f4c5e9cc7944247..bb7cad25e056539827ef18c97d2dd1d327c795a6 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 8eb3dcacef7e3431b2406d55518aa41b9e314744..4f2586343deb8df9a920b859977308d5c2caa568 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 a2e58ce598e047f07c33e9ec7516c1edd3e0e720..3a566bb2ca87b8bcaf9dd9d33858654f757380da 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 618755ce9b13650c355ca1cfc5127e17a9b6b557..14509ce3dcf7fc306679dd19789c87642057f896 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 01861bb98f9610e897963dd09209f5ea209a29a3..022137f4c5150a7de4afca84a695238cb674f4dd 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." diff --git a/grammars/propbank-grammar/fcg-components/extract-frames.lisp b/grammars/propbank-grammar/fcg-components/extract-frames.lisp index bce01adc88108d4eb3234fd2128575a2a5df6fa8..238d57bd6e61010eae8c9bc90542f05a05e3c146 100644 --- a/grammars/propbank-grammar/fcg-components/extract-frames.lisp +++ b/grammars/propbank-grammar/fcg-components/extract-frames.lisp @@ -17,7 +17,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." diff --git a/grammars/propbank-grammar/fcg-components/node-tests.lisp b/grammars/propbank-grammar/fcg-components/node-tests.lisp index 04c1f079709eb811e03edd302b5eeb4fa18e8a70..d9365485566d6f419762c5f411f1d62172d157b1 100644 --- a/grammars/propbank-grammar/fcg-components/node-tests.lisp +++ b/grammars/propbank-grammar/fcg-components/node-tests.lisp @@ -25,11 +25,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 diff --git a/grammars/propbank-grammar/grammars/propbank-grammar-ontonotes-ewt-core-roles-lw.fcg b/grammars/propbank-grammar/grammars/propbank-grammar-ontonotes-ewt-core-roles-lw.fcg new file mode 100644 index 0000000000000000000000000000000000000000..6ec186cc41be3ed6916f0e0bce4576c85620de68 Binary files /dev/null and b/grammars/propbank-grammar/grammars/propbank-grammar-ontonotes-ewt-core-roles-lw.fcg differ diff --git a/grammars/propbank-grammar/grammars/propbank-grammar-ontonotes-ewt-core-roles-sbcl.fcg b/grammars/propbank-grammar/grammars/propbank-grammar-ontonotes-ewt-core-roles-sbcl.fcg new file mode 100644 index 0000000000000000000000000000000000000000..72fadf7db4fd69c9ad32dc038a1d8da63fecad73 Binary files /dev/null and b/grammars/propbank-grammar/grammars/propbank-grammar-ontonotes-ewt-core-roles-sbcl.fcg differ diff --git a/grammars/propbank-grammar/learn-ccl.lisp b/grammars/propbank-grammar/learn-ccl.lisp new file mode 100644 index 0000000000000000000000000000000000000000..036ee600c918dbc9a3d0b2c96f54b88db12a4276 --- /dev/null +++ b/grammars/propbank-grammar/learn-ccl.lisp @@ -0,0 +1,62 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; Learning and evaluating PropBank-based grammars. ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;,;;;; + +;; Loading the :propbank-grammar system +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(ql:quickload :propbank-grammar) +(in-package :propbank-grammar) + +;; Loading the Propbank annotations (takes a couple of minutes) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(load-propbank-annotations 'ewt :ignore-stored-data nil) ; *ewt-annotations* + +;; Learning grammars from the annotated data +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *training-configuration* + '((:de-render-mode . :de-render-constituents-dependents) + (:node-tests :check-double-role-assignment) + (:parse-goal-tests :no-valid-children) + (:max-nr-of-nodes . 100) + (:node-expansion-mode . :multiple-cxns) + (:priority-mode . :nr-of-applied-cxns) + (:queue-mode . :greedy-best-first) + (:hash-mode . :hash-lemma) + (:parse-order + lexical-cxn + argument-structure-cxn + argm-phrase-cxn + argm-leaf-cxn + word-sense-cxn) + (:replace-when-equivalent . nil) + (:learning-modes + :core-roles + ;:argm-pp + ;:argm-sbar + ;:argm-leaf + ;:argm-phrase-with-string + ) + (:cxn-supplier-mode . :propbank-english))) + +(defparameter *propbank-ewt-learned-cxn-inventory* nil) + +(learn-propbank-grammar + (train-split *ewt-annotations*) + ;(append (train-split *ontonotes-annotations*) (train-split *ewt-annotations*)) + :selected-rolesets nil + :cxn-inventory '*propbank-ewt-learned-cxn-inventory* + :fcg-configuration *training-configuration*) + +;; Storing and restoring grammars +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; cannot store object of type recursive-lock in CCL :-( +(cl-store:store *propbank-ewt-learned-cxn-inventory* + (babel-pathname :directory '("grammars" "propbank-grammar" "grammars") + :name "propbank-grammar-ontonotes-ewt-core-roles-ccl" + :type "fcg")) diff --git a/grammars/propbank-grammar/learn-lw.lisp b/grammars/propbank-grammar/learn-lw.lisp new file mode 100644 index 0000000000000000000000000000000000000000..43ca1d6f88cdb33b48e5cdf21a0740b2a8fe6577 --- /dev/null +++ b/grammars/propbank-grammar/learn-lw.lisp @@ -0,0 +1,61 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; Learning and evaluating PropBank-based grammars. ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;,;;;; + +;; Loading the :propbank-grammar system +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(ql:quickload :propbank-grammar) +(in-package :propbank-grammar) + +;; Loading the Propbank annotations (takes a couple of minutes) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(load-propbank-annotations 'ewt :ignore-stored-data nil) ; *ewt-annotations* + +;; Learning grammars from the annotated data +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *training-configuration* + '((:de-render-mode . :de-render-constituents-dependents) + (:node-tests :check-double-role-assignment) + (:parse-goal-tests :no-valid-children) + (:max-nr-of-nodes . 100) + (:node-expansion-mode . :multiple-cxns) + (:priority-mode . :nr-of-applied-cxns) + (:queue-mode . :greedy-best-first) + (:hash-mode . :hash-lemma) + (:parse-order + lexical-cxn + argument-structure-cxn + argm-phrase-cxn + argm-leaf-cxn + word-sense-cxn) + (:replace-when-equivalent . nil) + (:learning-modes + :core-roles + ;:argm-pp + ;:argm-sbar + ;:argm-leaf + ;:argm-phrase-with-string + ) + (:cxn-supplier-mode . :propbank-english))) + +(defparameter *propbank-ewt-learned-cxn-inventory* nil) + +(learn-propbank-grammar + (train-split *ewt-annotations*) + ;(append (train-split *ontonotes-annotations*) (train-split *ewt-annotations*)) + :selected-rolesets nil + :cxn-inventory '*propbank-ewt-learned-cxn-inventory* + :fcg-configuration *training-configuration*) + +;; Storing and restoring grammars +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl-store:store *propbank-ewt-learned-cxn-inventory* + (babel-pathname :directory '("grammars" "propbank-grammar" "grammars") + :name "propbank-grammar-ontonotes-ewt-core-roles-lw" + :type "fcg")) diff --git a/grammars/propbank-grammar/learn-sbcl.lisp b/grammars/propbank-grammar/learn-sbcl.lisp new file mode 100644 index 0000000000000000000000000000000000000000..84dceaeaafc6969450d0347eb20c07321d730303 --- /dev/null +++ b/grammars/propbank-grammar/learn-sbcl.lisp @@ -0,0 +1,61 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; Learning and evaluating PropBank-based grammars. ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;,;;;; + +;; Loading the :propbank-grammar system +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(ql:quickload :propbank-grammar) +(in-package :propbank-grammar) + +;; Loading the Propbank annotations (takes a couple of minutes) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(load-propbank-annotations 'ewt :ignore-stored-data nil) ; *ewt-annotations* + +;; Learning grammars from the annotated data +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *training-configuration* + '((:de-render-mode . :de-render-constituents-dependents) + (:node-tests :check-double-role-assignment) + (:parse-goal-tests :no-valid-children) + (:max-nr-of-nodes . 100) + (:node-expansion-mode . :multiple-cxns) + (:priority-mode . :nr-of-applied-cxns) + (:queue-mode . :greedy-best-first) + (:hash-mode . :hash-lemma) + (:parse-order + lexical-cxn + argument-structure-cxn + argm-phrase-cxn + argm-leaf-cxn + word-sense-cxn) + (:replace-when-equivalent . nil) + (:learning-modes + :core-roles + ;:argm-pp + ;:argm-sbar + ;:argm-leaf + ;:argm-phrase-with-string + ) + (:cxn-supplier-mode . :propbank-english))) + +(defparameter *propbank-ewt-learned-cxn-inventory* nil) + +(learn-propbank-grammar + (train-split *ewt-annotations*) + ;(append (train-split *ontonotes-annotations*) (train-split *ewt-annotations*)) + :selected-rolesets nil + :cxn-inventory '*propbank-ewt-learned-cxn-inventory* + :fcg-configuration *training-configuration*) + +;; Storing and restoring grammars +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl-store:store *propbank-ewt-learned-cxn-inventory* + (babel-pathname :directory '("grammars" "propbank-grammar" "grammars") + :name "propbank-grammar-ontonotes-ewt-core-roles-sbcl" + :type "fcg")) diff --git a/grammars/propbank-grammar/learning/cxn-name.lisp b/grammars/propbank-grammar/learning/cxn-name.lisp index 35762ff05a2980a411d033afec919c1acfe702ec..6779b6c16bbf2048f90eab32579a9b1cb11c94b9 100644 --- a/grammars/propbank-grammar/learning/cxn-name.lisp +++ b/grammars/propbank-grammar/learning/cxn-name.lisp @@ -9,10 +9,11 @@ (cxn-units-with-role list) (cxn-units-without-role list) &key (mode :core-roles) - (pp-units) + pp-units lemma s-bar-units + ) "" + (declare (ignore mode)) - (loop with pp-unit-number = 0 with s-bar-unit-number = 0 for (role . unit) in ts-units-with-role @@ -23,16 +24,16 @@ ;; unit is a pp ((find 'pp (unit-feature-value (unit-body unit) 'syn-class)) (incf pp-unit-number) - (if (= 1 (length (nth1 pp-unit-number preposition-units))) + (if (= 1 (length (nth1 pp-unit-number pp-units))) (format nil "~{~a~}(~a)" (unit-feature-value unit 'syn-class ) (or lemma (second (find 'lemma - (nthcdr 2 (first (nth1 pp-unit-number preposition-units))) + (nthcdr 2 (first (nth1 pp-unit-number pp-units))) :key #'feature-name)))) (format nil "~{~a~}(cc-~a)" (unit-feature-value unit 'syn-class ) (or lemma (second (find 'lemma - (nthcdr 2 (third (nth1 pp-unit-number preposition-units))) + (nthcdr 2 (third (nth1 pp-unit-number pp-units))) :key #'feature-name)))))) ;; unit is an s-bar ((find 'sbar (unit-feature-value (unit-body unit) 'syn-class)) diff --git a/grammars/propbank-grammar/propbank-grammar.asd b/grammars/propbank-grammar/propbank-grammar.asd index c6d67fbacfbd77c7dd7a8b6ad3cac69e3ac26954..78a33cf4ffc8cd27f8271d95d08142a2c12a21b3 100644 --- a/grammars/propbank-grammar/propbank-grammar.asd +++ b/grammars/propbank-grammar/propbank-grammar.asd @@ -24,4 +24,5 @@ (:file "comprehend"))) (:module learning :serial t - :components ((:file "learn-propbank-constructions"))))) + :components ((:file "cxn-name") + (:file "learn-propbank-constructions"))))) diff --git a/grammars/propbank-grammar/start.lisp b/grammars/propbank-grammar/start.lisp index c24195e60cc43958e35525fcbfbcd22cdd4c46dd..7f2bde9ca0b9dc19383c694e9f8a6e8b69cf5f86 100644 --- a/grammars/propbank-grammar/start.lisp +++ b/grammars/propbank-grammar/start.lisp @@ -11,6 +11,8 @@ (in-package :propbank-grammar) + + ;; Activating spacy-api locally ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -28,9 +30,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *restored-grammar* - (restore (babel-pathname :directory '("grammars" "propbank-grammar" "grammars") - :name "propbank-grammar-ontonotes-ewt" - :type "fcg"))) + (cl-store:restore + (babel-pathname :directory '("grammars" "propbank-grammar" "grammars") + :name "propbank-grammar-ontonotes-ewt-core-roles-sbcl" + :type "fcg"))) (cl-store:store *propbank-ontonotes-ewt-learned-cxn-inventory* (babel-pathname :directory '("grammars" "propbank-grammar" "grammars") @@ -67,7 +70,8 @@ (:cxn-supplier-mode . :propbank-english))) (learn-propbank-grammar - (append (train-split *ontonotes-annotations*) (train-split *ewt-annotations*)) + (train-split *ewt-annotations*) + ;(append (train-split *ontonotes-annotations*) (train-split *ewt-annotations*)) :selected-rolesets nil :cxn-inventory '*propbank-ewt-learned-cxn-inventory* :fcg-configuration *training-configuration*) @@ -82,3 +86,5 @@ (comprehend-and-extract-frames "Oxygen levels in oceans have fallen 2% in 50 years due to climate change, affecting marine habitat and large fish such as tuna and sharks" :cxn-inventory *propbank-ewt-learned-cxn-inventory*) (comprehend-and-extract-frames "She sent her mother a dozen roses" :cxn-inventory *propbank-ewt-learned-cxn-inventory*) + +(comprehend-and-extract-frames (sentence-string (nth 0 (train-split *ewt-annotations*))) :cxn-inventory *propbank-ewt-learned-cxn-inventory*) diff --git a/libraries/cl-skip-list/LICENSE b/libraries/cl-skip-list/LICENSE new file mode 100644 index 0000000000000000000000000000000000000000..2c46ab767001d8a0176dcd0633ae36d27307db08 --- /dev/null +++ b/libraries/cl-skip-list/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2010 Kevin Thomas Raison + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +Except as contained in this notice, the name(s) of the above copyright holders +shall not be used in advertising or otherwise to promote the sale, use or other +dealings in this Software without prior written authorization. + diff --git a/libraries/cl-skip-list/README b/libraries/cl-skip-list/README new file mode 100644 index 0000000000000000000000000000000000000000..d66fc2bf4b427497c18ec9e7c863c9595846f22e --- /dev/null +++ b/libraries/cl-skip-list/README @@ -0,0 +1,19 @@ +Concurrent lockless skip lists for Common Lisp. + +Currently, "Common Lisp" means SBCL version 1.0.42 or higher. If other Lisps +support compare-and-swap and memory barriers, let me know and I will add macros +for those Lisps. There is also a need to sort update locations based on some +global order, in this case the pointer addresses. SBCL allows that via +(logandc2 (sb-kernel:get-lisp-obj-address vector) sb-vm:lowtag-mask)) +combined with sb-sys:with-pinned-objects to avoid a GC moving things around. +Do other Lisps have similar facilities? + +TODO +1. Improve performance by reusing CCAS descriptors during the first phase of an MCAS +2. Add search fingers +2. Add skip list merges +3. Add splitting + +DONE +1. Added a skip-list-based priority queue +2. Added memory barriers where necessary, making the code dependent on sbcl 1.0.42 diff --git a/libraries/cl-skip-list/cl-skip-list-package.lisp b/libraries/cl-skip-list/cl-skip-list-package.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0ebbae508139ea8ff927655aa8d93cc2f494c86b --- /dev/null +++ b/libraries/cl-skip-list/cl-skip-list-package.lisp @@ -0,0 +1,30 @@ +(in-package #:cl-user) + +(defpackage #:cl-skip-list + (:use #:cl #:cffi) + (:export + #:make-skip-list + #:less-than + #:skip-list? + #:skip-list-empty? + #:skip-list-to-list + #:skip-list-lookup + #:skip-list-replace-kv + #:skip-list-add + #:skip-list-delete + #:sl-cursor + #:skip-list-values-cursor + #:skip-list-keys-cursor + #:skip-list-range-cursor + #:sl-cursor-next + #:map-skip-list + #:map-skip-list-values + #:skip-list-fetch-all + #:skip-list-length + #:+mcas-succeeded+ + #:+mcas-undecided+ + #:+mcas-failed+ + + #:make-skip-pq + #:delete-min + )) diff --git a/libraries/cl-skip-list/cl-skip-list.asd b/libraries/cl-skip-list/cl-skip-list.asd new file mode 100644 index 0000000000000000000000000000000000000000..36d10f91e10b68e6d4b6009356d7c10fb73227cc --- /dev/null +++ b/libraries/cl-skip-list/cl-skip-list.asd @@ -0,0 +1,21 @@ +;; ASDF package description for cl-skip-list -*- Lisp -*- + +(defpackage :cl-skip-list-system (:use :cl :asdf)) +(in-package :cl-skip-list-system) + +(defsystem cl-skip-list + :name "cl-skip-list" + :maintainer "Kevin Raison" + :author "Kevin Raison " + :version "0.1" + :description "Concurrent lock-free skip list." + :long-description "Concurrent lock-free skip list." + :depends-on (:cffi) + :components ((:file "cl-skip-list-package") + (:file "random" :depends-on ("cl-skip-list-package")) + (:file "utilities" :depends-on ("cl-skip-list-package")) + (:file "gettimeofday" :depends-on ("cl-skip-list-package")) + (:file "constants" :depends-on ("cl-skip-list-package")) + (:file "mcas" :depends-on ("utilities" "constants" "gettimeofday")) + (:file "skip-list" :depends-on ("mcas" "random")) + (:file "skip-pq" :depends-on ("skip-list")))) diff --git a/libraries/cl-skip-list/constants.lisp b/libraries/cl-skip-list/constants.lisp new file mode 100644 index 0000000000000000000000000000000000000000..182423199ffa5ff601d279e6ae567937a8d04fa7 --- /dev/null +++ b/libraries/cl-skip-list/constants.lisp @@ -0,0 +1,10 @@ +(in-package #:cl-skip-list) + +;; MCAS status markers +(defconstant +mcas-undecided+ :undecided) +(defconstant +mcas-failed+ :failed) +(defconstant +mcas-succeeded+ :succeeded) +(defconstant +mcas-make-durable+ :make-durable) + +;; MCAS transaction global +(defvar *mcas* nil) diff --git a/libraries/cl-skip-list/gettimeofday.lisp b/libraries/cl-skip-list/gettimeofday.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a2f4c77bd8a61bf04a0a34940385c6ded0eb9a9a --- /dev/null +++ b/libraries/cl-skip-list/gettimeofday.lisp @@ -0,0 +1,88 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2) +;;; +;;; Copyright (C) 2005-2006, James Bielman +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. +;;; + +;;;# CFFI Example: gettimeofday binding +;;; +;;; This example illustrates the use of foreign structures, typedefs, +;;; and using type translators to do checking of input and output +;;; arguments to a foreign function. + +;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes +;;; that 'time_t' is a 'long' --- it would be nice if CFFI could +;;; provide a proper :TIME-T type to help make this portable. +(in-package #:cl-skip-list) + +(defcstruct timeval + (tv-sec :long) + (tv-usec :long)) + +;;; A NULL-POINTER is a foreign :POINTER that must always be NULL. +;;; Both a NULL pointer and NIL are legal values---any others will +;;; result in a runtime error. +(define-foreign-type null-pointer-type () + () + (:actual-type :pointer) + (:simple-parser null-pointer)) + +;;; This type translator is used to ensure that a NULL-POINTER has a +;;; null value. It also converts NIL to a null pointer. +(defmethod translate-to-foreign (value (type null-pointer-type)) + (cond + ((null value) (null-pointer)) + ((null-pointer-p value) value) + (t (error "~A is not a null pointer." value)))) + +;;; The SYSCALL-RESULT type is an integer type used for the return +;;; value of C functions that return -1 and set errno on errors. +;;; Someday when CFFI has a portable interface for dealing with +;;; 'errno', this error reporting can be more useful. +(define-foreign-type syscall-result-type () + () + (:actual-type :int) + (:simple-parser syscall-result)) + +;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error +;;; if the value is negative. +(defmethod translate-from-foreign (value (type syscall-result-type)) + (if (minusp value) + (error "System call failed with return value ~D." value) + value)) + +;;; Define the Lisp function %GETTIMEOFDAY to call the C function +;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill +;;; in. The TZP parameter is deprecated and should be NULL --- we can +;;; enforce this by using our NULL-POINTER type defined above. +(defcfun ("gettimeofday" %gettimeofday) syscall-result + (tp :pointer) + (tzp null-pointer)) + +(defun gettimeofday () + (with-foreign-object (tv 'timeval) + (%gettimeofday tv nil) + (with-foreign-slots ((tv-sec tv-usec) tv timeval) + (+ tv-sec (/ tv-usec 1000000))))) + diff --git a/libraries/cl-skip-list/mcas.lisp b/libraries/cl-skip-list/mcas.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e156b338031e6c6ce60c859763bf8fc194f9b2e6 --- /dev/null +++ b/libraries/cl-skip-list/mcas.lisp @@ -0,0 +1,262 @@ +(in-package #:cl-skip-list) + +(define-condition transaction-error (error) + ((instance :initarg :instance) + (reason :initarg :reason)) + (:report (lambda (error stream) + (with-slots (instance reason) error + (format stream "Transaction failed for ~a because of ~a." instance reason))))) + +(define-condition mcas-error (error) + ((instance :initarg :instance) + (reason :initarg :reason)) + (:report (lambda (error stream) + (with-slots (instance reason) error + (format stream "MCAS failed for ~a because ~a." instance reason))))) + +;; Make compare-and-swap shorter to call +(defmacro cas (place old new) + `(sb-ext:compare-and-swap ,place ,old ,new)) + +(defun get-vector-addr (vector) + (logandc2 (sb-kernel:get-lisp-obj-address vector) sb-vm:lowtag-mask)) + +(defstruct (ccas-descriptor + (:type vector) + (:predicate ccas-descriptor?) + (:conc-name cd-) + :named) + vector control-vector control-index index old new equality) + +(defstruct (safe-update + (:type vector) + (:predicate safe-update?) + (:conc-name update-) + :named) + vector index old new) + +(defstruct (mcas-descriptor + (:type vector) + (:predicate mcas-descriptor?) + (:conc-name mcas-) + :named) + (status +mcas-undecided+) + (count 0) + updates + (equality #'equal) + success-actions + (retries 0) + (timestamp (gettimeofday))) + +(defun ccas-help (cd) + (sb-thread:barrier (:read) + (if (eq (svref (cd-control-vector cd) (cd-control-index cd)) +mcas-undecided+) + (cas (svref (cd-vector cd) (cd-index cd)) cd (cd-new cd)) + (cas (svref (cd-vector cd) (cd-index cd)) cd (cd-old cd))))) + +(defun ccas-read (vector index) + (let ((r nil)) + (sb-thread:barrier (:read) + (setq r (svref vector index))) + (if (ccas-descriptor? r) + (progn + (ccas-help r) + (ccas-read vector index)) + r))) + +(defun ccas (vector index control-vector control-index old new + &optional (equality #'equal)) + (let ((cd (make-ccas-descriptor :vector vector + :index index + :control-vector control-vector + :control-index control-index + :old old + :new new + :equality equality))) + (let ((r nil)) + (sb-thread:barrier (:read) + (setq r (cas (svref vector index) old cd))) + (while (not (funcall equality r old)) + (if (not (ccas-descriptor? r)) + (return-from ccas r) + (progn + (ccas-help r) + (setq r (cas (svref vector index) old cd)))))) + (ccas-help cd))) + +(defun mcas-help (md) + "This is the bulk of the transaction logic." + (let ((state +mcas-failed+)) + (tagbody + (dotimes (i (mcas-count md)) + (let ((update (elt (mcas-updates md) i))) + (loop + ;; Try to replace the slot with our mcas descriptor. + (ccas (update-vector update) (update-index update) + md 1 + (update-old update) md + (mcas-equality md)) + (let ((r (svref (update-vector update) (update-index update)))) + (cond ((and (eq (mcas-status md) +mcas-undecided+) + (funcall (mcas-equality md) (update-old update) r)) + ;; Got old value, not our mcas descriptor. Try again. + t) + ((eq r md) + ;; This slot has been successfully replaced by our mcas descriptor. Next. + (return)) + ((not (mcas-descriptor? r)) + ;; Oops, someone else changed this slot. Abort. + (go decision-point)) + (t + ;; Someone else has a transaction active on this slot. Help them out. + (mcas-help r))))))) + (setq state +mcas-succeeded+) + decision-point + (sb-thread:barrier (:write) + (cas (svref md 1) +mcas-undecided+ state)) + (sb-thread:barrier (:write) + (cond ((eq (mcas-status md) +mcas-succeeded+) + (dotimes (i (mcas-count md)) + (let ((update (elt (mcas-updates md) i))) + (cas (svref (update-vector update) (update-index update)) + md + (update-new update))))) + ((eq (mcas-status md) +mcas-failed+) + (dotimes (i (mcas-count md)) + (let ((update (elt (mcas-updates md) i))) + (cas (svref (update-vector update) (update-index update)) + md + (update-old update))))))))) + (mcas-status md)) + +(defun mcas-read (vector index) + (let ((r nil)) + (sb-thread:barrier (:read) + (setq r (svref vector index))) + (if (mcas-descriptor? r) + (progn + (mcas-help r) + (mcas-read vector index)) + r))) + +(defun mcas (md) + (let ((objects (remove-duplicates + (mapcar #'(lambda (update) (update-vector update)) + (mcas-updates md))))) + (sb-sys:with-pinned-objects (objects) + (setf (mcas-updates md) + (sort (mcas-updates md) #'< + :key #'(lambda (update) + (+ (get-vector-addr (update-vector update)) + (update-index update))))) + (mcas-help md)))) + +(defun mcas-set (vector index old new) + (if (mcas-descriptor? *mcas*) + (progn + (push (make-safe-update :vector vector :index index :old old :new new) + (mcas-updates *mcas*)) + (incf (mcas-count *mcas*))) + (error 'mcas-error + :instance *mcas* + :reason "MCAS-SET must be called within the body of with-mcas. *MCAS* not bound!"))) + +(defun reset-mcas (mcas) + (setf (mcas-status mcas) +mcas-undecided+ + (mcas-count mcas) 0 + (mcas-updates mcas) nil + (mcas-success-actions mcas) nil + (mcas-timestamp mcas) (gettimeofday)) + mcas) + +(defgeneric mcas-successful? (thing)) + +(defmethod mcas-successful? ((md array)) + (eq +mcas-succeeded+ (mcas-status md))) + +(defmethod mcas-successful? ((s symbol)) + (eq +mcas-succeeded+ s)) + +(defmacro with-mcas (lambda-list &body body) + (let ((args (gensym)) + (equality (get-prop lambda-list :equality)) + (success-action (get-prop lambda-list :success-action))) + `(let ((,args nil)) + (when (functionp ,equality) + (push ,equality ,args) + (push :equality ,args)) + (when (functionp ,success-action) + (push (list ,success-action) ,args) + (push :success-actions ,args)) + (let ((*mcas* (apply #'make-mcas-descriptor ,args))) + (unwind-protect + (loop + for retries from 0 to 199 + do + (progn ,@body) + (mcas *mcas*) + (if (eq +mcas-succeeded+ (mcas-status *mcas*)) + (return) + (progn + (incf (mcas-retries *mcas*)) + (sleep (* 0.000002 (nth (random 3) (list 0 1 retries)))) + (reset-mcas *mcas*)))) + (if (eq +mcas-succeeded+ (mcas-status *mcas*)) + (dolist (func (reverse (mcas-success-actions *mcas*))) + (funcall func)) + (error 'transaction-error :instance *mcas* :reason "retries exhausted."))) + (mcas-status *mcas*))))) + +(defmacro with-recursive-mcas (lambda-list &body body) + (let ((success-action (get-prop lambda-list :success-action))) + `(if (mcas-descriptor? *mcas*) + (progn + (when (functionp ,success-action) + (push ,success-action (mcas-success-actions *mcas*))) + ,@body) + (with-mcas ,lambda-list + ,@body)))) + + +#| +(defun mcas-test (&key (threads 4) (size 100)) + (sb-profile:reset) + (sb-profile:profile get-vector-addr + print-ccas-descriptor + new-ccas-descriptor + make-ccas-descriptor + ccas-help + ccas + ccas-read + safe-update + safe-update? + make-mcas-descriptor + mcas-descriptor? + mcas-help + mcas + mcas-read + mcas-set) + (let* ((initial (random 100000)) + (v (make-array size :initial-element initial)) + (thread-list nil) + (queue (sb-concurrency:make-queue))) + (format t "Initial element is ~A~%" initial) + (dotimes (x threads) + (sb-concurrency:enqueue x queue) + (push (sb-thread:make-thread + #'(lambda () + (let ((i (sb-concurrency:dequeue queue))) + (sleep (/ i 10)) + (format t "~A: I IS ~A~%" sb-thread:*current-thread* i) + (with-mcas (:equality #'equal) + (dotimes (j size) + (mcas-set v j (+ i initial) (+ 1 i initial)))))) + :name (format nil "thread~A" x)) + thread-list)) + (format t "~A: V 0 = ~A~%" sb-thread:*current-thread* (mcas-read v 0)) + (dolist (thread (reverse thread-list)) + (sb-thread:join-thread thread) + (format t "~A: V 0 = ~A~%" thread (mcas-read v 0))) + (format t "v[0] = ~A & v[~A] = ~A~%" (svref v 0) (1- size) (svref v (1- size)))) + (sb-profile:report)) +|# diff --git a/libraries/cl-skip-list/random.lisp b/libraries/cl-skip-list/random.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2b08a04e8a16593511e6100c6cd801bff21fde3b --- /dev/null +++ b/libraries/cl-skip-list/random.lisp @@ -0,0 +1,254 @@ +;;; -*- Mode: Lisp -*- +;;; +;;; $Header: /home/gene/library/website/docsrc/jmt/RCS/jmt.lisp,v 395.1 2008/04/20 17:25:47 gene Exp $ +;;; +;;; Copyright (c) 2002, 2004 Jason Stover. All rights reserved. +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation; either version 2.1 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +;;; USA + +;;; This is a implementation of the Mersenne Twister pseudo-random +;;; number generator by M. Matsumoto and T. Nishimura. See +;;; "Mersenne Twister: A 623-dimensionally equidistributed uniform +;;; pseudorandom number generator", ACM Transactions on Modeling and +;;; Computer Simulation vol. 8, no. 1, January 1998, pp 3-30. +;;; As of the time of this writing, the paper can also be found at +;;; www.math.keio.ac.jp/~matumoto/emt.html. + +;;; LOG +;;; +;;; WARNING: I just finished this on 1/8/02 after learning +;;; just a bit of Lisp. I haven't tested it to make sure +;;; its generated values look uniformly distributed in high +;;; dimensions. Both a simple histogram and scatterplot of the +;;; values looked okay, but there could be problems. Feel free +;;; to fix them and tell me about your solutions. (JHS) +;;; +;;; 4 February 2004, Gene Michael Stover +;;; Rewrite & testing. +;;; +;;; 7 February 2004, Gene Michael Stover. +;;; Fixed two bugs found by Marc Battyani. In one of the ASSERTs, +;;; I had APPLYied #'AND as if it's a function, but AND is a macro. +;;; Also, I create the MAG01 array by COERCEing a list to an array. +;;; I guess Lispworks doesn't like that, but Mr. Battyani said it +;;; worked if the array was a 'vector. So I changed that. It runs +;;; fine on clisp 2.31 with the two fixes. I don't have any other +;;; Lisp installed, though, so I can't conveniently test it on others. +;;; +;;; 8 February 2004. Gene Michael Stover. +;;; Renamed a couple of constants to begin with "mt-" to avoid +;;; name collisions. +;;; MT-RANDOM now works when its "limit" argument is an integral +;;; bignum. In other words, "(mt-random (expt 2 68))" should +;;; return (- (expt 2 68) 1) with the same frequency it returns +;;; any other number. +(in-package #:cl-skip-list) + +;;; These two constants should begin with "*mt-" to help avoid +;;; collisions. (2004-Feb-07, gms) +(defconstant *mt-k2^32* (expt 2 32)) +(defconstant *mt-k-inverse-2^32f* (expt 2.0 -32.0) + "1/(2^32), as a floating-point number") + +(defconstant *mt-n* 624) +(defconstant *mt-m* 397) +(defconstant *mt-upper-mask* #x80000000 "most significant w-r bits") +(defconstant *mt-lower-mask* #x7FFFFFFF "least significant r bits") + +(defstruct (mt-random-state + (:constructor mt-internal-make-random-state)) + ;; Could have avoided MTI, which is an index into ARR, with a + ;; fill pointer in ARR. MTI more closely follows the reference + ;; implementation. + ;; ARR corresponts to "mt[]" in the reference implementation. + ;; Probably should have called it MT after all. Oh well. + mti ; index into ARR + arr) ; array of numbers + +(labels + ((next-seed (n) (mod (1+ (* 69069 n)) *mt-k2^32*)) + (get-hi16 (n) (logand n #xFFFF0000)) + (next-elt (n) + (logior (get-hi16 n) + (ash (get-hi16 (next-seed n)) -16)))) + (defun mt-make-random-state-integer (n) + "Use the single integer to expand into a bunch of +integers to use as an MT-RANDOM-STATE. +Copied from the 'sgenrand' function in mt19937int.c. +This is mostly an internal function. I recommend using +MAKE-MT-RANDOM-STATE unless specific circumstances dictate otherwise." + (mt-internal-make-random-state + :mti *mt-n* + :arr (make-array + *mt-n* + :element-type 'integer + :initial-contents (do ((i 0 (1+ i)) + (sd n (next-seed (next-seed sd))) + (lst () (cons (next-elt sd) lst))) + ((>= i *mt-n*) (nreverse lst))))))) + +(defvar *mt-random-state* nil + "Unlike the reference implementation, we'll initialize the random +state to a hopefully somewhat random & unique value., but not until after defining +(mt-make-random-state-random)") + +(let ((some-number 0)) + (defun mt-make-random-state-random () + "Generate a new random state from a new, hopefully somewhat +random, value. +This is mostly an internal function. I recommend using +MAKE-MT-RANDOM-STATE unless specific circumstances dictate otherwise." + (mt-make-random-state-integer (+ (get-universal-time) + (incf some-number))))) + +(defun make-mt-random-state (&optional state) + "Analogous to Common Lisp's MAKE-RANDOM-STATE except that this function +works on random states for JMT's Mersenne Twister implementation." + (cond ((eq state t) (mt-make-random-state-random)) + ((null state) + ;; For NIL, return a copy of the current state. + (make-mt-random-state *mt-random-state*)) + ((integerp state) + ;; Expand the integer STATE into controlled junk that is an + ;; MT RANDOM STATE. + (mt-make-random-state-integer state)) + ((typep state 'sequence) + ;; It's a list or an array. It must be of length *MT-N*, & it + ;; must contain integers. We'll create a random state object + ;; using a copy of that sequence. + (assert state) ; should have caught NIL earlier + (assert (eql (length state) *mt-n*)) + (assert (not (find-if #'integerp state))) + (mt-internal-make-random-state + :mti 0 + :arr (copy-seq (coerce state 'array)))) + ((mt-random-state-p state) + ;; Return a copy of state. It is an instance of MT-RANDOM-STATE. + (mt-internal-make-random-state + :mti (mt-random-state-mti state) + :arr (copy-seq (mt-random-state-arr state)))) + (t + ;; For anything else, error. + (cerror "STATE should not have a value of ~A" state)))) + +(setq *mt-random-state* (make-mt-random-state t)) + +(let* ((matrix-a #x9908B0DF) + (mag01 (coerce (list 0 matrix-a) 'vector))) + (defun mt-refill () + "In the C program mt19937int.c, there is a function called 'genrand', & in +that function there is a block of code to execute when the mt[] array is +exhausted. This function is that block of code. I've removed it from my +MT-GENRAND function for clarity." + ;; This function is pretty much a direct translation of the C function. + ;; In other words, you're about to see some very un-Lispy code. + (let (y kk) + (setq kk 0) + (do () + ((>= kk (- *mt-n* *mt-m*))) + (setq y (logior + (logand (aref (mt-random-state-arr *mt-random-state*) + kk) + *mt-upper-mask*) + (logand (aref (mt-random-state-arr *mt-random-state*) + (1+ kk)) + *mt-lower-mask*))) + (setf (aref (mt-random-state-arr *mt-random-state*) kk) + (logxor + (aref (mt-random-state-arr *mt-random-state*) (+ kk *mt-m*)) + (ash y -1) + (aref mag01 (logand y 1)))) + (incf kk)) + (do () + ((>= kk (- *mt-n* 1))) + (setq y (logior + (logand + (aref (mt-random-state-arr *mt-random-state*) kk) + *mt-upper-mask*) + (logand + (aref (mt-random-state-arr *mt-random-state*) (1+ kk)) + *mt-lower-mask*))) + (setf (aref (mt-random-state-arr *mt-random-state*) kk) + (logxor (aref (mt-random-state-arr *mt-random-state*) + (+ kk (- *mt-m* *mt-n*))) + (ash y -1) + (aref mag01 (logand y 1)))) + (incf kk)) + (setq y (logior + (logand + (aref (mt-random-state-arr *mt-random-state*) (- *mt-n* 1)) + *mt-upper-mask*) + (logand + (aref (mt-random-state-arr *mt-random-state*) 0) + *mt-lower-mask*))) + (setf (aref (mt-random-state-arr *mt-random-state*) (- *mt-n* 1)) + (logxor + (aref (mt-random-state-arr *mt-random-state*) (- *mt-m* 1)) + (ash y -1) + (aref mag01 (logand y 1)))) + (setf (mt-random-state-mti *mt-random-state*) 0)) + 'mt-refill)) + +(defun mt-tempering-shift-u (n) + (mod (ash n -11) *mt-k2^32*)) + +(defun mt-tempering-shift-s (n) + (mod (ash n 7) *mt-k2^32*)) + +(defun mt-tempering-shift-t (n) + (mod (ash n 15) *mt-k2^32*)) + +(defun mt-tempering-shift-l (n) + (mod (ash n -18) *mt-k2^32*)) + +(let ((mt-tempering-mask-b #x9d2c5680) + (mt-tempering-mask-c #xefc60000)) + (defun mt-genrand () + (when (>= (mt-random-state-mti *mt-random-state*) *mt-n*) + (mt-refill)) + (let ((y (aref (mt-random-state-arr *mt-random-state*) + (mt-random-state-mti *mt-random-state*)))) + (incf (mt-random-state-mti *mt-random-state*)) + ;; The following separate, explicit SETQ & other expressions + ;; could be compacted/optimized into a single arithmetic expression + ;; that does not store into any temporary variables. That could be + ;; more efficient at run-time, but I have chosen instead of immitate + ;; the statements in the C program, mt19937int.c. + (setq y (logxor y (mt-tempering-shift-u y))) + (setq y (logxor y (logand (mt-tempering-shift-s y) + mt-tempering-mask-b))) + (setq y (logxor y (logand (mt-tempering-shift-t y) + mt-tempering-mask-c))) + (setq y (logxor y (mt-tempering-shift-l y))) + y))) + +(defun mt-random (n &optional state) + "Generate a random number. WARNING: setting state here is not thread safe; +*mt-random-state* will be set without any regard for what others are doing with it!" + (assert (plusp n)) + (when state + (assert (mt-random-state-p state)) + ;; Save a copy of the random state. + (setq *mt-random-state* (make-mt-random-state state))) + (if (integerp n) + (mod (do ((bits-needed (log n 2) ) + (bit-count 0 (+ 32 bit-count)) + (r 0 (+ (ash r 32) (mt-genrand)))) + ((>= bit-count bits-needed) r)) + n) + (* (mt-genrand) *mt-k-inverse-2^32f* n))) + +;;; --- end of file --- diff --git a/libraries/cl-skip-list/skip-list.lisp b/libraries/cl-skip-list/skip-list.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7b6a861875e51905491fe6811ed119cb35fe0560 --- /dev/null +++ b/libraries/cl-skip-list/skip-list.lisp @@ -0,0 +1,341 @@ +(in-package :cl-skip-list) + +(define-condition skip-list-duplicate-error (error) + ((key :initarg :key) + (value :initarg :value)) + (:report (lambda (error stream) + (with-slots (key value) error + (format stream "Skip list already has node with key ~A and value ~A." + key value))))) + +(define-condition skip-list-kv-not-found-error (error) + ((key :initarg :key) + (value :initarg :value)) + (:report (lambda (error stream) + (with-slots (key value) error + (format stream + "Could not find node with key ~A and value ~A in skip-list." + key value))))) + +(defconstant +max-level+ (the fixnum 32) + "Maximum level of skip-list, should be enough for 2^32 elements.") + +(defun random-level () + "Returns a random level for a new skip-list node, following Pugh's pattern of +L1: 50%, L2: 25%, L3: 12.5%, ..." + (declare (optimize speed)) + (do ((level 1 (1+ level))) + ((or (= level +max-level+) + (= (mt-random 4 (make-mt-random-state)) 3)) ;; + level) + (declare (type fixnum level)))) + +;;; A node is a SIMPLE-VECTOR containing KEY, VALUE, LEVEL and the forward pointers +(defconstant +skip-node-key+ 0) +(defconstant +skip-node-value+ 1) +(defconstant +skip-node-forward+ 2) +(defconstant +skip-node-level+ 3) + +(defmacro skip-node-key (node) + `(svref (the simple-vector ,node) +skip-node-key+)) +(defmacro skip-node-value (node) + `(svref (the simple-vector ,node) +skip-node-value+)) +(defmacro skip-node-forward (node) + `(svref (the simple-vector ,node) +skip-node-forward+)) +(defmacro skip-node-level (node) + `(svref (the simple-vector ,node) +skip-node-level+)) + +(defun make-skip-node (key value size &key initial-element) + (let ((node (make-array 4 :initial-element initial-element))) + (setf (svref node +skip-node-key+) key + (svref node +skip-node-value+) value + (svref node +skip-node-forward+) (make-array size :initial-element nil) + (svref node +skip-node-level+) size) + node)) + +(defun make-head (&key initial-element) + (make-skip-node :head nil +max-level+ :initial-element initial-element)) + +(defstruct (skip-list + (:predicate skip-list?) + (:print-function print-skip-list)) + (head (make-head)) + (key-equal #'equal) + (value-equal #'equal) + (comparison #'less-than) + (duplicates-allowed? nil) + (node-fn #'make-skip-node) + (length 0 :type + #+CFFI-FEATURES:X86 (UNSIGNED-BYTE 32) + #+CFFI-FEATURES:X86-64 (UNSIGNED-BYTE 64) + #+ARM64 (UNSIGNED-BYTE 64))) + +(defun print-skip-list (sl stream depth) + (declare (ignore depth)) + (format stream "#" + (skip-list-length sl) (skip-list-key-equal sl) + (if (skip-list-duplicates-allowed? sl) "ALLOWED" "NOT ALLOWED"))) + +(defmethod skip-list-search ((sl skip-list) key &optional value) + (let ((start-node (skip-list-head sl))) + (let ((x start-node) (y nil) + (left-list (make-array +max-level+ :initial-element nil)) + (right-list (make-array +max-level+ :initial-element nil))) + (loop for level from (1- (skip-node-level start-node)) downto 0 do + (loop + (setq y (mcas-read (skip-node-forward x) level)) + (if (or (null y) + (funcall (skip-list-comparison sl) key (skip-node-key y)) + (and value + (funcall (skip-list-key-equal sl) key (skip-node-key y)) + (funcall (skip-list-value-equal sl) + value (mcas-read y +skip-node-value+))) + (and (null value) + (funcall (skip-list-key-equal sl) key (skip-node-key y)))) + (return) + (setq x y))) + (setf (svref left-list level) x + (svref right-list level) y)) + (values left-list right-list)))) + +(defmethod skip-list-empty? ((sl skip-list)) + (= (skip-list-length sl) 0)) + +(defun node-forward (node) + (declare (type (or null simple-vector) node)) + (if node + (mcas-read (skip-node-forward node) 0) + nil)) + +(defmethod skip-list-to-list ((sl skip-list)) + (let ((node (skip-list-head sl))) + (loop for next = (node-forward node) then (node-forward next) + while next + collect (list (skip-node-key next) (mcas-read next +skip-node-value+))))) + +(defmethod skip-list-lookup ((sl skip-list) key &optional value) + (multiple-value-bind (left-list right-list) (skip-list-search sl key value) + (declare (ignore left-list)) + (if (and (svref right-list 0) + (funcall (skip-list-key-equal sl) key (skip-node-key (svref right-list 0)))) + (mcas-read (svref right-list 0) +skip-node-value+) + nil))) + +(defmethod skip-list-replace-kv ((sl skip-list) key new-value &optional old-value) + "Replaces a node's value with new-value. If old-value is supplied, will only replace the value +if it matches old-value, otherwise throws 'skip-list-kv-not-found-error." + (multiple-value-bind (left-list right-list) (skip-list-search sl key old-value) + (declare (ignore left-list)) + (let ((node (svref right-list 0))) + (when (and node + (funcall (skip-list-key-equal sl) key (skip-node-key node))) + (if old-value + (let ((read-value (mcas-read node +skip-node-value+))) + (if (funcall (skip-list-value-equal sl) old-value read-value) + (if (funcall (skip-list-value-equal sl) + read-value + (cas (svref node +skip-node-value+) + read-value + new-value)) + t + nil) + (error 'skip-list-kv-not-found-error :key key :value old-value))) + (let ((read-value (mcas-read node +skip-node-value+))) + (if (funcall (skip-list-value-equal sl) + read-value + (cas (svref node +skip-node-value+) + read-value + new-value)) + t + nil))))))) + +(defmethod skip-list-add ((sl skip-list) key value) + "Adds a new k/v pair to the skip list. Will not overwrite existing nodes or values. Use skip-list-replace-kv for that. Be prepared to catch a 'skip-list-duplicate-error." + (multiple-value-bind (left-list right-list) (skip-list-search sl key value) + (let ((right-node (svref right-list 0)) + (left-node (svref left-list 0))) + (cond ((and right-node + (funcall (skip-list-key-equal sl) key (skip-node-key right-node)) + (not (skip-list-duplicates-allowed? sl))) + (error 'skip-list-duplicate-error :key key :value (skip-node-value right-node))) + ((and left-node + (funcall (skip-list-key-equal sl) key (skip-node-key left-node)) + (not (skip-list-duplicates-allowed? sl))) + (error 'skip-list-duplicate-error :key key :value (skip-node-value left-node))) + (t + (let ((new-node (funcall (skip-list-node-fn sl) key value (random-level)))) + (mcas-successful? + (with-mcas (:equality #'equal + :success-action + #'(lambda () + (sb-ext:atomic-incf (skip-list-length sl)))) + (dotimes (i (skip-node-level new-node)) + (setf (svref (skip-node-forward new-node) i) + (svref right-list i)) + (mcas-set (skip-node-forward (svref left-list i)) i + (svref right-list i) + new-node)))))))))) + +(defmethod skip-list-delete ((sl skip-list) key &optional value) + "Delete a key or k/v pair from the skip list. If no value is specified and duplicates are +allowed, it will delete the first key it finds." + (multiple-value-bind (left-list right-list) (skip-list-search sl key value) + (let ((match-node (svref right-list 0))) + (cond ((null match-node) + nil) + ((not (funcall (skip-list-key-equal sl) (skip-node-key match-node) key)) + nil) + (t + (let ((old-value (mcas-read match-node +skip-node-value+))) + (mcas-successful? + (with-mcas (:equality #'equal + :success-action + #'(lambda () + (sb-ext:atomic-decf (skip-list-length sl)))) + (loop for i from 0 to (1- (skip-node-level match-node)) do + (let ((next-node (mcas-read (skip-node-forward match-node) i))) + (if (and next-node + (funcall (skip-list-comparison sl) + (skip-node-key next-node) + (skip-node-key match-node))) + nil + (progn + (mcas-set (skip-node-forward (svref left-list i)) i + match-node + next-node) + (mcas-set (skip-node-forward match-node) i + next-node + (svref left-list i)))))) + (mcas-set match-node +skip-node-value+ old-value nil))))))))) + +;;; cursors, some code borrowed from Manuel Odendahl 's skip list code +(defclass skip-list-cursor () + ((node :initarg :node :accessor skip-list-cursor-node) + (skip-list :initarg :skip-list :accessor skip-list))) + +(defmethod sl-cursor-next ((slc skip-list-cursor) &optional eoc) + (with-slots (node) slc + (if node + (let ((result (list (skip-node-key node) + (mcas-read node +skip-node-value+)))) + (setf node (node-forward node)) + result) + eoc))) + +(defclass skip-list-value-cursor (skip-list-cursor) + ()) + +(defmethod sl-cursor-next :around ((slc skip-list-value-cursor) &optional eoc) + (let ((result (call-next-method))) + (if (eql result eoc) + eoc + (second result)))) + +(defclass skip-list-key-cursor (skip-list-cursor) + ()) + +(defmethod sl-cursor-next :around ((slc skip-list-key-cursor) &optional eoc) + (let ((result (call-next-method))) + (if (eql result eoc) + eoc + (first result)))) + +(defmethod skip-list-cursor ((sl skip-list) &key cursor + (cursor-class 'skip-list-cursor)) + (if cursor + (progn (setf (skip-list-cursor-node cursor) + (node-forward (skip-list-head sl))) + cursor) + (make-instance cursor-class + :node (node-forward (skip-list-head sl)) :skip-list sl))) + +(defmethod skip-list-values-cursor ((sl skip-list)) + (skip-list-cursor sl :cursor-class 'skip-list-value-cursor)) + +(defmethod skip-list-keys-cursor ((sl skip-list)) + (skip-list-cursor sl :cursor-class 'skip-list-key-cursor)) + +(defclass skip-list-range-cursor (skip-list-cursor) + ((end :initarg :end :reader slrc-end))) + +(defmethod sl-cursor-next :around ((slc skip-list-range-cursor) &optional eoc) + (with-slots (node end) slc + (if (and node + (or + (funcall (skip-list-comparison (skip-list slc)) (skip-node-key node) end) + (funcall (skip-list-key-equal (skip-list slc)) (skip-node-key node) end))) + (call-next-method) + eoc))) + +(defmethod skip-list-range-cursor ((sl skip-list) start end) + (multiple-value-bind (left-list right-list) (skip-list-search sl start) + (let ((right-node (svref right-list 0)) + (left-node (svref left-list 0))) + (cond ((and left-node (or (funcall (skip-list-comparison sl) + start + (skip-node-key left-node)) + (funcall (skip-list-key-equal sl) + start + (skip-node-key left-node)))) + (make-instance 'skip-list-range-cursor + :node left-node :end end :skip-list sl)) + ((and right-node (or (funcall (skip-list-comparison sl) + start + (skip-node-key right-node)) + (funcall (skip-list-key-equal sl) + start + (skip-node-key right-node)))) + (make-instance 'skip-list-range-cursor + :node right-node :end end :skip-list sl)))))) + +(defmethod map-skip-list (fun (sl skip-list)) + (let ((cursor (skip-list-cursor sl))) + (do ((val (sl-cursor-next cursor) + (sl-cursor-next cursor))) + ((null val)) + (apply fun val)))) + +(defmethod map-skip-list-values (fun (sl skip-list)) + (let ((cursor (skip-list-values-cursor sl))) + (do ((val (sl-cursor-next cursor) + (sl-cursor-next cursor))) + ((null val)) + (funcall fun val)))) + +(defmethod skip-list-fetch-all ((sl skip-list) key) + "Return all values for a key in a skip list where duplicates are allowed." + (let ((cursor (skip-list-range-cursor sl key key)) + (result nil)) + (if cursor + (progn + (do ((node (sl-cursor-next cursor) (sl-cursor-next cursor))) + ((null node)) + (push (second node) result)) + (nreverse result)) + nil))) + +(defun sl-test () + (let ((sl (make-skip-list :duplicates-allowed? t))) + (dotimes (j 10) + (dotimes (i 10) + (skip-list-add sl i (code-char i))) + ) + (format t "GOT: 0 = ~A~%" (skip-list-lookup sl 0)) + (map-skip-list #'(lambda (k v) + (format t "~A: ~A (~D)~%" k v (char-code v))) + sl) + (let ((c (skip-list-range-cursor sl 2 2))) + ;;(let ((c (skip-list-cursor sl))) + (format t "CURSOR: ~A~%" c) + (do ((i (sl-cursor-next c) (sl-cursor-next c))) + ((null i)) + (format t "CURSOR: '~A'~%" i))) + (format t "~A~%" (skip-list-to-list sl)) + (format t "~A~%" sl) + ;;(format t "lookup 5: ~A~%" (skip-list-lookup sl 5)) + (dotimes (i 10) + (dotimes (j 10) + (format t "Deleting ~A~%" i) + (skip-list-delete sl i) + (format t "~A~%" (skip-list-to-list sl)) + (format t "~A~%" sl))))) diff --git a/libraries/cl-skip-list/skip-pq.lisp b/libraries/cl-skip-list/skip-pq.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1e370f5b3e626419311d66ba3cc31bc7d4c3985b --- /dev/null +++ b/libraries/cl-skip-list/skip-pq.lisp @@ -0,0 +1,129 @@ +(in-package :cl-skip-list) + +(defconstant +skip-node-deleted+ 4) +(defconstant +skip-node-timestamp+ 5) + +(defmacro skip-node-deleted? (node) + `(svref (the simple-vector ,node) +skip-node-deleted+)) + +(defmacro skip-node-timestamp (node) + `(svref (the simple-vector ,node) +skip-node-timestamp+)) + +(defun make-skip-pq-node (key value size &key initial-element timestamp) + (let ((node (make-array 6 :initial-element initial-element))) + (setf (svref node +skip-node-key+) key + (svref node +skip-node-value+) value + (svref node +skip-node-forward+) (make-array size :initial-element nil) + (svref node +skip-node-level+) size + (svref node +skip-node-deleted+) nil + (svref node +skip-node-timestamp+) (or timestamp (gettimeofday))) + node)) + +(defun make-skip-pq (&key (key-equal #'=) (value-equal #'equal) (comparison #'<) + (head-value most-negative-fixnum)) + (make-skip-list + :head (make-skip-pq-node head-value nil +max-level+ :timestamp most-positive-fixnum) + :key-equal key-equal + :value-equal value-equal + :comparison comparison + :duplicates-allowed? t + :node-fn #'make-skip-pq-node)) + +(defmethod skip-pq-search ((sl skip-list) key id) + (let ((start-node (skip-list-head sl))) + (let ((x start-node) (y nil) + (left-list (make-array +max-level+ :initial-element nil)) + (right-list (make-array +max-level+ :initial-element nil))) + (loop for level from (1- (skip-node-level start-node)) downto 0 do + (loop + (setq y (mcas-read (skip-node-forward x) level)) + (cond ((null y) + (return)) + ((funcall (skip-list-comparison sl) key (skip-node-key y)) + (return)) + ((and (funcall (skip-list-key-equal sl) key (skip-node-key y)) + (eql id (skip-node-deleted? y))) + (return)) + ((funcall (skip-list-key-equal sl) key (skip-node-key y)) + (return)) + (t + (setq x y)))) + (setf (svref left-list level) x + (svref right-list level) y)) + (values left-list right-list)))) + +(defmethod skip-pq-add ((sl skip-list) key value) + (skip-list-add sl key value)) + +(defmethod skip-pq-delete ((sl skip-list) node) + "Delete a key or k/v pair from the skip pq. If no value is specified and duplicates are +allowed, it will delete the first key it finds." + (multiple-value-bind (left-list right-list) + (skip-pq-search sl (skip-node-key node) (skip-node-deleted? node)) + (let ((match-node (svref right-list 0))) + (cond ((null match-node) + nil) + ((not (and (funcall (skip-list-key-equal sl) + (skip-node-key match-node) (skip-node-key node)) + (eql sb-thread:*current-thread* (skip-node-deleted? match-node)))) + nil) + (t + (let ((old-value (mcas-read match-node +skip-node-value+))) + (mcas-successful? + (with-mcas (:equality #'equal + :success-action + #'(lambda () + (sb-ext:atomic-decf (skip-list-length sl)))) + (loop for i from 0 to (1- (skip-node-level match-node)) do + (let ((next-node (mcas-read (skip-node-forward match-node) i))) + (if (and next-node + (funcall (skip-list-comparison sl) + (skip-node-key next-node) + (skip-node-key match-node))) + nil + (progn + (mcas-set (skip-node-forward (svref left-list i)) i + match-node + next-node) + (mcas-set (skip-node-forward match-node) i + next-node + (svref left-list i)))))) + (mcas-set match-node +skip-node-value+ old-value nil))))))))) + +(defmethod delete-min ((sl skip-list)) + (let ((start-time (gettimeofday))) + (let ((x (skip-list-head sl)) (y nil)) + (loop + (setq y (mcas-read (skip-node-forward x) 0)) + (cond ((null y) + (return-from delete-min nil)) + ((and (>= start-time (skip-node-timestamp y)) + (null (cas (svref y +skip-node-deleted+) nil sb-thread:*current-thread*))) + (let ((k (skip-node-key y)) (v (skip-node-value y))) + (skip-pq-delete sl y) + (return-from delete-min (list k v)))) + (t + (setq x y)))) + nil))) + +#| +(defun pq-test () + (let ((sl (make-skip-pq))) + (dotimes (j 4) + (dotimes (i 5) + (skip-list-add sl i (code-char i)))) + (format t "~A~%" (skip-list-to-list sl)) +; (map-skip-list #'(lambda (k v) (format t "~A: ~A~%" k v)) sl) +; (let ((c (skip-list-range-cursor sl 33 126))) +; (do ((i (sl-cursor-next c) (sl-cursor-next c))) +; ((null i)) +; (format t "~A~%" i))) + (format t "~A~%" sl) + (dotimes (i 5) + (dotimes (j 4) + (format t "~A~%" (delete-min sl)) + (format t "~A~%" (skip-list-to-list sl)) + (format t "~A~%" sl))))) + +; (skip-list-to-list sl))) +|# diff --git a/libraries/cl-skip-list/test-skip-list.lisp b/libraries/cl-skip-list/test-skip-list.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8dd3601558b23e15100451e4fb9d36fa29a5c6fd --- /dev/null +++ b/libraries/cl-skip-list/test-skip-list.lisp @@ -0,0 +1,61 @@ +(require 'asdf) +(asdf:oos 'asdf:load-op 'cl-skip-list) +(in-package #:cl-skip-list) +(asdf:oos 'asdf:load-op 'fiveam) +;;(use-package (find-package "FIVEAM")) + +(fiveam:def-suite skip-list-test-suite :description "Skip List Test Suite") +(fiveam:in-suite skip-list-test-suite) +(format t "~%~%Preparing to run all Skip List Tests.~%") + +(fiveam:def-fixture sl/fixture + (&key + (sl-no-dupes (make-skip-list)) + (sl-dupes (make-skip-list :duplicates-allowed? t))) + (&body)) + +(fiveam:test (skip-list-tests :fixture sl/fixture) + ;;; no dupes tests + (fiveam:is-true (skip-list? sl-no-dupes)) + (fiveam:is (eq t (skip-list-add sl-no-dupes 2 "V2"))) + (fiveam:is (eq t (skip-list-add sl-no-dupes :k6 "v6"))) + (fiveam:is (eq t (skip-list-add sl-no-dupes 1 1))) + (fiveam:is (eq t (skip-list-add sl-no-dupes "K3" 3))) + (fiveam:is (eq t (skip-list-add sl-no-dupes :k5 5))) + (fiveam:is (eq t (skip-list-add sl-no-dupes "K4" "V4"))) + (fiveam:signals + (skip-list-duplicate-error "Attempt to add node with duplicate key succeeded. Not OK!") + (skip-list-add sl-no-dupes :k6 "v666")) + (fiveam:signals + (skip-list-duplicate-error "Attempt to add node with duplicate key succeeded. Not OK!") + (skip-list-add sl-no-dupes 1 "v1")) + (fiveam:signals + (skip-list-duplicate-error "Attempt to add node with duplicate key succeeded. Not OK!") + (skip-list-add sl-no-dupes "K3" "v3")) + (fiveam:is (= 1 (skip-list-lookup sl-no-dupes 1))) + (fiveam:is (= 3 (skip-list-lookup sl-no-dupes "K3"))) + (fiveam:is (= 5 (skip-list-lookup sl-no-dupes :k5))) + (fiveam:is (equal "V2" (skip-list-lookup sl-no-dupes 2))) + (fiveam:is (equal "V4" (skip-list-lookup sl-no-dupes "K4"))) + (fiveam:is (equal "v6" (skip-list-lookup sl-no-dupes :k6))) + (fiveam:is (eq t (skip-list-delete sl-no-dupes 1))) + (fiveam:is (eq t (skip-list-delete sl-no-dupes 2))) + (fiveam:is (eq t (skip-list-delete sl-no-dupes :k5))) + ;; Dupe list tests UNFINISHED! + (fiveam:is-true (skip-list? sl-dupes)) + (fiveam:is (eq t (skip-list-add sl-dupes 1 1))) + (fiveam:is (eq t (skip-list-add sl-dupes 2 "V2"))) + (fiveam:is (eq t (skip-list-add sl-dupes "K3" 3))) + (fiveam:is (eq t (skip-list-add sl-dupes "K4" "V4"))) + (fiveam:is (eq t (skip-list-add sl-dupes :k5 5))) + (fiveam:is (eq t (skip-list-add sl-dupes :k6 "v6"))) + (fiveam:is (eq t (skip-list-add sl-dupes 1 11))) + (fiveam:is (eq t (skip-list-add sl-dupes 2 "V12"))) + (fiveam:is (eq t (skip-list-add sl-dupes "K3" 13))) + (fiveam:is (eq t (skip-list-add sl-dupes "K4" "V14"))) + (fiveam:is (eq t (skip-list-add sl-dupes :k5 15))) + (fiveam:is (eq t (skip-list-add sl-dupes :k6 "v16"))) + ;; TEST LOOKUPS... + ) + +(fiveam:run!) diff --git a/libraries/cl-skip-list/utilities.lisp b/libraries/cl-skip-list/utilities.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a498dcd018faf1f80e67ecccb617a100669ca23a --- /dev/null +++ b/libraries/cl-skip-list/utilities.lisp @@ -0,0 +1,23 @@ +(in-package #:cl-skip-list) + +(defmacro while (test &rest body) + `(loop until (not ,test) do + ,@body)) + +(defgeneric less-than (x y) + (:documentation "Generic less-than operator. Allows comparison of apples and oranges.") + (:method ((x symbol) (y symbol)) (string< (symbol-name x) (symbol-name y))) + (:method ((x symbol) (y string)) (string< (symbol-name x) y)) + (:method ((x symbol) (y number)) (string< (symbol-name x) (write-to-string y))) + (:method ((x number) (y number)) (< x y)) + (:method ((x number) (y symbol)) (string< (write-to-string x) (symbol-name y))) + (:method ((x number) (y string)) (string< (write-to-string x) y)) + (:method ((x string) (y string)) (string< x y)) + (:method ((x string) (y symbol)) (string< x (symbol-name y))) + (:method ((x string) (y number)) (string< x (write-to-string y)))) + +(defun get-prop (plist prop) + (cond ((null plist) nil) + ((eql (car plist) prop) + (cadr plist)) + (t (get-prop (cddr plist) prop)))) diff --git a/libraries/lw-add-ons/documentation.lisp b/libraries/lw-add-ons/documentation.lisp index dc06eee0920440d58dd1da05194cf64b3c8a4e9e..6bb854134fa4349a54e0c15568a4e141749ac7f5 100644 --- a/libraries/lw-add-ons/documentation.lisp +++ b/libraries/lw-add-ons/documentation.lisp @@ -34,8 +34,12 @@ 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" + #+(and :lispworks8 :linux) + "manual/html-l/~A" #+(or :lispworks6.1 :lispworks7) "manual/online/~A" #-(or :lispworks6.1 :lispworks7 :lispworks8) diff --git a/sharing/clevr-world/clevr-ontology.lisp b/sharing/clevr-world/clevr-ontology.lisp index dd668a777fd5aa25a1640a611aaf44642213723b..9609afe20295ede727f23796069bed429d881269 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")) ;; ################################ diff --git a/systems/corpus-processing/corpus-processing-with-subprocesses.lisp b/systems/corpus-processing/corpus-processing-with-subprocesses.lisp index b6bcebeda19ab8113318cb528eb34580069f672b..bb3e06ecc81cf74abd2ea737f28b8063a3398e0d 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 diff --git a/systems/fcg/categorial-networks/categorial-network.lisp b/systems/fcg/categorial-networks/categorial-network.lisp index 2f9a92d355afdbb879d0e2837eaf03760e5b320c..06b14adb07a7c06be3571bb5ad68237a4e8f0da4 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/development-grammars/basic-holistic-chunking.lisp b/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp deleted file mode 100644 index 006daaabe49d5fcc7fcce2998a530f51ee85c6c2..0000000000000000000000000000000000000000 --- a/systems/grammar-learning/development-grammars/basic-holistic-chunking.lisp +++ /dev/null @@ -1,97 +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 (?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)) - (syn-cat (phrase-type holistic) - (lex-class large-gray)) - (boundaries - (left ?tiny-unit) - (right ?yellow-unit)) - ) - <- - (?tiny-yellow-unit - (HASH meaning ((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) - (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") - (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 (?size-4 ?color-2)) - -- - (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/development-grammars/irl-anti-unification-example.lisp b/systems/grammar-learning/development-grammars/template-grammar.lisp similarity index 67% rename from systems/grammar-learning/development-grammars/irl-anti-unification-example.lisp rename to systems/grammar-learning/development-grammars/template-grammar.lisp index 1a2d8eeda83e14a91aae9ccf255456373f8fb07f..3f228c08a6bb23b7140a61060f697c5586357293 100644 --- a/systems/grammar-learning/development-grammars/irl-anti-unification-example.lisp +++ b/systems/grammar-learning/development-grammars/template-grammar.lisp @@ -12,44 +12,25 @@ (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 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)) + (lex-class categorial-network-lookup)) (boundaries (left ?tiny-unit) - (right ?yellow-unit)) - ) + (right ?yellow-unit))) <- (?tiny-yellow-unit - (HASH meaning ((filter ?target-2 ?target-1 ?color-2) - (filter ?target-39552 ?target-2 ?size-4) + (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") @@ -57,13 +38,33 @@ (meets ?tiny-unit ?yellow-unit)))))) +(def-fcg-cxn yellow-cxn + ((?yellow-unit + (args (?target-1 ?target-39552)) + (syn-cat (phrase-type holistic) + (lex-class categorial-network-lookup)) + (boundaries + (left ?yellow-unit) + (right ?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")))) + )) + + (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))) - + (syn-cat (lex-class categorial-network-lookup)) + (boundaries + (left ?large-unit) + (right ?gray-unit))) <- (?item-based-unit (HASH meaning ((query ?target-8 ?source-10 ?attribute-2) @@ -86,11 +87,7 @@ (?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?") + ))) +;(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?") 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 af728a1658c05f99cfbe510dc0cc07175d5b25b9..956759273ae15fae44018cced6dcda1a977fbef9 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 @@ -35,36 +35,23 @@ :problem problem :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 :update-categorial-links nil) - (set-configuration cxn-inventory :use-meta-layer nil) - (set-configuration cxn-inventory :consolidate-repairs nil)) - -(defun enable-meta-layer-configuration (cxn-inventory) - (set-configuration cxn-inventory :category-linking-mode :neighbours) - (set-configuration cxn-inventory :update-categorial-links t) - (set-configuration cxn-inventory :use-meta-layer t) - (set-configuration cxn-inventory :consolidate-repairs t)) - (defun filter-by-phrase-type (type cxns) "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)) (defun create-new-categorial-links (lex-classes-holistic-cxns lex-classes-item-based-units categorial-network) - "Creates all TH links for matching lexical cxns using their original lex-class." + "Creates all categorial links for matching holistic cxns using their original lex-class." (loop for holistic-cxn-lex-class in lex-classes-holistic-cxns for item-slot-lex-class in lex-classes-item-based-units unless (neighbouring-categories-p holistic-cxn-lex-class item-slot-lex-class categorial-network) 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)) @@ -78,7 +65,7 @@ ;;there is a solution with connected links in the categorial-network (when (member 'succeeded (statuses cip-node) :test #'string=) (let* ((applied-cxns (applied-constructions cip-node)) - (holistic-cxns (sort-cxns-by-form-string (filter-by-phrase-type 'holistic applied-cxns) utterance)) ; why sort? reuse the same lookup function from the holistic->item-based repair + (holistic-cxns (sort-cxns-by-form-string (filter-by-phrase-type 'holistic applied-cxns) utterance cxn-inventory)) ; why sort? reuse the same lookup function from the holistic->item-based repair (lex-classes-holistic-cxns (when holistic-cxns (map 'list #'lex-class-cxn holistic-cxns))) (item-based-cxn (first (filter-by-phrase-type 'item-based applied-cxns))) @@ -96,5 +83,3 @@ categorial-links nil))))))) -;; todo: make flag in categorial-network class to indicate whether the network was modified after calculating the transitive closure the last time -;; when calling the connected-path-p function, set calculate the transitive closure, which resets the flag. 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 031e2efe91237ea22389d9b6373150f0931cf8c2..4c4b747e301303a3bbddd08801d39e35b7f62737 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) @@ -33,81 +33,67 @@ :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)) (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))) - (when matching-holistic-cxns - (let* ( - (optimal-coverage-cars (find-optimal-coverage-cars matching-holistic-cxns node)) - (last-car (last-elt optimal-coverage-cars)) - (car-res-cfs (car-resulting-cfs last-car)) + (best-partial-analysis-node (get-best-partial-analysis-cipn + utterance + original-cxn-set + (get-configuration original-cxn-set :learning-strategy))) + (applied-cxns (applied-constructions best-partial-analysis-node)) + (item-based-cxn (first (filter-by-phrase-type 'item-based applied-cxns))) + (applied-holistic-cxns (filter-by-phrase-type 'holistic applied-cxns))) + (when (and applied-holistic-cxns + (not item-based-cxn)) + (let* ((car-res-cfs (car-resulting-cfs (cipn-car best-partial-analysis-node))) (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)) - ; 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)) - + (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 (append placeholder-var-string-predicates chunk-item-based-cxn-form-constraints) original-cxn-set :add-numeric-tail t :add-cxn-suffix nil)) (holistic-cxn-subunit-blocks (multiple-value-list - (loop for unit in resulting-units - for form-constraints = (unit-feature-value unit 'form) - for holistic-cxn-unit-name = (unit-ify (make-cxn-name form-constraints original-cxn-set :add-cxn-suffix nil)) + (loop with remaining-gold-std-meaning = gold-standard-meaning + for unit in resulting-units + for form-constraints = (variablify-form-constraints-with-constants (unit-feature-value unit 'form)) + 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 subtracted-meaning-list = (multiple-value-list (commutative-irl-subset-diff remaining-gold-std-meaning (unit-feature-value unit 'meaning))) + for subtracted-meaning = (second subtracted-meaning-list) 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 (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) + (setf remaining-gold-std-meaning (first subtracted-meaning-list)) collect subtracted-meaning into subtracted-meanings 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 ,leftmost-unit-holistic-cxn) - (right ,rightmost-unit-holistic-cxn)) ) into conditional-units - finally (return (values conditional-units contributing-units holistic-subunit-names categorial-links subtracted-meanings))))) + finally (return (values conditional-units contributing-units holistic-subunit-names categorial-links remaining-gold-std-meaning))))) (holistic-cxn-conditional-units (first holistic-cxn-subunit-blocks)) (holistic-cxn-contributing-units @@ -115,13 +101,15 @@ (holistic-subunit-names (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 (second (multiple-value-list (eval + (remaining-gold-std-meaning (fifth holistic-cxn-subunit-blocks)) + (item-based-cxn-meaning remaining-gold-std-meaning) + (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)) + (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)) @@ -141,9 +129,18 @@ (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)))))) - (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))) + :cxn-inventory ,(copy-object original-cxn-set))))))) + (cxns-to-apply (append applied-holistic-cxns (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/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 485c53c9ad9fce7233f661776c80b8731d0314b0..0388fc061e432e6138d7d3216ba849b26d78e0eb 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,20 +72,22 @@ 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 + :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))) - - ;; args and syn-cat + leftmost-unit-holistic-cxn-2) + ;; lex classes (lex-class-holistic-cxn-1 (if holistic-cxn-1 (lex-class-cxn holistic-cxn-1) @@ -97,21 +99,19 @@ 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)) (categorial-link-2 (cons lex-class-holistic-cxn-2 lex-class-item-based-cxn)) - ;; Args + ;; args (args-holistic-cxn-1 (extract-args-from-irl-network non-overlapping-meaning-cxn)) - - (args-holistic-cxn-2 (extract-args-from-irl-network non-overlapping-meaning-observation)) (hash-string (third (find 'string non-overlapping-form-cxn :key #'first))) - ;; CXNs + ;; cxns (new-holistic-cxn-1 (or holistic-cxn-1 @@ -156,25 +156,27 @@ 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 (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) -- - (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)))) + )) :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 6556ed61e29bfd2914cb7934c02fb264fdb4b042..e3306f4aa48c6000d04c19490efd6d86fc998f88 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,9 +82,11 @@ (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)) - (unit-name-holistic-cxn - (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil))) + (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries + overlapping-meaning + cxn-inventory + :cxn-type 'item-based)) + (unit-name-holistic-cxn leftmost-unit-holistic-cxn) ;; lex-class (lex-class-holistic-cxn (if existing-holistic-cxn @@ -90,7 +95,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)) @@ -119,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) @@ -160,18 +165,19 @@ (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) -- - (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)))) + )) :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 b4e212e2fe9ab67b6d720db1c1cefa80c309a68e..c46d93abf4620d5bc6a582c3b4393baad7b4af8e 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,18 +76,19 @@ (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)) - (unit-name-holistic-cxn - (unit-ify (make-cxn-name non-overlapping-form cxn-inventory :add-cxn-suffix nil)) - ) + (find-cxn-by-form-and-meaning overlapping-form-with-rewritten-boundaries + overlapping-meaning + cxn-inventory + :cxn-type 'item-based)) + (unit-name-holistic-cxn leftmost-unit-holistic-cxn) ;; lex-class (lex-class-holistic-cxn (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))) + (make-lex-class (concatenate 'string (symbol-name cxn-name-item-based-cxn) "-(x)") :trim-cxn-suffix t))) ;; categorial links (categorial-link @@ -123,18 +127,19 @@ (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) -- - (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)))) + )) :attributes (:cxn-type item-based :repair holophrase->item-based+holistic--addition :meaning ,(loop for predicate in overlapping-meaning @@ -144,6 +149,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/repair-item-based-to-holistic.lisp b/systems/grammar-learning/diagnostics-and-repairs/repair-item-based-to-holistic.lisp index 7f2090689c852d125462b7bda3d85028f0fcc452..3234e7032df5e6e013a92b50772c659ba527b4da 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 @@ -1,10 +1,10 @@ (in-package :grammar-learning) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Repair Add holistic construction ;; +;; Repair item-based->holistic ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass item-based->holistic (repair) +(defclass item-based->holistic (add-cxns-and-categorial-links) ((trigger :initform 'fcg::new-node))) (defmethod repair ((repair item-based->holistic) @@ -13,7 +13,7 @@ &key &allow-other-keys) "Repair by making a new holistic construction." (when (initial-node-p node) - (let ((holistic-cxn-and-categorial-link (create-holistic-cxn problem node))) + (let ((holistic-cxn-and-categorial-link (create-holistic-cxn-from-partial-analysis problem node))) (when holistic-cxn-and-categorial-link (make-instance 'fcg::cxn-fix :repair repair @@ -26,134 +26,80 @@ &key &allow-other-keys) "Repair by making a new holistic construction." (when (initial-node-p node) - (let ((holistic-cxn-and-categorial-link (create-holistic-cxn problem node))) + (let ((holistic-cxn-and-categorial-link (create-holistic-cxn-from-partial-analysis problem node))) (when holistic-cxn-and-categorial-link (make-instance 'fcg::cxn-fix :repair repair :problem problem :restart-data holistic-cxn-and-categorial-link))))) + +(defun create-holistic-cxn-from-partial-analysis (problem node) + (let* ((original-cxn-inventory (original-cxn-set (construction-inventory node))) + (utterance (random-elt (get-data problem :utterances))) + (meaning-representation-formalism (get-configuration original-cxn-inventory :meaning-representation-formalism)) + (gold-standard-meaning (meaning-predicates-with-variables (random-elt (get-data problem :meanings)) meaning-representation-formalism)) + (best-partial-analysis-node (get-best-partial-analysis-cipn + utterance + original-cxn-inventory + (get-configuration original-cxn-inventory :learning-strategy))) + (applied-cxns (applied-constructions best-partial-analysis-node)) + (item-based-cxn (first (filter-by-phrase-type 'item-based applied-cxns))) + (applied-holistic-cxns (filter-by-phrase-type 'holistic applied-cxns))) + (when item-based-cxn + (let* ((root-form-constraints (form-predicates-with-variables (unit-feature-value (get-root (left-pole-structure (car-resulting-cfs (cipn-car best-partial-analysis-node)))) 'form))) + (inverted-cxn-meanings (get-inverted-cxn-meanings applied-cxns gold-standard-meaning)) + (remaining-meaning (subtract-cxn-meanings-from-gold-standard-meaning inverted-cxn-meanings gold-standard-meaning))) + (when (and (check-meets-continuity root-form-constraints) ;there is one continuous string in root + (cxn-meaning-is-valid-gold-standard-subset-p inverted-cxn-meanings)) ;; the subtracted meaning must not be nil + (let* ((holistic-cxn-name (make-cxn-name root-form-constraints original-cxn-inventory :add-numeric-tail t :add-cxn-suffix t)) + (lex-class-holistic-cxn (make-lex-class holistic-cxn-name :trim-cxn-suffix t)) + (categorial-network (categorial-network original-cxn-inventory)) + (boundaries-holistic-cxn (get-boundary-units root-form-constraints)) + (leftmost-unit-holistic-cxn (first boundaries-holistic-cxn)) + (rightmost-unit-holistic-cxn (second boundaries-holistic-cxn)) + (args-holistic-cxn (extract-args-from-irl-network remaining-meaning)) + (existing-holistic-cxn (find-cxn-by-form-and-meaning root-form-constraints remaining-meaning original-cxn-inventory :cxn-type 'holistic)) + (holistic-cxn (or existing-holistic-cxn + (second (multiple-value-list (eval + `(def-fcg-cxn ,holistic-cxn-name + ((,leftmost-unit-holistic-cxn + (args ,args-holistic-cxn) + (syn-cat (phrase-type holistic) + (lex-class ,lex-class-holistic-cxn)) + (boundaries + (left ,leftmost-unit-holistic-cxn) + (right ,rightmost-unit-holistic-cxn))) + <- + (,leftmost-unit-holistic-cxn + (HASH meaning ,remaining-meaning) + -- + (HASH form ,root-form-constraints))) + :attributes (:cxn-type holistic + :repair item-based->holistic + :meaning ,(fourth (find 'bind remaining-meaning :key #'first)) + :string ,(third (find 'string root-form-constraints :key #'first))) + :cxn-inventory ,(copy-object original-cxn-inventory))))))) + (all-holistic-cxns (sort-cxns-by-form-string (append + (list holistic-cxn) + applied-holistic-cxns) utterance original-cxn-inventory)) + (lex-classes-holistic-cxns (when all-holistic-cxns (mapcar #'lex-class-cxn all-holistic-cxns))) + (lex-classes-item-based-units (when item-based-cxn (get-all-unit-lex-classes item-based-cxn))) + ;; assign all categorial links + (categorial-links (when (and lex-classes-holistic-cxns + lex-classes-item-based-units + (= (length lex-classes-holistic-cxns) + (length lex-classes-item-based-units))) + (create-new-categorial-links lex-classes-holistic-cxns lex-classes-item-based-units categorial-network))) + + (cxns-to-apply (append all-holistic-cxns (list item-based-cxn))) + (cxns-to-consolidate (unless existing-holistic-cxn (list holistic-cxn)))) + (when categorial-links + (list + cxns-to-apply + categorial-links + cxns-to-consolidate + )))))))) + + -(defun create-holistic-cxn (problem node) - "Creates a holistic cxn if a surrounding item-based cxn with one empty slot exists." - (with-disabled-monitor-notifications - (let* ((processing-cxn-inventory (construction-inventory node)) - (original-cxn-inventory (original-cxn-set processing-cxn-inventory)) - (meaning-representation-formalism (get-configuration processing-cxn-inventory :meaning-representation-formalism)) - (resulting-cars (loop for cxn in (constructions processing-cxn-inventory) - when (and - (equal (attr-val cxn :cxn-type) 'item-based) - (fcg-apply cxn (car-source-cfs (cipn-car (initial-node node))) - (direction (cip node)) - :configuration (configuration processing-cxn-inventory) - :cxn-inventory processing-cxn-inventory)) - return it)) - (item-based-cxn (when resulting-cars (car-applied-cxn (first resulting-cars)))) - (observation (when resulting-cars (left-pole-structure (car-resulting-cfs (first resulting-cars))))) - (string-predicates-in-root (when resulting-cars (form-predicates-with-variables (extract-string (get-root observation)))))) - ;; TODO: rewrite this logic: there can be more than one matching lex cxn without th links and it could still apply, so there can be no new lex cxn and still make the th links --> is this for add-categorial-links? - ;; there is more than one string in root, but there can be a matching lex cxn with missing th links that can be subtracted - (when (and (> (length string-predicates-in-root) 0) - item-based-cxn) - (let* ( - (matching-holistic-cxns (find-matching-holistic-cxns-in-root original-cxn-inventory string-predicates-in-root))) - ;; there are one or more lex cxns, and one remaining string in root - (when (or (and matching-holistic-cxns - (= 1 (- (length string-predicates-in-root) (length matching-holistic-cxns)))) - (= (length string-predicates-in-root) 1)) - ;; construct the remaining cxn first - (let* ((utterance (random-elt (get-data problem :utterances))) - (type-hierarchy (categorial-network original-cxn-inventory)) - (meaning-predicates-gold (meaning-predicates-with-variables (first (get-data problem :meanings)) - meaning-representation-formalism)) - (meaning-predicates-gold-minus-lex (subtract-holistic-cxn-meanings matching-holistic-cxns meaning-predicates-gold)) - (meaning-predicates-observed (extract-meanings observation)) - (meaning-predicates-holistic-cxn (if (= 1 (length string-predicates-in-root)) - (set-difference meaning-predicates-gold meaning-predicates-observed :test #'unify) - (set-difference meaning-predicates-gold-minus-lex meaning-predicates-observed :test #'unify))) - (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)) - (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 - (lex-class-cxn existing-holistic-cxn) - (intern (get-base-name unit-name) :grammar-learning))) - (args (mapcar #'(lambda (predicate) - (extract-args-from-predicate predicate meaning-representation-formalism)) - meaning-predicates-holistic-cxn)) - (new-holistic-cxn (or existing-holistic-cxn (second (multiple-value-list (eval - `(def-fcg-cxn ,cxn-name - ((,unit-name - (syn-cat (phrase-type holistic) - (lex-class ,lex-class)) - (args ,args)) - <- - (,unit-name - (HASH meaning ,meaning-predicates-holistic-cxn) - -- - (HASH form ,form-predicates-holistic-cxn))) - :attributes (:cxn-type holistic - :repair item-based->holistic - :meaning ,(fourth (find 'bind meaning-predicates-holistic-cxn :key #'first)) - :string ,(third (find 'string form-predicates-holistic-cxn :key #'first))) - :cxn-inventory ,(copy-object original-cxn-inventory))))))) - ;; make a list of all cxns, sort them - (applied-holistic-cxns (filter-by-phrase-type 'holistic (applied-constructions node))) - (holistic-cxns (sort-cxns-by-form-string (append - (list new-holistic-cxn) - matching-holistic-cxns - applied-holistic-cxns) utterance)) - (lex-classes-holistic-cxns (when holistic-cxns (map 'list #'lex-class-cxn holistic-cxns))) - (lex-classes-item-based-units (when item-based-cxn (get-all-unit-lex-classes (original-cxn item-based-cxn)))) - ;; assign all th links - (categorial-links (when (and lex-classes-holistic-cxns - lex-classes-item-based-units - (= (length lex-classes-holistic-cxns) (length lex-classes-item-based-units))) - (create-new-categorial-links lex-classes-holistic-cxns lex-classes-item-based-units type-hierarchy)))) - ;; return - (when categorial-links - (list new-holistic-cxn (append (list item-based-cxn) - (list (get-processing-cxn new-holistic-cxn)) - (unless (= 1 (length string-predicates-in-root)) - (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) - "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 - (let* ((new-holistic-cxn (first (restart-data fix))) - (cxns (second (restart-data fix))) - (categorial-links (third (restart-data fix))) - ;; temporarily store the original type hierarchy, copy it and add the links, and set it to the cxn-inventory - (orig-type-hierarchy (categorial-network (construction-inventory node))) - (temp-type-hierarchy (copy-object (categorial-network (construction-inventory node)))) - (categorial-flat-list nil) - (th (loop for categorial-link in categorial-links - do (add-categories (list (car categorial-link) (cdr categorial-link)) temp-type-hierarchy :recompute-transitive-closure nil) - (add-link (car categorial-link) (cdr categorial-link) temp-type-hierarchy :weight 0.5 :recompute-transitive-closure nil) - (setf categorial-flat-list (append categorial-flat-list (list categorial-link))) - finally (set-categorial-network (construction-inventory node) temp-type-hierarchy))) - (last-node (initial-node node)) - (applied-nodes (loop for cxn in cxns - do (setf last-node (fcg::cip-add-child last-node (first (fcg-apply cxn (if (initial-node-p last-node) - (car-source-cfs (cipn-car last-node)) - (car-resulting-cfs (cipn-car last-node))) - (direction (cip node)) - :configuration (configuration (construction-inventory node)) - :cxn-inventory (construction-inventory node))))) - collect last-node))) - ;; ignore - ;; Reset type hierarchy - (set-categorial-network (construction-inventory node) orig-type-hierarchy) - ;; Add cxns to blackboard of last new node - (set-data (car-resulting-cfs (cipn-car last-node)) :fix-cxns (list new-holistic-cxn)) - (set-data (car-resulting-cfs (cipn-car last-node)) :fix-categorial-links categorial-flat-list) - ;; set cxn-supplier to last new node - (setf (cxn-supplier last-node) (cxn-supplier node)) - ;; set statuses (colors in web interface) - (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))))) diff --git a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp index 74005d09e10d73e25c2d1cce163d48c55360be47..793183493301089057843639feb97d1024ad2aa7 100644 --- a/systems/grammar-learning/diagnostics-and-repairs/utils.lisp +++ b/systems/grammar-learning/diagnostics-and-repairs/utils.lisp @@ -3,7 +3,7 @@ (defconstant +placeholder-vars+ '("?X" "?Y" "?Z" "?A" "?B" "?C" "?D" "?E" "?F" "?G" "?H" "?I" "?J" "?K" "?L" "?M" "?N" "?O" "?P" "?Q" "?R" "?S" "?T" "?U" "?V" "?W")) -(defun sort-cxns-by-form-string (cxns-to-sort utterance) +(defun sort-cxns-by-form-string (cxns-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! @@ -11,7 +11,38 @@ cxns-to-sort (let ((resulting-list (make-list (length utterance)))) (loop for cxn-obj in cxns-to-sort - for cxn-string = (third (first (extract-form-predicates cxn-obj))) + for cxn-string = (format nil "~{~a~^ ~}" + (render (extract-form-predicates cxn-obj) + (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 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) @@ -53,8 +84,26 @@ (and (= 1 (length left-most-diff)) (= 1 (length right-most-diff)) (not string-meets-diff) - (not meets-string-diff)) - t))) + (not meets-string-diff) + (get-boundary-units form-constraints)) + (get-boundary-units form-constraints)))) + +(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"))) + (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 (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-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" @@ -92,13 +141,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) @@ -113,12 +155,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))) @@ -170,15 +206,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 &key boundary-list) +(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 (constructions cxn-inventory) - 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)) - t)) + (loop for cxn in (sort (constructions cxn-inventory) #'> :key #'(lambda (x) (attr-val x :score))) + 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)) @@ -265,7 +302,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)))) @@ -314,6 +350,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 @@ -327,7 +371,58 @@ (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-inverted-cxn-meanings (cxns gold-standard-meaning) + "does the inverse set difference between the gold std meaning and the cxn meanings, as to return the matching part from the gold standard meanings that can be subtracted with equals" + (loop for cxn in cxns + for meaning = (get-subtracted-meaning-from-cxn cxn gold-standard-meaning) + collect meaning)) + +(defun cxn-meaning-is-valid-gold-standard-subset-p (cxn-meanings) + (never nil cxn-meanings)) + +(defun subtract-cxn-meanings-from-gold-standard-meaning (cxn-meanings gold-standard-meaning) + (loop with resulting-meaning = gold-standard-meaning + for meaning in cxn-meanings + do (setf resulting-meaning (set-difference resulting-meaning meaning :test #'equal)) + finally (return resulting-meaning))) + +(defun get-subtracted-meaning-from-cxn (cxn gold-standard-meaning) + (let* ((cxn-meaning (extract-meaning-predicates (original-cxn cxn))) + (subtracted-meaning (second (multiple-value-list (commutative-irl-subset-diff gold-standard-meaning cxn-meaning))))) + subtracted-meaning)) + +(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 = (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)) (defgeneric meaning-predicates-with-variables (meaning mode)) @@ -483,7 +578,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 @@ -499,7 +594,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)) @@ -526,7 +621,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)) @@ -555,6 +650,8 @@ cxn))))))) + + (defun find-all-matching-cxn-cars-for-node (cxn-inventory node) ;; handles duplicates by skipping them. return all first cars (not applied to eachother) (with-disabled-monitor-notifications @@ -574,7 +671,7 @@ (= 1 (length cars))) ; if not 1, the cxn matches multiple times collect (first cars))))) -(defun find-optimal-coverage-cars (matching-holistic-cars node) +(defun find-optimal-coverage-cars (matching-holistic-cars node) ;; this should be comprehend with goal test no more strings in root, then iterate through leaf nodes and get the one with shortest root "make hypotetical cars, return the one with highest coverage" ; todo make overlapping testcases, retry until no overlap or tried combinations of cxns, return car with best score (let* ((cars (multiple-value-list (make-hypothetical-car matching-holistic-cars node))) @@ -609,26 +706,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, @@ -715,7 +792,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) 'holistic) (string= (third (first (extract-form-predicates cxn))) root-string)) return cxn)))) @@ -863,3 +940,25 @@ for in-var = (first (multiple-value-list (extract-vars-from-irl-network (list predicate)))) when (equal var in-var) return predicate)) + +(defun disable-meta-layer-configuration (cxn-inventory) + (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)) + +(defun enable-meta-layer-configuration (cxn-inventory) + (set-configuration cxn-inventory :category-linking-mode :neighbours) + (set-configuration cxn-inventory :update-categorial-links t) + (set-configuration cxn-inventory :use-meta-layer t) + (set-configuration cxn-inventory :consolidate-repairs t) + (set-configuration cxn-inventory :parse-goal-tests '(:non-gold-standard-meaning))) + +(defmethod get-best-partial-analysis-cipn ((utterance string) (original-cxn-inventory fcg-construction-set) (mode (eql :optimal-form-coverage))) + (disable-meta-layer-configuration original-cxn-inventory) ;; also relaxes cat-network-lookup to path-exists without transitive closure! + (set-configuration original-cxn-inventory :parse-goal-tests '(:no-applicable-cxns)) + (with-disabled-monitor-notifications + (let* ((comprehension-result (multiple-value-list (comprehend-all utterance :cxn-inventory original-cxn-inventory))) + (cip-nodes (second comprehension-result))) + (enable-meta-layer-configuration original-cxn-inventory) + (first (sort cip-nodes #'< :key #'(lambda (cipn) (length (unit-feature-value (get-root (left-pole-structure (car-resulting-cfs (cipn-car cipn)))) 'form)))))))) \ No newline at end of file diff --git a/systems/grammar-learning/experiment-setup/experiment.lisp b/systems/grammar-learning/experiment-setup/experiment.lisp index 4359d7c39d24bc32e96fc3c7540bcac01779ce72..073a1ace65f555121c38ab49390d8db9fe6226dc 100644 --- a/systems/grammar-learning/experiment-setup/experiment.lisp +++ b/systems/grammar-learning/experiment-setup/experiment.lisp @@ -34,6 +34,7 @@ (define-configuration-default-value :determine-interacting-agents-mode :corpus-learner) (define-configuration-default-value :learner-cxn-supplier :hashed-and-scored) (define-configuration-default-value :category-linking-mode :neighbours) +(define-configuration-default-value :learning-strategy :optimal-form-coverage) ;or: by-score ;; Misc diff --git a/systems/grammar-learning/experiment-setup/grammar.lisp b/systems/grammar-learning/experiment-setup/grammar.lisp index 61142b1b5d60ee8258f5788da6fbcc337351b023..ba09685c6e60417066ba34e9274a16de3562d921 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 ee9f238b2e8968b45100f76267cac75400a3be89..9f089d602015daa9c9ee37c75e595c0c27063f8f 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/experiment-setup/monitors/csv-monitors.lisp b/systems/grammar-learning/experiment-setup/monitors/csv-monitors.lisp index 068d9509bedba184b956c3aeaf964a16f2eca37f..de75acd04ff36de7beedb2e1af23a3363732e304 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 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 d3fb68a21e8bd87e6c3b604453ca95bfde8bc53f..d8934fb182a62ebb5e8de3d7937cfff17c8708e2 100644 --- a/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp +++ b/systems/grammar-learning/tests/test-add-categorial-links-repair.lisp @@ -77,10 +77,64 @@ (bind color-category ?color-8 yellow) (query ?target-4 ?target-object-1 ?attribute-6)))))))) - ; (test-categorial-links-repair-comprehension) - - -; issues: -; 1. why aren't the equivalent 'what is the size of the x cube' cxns recognised as existing in the substitution repair? +(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) + diff --git a/systems/grammar-learning/tests/test-addition-repair.lisp b/systems/grammar-learning/tests/test-addition-repair.lisp index 4eda0251384a5f474cb000d17710d3e8707801ae..e6edebb71010c1605432107313981144b4608217 100644 --- a/systems/grammar-learning/tests/test-addition-repair.lisp +++ b/systems/grammar-learning/tests/test-addition-repair.lisp @@ -63,7 +63,7 @@ - +; (activate-monitor trace-fcg) (defun run-addition-tests () (test-addition-repair-comprehension) (test-double-addition-repair-comprehension) diff --git a/systems/grammar-learning/tests/test-deletion-repair.lisp b/systems/grammar-learning/tests/test-deletion-repair.lisp index 0cf548b544f337ed71a516ad2e5be3c41f306823..4e776066ae2b5688dcc4f971ebbef43f98aa4a50 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 () @@ -111,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) ) 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 b764f6cbb87ddfbbd56ac316d3efed57eefc1459..9fda0eefc626a3a9c19e1a64fea346530440c783 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 @@ -134,7 +134,7 @@ (bind size-category ?size-4 large) (query ?target-4 ?target-object-1 ?attribute-2)))))))) -(deftest test-holistic-to-item-based-duplicates-comprehension () +(defun test-holistic-to-item-based-duplicates-comprehension () (let* ((experiment (set-up-cxn-inventory-and-repairs)) (cxn-inventory (grammar (first (agents experiment))))) (comprehend "Are any green cubes visible?" @@ -155,23 +155,21 @@ (filter ?target-2 ?target-1 ?color-8))) (test-repair-status 'nothing->holophrase (second (multiple-value-list - (comprehend "Are there fewer matte cubes than large green shiny cubes?" + (comprehend "Are there fewer small cubes than blue matte cubes?" :cxn-inventory cxn-inventory - :gold-standard-meaning '((bind material-category ?material-2 rubber) - (filter ?target-9839 ?source-1 ?shape-5228) - (bind color-category ?color-8 green) - (filter ?target-2 ?target-1 ?material-4) - (bind material-category ?material-4 metal) - (filter ?target-1 ?source-1 ?shape-2) + :gold-standard-meaning '((bind color-category ?color-6 blue) + (filter ?target-2 ?target-7233 ?material-2) + (bind material-category ?material-2 rubber) + (filter ?target-7233 ?source-7047 ?shape-4) (bind shape-category ?shape-2 cube) - (bind shape-category ?shape-5228 cube) - (filter ?target-9842 ?target-2 ?color-8) - (bind size-category ?size-4 large) - (get-context ?source-1) - (filter ?target-9843 ?target-9842 ?size-4) - (filter ?target-9845 ?target-9839 ?material-2) - (count! ?count-5 ?target-9845) - (count! ?count-6 ?target-9843) + (bind shape-category ?shape-4 cube) + (filter ?target-1 ?source-7047 ?shape-2) + (bind size-category ?size-2 small) + (get-context ?source-7047) + (filter ?target-7238 ?target-2 ?color-6) + (filter ?target-7235 ?target-1 ?size-2) + (count! ?count-5 ?target-7235) + (count! ?count-6 ?target-7238) (less-than ?target-74 ?count-5 ?count-6)))))))) (deftest test-double-holistic-to-item-based-from-substitution-repair-comprehension () @@ -201,7 +199,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 @@ -216,11 +214,68 @@ (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) + (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-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) + ) 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 68bf49484796905b5b16073ca29d1cc47ad7f91e..5bbadea3e74bafeaa1b8c76d1ea7b1d4bb35f8ff 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,116 +1,92 @@ -(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-multiple-item-based-cxns-comprehension () + (let* ((experiment (set-up-cxn-inventory-and-repairs)) + (cxn-inventory (grammar (first (agents experiment))))) + (comprehend "The gray object is what material?" + :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) + (bind attribute-category ?attribute-2 material) (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 large gray object is what material?" + :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 attribute-category ?attribute-2 material) (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 blue sphere is what size?" + :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 sphere) + (bind attribute-category ?attribute-2 size) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 blue) + (query ?target-7 ?source-9 ?attribute-2))) + (comprehend "The blue sphere is what material?" + :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 sphere) + (bind attribute-category ?attribute-2 material) + (filter ?target-1 ?source-1 ?shape-8) + (bind color-category ?color-2 blue) + (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 small gray object is what material?" + :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 material) (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 8 (length (constructions cxn-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) + (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))) - - ;; disable learning - (disable-learning *inventory*) - - (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-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) @@ -121,43 +97,59 @@ (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* + (comprehend "The large gray object has 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) + (filter ?target-107036 ?target-2 ?size-2) + (unique ?source-9 ?target-107036) + (bind attribute-category ?attribute-2 color) (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) + (filter ?target-2 ?target-1 ?color-2) + (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)))) - -(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* + (bind material-category ?size-2 metal) + (query ?target-7 ?source-9 ?attribute-2)))))) + (test-equal 8 (length (constructions cxn-inventory))))) + +(deftest test-item-based-to-holistic-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) @@ -168,79 +160,37 @@ (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* + (comprehend "The large gray object has 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) + (filter ?target-107036 ?target-2 ?size-2) + (unique ?source-9 ?target-107036) + (bind attribute-category ?attribute-2 color) (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) + (filter ?target-2 ?target-1 ?color-2) + (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 large 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) + (filter ?target-107036 ?target-2 ?material-9) + (filter ?target-107037 ?target-107036 ?size-2) + (unique ?source-9 ?target-107037) + (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 size-category ?material-9 metal) + (bind material-category ?size-2 large) + (query ?target-7 ?source-9 ?attribute-2)))))) + (test-equal 8 (length (constructions cxn-inventory))))) + +; (activate-monitor trace-fcg) +; (test-item-based-to-holistic-double-comprehension) +; (test-item-based-to-holistic-comprehension) +; (test-item-based-to-holistic-multiple-item-based-cxns-comprehension) \ No newline at end of file diff --git a/systems/grammar-learning/tests/test-substitution-repair.lisp b/systems/grammar-learning/tests/test-substitution-repair.lisp index edd7807313c5307780fd44f0583e46b8462186d9..c7666a23ccc99cbe181de0b71a72e7583d5290d7 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?" @@ -301,6 +301,49 @@ (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 'item-based->holistic + (second (multiple-value-list + (comprehend "What is the size of the yellow metallic cube?" + :cxn-inventory cxn-inventory + :gold-standard-meaning '((get-context ?source-1) + (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)))))) + (test-equal 5 (length (constructions cxn-inventory))))) + + +;; (activate-monitor trace-fcg) ;; (test-substitution-repair-comprehension) ;ok ;; (test-substitution-repair-comprehension-right) ;ok ;; (test-substitution-repair-comprehension-multi-diff) ;should be holophrase @@ -311,9 +354,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 diff --git a/systems/grammar-learning/tests/test-utils.lisp b/systems/grammar-learning/tests/test-utils.lisp index 68047945361da5a4e9697845ac832eaf4ef93874..7bc0c21e24647a56385e58325365d4318720927a 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) + + + + diff --git a/systems/irl/evaluate-irl-program.lisp b/systems/irl/evaluate-irl-program.lisp index 9e8d4bc9437b954ba1c55a79474dd6cdd1cbb7be..e087b0b4240c9bb687a15a2b0b162585128562bb 100644 --- a/systems/irl/evaluate-irl-program.lisp +++ b/systems/irl/evaluate-irl-program.lisp @@ -14,6 +14,8 @@ (processor irl-program-processor) (primitive-inventory primitive-inventory)) +(define-event irl-node-finished + (node irl-program-processor-node)) (defun make-child-node (parent processor next-primitive &optional result) "Create a child node for the parent node with the specified next-primitive" @@ -218,6 +220,7 @@ (when (and solution-found-p (numberp n) (>= (length (solutions processor)) n)) (return-from queue-loop))))) + do (notify irl-node-finished current-node) while (queue processor))) ;; clean the solutions diff --git a/systems/irl/monitoring/html.lisp b/systems/irl/monitoring/html.lisp index a929dea4cd9cc402573ef9e39fd525399649a93b..430d7bb8496aedac358cd68c09b49799bfa68146 100644 --- a/systems/irl/monitoring/html.lisp +++ b/systems/irl/monitoring/html.lisp @@ -427,7 +427,7 @@ div.ippn-hidden-subtree { padding:0px;margin:0px;padding:0px;margin-bottom:2px; (duplicate . "#520") (max-depth-reached . "#888") (max-nr-of-nodes . "#888") - (not-evaluated . "#444"))) + (not-evaluated . "#990"))) (defun ippn->title-text (node) (if (eq (status node) 'initial) @@ -544,46 +544,56 @@ div.ippn-hidden-subtree { padding:0px;margin:0px;padding:0px;margin-bottom:2px; return t))) (defmethod make-html ((node irl-program-processor-node) - &key targets (expand-initially nil) - (expand/collapse-all-id (make-id 'ippn))) + &key (expand-initially nil) + (expand/collapse-all-id (make-id 'ippn)) + targets (draw-children t)) (let* ((element-id (make-id 'ippn)) (node-color (or (assqv (status node) *irl-program-processor-node-status-colors*) (error "no status color defined for status ~a" (status node))))) - (draw-node-with-children - `((div :class "ippn") - ,(make-expandable/collapsable-element - element-id (make-id) - ;; collapsed element - (collapsed-ippn-html node element-id node-color) - ;; expanded element - (expanded-ippn-html node element-id node-color - :expand/collapse-all-id expand/collapse-all-id))) - (let ((subtree-id (make-id 'subtree)) - nodes-to-show nodes-to-hide) - (if targets - (loop for child in (children node) - if (on-path-to-target-p child targets) - do (push child nodes-to-show) - else do (push child nodes-to-hide)) - (setf nodes-to-show (children node))) - (shuffle (append - (loop for child in nodes-to-show - collect (make-html child :targets targets - :expand-initially expand-initially - :expand/collapse-all-id expand/collapse-all-id)) - (if nodes-to-hide - (list - (make-expandable/collapsable-element - subtree-id expand/collapse-all-id - ;; collapsed element - (collapsed-hidden-subtree-html subtree-id) - ;; expanded element - (expanded-hidden-subtree-html nodes-to-hide subtree-id - :expand/collapse-all-id expand/collapse-all-id) - :expand-initially expand-initially)) - nil)))) - :color "#aaa"))) + (if draw-children + (draw-node-with-children + `((div :class "ippn") + ,(make-expandable/collapsable-element + element-id (make-id) + ;; collapsed element + (collapsed-ippn-html node element-id node-color) + ;; expanded element + (expanded-ippn-html node element-id node-color + :expand/collapse-all-id expand/collapse-all-id))) + (let ((subtree-id (make-id 'subtree)) + nodes-to-show nodes-to-hide) + (if targets + (loop for child in (children node) + if (on-path-to-target-p child targets) + do (push child nodes-to-show) + else do (push child nodes-to-hide)) + (setf nodes-to-show (children node))) + (shuffle (append + (loop for child in nodes-to-show + collect (make-html child :targets targets + :expand-initially expand-initially + :expand/collapse-all-id expand/collapse-all-id)) + (if nodes-to-hide + (list + (make-expandable/collapsable-element + subtree-id expand/collapse-all-id + ;; collapsed element + (collapsed-hidden-subtree-html subtree-id) + ;; expanded element + (expanded-hidden-subtree-html nodes-to-hide subtree-id + :expand/collapse-all-id expand/collapse-all-id) + :expand-initially expand-initially)) + nil)))) + :color "#aaa") + `((div :class "ippn") + ,(make-expandable/collapsable-element + element-id (make-id) + ;; collapsed element + (collapsed-ippn-html node element-id node-color) + ;; expanded element + (expanded-ippn-html node element-id node-color + :expand/collapse-all-id expand/collapse-all-id)))))) (defmethod make-html ((processor irl-program-processor) &key (expand/collapse-all-id (make-id 'ipp)) @@ -594,9 +604,10 @@ div.ippn-hidden-subtree { padding:0px;margin:0px;padding:0px;margin-bottom:2px; (the-biggest #'node-depth (find-all 'inconsistent (nodes processor) :key #'status)))) ;; when drawing the search tree, only show the path to the solution ;; or the deepest inconsistent node when there is no solution - (make-html (top processor) :targets (or solution-nodes - (when deepest-inconsistent-node - (list deepest-inconsistent-node))) + (make-html (top processor) + :targets (or solution-nodes + (when deepest-inconsistent-node + (list deepest-inconsistent-node))) :expand/collapse-all-id expand/collapse-all-id :expand-initially expand-initially))) diff --git a/systems/irl/monitoring/web-monitors.lisp b/systems/irl/monitoring/web-monitors.lisp index 6e0ce77b275a2e92ab71ca66929378aff55bfa79..40f5fb88b615612adc0a62bebe2391ef7157ea76 100644 --- a/systems/irl/monitoring/web-monitors.lisp +++ b/systems/irl/monitoring/web-monitors.lisp @@ -43,6 +43,26 @@ (let ((sorted-solutions (collect-solutions solution-nodes))) (solutions->html sorted-solutions))) +;; ============================================================================ +;; irl-node-finished +;; ---------------------------------------------------------------------------- + +(define-event-handler (trace-irl-verbose irl-node-finished) + (add-element '((hr))) + (add-element + `((table :class "two-col") + ((tbody) + ((tr) + ((td) "new tree: ") + ((td) ,(make-html (top (processor node))))) + ((tr) + ((td) "new queue: ") + ((td) ,@(html-hide-rest-of-long-list + (queue (processor node)) 5 + #'(lambda (node) + (make-html node :draw-children nil))))))))) + + #| ;; ============================================================================ ;; match-chunk diff --git a/systems/monitors/data-monitors.lisp b/systems/monitors/data-monitors.lisp index 54df43aa0b9c3e1116aa4246f89323160de449b6..c3619688241bcd34d8fbe2de92e2479dc7a71604 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)))))) diff --git a/systems/nlp-tools/penelope-interface.lisp b/systems/nlp-tools/penelope-interface.lisp index 45a6de96cee7c395c4e21f8f73b4ef0597ff9082..9690ea178b7a70640ba772ffda1011c27209873e 100644 --- a/systems/nlp-tools/penelope-interface.lisp +++ b/systems/nlp-tools/penelope-interface.lisp @@ -52,13 +52,14 @@ ;; 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*) (connection-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 + :connection-timeout connection-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)))))) diff --git a/systems/utils/symbols-and-strings.lisp b/systems/utils/symbols-and-strings.lisp index 40d45b21103222415937c84b40e7be2edcd578c9..5c41a3985f6a80d6ff14ee9ed7eba39e2ecab4e3 100644 --- a/systems/utils/symbols-and-strings.lisp +++ b/systems/utils/symbols-and-strings.lisp @@ -365,11 +365,15 @@ string will consist solely of decimal digits and ASCII letters." (let* ((string-without-newlines (format nil "~{~a~^ ~}" (split-sequence:split-sequence #\Newline string :remove-empty-subseqs t))) (string-without-no-break-spaces (format nil "~{~a~^ ~}" - (split-sequence:split-sequence #+LISPWORKS #\No-Break-Space #+CCL #\No-Break_Space + (split-sequence:split-sequence #+LISPWORKS #\No-Break-Space + #+ccl #\No-Break_Space + #+sbcl #\No-Break_Space string-without-newlines :remove-empty-subseqs t)))) (format nil "~{~a~^ ~}" (split-sequence:split-sequence #\Space string-without-no-break-spaces :remove-empty-subseqs t))) (let ((string-without-no-break-spaces (format nil "~{~a~^ ~}" - (split-sequence:split-sequence #+LISPWORKS #\No-Break-Space #+CCL #\No-Break_Space + (split-sequence:split-sequence #+LISPWORKS #\No-Break-Space + #+ccl #\No-Break_Space + #+sbcl #\No-Break_Space string :remove-empty-subseqs t)))) (format nil "~{~a~^ ~}" (split-sequence:split-sequence #\Space string-without-no-break-spaces :remove-empty-subseqs t))))) @@ -401,4 +405,4 @@ string will consist solely of decimal digits and ASCII letters." for end-split in (pushend (length string) split-positions) for substring = (string-trim " " (subseq string start-split end-split)) do (setf start-split (+ end-split (length string-delimiter))) - collect substring))) \ No newline at end of file + collect substring))) diff --git a/systems/web-interface/_favicon.ico b/systems/web-interface/_favicon.ico new file mode 100644 index 0000000000000000000000000000000000000000..9ea72aa8f89dfec462d66c47b2838e9a39a2b2f3 Binary files /dev/null and b/systems/web-interface/_favicon.ico differ diff --git a/systems/web-interface/favicon.ico b/systems/web-interface/favicon.ico index 9ea72aa8f89dfec462d66c47b2838e9a39a2b2f3..8f87e3af7e3aa9c32501a2ec55d5dc45617280bb 100644 Binary files a/systems/web-interface/favicon.ico and b/systems/web-interface/favicon.ico differ