If you use Gitkraken, immediately update to version 8.1 (or later) remove your SSH key from https://gitlab.ai.vub.ac.be/-/profile/keys and generate a new one. SSH keys generated with a vulnerable Gitkraken version are compromised.

Commit dd195082 authored by katrien's avatar katrien
Browse files

git subrepo clone git@gitlab.ai.vub.ac.be:ehai/fcg.git

subrepo:
  subdir:   "fcg"
  merged:   "d111f8e"
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 76cc0ba6
; DO NOT EDIT (unless you know what you are doing)
;
; This subdirectory is a git "subrepo", and this file is maintained by the
; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme
;
[subrepo]
remote = git@gitlab.ai.vub.ac.be:ehai/fcg.git
branch = master
commit = d111f8e45f1306f54b97b2ff4b942b8c1ba93b9d
parent = 76cc0ba6a764aec046e9b2bcb538a3f48b3937e0
method = merge
cmdver = 0.4.3
# Fluid Construction Grammar (FCG)
\ No newline at end of file
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
(defun au-match-structures (pattern source bsl)
"anti-unify structures in matching"
(setf pattern (remove-J-units pattern))
(when (<= (length pattern) (length source))
(cond ((null pattern) bsl)
((<= (length pattern) (length source))
(subset-p pattern source bsl :unify-fn #'(lambda (u1 u2 bsl)
(unify-units u1 u2 bsl))))
(t +fail+))))
\ No newline at end of file
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
;;;;;;;;;;;;;;;;;;;;;;
;; Anti-unification ;;
;;;;;;;;;;;;;;;;;;;;;;
(defgeneric anti-unify (pattern source mode &optional pattern-bindings source-bindings &key cost-params)
(:documentation "Anti-unifies pattern with source, according to mode, optionally providing bindings-lists
and parameters for cost calculation"))
;;;;;;;;;;;;;;;;;;;;;
;; Base Algorithms ;;
;;;;;;;;;;;;;;;;;;;;;
(defmethod anti-unify (pattern source (mode (eql :equal-feature-name-and-arity))
&optional (pattern-bindings +no-bindings+) (source-bindings +no-bindings+)
&key (cost-params nil))
"anti-unifies (= searches the least general generalisation (lgg) for pattern and source)
returns as values: resulting-pattern, bindings for pattern, bindings for source.
Feature name and arity (number of arguments) should be equal, otherwise the whole feature gets replace by a
variable (it's easy to adapt, what do we want?)"
(declare (ignore cost-params))
(cond
;; Case: Pattern equals Source, return pattern and all bindings for both pattern and source
((equalp pattern source)
(values pattern
pattern-bindings
source-bindings))
;; Case: pattern and source are already substitued by the same binding
;; Return this binding and all bindings for pattern and source
((subs-lookup pattern-bindings source-bindings pattern source)
(values (subs-lookup pattern-bindings source-bindings pattern source)
pattern-bindings
source-bindings))
;; Case: pattern and source have same feature-name and arity (number of arguments)
;; anti-unify the arguments, return resulting pattern and all bindings for source and pattern
((and (not (variable-p pattern))
(not (variable-p source))
(listp pattern)
(listp source)
(= (length pattern) (length source))
(equalp (feature-name source) (feature-name pattern)) ;; restricting anti-unification for same feature
(anti-unify-sequence pattern source :equal-feature-name-and-arity '() pattern-bindings source-bindings)) ;'() is for the accumulator
(multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings)
(anti-unify-sequence pattern source mode '() pattern-bindings source-bindings)
(values resulting-pattern
resulting-pattern-bindings
resulting-source-bindings)))
;; Case: non of the above: replace both by a new binding
(t
(let ((var (make-var)))
(values var
(extend-bindings pattern var pattern-bindings)
(extend-bindings source var source-bindings))))))
(defmethod anti-unify (pattern source (mode (eql :no-restrictions))
&optional (pattern-bindings +no-bindings+) (source-bindings +no-bindings+)
&key (cost-params nil))
"anti-unifies (= searches the least general generalisation (lgg) for pattern and source)
returns as values: resulting-pattern, bindings for pattern, bindings for source
Feature name should not be equal, arity should."
(declare (ignore cost-params))
(cond
;; Case: Pattern equals Source, return pattern and all bindings for both pattern and source
((equalp pattern source)
(values pattern
pattern-bindings
source-bindings))
;; Case: pattern and source are already substitued by the same binding
;; Return this binding and all bindings for pattern and source
((subs-lookup pattern-bindings source-bindings pattern source)
(values (subs-lookup pattern-bindings source-bindings pattern source)
pattern-bindings
source-bindings))
;; Case: pattern and source have same feature-name and arity (number of arguments)
;; anti-unify the arguments, return resulting pattern and all bindings for source and pattern
((and (not (variable-p pattern))
(not (variable-p source))
(listp pattern)
(listp source)
(= (length pattern) (length source))
(anti-unify-sequence pattern source :equal-feature-name-and-arity '() pattern-bindings source-bindings)) ;'() is for the accumulator
(multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings)
(anti-unify-sequence pattern source mode '() pattern-bindings source-bindings)
(values resulting-pattern
resulting-pattern-bindings
resulting-source-bindings)))
;; Case: non of the above: replace both by a new binding
(t
(let ((var (make-var)))
(values var
(extend-bindings pattern var pattern-bindings)
(extend-bindings source var source-bindings))))))
(defun anti-unify-sequence (pattern
source
mode
accumulator
pattern-bindings
source-bindings)
"anti-unify the elements of a feature"
(cond
;; Case: no elements anymore, return accumulator and bindings-lists
((and (null pattern) (null source))
(values accumulator
pattern-bindings
source-bindings))
;; Case: still elements, anti-unify first and then rest, every time with new bindings
(t
(multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings)
(anti-unify (first pattern) (first source) mode pattern-bindings source-bindings)
(anti-unify-sequence (rest pattern)
(rest source)
mode
(pushend resulting-pattern accumulator)
resulting-pattern-bindings
resulting-source-bindings)))))
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
(defun apply-pro-unification (cxn ts direction)
"returns new construction which is the result of pro-unification of cxn with ts in direction,"
(let* ((matching-pattern (matching-pattern cxn direction))
(source (left-pole-structure ts))
(couplings (pro-unify matching-pattern source))
(new-cxn (copy-object cxn)))
(setf (name new-cxn) (make-id (string-append "pro-unified-" (symbol-name (name cxn)))))
(setf (pole-structure (left-pole new-cxn)) (substitute-bindings couplings (left-pole-structure cxn)))
(setf (pole-structure (right-pole new-cxn)) (substitute-bindings couplings (right-pole-structure cxn)))
new-cxn))
(defun pro-unify (pattern source &optional (reduced-bindings nil) (renamings nil))
"if different variables occuring in pattern are under
matching with source consistently bound to the same value,
they are replaced with multiple occurences of the same variable.
returns nil if pattern and source don't unify.
returns the renamings that were performed in the form of (var-to-be-renamed . var-to-be-renamed-in)
e.g. (pro-unify '((?a (p ((n ?x) (q ?t))))
(?b (p ((m ?y) (f ?g)))))
'((unit-1 (p ((n l) (q p))))
(unit-2 (p ((m l) (f p))))))
=> ((FCG::?G . FCG::?T) (FCG::?Y . FCG::?X))"
(let ((bindings (reverse (reverse-bindings (first (match-structures pattern source)))))) ;; is only first matching solution enough??
(loop for (binding . var) in bindings
do
(if (assoc binding reduced-bindings :test 'equalp)
;; (variable-to-rename . renaming-variable) to renamings
(push (cons var (cdr (assoc binding reduced-bindings :test 'equalp))) renamings)
;; otherwise, push (binding . var) to reduced bindings
(push (cons binding var) reduced-bindings)))
(or renamings
+no-bindings+)))
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function for dispatching cost calculation to right function ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-anti-unification-cost (cost-type cost-params pattern source)
"if cost-type is found in cost-params, return cost of this cost-type
otherwise return 0"
(let ((cost (assoc cost-type cost-params :test 'string=)))
(cond ((not cost)
(warn "You didn't specify a cost for ~a, taking 0 as default cost." cost-type)
0)
((numberp (second cost))
(second cost))
(t
(let ((base-cost (funcall (second cost) pattern source)))
(* base-cost (third cost)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions for calculating cost based on pattern and source ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun depth-of-replaced-pattern (pattern source)
(declare (ignore source))
(if (variable-p pattern)
0
(1+ (depth pattern))))
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File demonstrating the use of anti-unification in FCG ;;
;; ;;
;; (Paul - 11/02/2016) ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 1. Load FCG
;; (asdf:operate 'asdf:load-op :fcg)
;; (activate-monitor trace-fcg)
;; 2. Evalutate the following grammar
(def-fcg-constructions anti-unification-example-grammar
:feature-types ((args sequence)
(footprints set)
(form set-of-predicates)
(meaning set-of-predicates)
(subunits set)
(forg set))
:diagnostics (diagnose-no-match)
:repairs (anti-unify-pro-unify)
;; Lexical construction for the word "fille"
(def-fcg-cxn fille-cxn
((?girl-unit
(syn-cat (lex-class noun)
(agreement (number sg)
(gender f)))
(sem-cat (sem-class physical-object)
(animate +))
(args (?x)))
<-
(?girl-unit
(HASH meaning ((girl ?x)))
--
(HASH form ((string ?girl-unit "fille"))))))
;; Lexical construction for the word "une"
(def-fcg-cxn une-cxn
((?a-unit
(syn-cat (lex-class determiner)
(agreement (number sg)
(gender f)))
(sem-cat (sem-class identifier)
(definite -))
(args (?x)))
<-
(?a-unit
(HASH meaning ((exists ?x)))
--
(HASH form ((string ?a-unit "une"))))))
;; Lexical construction for the word "un"
(def-fcg-cxn un-cxn
((?a-unit
(syn-cat (lex-class determiner)
(agreement (number sg)
(gender m)))
(sem-cat (sem-class identifier)
(definite -))
(args (?x)))
<-
(?a-unit
(HASH meaning ((exists ?x)))
--
(HASH form ((string ?a-unit "un"))))))
;; NP -> Det N
(def-fcg-cxn np-cxn
((?np-unit
(args (?args))
(subunits (?det ?noun))
(syn-cat (agreement (number ?number)
(gender ?gender))))
<-
(?det
(sem-cat (sem-class identifier)
(definite ?definite))
(args (?args))
--
(syn-cat (lex-class determiner)
(agreement (number ?number)
(gender ?gender))))
(?noun
(sem-cat (sem-class physical-object))
(args (?args))
--
(syn-cat (lex-class noun)
(agreement (number ?number)
(gender ?gender))))
(?np-unit
--
(HASH form ((meets ?det ?noun)))))))
;; 3. Comprehend these utterances the resulting meanings are all integrated (linked)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comprehend '("une" "fille"))
(comprehend '("un" "fille"))
(comprehend-all '("un" "fille"))
\ No newline at end of file
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Anti-unifying FCG constructions is not easy, mainly because the construction and transient structure ;;
;; consist of sets of units (free order) of which the unit-names are variables. Therefore, we first need ;;
;; to pair up all units from the construction with a unit from the transient structure. ;;
;; ;;
;; The functions which achieve this are located in this file... ;;
;; ;;
;; In short, we loop over all units in the construction (pattern) an find out which units from the ;;
;; transient structure match them. Then, a search process pairs up all possibilities: units that match ;;
;; one or more units in the transient structure are always paired up with them, other units from the ;;
;; construction get paired to all combination of remaining units in the transient structure. ;;
;; ;;
;; It is implemented as a search process now and should always return all possibilities ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun reorder-source-units (pattern source cost-params)
"Input: list of cxn-units as pattern
list of transient structure units as source
list of cost-paramaters for calculating reordering-cost
Returns: list of subsets of source with:
- as many units as in pattern
- aligned order (matching-units at same place, all combinations of other units)"
(let ((reordering-solutions (find-matching-units pattern source cost-params))
(list-of-reordered-sources nil))
;; Loop over possible reorderings
(dolist (rs reordering-solutions)
(let ((solution-structure (solution-structure rs))
(reordered-source (loop for n from 1 to (length pattern)
collect n))
(removed-pattern-units nil)
(pattern-unit-to-remove nil))
;; Loop over units
(dolist (unit solution-structure)
(if (equalp (cdr unit) 'remove-unit)
(setf pattern-unit-to-remove (car unit))
(let* ((pattern-index (- (car unit) 1))
(source-index (- (cdr unit) 1))
(source-feature (nth source-index source)))
(setf (nth pattern-index reordered-source) source-feature))))
(if pattern-unit-to-remove
(progn
(setf reordered-source (delete pattern-unit-to-remove reordered-source))
(push (unit-name (nth (- pattern-unit-to-remove 1) pattern)) removed-pattern-units)
(unless (equalp 'root (unit-name (nth (- pattern-unit-to-remove 1) pattern)))
(push (list reordered-source (cost rs) removed-pattern-units) list-of-reordered-sources)))
(push (list reordered-source (cost rs) nil) list-of-reordered-sources))))
(sort list-of-reordered-sources '< :key 'second)))
(defun find-matching-units (pattern source cost-params)
"given pattern and source (lists of fcg-units), and cost-params return:
- list of objects with all possibilities for binding units in pattern with source, maximizing number of matching
units objects contain: solution-structure, cost and non-matched-units of source"
(let ((source-unit-numbers (loop for n from 1 upto (length source)
collect n))
(all-matching-units nil)
(pattern-length (length pattern)))
(loop for pattern-unit in pattern
for i from 1 upto pattern-length
do
(let ((matches-for-this-unit nil))
(loop for source-unit in source
for j from 1 upto (length source)
do
(when (match-structures (list pattern-unit) (list source-unit))
(push j matches-for-this-unit)))
(push (cons i matches-for-this-unit) all-matching-units)))
(search-reordering-solutions all-matching-units
(if (> (length pattern) 1)
(cons 'remove-unit source-unit-numbers)
source-unit-numbers)
pattern-length
cost-params)))
(defun search-reordering-solutions (matching-units source-unit-numbers pattern-length cost-params)
"Given an a-list of numbers of matching units, the numbers of units in source, the number of units
in the construction and cost params, returns a series of solution states
This is implemented as a search process."
(let ((solutions nil)
(queue (list (make-instance 'reordering-search-state
:solution-structure (loop for i from 1 upto pattern-length
collect
(list i))
:remaining-matching-units matching-units
:remaining-source-units source-unit-numbers
:cost 0))))
(loop until (not queue)
do
(let ((current-state (pop queue)))
(if (reordering-solution-p (solution-structure current-state))
;; If current-state is solution: add to solutions
(unless (duplicate-search-state current-state solutions)
(push current-state solutions))
;; Else: see wheter there are still units in solution structure which had matches
(let ((non-matched-units (loop for unit in (solution-structure current-state)
when (and (not (cdr unit)) (find (first unit) (remaining-matching-units current-state) :key 'first))
collect (first unit))))
(if non-matched-units
;; If there are some, add their expansions as states to the queue
(dolist (nmu non-matched-units)
(let ((possible-matches (loop for mu in (remaining-matching-units current-state)
when (eq (car mu) nmu)
collect (second mu))))
(dolist (pm possible-matches)
(let ((new-search-state (make-instance 'reordering-search-state
:solution-structure (substitute (cons nmu pm) nmu (solution-structure current-state) :key 'first)
:remaining-matching-units (remove pm (remaining-matching-units current-state) :key 'cdr)
:remaining-source-units (remove pm (remaining-source-units current-state))
:cost (cost current-state))))
(unless (duplicate-search-state new-search-state queue)
(push new-search-state queue))))))
;; Else: assign other non-matching units to these
(let ((non-matched-unit (loop for unit in (solution-structure current-state)
unless (cdr unit)
return (first unit))))
(dolist (su (remaining-source-units current-state))
(push
(make-instance 'reordering-search-state
:solution-structure (substitute (cons non-matched-unit su) non-matched-unit (solution-structure current-state) :key 'first)
:remaining-matching-units '()
:remaining-source-units (remove su (remaining-source-units current-state))
:cost (if (equalp su 'remove-unit)
(+ (cost current-state) (get-anti-unification-cost 'removed-pattern-unit cost-params nil nil))
(+ (cost current-state) (get-anti-unification-cost 'non-matching-unit cost-params nil nil))))
queue))))))))
solutions))
;; ################################################################
;; Defining reordering-search-states and helper methods for these #
;; ################################################################
(defclass reordering-search-state ()
((solution-structure
:type (or list null)
:initform nil
:initarg :solution-structure
:accessor solution-structure)
(remaining-matching-units
:type (or list null)
:initform nil
:initarg :remaining-matching-units
:accessor remaining-matching-units)
(remaining-source-units
:type (or list null)
:initform nil
:initarg :remaining-source-units
:accessor remaining-source-units)
(cost
:initform 0
:initarg :cost
:accessor cost)))
(defun reordering-solution-p (solution-structure)
"solution structure is a solution if it has a non-nil cdr
returns true if so, false otherwise"
(let ((solution t))
(dolist (s solution-structure)
(unless (cdr s)
(setf solution nil)))
solution))
(defun duplicate-search-state (nss queue)
"returns nil if nss is a search space with equivalent solution-structure
to any search state in queue"
(let ((duplicate-p nil))
(dolist (ss queue)
(when (equal (solution-structure nss) (solution-structure ss))