From: Nathan J. Wilson
Subject: Pattern matching in Lisp?
Date: Wed, 02 Jun 1993 03:41:07 +0000
Message-ID: <1uh7gjINN3gv@darkstar.UCSC.EDU> I'm interesting in finding out if anyone knows of any packages for
doing pattern matching in Lisp.
By pattern matching I mean something similar to Prolog or Haskell.
There is some question how you distinguish literal atoms from
variables, but I'm sure something reasonable could be created either
through use of backquote or some other (maybe keyword) syntax. I see
two obvious approaches. First as a sequence of defining statements sort
of like defun's, e.g.
; Upper case is used for variable name just to be more Prolog-like.
; I am aware that Lisp is generally not case sensitive.
(defmatch list-matcher ((ferd `X `(:rest Y)))
(list X Y))
(defmatch list-matcher ((blat `(:rest Y)))
Y)
(defmatch list-matcher (`X)
X)
-> (list-match '(ferd blat flib))
(blat (flib))
-> (list-match '(blat froon ferb))
(froon ferb)
-> (list-match '(frizzle woz))
(frizzle woz)
The main problem I see with this method is that order matters in pattern
matching and you wouldn't want to only be able to add patterns to the
end. This would mean adding more functions to 'manage' the defmatch
functions.
The other possibility would be just a match macro. E.g.
(defun list-match (l)
(match l
((ferd `X `(:rest Y)) (list X Y))
((blat `(:rest Y)) Y)
((`X) X)))
With the same values for the examples given above. This would probably
be the preferred approach.
The closest I've found in CL itself is destructuring-bind and it
doesn't deal with literals, and, more importantly, it doesn't have a
way to have multiple patterns that are tried in sequence.
Nathan Wilson
······@cse.ucsc.edu From: Marty Hall
Subject: Re: Pattern matching in Lisp?
Date: Wed, 02 Jun 1993 13:22:35 +0000
Message-ID: <C7zx5n.GxH@aplcenmp.apl.jhu.edu> In article <············@darkstar.UCSC.EDU> ······@cse.ucsc.edu (Nathan J. Wilson) writes:
>I'm interesting in finding out if anyone knows of any packages for
>doing pattern matching in Lisp.
>
>By pattern matching I mean something similar to Prolog or Haskell.
There are PROLOG and Haskell (or was it Miranda?) systems written
in LISP; maybe you can extract the relevant parts from them. The
FAQ points to PROLOG implementations in LISP, and perhaps a query on
alt.lang.ml would tell you about the Haskell implementations? Anybody
know a better source?
- Marty
(proclaim '(inline skates)) From: Daniel LaLiberte
Subject: Re: Pattern matching in Lisp?
Date: Wed, 02 Jun 1993 19:34:12 +0000
Message-ID: <LIBERTE.93Jun2133412@ebony.cs.uiuc.edu> In article <············@darkstar.UCSC.EDU> ······@cse.ucsc.edu (Nathan J. Wilson) writes:
From: ······@cse.ucsc.edu (Nathan J. Wilson)
I'm interesting in finding out if anyone knows of any packages for
doing pattern matching in Lisp.
Not yet for Common Lisp, but my edebug.el package for GNU Emacs does
pattern matching of macro calls sufficiently to handle the
complexities of "loop". Patterns are specified in a way similar to
the CL destructuring-bind, but with numerous extensions. What edebug
doesnt have is a way to bind parts of the matched expression to
variables, mostly because I didnt need that capability.
Here is the pattern for the "do" macro. A "form" is evaluatable, and
"body" is an abbreviation for "&rest form".
(def-edebug-spec do
((&rest &or symbolp
(symbolp &optional form form))
(form body) body))
Dan LaLiberte
·······@cs.uiuc.edu
(Join the League for Programming Freedom: ···@uunet.uu.net) From: Ralf Moeller
Subject: Re: Pattern matching in Lisp?
Date: Thu, 03 Jun 1993 09:02:16 +0000
Message-ID: <moeller-030693110052@bomac1.informatik.uni-hamburg.de> In article <············@darkstar.UCSC.EDU>, ······@cse.ucsc.edu (Nathan J.
Wilson) wrote:
>
> I'm interesting in finding out if anyone knows of any packages for
> doing pattern matching in Lisp.
>
Maybe the following code is interesting for you. I found it a few year ago.
Ralf
=====================================================================
#|
(defun eval-expr (x)
(select-match x
('add x y) => (+ x y)
('sub x y) => (- x y)
('mul x y) => (* x y)
('div x y) => (/ x y)
)
)
I have made the source available by JANET ftp.
The site is uk.ac.soton.ecs and the file is
<FTP>lisp/select.lisp
The select-match macro is not only useful for writing
interpreters:
(defun my-append (a b)
(select-match a
'nil => b
(hd . tl) => (cons hd (my-append tl b))))
(defun fact (n)
(select-match n
'0 => 1
n => (* n (fact (1- n)))))
The file also contains a macro called IN which is similar
to the `where' clause of SML and Miranda.
--
______________________________________________________________
Stephen Adams ·········@ecs.soton.ac.uk
Computer Science ·········@sot-ecs.uucp
Southampton University
Southampton SO9 5NH, UK
|#
;;
;; SELECT-MATCH macro (and IN macro)
;;
;; Copyright 1990 Stephen Adams
;;
;; You are free to copy, distribute and make derivative works of this
;; source provided that this copyright notice is displayed near the
;; beginning of the file. No liability is accepted for the
;; correctness or performance of the code. If you modify the code
;; please indicate this fact both at the place of modification and in
;; this copyright message.
;;
;; Stephen Adams
;; Department of Electronics and Computer Science
;; University of Southampton
;; SO9 5NH, UK
;;
;; ···@ecs.soton.ac.uk
;;
;;
;; Synopsis:
;;
;; (select-match expression
;; (pattern action+)*
;; )
;;
;; --- or ---
;;
;; (select-match expression
;; pattern => expression
;; pattern => expression
;; ...
;; )
;;
;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
;; | symbol ;matches anything
;; | 'anything ;must be EQUAL
;; | (pattern = pattern) ;both patterns must match
;; | (#'function pattern) ;predicate test
;; | (pattern . pattern) ;cons cell
;;
;; Example
;;
;; (select-match item
;; (('if e1 e2 e3) 'if-then-else) ;(1)
;; ((#'oddp k) 'an-odd-integer) ;(2)
;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
;; (other 'anything-else)) ;(4)
;;
;; Notes
;;
;; . Each pattern is tested in turn. The first match is taken.
;;
;; . If no pattern matches, an error is signalled.
;;
;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
;; numbers, strings, characters, etc.) match things which are EQUAL.
;;
;; . Quoted patterns (which are CONSTANTP) are constants.
;;
;; . Symbols match anything. The symbol is bound to the matched item
;; for the execution of the actions.
;; For example, (SELECT-MATCH '(1 2 3)
;; (1 . X) => X
;; )
;; returns (2 3) because X is bound to the cdr of the candidate.
;;
;; . The two pattern match (p1 = p2) can be used to name parts
;; of the matched structure. For example, (ALL = (HD . TL))
;; matches a cons cell. ALL is bound to the cons cell, HD to its car
;; and TL to its tail.
;;
;; . A predicate test applies the predicate to the item being matched.
;; If the predicate returns NIL then the match fails.
;; If it returns truth, then the nested pattern is matched. This is
;; often just a symbol like K in the example.
;;
;; . Care should be taken with the domain values for predicate matches.
;; If, in the above eg, item is not an integer, an error would occur
;; during the test. A safer pattern would be
;; (#'integerp (#'oddp k))
;; This would only test for oddness of the item was an integer.
;;
;; . A single symbol will match anything so it can be used as a default
;; case, like OTHER above.
;;
(eval-when (compile) (proclaim '(optimize (safety 2))))
(defmacro select-match (expression &rest patterns)
(let* ( (do-let (not (atom expression)))
(key (if do-let (gensym) expression))
(cbody (expand-select-patterns key patterns))
(cform `(cond . ,cbody))
)
(if do-let
`(let ((,key ,expression)) ,cform)
cform))
)
(defun expand-select-patterns (key patterns)
(if (eq (second patterns) '=>)
(expand-select-patterns-style-2 key patterns)
(expand-select-patterns-style-1 key patterns)))
(defun expand-select-patterns-style-1 (key patterns)
(if (null patterns)
`((T (error "Case select pattern match failure on ~S" ,key)))
(let ((pattern (caar patterns))
(actions (cdar patterns))
(rest (cdr patterns)) )
(let ( (test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`( ,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(if (eq test t)
nil
(expand-select-patterns-style-1 key rest)))
)
)
))
(defun expand-select-patterns-style-2 (key patterns)
(if (null patterns)
`((T (error "Case select pattern match failure on ~S" ,key)))
(let ((pattern (first patterns))
(arrow (if (or (< (length patterns) 3)
(not (eq (second patterns) '=>)))
(error "Illegal patterns: ~S" patterns)))
(actions (list (third patterns)))
(rest (cdddr patterns)) )
(let ( (test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`( ,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(if (eq test t)
nil
(expand-select-patterns-style-2 key rest)))
)
)
))
(defun compile-select-test (key pattern)
(let ((tests (remove-if
#'(lambda (item) (eq item t))
(compile-select-tests key pattern))))
(cond
;; note AND does this anyway, but this allows us to tell if
;; the pattern will always match.
((null tests) t)
((= (length tests) 1) (car tests))
(T `(and . ,tests)))))
(defun compile-select-tests (key pattern)
(cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
((symbolp pattern) 'eq)
(T 'equal))
,key ,pattern)))
((symbolp pattern) '(T))
((select-double-match? pattern)
(append
(compile-select-tests key (first pattern))
(compile-select-tests key (third pattern))))
((select-predicate? pattern)
(append
`((,(second (first pattern)) ,key))
(compile-select-tests key (second pattern))))
((consp pattern)
(append
`((consp ,key))
(compile-select-tests (!cs-car key) (car
pattern))
(compile-select-tests (!cs-cdr key) (cdr
pattern))))
('T (error "Illegal select pattern: ~S" pattern))
)
)
(defun compile-select-bindings (key pattern action)
(cond ((constantp pattern) '())
((symbolp pattern)
(if (select!-in-tree pattern action) `((,pattern ,key))
'()))
((select-double-match? pattern)
(append
(compile-select-bindings key (first pattern) action)
(compile-select-bindings key (third pattern)
action)))
((select-predicate? pattern)
(compile-select-bindings key (second pattern)
action))
((consp pattern)
(append
(compile-select-bindings (!cs-car key) (car pattern)
action)
(compile-select-bindings (!cs-cdr key) (cdr pattern)
action)))
)
)
(defun select!-in-tree (atom tree)
(or (eq atom tree)
(if (consp tree)
(or (select!-in-tree atom (car tree))
(select!-in-tree atom (cdr tree))))))
(defun select-double-match? (pattern)
;; (<pattern> = <pattern>)
(and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
(null (cdddr pattern))
(eq (second pattern) '=)))
(defun select-predicate? (pattern)
;; ((function <f>) <pattern>)
(and (consp pattern)
(consp (cdr pattern))
(null (cddr pattern))
(consp (first pattern))
(consp (cdr (first pattern)))
(null (cddr (first pattern)))
(eq (caar pattern) 'function)))
(defun !cs-car (exp)
(!cs-car/cdr 'car exp '(
(car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
(cdar . cadar) (cddr . caddr)
(caaar . caaaar) (caadr . caaadr) (cadar . caadar)
(caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
(cddar . caddar) (cdddr . cadddr))))
(defun !cs-cdr (exp)
(!cs-car/cdr 'cdr exp '(
(car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
(cdar . cddar) (cddr . cdddr)
(caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
(caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
(cddar . cdddar) (cdddr . cddddr))))
(defun !cs-car/cdr (op exp table)
(if (and (consp exp) (= (length exp) 2))
(let ((replacement (assoc (car exp) table)))
(if replacement
`(,(cdr replacement) ,(second exp))
`(,op ,exp)))
`(,op ,exp)))
;(setf c1 '(select-match x (a 1) (b 2 3 4)))
;(setf c2 '(select-match (car y)
; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
else))))
;(setf c3 '(select-match (caddr y)
; ((all = (x y)) (list x y all))
; ((a '= b) (list 'assign a b))
; ((#'oddp k) (1+ k)))))
;;
;; IN macro
;;
;; (IN exp LET pat1 = exp1
;; pat2 = exp2
;; ...)
;;
;; (IN exp LET* pat1 = exp1
;; pat2 = exp2
;; ...)
;;
(defmacro in (&rest form)
(select-match form
(exp 'let . pats) =>
(let* ( (exps (select-in-let-parts pats 'exp))
(pats (select-in-let-parts pats 'pat))
(vars (mapcar #'(lambda (x) (gensym)) exps))
)
`(let ,(mapcar #'list vars exps)
,(reduce
#'(lambda (var-pat subselection)
(let ((var (first var-pat))
(pat (second var-pat)))
`(select-match ,var
,pat => ,subselection
else => (error "IN-LET type error: ~S
doesnt match ~S" ,var ',pat))))
(mapcar #'list vars pats)
:from-end t
:initial-value exp)))
(exp 'let*) => exp
(exp 'let* pat '= patexp . pats) =>
(let ((var (gensym)))
`(let ((,var ,patexp))
(select-match ,var
,pat => (in ,exp let* . ,pats)
else => (error "IN-LET type error: ~S doesnt match
~S" ,var ',pat))))
else =>
(error "Illegal IN form ~S" form)))
(defun select-in-let-parts (pats part)
(select-match pats
nil =>
nil
(pat '= exp . rest) =>
(cons (select-match part
'exp => exp
'pat => pat)
(select-in-let-parts rest part))
other =>
(error "Illegal LET form(s): ~S" pats)))
;(setf eg1 '(in (list h1 h2 t1 t2)
; let
; (h1 . t1) = (foo x)
; (h2 . t2) = (bar y))))
=========================================================================
Ralf Moeller
University of Hamburg
Bodenstedtstr. 16
2000 Hamburg 50
Germany
Phone: ++40 4123 6134
Fax ++40 4123 6530
Email: ·······@informatik.uni-hamburg.de From: Ralf Moeller
Subject: Re2: Pattern matching in Lisp?
Date: Thu, 03 Jun 1993 09:10:51 +0000
Message-ID: <moeller-030693110711@bomac1.informatik.uni-hamburg.de> In article <············@darkstar.UCSC.EDU>, ······@cse.ucsc.edu (Nathan J.
Wilson) wrote:
> By pattern matching I mean something similar to Prolog or Haskell.
I do not know very much about Haskell.
The following implements some ideas about comprehesions found in Miranda.
Sorry, I forgot the name of the programmer.
See also Winston/Horn: Lisp 3rd Edition for a pattern matcher
and Norvig: Paradigms of AI Programming for a Prolog-Compiler.
Hope I could provide some hints.
Ralf
==========================================================================
(defmacro comp ((e &rest qs) l2)
(if (null qs)
`(cons ,e ,l2)
(let ((q1 (car qs))
(q (cdr qs)))
(if (not (eq (cadr q1) '<-))
`(if ,q1
(comp (,e . ,q) ,l2) ,l2)
(let ((v (car q1))
(l1 (third q1))
(h (gensym "H-"))
(us (gensym "US-"))
(us1 (gensym "US1-")))
`(labels ((,h (,us)
(if (null ,us)
,l2
(let ((,v (car ,us))
(,us1 (cdr ,us)))
(comp (,e . ,q) (,h ,us1))))))
(,h ,l1)))))))
(defun open-bracket (stream ch)
(do ((l nil)
(c (read stream t nil t) (read stream t nil t)))
((eq c '|]|)
`(comp ,(reverse l) ()))
(push c l)))
(defun closing-bracket (stream ch)
'|]|)
(set-macro-character #\[ #'open-bracket)
(set-macro-character #\] #'closing-bracket)
#|
(setf xs '(1 2 3 4 5 6 7 8))
[x (x <- xs) (oddp x)]
(defun qsort (ax)
(and ax
(let ((a (car ax))
(x (cdr ax)))
(append (qsort [y (y <- x) (< y a)])
(list a)
(qsort [y (y <- x) (>= y a)])))))
(qsort '(6 2 7 3 5 1 98 44 22 31 555))
(require :select)
(defmacro miranda (function-name (arg) &body forms)
`(defun ,function-name (,arg)
(select-match ,arg . ,forms)))
(miranda perms (x)
() => '(())
(_ . _) => [(cons a p)
(a <- x)
(p <- (perms (remove a x :count 1)))])
(perms '(2 3 4 5))
|#