anti-unify-type-hierarchy.lisp 21.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
;; 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)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Method for anti-unifying FCG constructions ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod anti-unify (pattern source (mode (eql :fcg-with-type-hierarchy))
                               &optional
                               (pattern-bindings +no-bindings+) (source-bindings +no-bindings+)
                               &key
                               construction-inventory
                               (cost-params '((equality 0) ;; don't punish when source is equal to pattern 
                                                   (non-matching-unit 10) ;; Punish badly non-matching units
                                                   (subst-from-bindingslist 0)
                                                   (source-variable-pattern-in-bindingslist 1)
                                                   (replace-by-new-var depth-of-replaced-pattern 1)
                                                   (discarded-feature 5)
                                                   (discarded-negated-feature 4))))
  "anti-unifies an fcg-pattern, including special operators and a source. Returns the resulting
   least general generalisation as well as the binding lists for pattern and source and the cost
   of the anti-unification (calculated based on cost-params)"
  ;; Source should contain more units than pattern, then call helper function, fail otherwise
  (when (<= (length pattern) (length source))
    ;; Get units from source to anti-unify pattern against (ordered)
    (let ((source-unit-reorderings (reorder-source-units pattern source cost-params))
          anti-unification-results)
      (dolist (s-u-r source-unit-reorderings)
        (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features a-u-cost)
            (anti-unify-fcg-th pattern (first s-u-r) pattern-bindings source-bindings 'unit-level cost-params construction-inventory)
          (let ((total-cost (+ (second s-u-r) a-u-cost)))
            (push (list resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features total-cost) anti-unification-results))))
      (sort anti-unification-results '< :key 'fifth))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Main recursive anti-unification function for FCG patterns ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun anti-unify-fcg-th (pattern source pattern-bindings source-bindings level cost-params construction-inventory)
  ;; Case: equality of pattern and source
  (cond
   ((equalp pattern source)
    (values pattern
            pattern-bindings
            source-bindings
            '() ;; discarded features
            (get-anti-unification-cost 'equality cost-params pattern source)))
   ;; Substitution is already in bindingslist
   ((subs-lookup pattern-bindings source-bindings pattern source)
    (values (subs-lookup pattern-bindings source-bindings pattern source)
            pattern-bindings
            source-bindings
            '()
            (get-anti-unification-cost 'subst-from-bindingslist cost-params pattern source)))
   ;; Case: unit level: unit-name can be different
   ((and (equalp level 'unit-level)
         (anti-unify-fcg-sequence-th pattern source '() pattern-bindings source-bindings '() 'unit-level cost-params 0 construction-inventory)) ;'() is for the accumulator
    (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
        (anti-unify-fcg-sequence-th pattern source '() pattern-bindings source-bindings '() 'unit-level cost-params 0 construction-inventory)
      (values resulting-pattern
              resulting-pattern-bindings
              resulting-source-bindings
              resulting-discarded-features
              resulting-cost)))
   ;; Case: top-feature level (eg: syn-cat, sem-cat, args, subunits,...): no special operator, but still subset;; feature name should be exact
   ((and (equalp level 'top-feature-level)
         (anti-unify-fcg-set-th (rest pattern) (rest source) '() pattern-bindings source-bindings '() 'top-feature-level cost-params 0 construction-inventory)) ;'() is for the accumulator
    (multiple-value-bind (resulting-pattern-1 resulting-pattern-bindings-1 resulting-source-bindings-1 resulting-discarded-features-1 resulting-cost-1)
        (anti-unify-fcg-th (first pattern) (first source) pattern-bindings source-bindings nil cost-params construction-inventory)
      (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
          (anti-unify-fcg-set-th (rest pattern) (rest source) '() resulting-pattern-bindings-1 resulting-source-bindings-1 '() 'top-feature-level cost-params resulting-cost-1 construction-inventory)
        (values (append (list resulting-pattern-1) resulting-pattern)
                resulting-pattern-bindings
                resulting-source-bindings
                (if resulting-discarded-features-1
                  (push resulting-discarded-features-1 resulting-discarded-features)
                  resulting-discarded-features)
                resulting-cost))))
   ;; Case: subset with special operator ==1 or ==1
   ((and (listp pattern)
         (or (equalp (first pattern) '==1)
             (equalp (first pattern) '==))
         (anti-unify-fcg-set-th (rest pattern) source '() pattern-bindings source-bindings '() nil cost-params 0 construction-inventory)) ;'() is for the accumulator
    (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
        (anti-unify-fcg-set-th (rest pattern) source '() pattern-bindings source-bindings '() nil cost-params 0 construction-inventory)
      (values (append (list (first pattern)) resulting-pattern)
              resulting-pattern-bindings
              resulting-source-bindings
              resulting-discarded-features
              resulting-cost)))
   ;; Case: ==0
   ((and (listp pattern)
         (equalp (first pattern) '==0)
         (anti-unify-fcg-excludes-th (rest pattern) source '() pattern-bindings source-bindings '() cost-params 0 construction-inventory)) ;'() is for the accumulator
    (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
        (anti-unify-fcg-excludes-th (rest pattern) source '() pattern-bindings source-bindings '() cost-params 0 construction-inventory)
      (values (append (list (first pattern)) resulting-pattern)
              resulting-pattern-bindings
              resulting-source-bindings
              resulting-discarded-features
              resulting-cost)))
   ;; 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)
         (not (get-so (first pattern)))
         (= (length pattern) (length source))
          ;(equalp (feature-name source) (feature-name pattern)) ;; restricting anti-unification for same feature
         (anti-unify-fcg-sequence-th pattern source '() pattern-bindings source-bindings '() nil cost-params 0 construction-inventory)) ;'() is for the accumulator
    (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
        (anti-unify-fcg-sequence-th pattern source '() pattern-bindings source-bindings '() nil cost-params 0 construction-inventory)
      (values resulting-pattern
              resulting-pattern-bindings
              resulting-source-bindings
              resulting-discarded-features
              resulting-cost)))
   ;; Source is variable, pattern is already in bindingslist, then return its binding
   ((and (variable-p source)
         (assoc pattern pattern-bindings))
    (values (cdr (assoc pattern pattern-bindings))
            pattern-bindings
            source-bindings
            nil
            (get-anti-unification-cost 'source-variable-pattern-in-bindingslist cost-params pattern source)))
   ;; Else-case: introduce new variable
   (t
    (let ((cat (type-hierarchies:make-th-cat)))
      (type-hierarchies:add-categories '(pattern source cat) (type-hierarchies:type-hierarchy (construction-inventory)))
      (type-hierarchies:add-link cat pattern)
      (type-hierarchies:add-categori cat source)
      (values cat
              (extend-bindings pattern cat pattern-bindings)
              (extend-bindings source cat source-bindings)
              nil
              (get-anti-unification-cost 'replace-by-new-var cost-params pattern source))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Recursive helper function for anti-unifying sequences ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun anti-unify-fcg-sequence-th (pattern
                                source
                                accumulator
                                pattern-bindings
                                source-bindings
                                discarded-features
                                level
                                cost-params
                                cost
                                construction-inventory)
  "anti-unify the elements of a feature"
  (let ((new-level))
   (if (equalp level 'unit-level)
    (setf new-level 'top-feature-level)
    (setf new-level nil))
  (cond
   ;; Case: no elements anymore, return accumulator and bindings-lists
   ((and (null pattern) (null source))
    (values accumulator
            pattern-bindings
            source-bindings
            discarded-features
            cost))
   ;; 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 resulting-discarded-features resulting-cost)
        (anti-unify-fcg-th (first pattern) (first source)  pattern-bindings source-bindings new-level cost-params construction-inventory)
      (anti-unify-fcg-sequence-th (rest pattern)
                               (rest source)
                               (pushend resulting-pattern accumulator)
                               resulting-pattern-bindings
                               resulting-source-bindings
                               (if resulting-discarded-features
                                 (append resulting-discarded-features discarded-features)
                                 discarded-features)
                               level
                               cost-params
                               (+ resulting-cost cost)
                               construction-inventory))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Recursive helper function for anti-unifying sets ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun anti-unify-fcg-set-th (pattern
                           source
                           accumulator
                           pattern-bindings
                           source-bindings
                           discarded-features
                           level
                           cost-params
                           cost
                           construction-inventory)
  "anti-unify the elements of a feature"
  (let ((new-level))
    (when (equalp level 'top-feature-level)
      (setf new-level 'nil))
    (cond
     ;; Case: no elements in pattern anymore, return accumulator and bindings-lists
     ((null pattern)
      (values accumulator
              pattern-bindings
              source-bindings
              discarded-features
              cost))
     ;; Case: first element of pattern has binding with some variable in bindingslist: return binding
     ((assoc (first pattern) pattern-bindings :test 'equalp)
      (anti-unify-fcg-set-th (rest pattern)
                          (remove (cdr (assoc
                                        (cdr (assoc (first pattern) pattern-bindings :test 'equalp))
                                        (reverse-bindings source-bindings) :test 'equalp)) :test 'equalp)
                          (pushend (cdr (assoc (first pattern) pattern-bindings :test 'equalp)) accumulator)
                          pattern-bindings
                          source-bindings
                          discarded-features
                          level
                          cost-params
                          (get-anti-unification-cost 'subst-from-bindingslist cost-params pattern source)
                          construction-inventory))
     ;; first of pattern is an atom that is findable in source: return it
     ((and
       (atom (first pattern))
       (find (first pattern) source :test 'equalp))
      (anti-unify-fcg-set-th (rest pattern) (remove pattern source :test 'equalp)
                          (pushend (first pattern) accumulator)
                          pattern-bindings
                          source-bindings
                          discarded-features
                          level
                          cost-params
                          cost
                          construction-inventory))
     ;; Case: tag: continue with third
     ((and
       (listp (first pattern))
       (string= (first (first pattern)) "TAG")
       (find (feature-name (third (first pattern))) source :key 'car :test 'equalp))
      (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
          (anti-unify-fcg-th (third (first pattern))
                          (find (feature-name (third (first pattern))) source :key 'car :test 'equalp)
                          pattern-bindings
                          source-bindings
                          new-level
                          cost-params
                          construction-inventory)
        (anti-unify-fcg-set-th (rest pattern)
                            (remove (find (feature-name (third (first pattern))) source :key 'car :test 'equalp) source)
                            (pushend (append (list (first (first pattern)) (second (first pattern))) (list resulting-pattern)) accumulator)
                            resulting-pattern-bindings
                            resulting-source-bindings
                            (if resulting-discarded-features
                              (append resulting-discarded-features discarded-features)
                              discarded-features)
                            level
                            cost-params
                            (+ cost resulting-cost)
                            construction-inventory)))
     ;; first of pattern is list of which feature-name is findable in source: anti-unify it return it
     ((and
       (listp (first pattern))
       (find (feature-name (first pattern)) source :key 'car :test 'equalp))
      (multiple-value-bind (resulting-pattern resulting-pattern-bindings resulting-source-bindings resulting-discarded-features resulting-cost)
          (anti-unify-fcg-th (first pattern)
                          (find (feature-name (first pattern)) source :key 'car :test 'equalp)
                          pattern-bindings
                          source-bindings
                          new-level
                          cost-params
                          construction-inventory)
        (anti-unify-fcg-set-th (rest pattern)
                            (remove (find (feature-name (first pattern)) source :key 'car :test 'equalp) source)
                            (pushend resulting-pattern accumulator)
                            resulting-pattern-bindings
                            resulting-source-bindings
                            (if resulting-discarded-features
                              (append resulting-discarded-features discarded-features)
                              discarded-features)
                            level
                            cost-params
                            (+ cost resulting-cost)
                            construction-inventory)))
     ;; Case top-level-feature: feature-name of first of pattern is not found in source but unifies with (feature-name nil), append feature to accumulator and continue processing
     ((and (equalp level 'top-feature-level)
           (unify (first pattern) `(,(feature-name (first pattern)) nil)))
      (anti-unify-fcg-set-th (rest pattern)
                          source
                          (pushend (first pattern) accumulator)
                          pattern-bindings
                          source-bindings
                          discarded-features
                          level
                          cost-params
                          cost
                          construction-inventory))
     ;; Case: no matching feature-name: anti-unify-fcg-set rest + append pattern to descarded features
     (t
      (anti-unify-fcg-set-th (rest pattern)
                          source
                          accumulator
                          pattern-bindings
                          source-bindings
                          (push (first pattern) discarded-features)
                          level
                          cost-params
                          (+ cost (get-anti-unification-cost 'discarded-feature cost-params pattern source))
                          construction-inventory)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Recursive helper function for anti-unifying excluded (NOT or  ==0) featuers ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun anti-unify-fcg-excludes-th (pattern
                                source
                                accumulator
                                pattern-bindings
                                source-bindings
                                discarded-features
                                cost-params
                                cost
                                construction-inventory)
  "anti-unify the elements of a feature"
  (cond
   ;; Case: no elements in pattern anymore, return accumulator and bindings-lists
   ((null pattern)
    (values accumulator
            pattern-bindings
            source-bindings
            discarded-features
            cost))
   ;; first of pattern is an atom that is not findable in source: return it
   ((and
     (atom (first pattern))
     (not (find (first pattern) source :test 'equalp)))
    (anti-unify-fcg-excludes-th (rest pattern) source
                             (pushend (first pattern) accumulator)
                             pattern-bindings
                             source-bindings
                             discarded-features
                             cost-params
                             cost
                             construction-inventory))
   ;; first of pattern is list which is not unifiable in source: return it
   ((and
     (listp (first pattern))
     (not (find (first pattern) source :test 'unify))
     (anti-unify-fcg-excludes-th (rest pattern) source
                              (pushend (first pattern) accumulator)
                              pattern-bindings
                              source-bindings
                              discarded-features
                              cost-params
                              cost
                              construction-inventory))
    (anti-unify-fcg-excludes-th (rest pattern) source
                             (pushend (first pattern) accumulator)
                             pattern-bindings
                             source-bindings
                             discarded-features
                             cost-params
                             cost
                             construction-inventory))
   ;; Case: non matching feature-name: anti-unify-fcg-set rest + append pattern to discarded features
   (t
    (anti-unify-fcg-excludes-th (rest pattern)
                             source
                             accumulator
                             pattern-bindings
                             source-bindings
                             (push (first pattern) discarded-features)
                             cost-params
                             (+ cost (get-anti-unification-cost 'discarded-negated-feature cost-params pattern source))
                             construction-inventory))))