Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / common-lisp / cesarum / pmatch.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               pmatch.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Sexp Pattern Matcher.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2012-02-03 <PJB> Added match-case*.
15 ;;;;    2003-12-17 <PJB> Created.
16 ;;;;BUGS
17 ;;;;    pattern matcher and instantiation won't work with arrays/matrices,
18 ;;;;    structures...
19 ;;;;BUGS
20 ;;;;LEGAL
21 ;;;;    AGPL3
22 ;;;;    
23 ;;;;    Copyright Pascal J. Bourguignon 2003 - 2012
24 ;;;;    
25 ;;;;    This program is free software: you can redistribute it and/or modify
26 ;;;;    it under the terms of the GNU Affero General Public License as published by
27 ;;;;    the Free Software Foundation, either version 3 of the License, or
28 ;;;;    (at your option) any later version.
29 ;;;;    
30 ;;;;    This program is distributed in the hope that it will be useful,
31 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
32 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
33 ;;;;    GNU Affero General Public License for more details.
34 ;;;;    
35 ;;;;    You should have received a copy of the GNU Affero General Public License
36 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
37 ;;;;****************************************************************************
38
39 (in-package "COMMON-LISP-USER")
40 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.PMATCH"
41   (:use "COMMON-LISP" "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
42   (:export "MATCH-CASE" "MATCH-CASE*" "COLLECT-VARIABLES"
43            ":" "?/" "?*" "?+" "??" "?N" "?X" "?C" "?V" "?AX" "?AC" "?AV"
44            "MATCH-DICT-MAP" "MATCH-STATE-DICT"
45            "MATCH-STATE-FAILED-P" "MATCH")
46   (:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "WITH-GENSYMS")
47   (:documentation
48    "Sexp Pattern Matcher
49
50     Copyright Pascal J. Bourguignon 2003 - 2004
51     This package is provided under the GNU General Public License.
52     See the source file for details."))
53 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.PMATCH")
54
55
56
57
58 (defun make-match-state (&key dict) dict)
59 (defun match-state-dict (ms) ms)
60
61 (defun match-state-fail     (ms raison)
62   "PRIVATE"
63   (make-match-state :dict  (list* :failed raison (match-state-dict ms))))
64
65
66 (defun match-state-failed-p (ms)
67   "
68 RETURN: Whether the match failed.
69 "
70   (eq :failed (car (match-state-dict ms))) )
71
72
73 (defun match-state-retry    (ms)
74   "PRIVATE" 
75   (if (match-state-failed-p ms)
76       (make-match-state :dict (cdr (match-state-dict ms)))
77       ms))
78
79
80 (defun match-dict-map (ms function)
81   "
82 DO:     Calls FUNCTION (lambda (symbol value) ...) with all successive bindings,
83         (unless matching state is failed).
84 RETURN: The list of results of the FUNCTION.
85 "
86   (unless (match-state-failed-p ms)
87     (mapcar (lambda (binding) (funcall function (first binding) (second binding)))
88             (match-state-dict ms))))
89
90
91 (defun match-dict-add-binding (ms pat exp)
92   "PRIVATE" 
93   (let* ((var (second (car pat)))
94          (val (car exp))
95          (ass (assoc var (match-state-dict ms))))
96     (cond
97       ((null ass)                       ; a new binding:
98        (make-match-state :dict (cons (cons var val) (match-state-dict ms))))
99       ((equalp (cdr ass) val)           ; already there, same
100        ms)
101       (t                                ; already there, different
102        (match-state-fail ms `(:mismatching-binding ,ass ,val))))))
103
104
105 (defmacro defpattern (name pattern)
106   (if (symbolp pattern)
107       `(defun ,name (pat) ;; (?ac ...)
108          "PRIVATE"
109          (and (listp pat) (symbolp (car pat))
110               (string= ',pattern (car pat))))
111       `(defun ,name (pat) ;; ((?n ...)...)
112          "PRIVATE" 
113          (and (listp pat) (listp (car pat)) (symbolp (caar pat))
114               (string= ',(car pattern) (caar pat))))))
115
116
117 (defpattern pat-anonymous-variable-p   ?av)
118 (defpattern pat-anonymous-constant-p   ?ac)
119 (defpattern pat-anonymous-expression-p ?ax)
120 (defpattern pat-named-p                (?n))
121 (defpattern pat-variable-p             (?v))
122 (defpattern pat-constant-p             (?c))
123 (defpattern pat-expression-p           (?x))
124 (defpattern pat-optional-p             (??))
125 (defpattern pat-repeat-p               (?+))
126 (defpattern pat-optional-repeat-p      (?*))
127 (defpattern pat-alternative-p          (?/))
128 (defpattern pat-squeleton-eval-p       |:|)
129
130
131 (defun exp-variable-p (exp)
132   "PRIVATE"
133   (and (consp exp)
134        (symbolp   (car exp))))
135
136 (defun exp-constant-p (exp)
137   "PRIVATE"
138   (and (consp exp)
139        (atom (car exp))
140        (not (symbolp (car exp)))))
141
142
143 ;; (?n n ?v) == (?v n)
144
145
146 ;; (match '((?+ a b c)) '(a b c a b c))
147
148
149
150 ;; pattern ::= term | ( pattern-seq ) .
151 ;; pattern-seq ::= | pattern pattern-seq .
152 ;; pattern-lst ::= | pattern pattern-lst .
153 ;;
154 ;; term      ::= ?av | ?ac | ?ax                    -- anonymous terms
155 ;;             | (?v name) | (?c name) | (?x name)  -- named terms
156 ;;             | (?n name pattern-seq)              -- named sequence
157 ;;             | (?? pattern-seq )                  -- optional sequence
158 ;;             | (?+ pattern-seq )                  -- repeat sequence
159 ;;             | (?* pattern-seq )                  -- optional repeat sequence
160 ;;             | (?/ pattern-lst )                  -- alternative
161 ;;             | atom | compound .
162 ;;
163 ;; name     ::= symbol .
164 ;;
165 ;; atom     ::= symbol | string | character | number .
166 ;; compound ::= list | array | structure .
167 ;; list     ::= ( pattern-seq ) .
168 ;; array    ::= #A( pattern-seq )
169 ;;            | #1A( pattern-seq )
170 ;;            | #2A( (pattern-seq)... )
171 ;;            | #3A( ((pattern-seq)...)... )
172 ;;            | ... .
173
174 (defun generate-all-follows (exp)
175   "
176 RETURN: a list of possible follows from shortest to longuest.
177 "
178   (do ((rest  exp (cdr rest)) ;; what should match after
179        (list  '())            ;; what we match (reversed),
180        ;;             we reverse only in the final result [F].
181        (frame '()))
182       ((null rest)
183        (push (list list rest) frame)
184        frame)
185     (push (list list rest) frame)
186     (push (car rest) list)))
187
188
189 (defun match (pat exp &optional (ms (make-match-state)))
190   "
191 DO:        A pattern matcher accepting the following syntax:
192              ?av        expects a symbol (variable).
193              ?ac        expects a constant (non symbol atom).
194              ?ax        expects anything (one item).
195              (?v n)     expects a symbol (variable)     and bind it.
196              (?c n)     expects a constant (non symbol atom)  and bind it.
197              (?x n)     expects anything (one item)     and bind it.
198              (?n n ...) expects anything (several item) and bind them.
199              (?+ ...)   expects anything (one or more times).  AOB
200              (?* ...)   expects anything (zero or more times). AOB
201              (?? ...)   expects anything (zero or one time).
202              ...        expects exactly ... (can be a sublist).
203            AOB = All occurences bind.
204 RETURN:    A match-state structure.
205 SEE ALSO:  match-state-failed-p to check if the matching failed.
206            match-state-dict     to get the binding dictionary.
207 "
208   ;; The pattern and the expression may be atoms or lists,
209   ;; but usually we process (car pat) and (car exp), to be able
210   ;; to match several items (?+ and ?*).
211   (cond
212     ((match-state-failed-p ms) ms)
213     ((atom pat)
214      (if (equal pat exp)
215          ms
216          (match-state-fail ms `(:different ,pat ,exp))))
217     ((pat-anonymous-constant-p pat)
218      (if (exp-constant-p exp)
219          (match (cdr pat) (cdr exp) ms)
220          (match-state-fail ms `(:not-constant ,exp))))
221     ((pat-anonymous-variable-p pat)
222      (if (exp-variable-p exp)
223          (match (cdr pat) (cdr exp) ms)
224          (match-state-fail ms `(:not-variable ,exp))))
225     ((pat-anonymous-expression-p pat)
226      (if (null exp)
227          (match-state-fail ms `(:missing-expression))
228          (match (cdr pat) (cdr exp) ms)))
229     ((pat-constant-p pat)
230      (if (exp-constant-p exp)
231          (match (cdr pat) (cdr exp) (match-dict-add-binding ms pat exp))
232          (match-state-fail ms `(:not-constant ,exp))))
233     ((pat-variable-p pat)
234      (if (exp-variable-p exp)
235          (match (cdr pat) (cdr exp) (match-dict-add-binding ms pat exp))
236          (match-state-fail ms `(:not-variable ,exp))))
237     ((pat-expression-p pat)
238      (if (null exp)
239          (match-state-fail ms `(:missing-expression))
240          (match (cdr pat) (cdr exp) (match-dict-add-binding ms pat exp)) ))
241     ((pat-named-p pat)
242      (loop
243         for (list rest) in (generate-all-follows exp)
244         for soe = (match (cdr pat) rest ms)
245         for nms = (if (match-state-failed-p soe)
246                       soe
247                       (let* ((list (reverse list))
248                              (nms (match (cddar pat) list soe)))
249                         (if (match-state-failed-p nms)
250                             nms
251                             (match-dict-add-binding nms pat (list list)))))
252         while (match-state-failed-p nms)
253         finally (return nms)))
254     ((and (pat-repeat-p pat) (null exp))
255      (match-state-fail ms `(:missing-repeat ,pat)))
256     ((or (pat-repeat-p pat) (pat-optional-repeat-p pat) (pat-optional-p pat))
257      (loop
258         for (list rest) in (generate-all-follows exp)
259         for soe = (match (cdr pat) rest ms)
260         for nms = (if (match-state-failed-p soe)
261                       soe
262                       (cond
263                         ((pat-repeat-p pat)
264                          ;; at least one (...2... already matches)
265                          ;; ((?+ ...1...) ...2...)
266                          ;; --> (...1... (?* ...1...) ...2...)
267                          (match (append (cdar pat) (list (cons '?* (cdar pat))))
268                                 (reverse list) soe))
269                         ((pat-optional-repeat-p pat)
270                          ;; zero or more (...2... already matches)
271                          ;; ((?* ...1...) ...2...)
272                          ;; --> (...1... (?* ...1...) ...2...)
273                          ;; --> (...2...)
274                          (let ((nms (match (append (cdar pat) (list (car pat)))
275                                            (reverse list) soe)))
276                            (if (match-state-failed-p nms)
277                                (match nil list soe)
278                                nms)))
279                         ((pat-optional-p pat)
280                          ;; zero or one (...2... already matches)
281                          ;; ((?? ...1...) ...2...)
282                          ;; --> (...1... ...2...)
283                          ;; --> (...2...)
284                          (let ((nms (match  (cdar pat) (reverse list) soe)))
285                            (if (match-state-failed-p nms)
286                                (match  nil list soe)
287                                nms)))))
288         while (match-state-failed-p nms)
289         finally (return nms)))
290     ((atom exp)
291      (match-state-fail ms `(:unexpected-atom ,exp)))
292     (t ;; both cars are sublists.
293      (match (cdr pat) (cdr exp) (match (car pat) (car exp) ms)))))
294
295
296 (defun evaluate (instance)
297   "PRIVATE"
298   (cond
299     ((atom instance)               instance)
300     ((and (atom (car instance)) (string= :|| (car instance)))
301      (eval (evaluate (second instance))))
302     (t (mapcar (function evaluate) instance))))
303
304
305 (defun dict-value (dict name)
306   "PRIVATE"
307   (second (assoc name dict :test (function string=))))
308
309
310 (defun dict-boundp (dict name)
311   "PRIVATE"
312   (and (or (symbolp name) (stringp name))
313        (assoc name dict :test (function string=))))
314   
315
316 (defun subst-bindings (expr dict)
317   "PRIVATE"
318   (cond
319     ((atom expr) (list expr))
320     ((and (atom (first expr)) (string= :||  (first expr)))
321      (if (and (atom (second expr))
322               (dict-boundp dict (second expr)))
323          (list (dict-value dict (second expr)))
324          (list (mapcan (lambda (subexpr) (subst-bindings subexpr dict)) expr))))
325     ((and (atom (first expr)) (string= :|@| (first expr)))
326      (copy-seq (dict-value dict (second expr))))
327     (t (list (mapcan (lambda (subexpr) (subst-bindings subexpr dict))
328                      expr)))))
329
330
331 (defun instanciate (ms skeleton)
332   "PRIVATE
333 PRE:   (not (match-state-failed-p ms))
334 DO:    Instanciate the skeleton, substituting all occurence of (: var)
335        with the value bound to var in the binding dictionary of MS,
336        Occurences of (:@ var) are split in line like ,@ in backquotes.
337        Then all remaining (: form) are evaluated (with eval) from the
338        deepest first.
339 "
340   (assert (not (match-state-failed-p ms)))
341   (evaluate (first (subst-bindings skeleton (match-state-dict ms)))))
342
343
344 (defun collect-variables (pat)
345   "
346 PAT:       A symbolic expression with the following syntax:
347              (?v v)  expects a symbol (variable).
348              (?c c)  expects a constant (non symbol atom).
349              (?x x)  expects anything (one item).
350              (?+ l)  expects anything (one or more items).
351              (?* l)  expects anything (zero or more items).
352              other   expects exactly other (can be a sublist).
353 RETURN:    A list of the symbol used in the various (?. sym) items, 
354            in no particular order, but with duplicates deleted.
355 "
356   (delete-duplicates
357    (cond
358      ((atom pat)
359       nil)
360      ((and (atom (car pat))
361            (member (car pat) '(?v ?c ?x ?+ ?*) :test (function string=)))
362       (list (cadr pat)))
363      (t
364       (nconc (collect-variables (car pat)) (collect-variables (cdr pat)))))))
365
366
367 (defun match-case* (sexp clauses)
368   "
369 SEXP:    A symbolic expression, evaluated.
370 CLAUSES: A list of (pattern func) or (otherwise ofunc)
371          The functions FUNC is called with one BINDING argument.
372          The function OFUNC is called with no argument.
373 DO:      Call the function of the clause whose pattern matches the SEXP,
374          or whose pattern is a symbol string-equal to OTHERWISE.
375 RETURN:  The result of the called function, and the pattern that matched.
376 EXAMPLE: (match-case* expr
377             `(((add       (?x a) to   (?x b)) 
378                 ,(lambda (bindings) `(+ ,(aget bindings 'a) ,(aget bindings 'b)))
379                ((multiply  (?x a) with (?x b))
380                 ,(lambda (bindings) `(* ,(aget bindings 'a) ,(aget bindings 'b))))
381                ((substract (?x a) from (?x a)) 
382                 ,(constantly 0))
383                (otherwise
384                 ,(lambda () (error \"No matching pattern\"))))))
385 "
386   (loop
387      :for (pattern func) :in clauses
388      :do (if (and (symbolp pattern) (string-equal "OTHERWISE" pattern))
389              (return (values (funcall func) pattern))
390              (let ((bindings (match pattern sexp)))
391                (unless (match-state-failed-p bindings)
392                  (return (values (funcall func bindings) pattern)))))))
393
394
395 (defmacro match-case (sexp &rest clauses)
396   "
397 SEXP:    A symbolic expression, evaluated.
398 CLAUSES: A list of (pattern &body body)
399          The pattern must be litteral. 
400          Lexical variable names are extracted from it, and body is executed
401          in a lexical environment where these names are bound to the matched
402          subexpression of SEXP.
403 DO:      Execute the body of the clause whose pattern matches the SEXP,
404          or whose pattern is a symbol string-equal to OTHERWISE.
405 EXAMPLE: (match-case expr
406             ((add       (?x a) to   (?x b)) `(+ ,a ,b))
407             ((multiply  (?x a) with (?x b)) `(* ,a ,b))
408             ((substract (?x a) from (?x a)) 0)
409             (otherwise                      :error))
410 "
411   (with-gensyms (ex ms dc)
412     `(let ((,ex ,sexp) (,ms) (,dc))
413        (cond
414          ,@(mapcar
415             (lambda (clause)
416               (let ((pat (car clause)) (body (cdr clause)))
417                 (if (and (symbolp pat) (string-equal "OTHERWISE" pat))
418                     `(t ,@body)
419                     `((progn (setf ,ms (match ',pat ,ex))
420                              (not (match-state-failed-p ,ms)))
421                       (setf ,dc (match-state-dict ,ms))
422                       (let ( ,@(mapcar
423                                 (lambda (name) `(,name (cdr (assoc ',name ,dc)))) 
424                                 (collect-variables pat)) )
425                         ,@body))))) clauses)))))
426
427
428 ;;;; THE END ;;;;