Commit 1922d21a authored by Jens Nevens's avatar Jens Nevens
Browse files

git subrepo pull (merge) systems/fcg

subrepo:
  subdir:   "systems/fcg"
  merged:   "bf65536"
upstream:
  origin:   "git@gitlab.ai.vub.ac.be:ehai/fcg.git"
  branch:   "master"
  commit:   "d111f8e"
git-subrepo:
  version:  "0.4.3"
  origin:   "https://github.com/ingydotnet/git-subrepo"
  commit:   "2f68596"
parent bf63e3f7
......@@ -6,7 +6,7 @@
[subrepo]
remote = git@gitlab.ai.vub.ac.be:ehai/fcg.git
branch = master
commit = bd913b54b1b58dd1c49e940089f1b4d7e6cd3dcb
parent = 03cf639e4a481c6f5cd1f94d553aba08ed2b6d9c
commit = d111f8e45f1306f54b97b2ff4b942b8c1ba93b9d
parent = 8432c2835f03ac4fbfdf163f88e2de7e2f216b63
method = merge
cmdver = 0.4.0
cmdver = 0.4.3
......@@ -119,12 +119,7 @@
(<- (right-pole cxn))))
(defun merge-poles (cxn coupled-feature-structure direction
&optional (bindings +no-bindings+) source unified configuration second-merge? &key cxn-inventory)
;; If there's a configuration given...
(when (and configuration
(get-configuration configuration
'replace-symbols-with-their-original-variable))
(setf bindings (replace-symbols-with-their-original-variable bindings)))
&optional (bindings +no-bindings+) source unified configuration second-merge? &key cxn-inventory)
;; Extract the features to merge from the transient structure
(let* ((merging-pole (merging-pole cxn direction))
(merging-pattern (pole-structure merging-pole)))
......@@ -143,7 +138,7 @@
;; set merging-pattern to new merging-pattern without negations of features added by the same cxn
(setf merging-pattern (remove-overwrites ow-feat merging-pattern)))))
;; Merge the merging-pattern with the transient structure.
(merge-structures
(merge-structures
merging-pattern
(or source
(ecase (pole-domain merging-pole)
......@@ -490,12 +485,12 @@
(push car failed-cars)))
;; finally we check whether something changed
(setq second-merge-cars
(loop for car in second-merge-cars
if (equivalent-coupled-feature-structures cfs (car-resulting-cfs car))
do (setf (car-status car) 'structure-not-changed)
(push car failed-cars)
else collect car))
; (setq second-merge-cars
; (loop for car in second-merge-cars
; if (equivalent-coupled-feature-structures cfs (car-resulting-cfs car))
; do (setf (car-status car) 'structure-not-changed)
; (push car failed-cars)
; else collect car))
;; done!
(values second-merge-cars failed-cars)))
......
......@@ -15,7 +15,7 @@
(in-package :fcg)
(export '(constructions size clear find-cxn add-cxn delete-cxn cxn-added cxn-deleted cxn-pathnames
(export '(constructions size constructions-list clear find-cxn add-cxn delete-cxn cxn-added cxn-deleted cxn-pathnames
set-expansion-data-for-type get-expansion-data-for-type expansion-data configuration visualization-configuration))
(defclass construction-inventory ()
......@@ -87,9 +87,9 @@ is overwritten."
(set-configuration construction-inventory
:create-initial-structure-mode :one-pole-mode :replace nil)
(set-configuration construction-inventory
:render-mode :render-string-meets-precedes :replace nil)
:render-mode :generate-and-test :replace nil)
(set-configuration construction-inventory
:de-render-mode :de-render-string-meets-precedes :replace nil)
:de-render-mode :de-render-string-meets :replace nil)
(set-configuration construction-inventory
:parse-goal-tests '(:no-applicable-cxns) :replace nil)
(set-configuration construction-inventory
......@@ -109,11 +109,11 @@ is overwritten."
(set-configuration construction-inventory
:equivalent-meaning-mode :unify-no-equalities :replace nil)
(set-configuration construction-inventory
:node-expansion-mode :default :replace nil)
:node-expansion-mode :multiple-cxns :replace nil)
(set-configuration construction-inventory
:queue-mode :by-priority :replace nil)
:queue-mode :greedy-best-first :replace nil)
(set-configuration construction-inventory
:priority-mode :depth-first :replace nil)
:priority-mode :nr-of-applied-cxns :replace nil)
(set-configuration construction-inventory
:node-tests '(:check-duplicate :restrict-nr-of-nodes :restrict-search-depth) :replace nil)
(set-configuration construction-inventory
......@@ -124,6 +124,12 @@ is overwritten."
:show-meaning/utterance nil :replace nil)
(set-configuration construction-inventory
:update-boundaries-feature 'subunits)
(set-configuration construction-inventory
:equivalent-cxn-key #'name)
(set-configuration construction-inventory
:equivalent-cxn-fn #'eql)
(set-configuration construction-inventory
:th-connected-mode :neighbours)
;; Set default visualization configuration
(set-configuration (visualization-configuration construction-inventory) :coupled-mode nil :replace nil)
......@@ -164,6 +170,13 @@ is overwritten."
"Default implementation returning (length (constructions ci))"
(length (constructions construction-inventory)))
(defgeneric constructions-list (construction-inventory)
(:documentation "Returns a list of all constructions stored in this inventory."))
(defmethod constructions-list ((construction-inventory construction-inventory))
"Default implementation returning (length (constructions ci))"
(constructions construction-inventory))
;; ------------------------------------------------------------------------
;; clear
......@@ -243,7 +256,8 @@ is overwritten."
;; but the method combination tries to do it again here
(unless (string= (type-of source) 'fcg-construction-set)
(setf (configuration destination) (copy-object (configuration source)))
(setf (blackboard destination) (blackboard source)))
(setf (blackboard destination) (blackboard source))
(setf (visualization-configuration destination) (visualization-configuration source)))
(setf (cxn-pathnames destination) (copy-object (cxn-pathnames destination)))
(setf (hierarchy-features destination) (copy-list (hierarchy-features source)))
(setf (original-cxn-set destination) (original-cxn-set source))
......
......@@ -167,9 +167,27 @@
;; size
;; ---------------------------------------------------------
#|
(defmethod size ((hashed-construction-set hashed-construction-set))
"Calculates the size of the hash table of a hashed construction set
in terms of the number of hash keys."
(hash-table-count (constructions-hash-table hashed-construction-set)))
|#
(defmethod size ((hashed-construction-set hashed-construction-set))
"Calculates the size of the hash table of a hashed construction set
in terms of the number construcitons."
(length (constructions-list hashed-construction-set)))
;; #########################################################
;; constructions
;; ---------------------------------------------------------
(defmethod constructions-list ((hashed-construction-set hashed-construction-set))
"Returns a list of constructions of a hashed-construction-set"
(remove-duplicates (loop for value being the hash-values of (constructions-hash-table hashed-construction-set)
append value)
:test #'eql
:key #'name))
......@@ -18,7 +18,7 @@
(defun constructions-for-application (construction-inventory)
(if (get-configuration construction-inventory :shuffle-cxns-before-application)
(shuffle (copy-list (constructions construction-inventory)))
(shuffle (copy-list (constructions-list construction-inventory)))
(constructions construction-inventory)))
;; #########################################################
......@@ -76,8 +76,13 @@
"returns all constructions that of label 'label'"
(loop for cxn in (constructions-for-application (construction-inventory (cip node)))
for cxn-label = (attr-val cxn :label)
when (or (and (symbolp cxn-label) (string= (symbol-name label) (symbol-name cxn-label)))
(and (listp cxn-label) (member label cxn-label)))
when (or (and (symbolp cxn-label)
(eq (intern (symbol-name label))
(intern (symbol-name cxn-label))))
(and (listp cxn-label)
(member (intern (symbol-name label))
(mapcar #'intern (mapcar #'symbol-name cxn-label))
:test #'eq)))
collect cxn))
(defun all-tried-constructions (cxn-supplier-with-ordered-labels)
......@@ -277,36 +282,6 @@
(pop (remaining-constructions cxn-supplier)))
#|
(defmethod hash ((construction construction)
(mode (eql :hash-word-entity-root))
&key &allow-other-keys)
"Returns the string and meaning from the attributes of the construction"
(when (or (attr-val construction :string)
(attr-val construction :meaning))
(list (attr-val construction :string)
(attr-val construction :meaning))))
(defmethod hash ((node cip-node)
(mode (eql :hash-word-entity-root)) ;; For using hashed construction sets in the root.
&key &allow-other-keys)
"Checks the root and returns entities (for IRL meanings) or predicates."
(let ((transient-structure (car-resulting-cfs (cipn-car node))))
(if (eq '<- (direction (cip node)))
(let ((strings (extract-string (get-root (right-pole-structure transient-structure)))))
(mapcar #'third strings))
;; In production return the meanings.
(loop with meanings = (extract-meaning (get-root (left-pole-structure transient-structure)))
for m in meanings
;; collect the "entity" or "predicate":
collect (if (and (eq (first m) 'bind)
(fourth m))
(fourth m)
(first m))))))
|#
(defmethod hash ((construction construction)
(mode (eql :hash-word-entity-root-one-pole))
&key &allow-other-keys)
......@@ -350,8 +325,13 @@
"returns all constructions of label 'label'"
(loop for cxn in (constructions-for-application-hashed node)
for cxn-label = (attr-val cxn :label)
when (or (eq label cxn-label)
(and (listp cxn-label) (member label cxn-label)))
when (or (and (symbolp cxn-label)
(eq (intern (symbol-name label))
(intern (symbol-name cxn-label))))
(and (listp cxn-label)
(member (intern (symbol-name label))
(mapcar #'intern (mapcar #'symbol-name cxn-label))
:test #'eq)))
collect cxn))
(defmethod create-cxn-supplier ((node cip-node) (mode (eql :hashed-ordered-by-label)))
......@@ -393,4 +373,223 @@
(all-constructions-of-label-hashed node (current-label cxn-supplier)))
(setf (remaining-constructions cxn-supplier)
(all-constructions-of-current-label cxn-supplier))
(next-cxn cxn-supplier node))))
\ No newline at end of file
(next-cxn cxn-supplier node))))
;; #########################################################
;; cxn-supplier
;; ---------------------------------------------------------
(export '(cxn-supplier-with-hashed-simple-queue))
(defun all-cxns-except-incompatible-hashed-cxns (node)
"computes all constructions that could be applied for this node
plus nil hashed constructions"
(let ((constructions
;; get all constructions compatible
;; with the hashes of the node
;; append nil hashed constructions
(remove-duplicates
(append
(loop
for hash in (hash node (get-configuration node :hash-mode))
append (gethash hash (constructions-hash-table (construction-inventory node))))
(gethash nil (constructions-hash-table (construction-inventory node)))))))
;; shuffle if requested
(when (get-configuration node :shuffle-cxns-before-application)
(setq constructions
(shuffle constructions)))
;; return constructions
constructions))
(defclass cxn-supplier-all-cxns-except-incompatible-hashed-cxns ()
((remaining-constructions
:type list :initarg :remaining-constructions
:accessor remaining-constructions
:documentation "A list of constructions that are still to try")))
(defmethod create-cxn-supplier ((node cip-node)
(mode (eql :all-cxns-except-incompatible-hashed-cxns)))
(make-instance
'cxn-supplier-all-cxns-except-incompatible-hashed-cxns
:remaining-constructions (all-cxns-except-incompatible-hashed-cxns node)))
(defmethod next-cxn ((cxn-supplier cxn-supplier-all-cxns-except-incompatible-hashed-cxns)
(node cip-node))
(let ((next-constructions (remaining-constructions cxn-supplier)))
;;now we need to remove the next-constructions from the list of remaining constructions
(setf (remaining-constructions cxn-supplier) nil)
;;return next constructions:
next-constructions))
(defmethod hash ((construction construction)
(mode (eql :hash-string-meaning-lex-id))
&key &allow-other-keys)
"Returns the string and meaning from the attributes of the construction"
(when (or (attr-val construction :string)
(attr-val construction :meaning)
(attr-val construction :lex-id))
(remove-duplicates
(remove nil (list (attr-val construction :string)
(attr-val construction :meaning)
(attr-val construction :lex-id))))))
(defmethod hash ((node cip-node)
(mode (eql :hash-string-meaning-lex-id)) ;; For using hashed construction sets in the root.
&key &allow-other-keys)
"Checks the root and returns entities (for IRL meanings) or predicates."
(let* ((units (fcg-get-transient-unit-structure node))
(lex-ids (loop for unit in units
for lex-id = (unit-feature-value unit 'lex-id)
when lex-id collect it))
(strings (mapcar #'third (extract-strings (list (get-root units)))))
(meanings (loop for meaning in (extract-meaning (get-root units))
collect (if (and (= 4 (length meaning)) (eql 'bind (first meaning)))
(fourth meaning)
(first meaning)))))
(if (eql (car-direction (cipn-car node)) '<-)
(append strings lex-ids)
(append meanings lex-ids))))
;; hashed-and-scored ;;
;;;;;;;;;;;;;;;;;;;;;;;
(defun constructions-for-application-hashed-and-scored (node)
"computes all constructions that could be applied for this node
plus nil hashed constructions"
(let ((constructions
;; get all constructions compatible
;; with the hashes of the node
;; append nil hashed constructions
(remove-duplicates
(append
(loop
for hash in (hash node (get-configuration node :hash-mode))
append (gethash hash (constructions-hash-table (construction-inventory node))))
(gethash nil (constructions-hash-table (construction-inventory node)))))))
;; shuffle if requested
(when (get-configuration node :shuffle-cxns-before-application)
(setq constructions
(shuffle constructions)))
;; sort
(setq constructions
(sort constructions #'> :key #'(lambda (cxn) (attr-val cxn :score))))
;; return constructions
constructions))
(defclass cxn-supplier-hashed-and-scored ()
((remaining-constructions
:type list :initarg :remaining-constructions
:accessor remaining-constructions
:documentation "A list of constructions that are still to try")))
(defmethod create-cxn-supplier ((node cip-node)
(mode (eql :hashed-and-scored)))
(make-instance
'cxn-supplier-hashed-and-scored
:remaining-constructions (constructions-for-application-hashed-and-scored node)))
(defmethod next-cxn ((cxn-supplier cxn-supplier-hashed-and-scored)
(node cip-node))
(pop (remaining-constructions cxn-supplier)))
;; hashed-scored-labeled ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass cxn-supplier-hashed-scored-labeled ()
((current-label
:initarg :current-label :accessor current-label
:documentation "The current label that is tried")
(remaining-labels
:type list :initarg :remaining-labels :accessor remaining-labels
:documentation "All labels that have not been tried yet")
(all-constructions-of-current-label
:type list :initarg :all-constructions-of-current-label
:accessor all-constructions-of-current-label
:documentation "All constructions that have the current label")
(remaining-constructions
:type list :initform nil :accessor remaining-constructions :initarg :remaining-constructions
:documentation "A sublist of :all-constructions-of-current-label
that are still to try"))
(:documentation "A construction pool that applies constructions of
different labels by a pre-specified order"))
(defmethod create-cxn-supplier ((node cip-node) (mode (eql :hashed-scored-labeled)))
(let* ((parent (car (all-parents node))))
(if parent
;; copy most of the stuff from the the pool of the parent
(make-instance
'cxn-supplier-hashed-scored-labeled
:current-label (current-label (cxn-supplier parent))
:remaining-labels (remaining-labels (cxn-supplier parent))
:remaining-constructions (all-constructions-of-current-label (cxn-supplier parent))
:all-constructions-of-current-label (all-constructions-of-current-label (cxn-supplier parent)))
;; there is no parent, start from first label
(let* ((labels (get-configuration (construction-inventory (cip node))
(if (eq (direction (cip node)) '->)
:production-order :parse-order)))
(all-constructions-of-current-label
(all-constructions-of-label-by-hash-and-score node (car labels))))
(make-instance
'cxn-supplier-hashed-scored-labeled
:current-label (car labels)
:remaining-labels (cdr labels)
:remaining-constructions all-constructions-of-current-label
:all-constructions-of-current-label all-constructions-of-current-label)))))
(defun all-constructions-of-label-by-hash-and-score (node label)
"returns all constructions that of label 'label'"
(let ((constructions
(loop for cxn in (remove-duplicates
(append
(loop for hash in (hash node (get-configuration node :hash-mode))
append (gethash hash (constructions-hash-table (construction-inventory node))))
(gethash nil (constructions-hash-table (construction-inventory node)))))
for cxn-label = (attr-val cxn :label)
when (or (and (symbolp cxn-label) (equalp (symbol-name label) (symbol-name cxn-label)))
(and (listp cxn-label) (member label cxn-label)))
collect cxn)))
;; shuffle if requested
(when (get-configuration node :shuffle-cxns-before-application)
(setf constructions
(shuffle constructions)))
;; sort
(setf constructions
(sort constructions #'(lambda (cxn-1 cxn-2)
(cond ((> (attr-val cxn-1 :score) (attr-val cxn-2 :score)))
((< (attr-val cxn-1 :score) (attr-val cxn-2 :score))
nil)
((>= (attr-val cxn-1 :frequency) (attr-val cxn-2 :frequency)))))))
;; return constructions
constructions))
(defmethod next-cxn ((cxn-supplier cxn-supplier-hashed-scored-labeled) (node cip-node))
(cond ((remaining-constructions cxn-supplier)
;; there are remaining constructions. just return the next one
(pop (remaining-constructions cxn-supplier)))
((loop for child in (children node)
thereis (cxn-applied child))
;; when the node already has children where cxn application succeeded,
;; then we don't move to the next label
nil)
((remaining-labels cxn-supplier)
;; go to the next label
(setf (current-label cxn-supplier) (car (remaining-labels cxn-supplier)))
(setf (remaining-labels cxn-supplier) (cdr (remaining-labels cxn-supplier)))
(setf (all-constructions-of-current-label cxn-supplier)
(all-constructions-of-label-by-hash-and-score node (current-label cxn-supplier)))
(setf (remaining-constructions cxn-supplier)
(all-constructions-of-current-label cxn-supplier))
(next-cxn cxn-supplier node))))
\ No newline at end of file
......@@ -68,9 +68,7 @@ transient structure."
(progn
(set-data (goal-test-data node) 'dependencies-realized left-pole)
nil))))
(defmethod cip-goal-test ((node cip-node) (mode (eql :no-meaning-in-root)))
"The node is a valid solution when there is no meaning predicate
left in the root unit (formulation only)."
......@@ -141,51 +139,46 @@ left in the root unit's form predicates (comprehension only)."
(defmethod equivalent-meaning? ((interpreted-meaning list) (intended-meaning list)
(mode (eql :unify-no-equalities)))
(delete-if #'(lambda (bs)
(delete-if #'(lambda (binding-set)
(equalities?
(delete-if #'(lambda (binding) (null (binding-val binding)))
bs)))
binding-set)))
(unify (cons '== intended-meaning) interpreted-meaning)))
(require-configuration :equivalent-meaning-mode)
(defmethod cip-goal-test ((node cip-node) (mode (eql :re-enter-utterance)))
"This is a goal test that can uses the old FCG notation (before 2015)."
(warn "Please check this goal test before using it. It is not guaranteed to work (old FCG notation).")
(defmethod cip-goal-test ((node cip-node) (mode (eql :re-enter-produced-utterance)))
""
(let* ((construction-inventory (construction-inventory (cip node)))
(utterance (render
(right-pole-structure (car-resulting-cfs (cipn-car node)))
(get-configuration construction-inventory :render-mode)
:node node))
(cfs (de-render utterance (get-configuration construction-inventory
:de-render-mode)))
(utterance (render (car-resulting-cfs (cipn-car node)) (get-configuration construction-inventory :render-mode)))
(cfs (de-render utterance (get-configuration construction-inventory :de-render-mode)))
(solution+cip (multiple-value-list
(with-disabled-monitor-notifications
(fcg-apply (construction-inventory (cip node))
cfs '<-
:configuration (configuration (construction-inventory node))))))
(solution (car solution+cip))
(cip (cadr solution+cip))
(intended-meaning
(extract-meanings
(left-pole-structure
(car-resulting-cfs (cipn-car (top-node (cip node)))))))
(interpreted-meaning
(when solution
(extract-meanings (left-pole-structure
(car-resulting-cfs (cipn-car solution))))))
(equivalent-meaning?
(equivalent-meaning?
interpreted-meaning intended-meaning
(get-configuration construction-inventory :equivalent-meaning-mode))))
(set-data (goal-test-data node) 'utterance utterance)
(set-data (goal-test-data node) 'parse-process cip)
(set-data (goal-test-data node) 'solution solution)
(set-data (goal-test-data node) 'intended-meaning intended-meaning)
(set-data (goal-test-data node) 'interpreted-meaning interpreted-meaning)
(set-data (goal-test-data node) 'equivalent-meaning? equivalent-meaning?)
equivalent-meaning?))
(solution (when (find 'succeeded (statuses (first solution+cip)))
(first solution+cip))))
(when solution
(let* ((cip (second solution+cip))
(intended-meaning (extract-meanings
(left-pole-structure
(car-resulting-cfs (cipn-car (top-node (cip node)))))))
(interpreted-meaning (extract-meanings (left-pole-structure
(car-resulting-cfs (cipn-car solution)))))
(equivalent-meaning? (equivalent-meaning?
intended-meaning interpreted-meaning
(get-configuration construction-inventory :equivalent-meaning-mode))))
(set-data (goal-test-data node) 'utterance utterance)
(set-data (goal-test-data node) 'parse-process cip)
(set-data (goal-test-data node) 'solution solution)
(set-data (goal-test-data node) 'intended-meaning intended-meaning)
(set-data (goal-test-data node) 'interpreted-meaning interpreted-meaning)
(set-data (goal-test-data node) 'equivalent-meaning? equivalent-meaning?)
equivalent-meaning?))))
(defmethod cip-goal-test ((node cip-node) (mode (eql :re-enter-utterance-until-found)))
"This is a goal test that can uses the old FCG notation (before 2015)."
......
......@@ -502,7 +502,7 @@ standard sentences"
(write-bidirectional-meanings nil))
"Write evaluation results to csv file." ;;TO DO: make this function more modular! Now it works best in comprehension
(setf output (or output
(monitors::make-file-name-with-time
(make-file-name-with-time
(babel-pathname :directory '(".tmp")
:name "evaluation-summary"
:type "csv"))))
......@@ -599,7 +599,7 @@ standard sentences"
max-sentence-length ;;evaluate sentences until length X
(bi-directional? t)
(exclude-sentences-with-single-word t)
(csv-output-file (monitors::make-file-name-with-time
(csv-output-file (make-file-name-with-time
(babel-pathname :directory '(".tmp")
:name "evaluation-summary-comprehension"
:type "csv")))
......@@ -667,7 +667,7 @@ sentences profiles and then writes information in these to a csv file
grammar ;;fcg-constructions
&key max-meaning-size
(bi-directional? t) (segmentor "<->")
(csv-output-file (monitors::make-file-name-with-time