[Small-cl-src] Pattern matching in function headers

[Julian Stecklina]

Hello,

I had the idea to do pattern matching in function definitions as
Haskell allows. Any comments are welcome.

-------------- next part --------------
(defpackage "PATTERN-MATCHING"
  (:nicknames "PM")
  (:use "CL")
  (:export "DEFH" "ONE-OF" "AIF"))
(in-package "PATTERN-MATCHING")

;;; Some basic macros

(defmacro aif ((arg test) then &optional else)
  (let ((tt (gensym)))
    `(let ((,tt ,test))
       (if ,tt
	   (let ((,arg ,tt))
	     ,then)
	 ,else))))

(defmacro one-of (&rest things)
  "Constructs a function that checks whether is in the set of 'things'"
  `(lambda (x)
     (find x ',things)))

;;; Pattern matching as in Haskell

;; Variables are constructed using this read macro:
;; ?var -> #S(VARIABLE :NAME VAR :KEY NIL)
;; ?(var test) -> #S(VARIABLE :NAME VAR :KEY TEST)

;; A structure that describes a variable.
;; On the first occurrence of a variable key is a function
;; taking one argument and returning a generalised boolean. On
;; every other occurrence it takes two parameters and returns 
;; true iff they match.
(defstruct variable
  name
  (key nil))

(set-macro-character #\? 
		     (lambda (stream char)
		       (declare (ignore char))
		       (let ((form (read stream t nil t)))
			 (if (consp form)
			     (make-variable :name (first form)
					    :key (second form))
			   (make-variable :name form)))))

;; This special variable is used during pattern compilation
(defvar *vars-assigned*)

(defun generate-matcher (pattern variable)
  "Generate code to match a specific pattern in a given variable"
  (cond
   ;; If the pattern is a variable and it was already assigned
   ;; check whether the new value is equal, else fail.
   ((and (variable-p pattern)
	 (member pattern *vars-assigned*))
    (aif (key (variable-key pattern))
	 `(funcall ,key
		   ,(variable-name pattern) ,variable)
	 `(eql ,(variable-name pattern) ,variable)))
   ;; If the pattern is an unassigned variable and fits key, 
   ;; set it.
   ((variable-p pattern)
    (push pattern *vars-assigned*)
    (aif (key (variable-key pattern))
	 `(cond
	   ((funcall ,key ,variable)
	    (setq ,(variable-name pattern) ,variable)
	    t)
	   (t nil))
	 `(progn
	    (setq ,(variable-name pattern) ,variable)
	    t)))
   ;; If the pattern is NIL so must be the variable we were given
   ((null pattern)
    `(null ,variable))
   ;; Our pattern is a CONS. Let's generate code for its head
   ;; and tail.
   ((consp pattern)
    (let ((new-var (gensym)))
      `(and 
	(consp ,variable)
	(let ((,new-var (car ,variable)))
	  ,(generate-matcher (car pattern) new-var))
	(let ((,new-var (cdr ,variable)))
	  ,(generate-matcher (cdr pattern) new-var)))))
   ;; The pattern is an ATOM, it has to be equal to what we have
   ;; been given.
   ((atom pattern)
    `(eql ',pattern ,variable))
   ;; If we arrive here, somethings wrong...
   (t
    (error "Do know how to compile pattern ~S." pattern))))
       
(defun find-all-variables (pattern)
  "Find all variables in a given pattern"
  (cond
    ((variable-p pattern)
     (cons pattern nil))
    ((consp pattern)
     (nconc (find-all-variables (car pattern))
	    (find-all-variables (cdr pattern))))
    ((or (null pattern)
	 (atom pattern))
     nil)))
       
(defun compile-pattern-spec (patterns forms body not-matched)
  "Compile a pattern specification of a defh form"
  (let* ((variables (remove-duplicates
		     (mapcan #'find-all-variables patterns))))
    `(let ,(mapcar (lambda (x)
		     `(,(variable-name x) nil))
		   variables)
      (if ,(let ((*vars-assigned* nil))
		`(and ,@(loop for form-var in forms
			      and pattern in patterns
			      collect (generate-matcher pattern form-var))))
	  ,body
	  ,not-matched))))

(defun clauses-sane-p (clauses)
  "Every clause should have the same number of patterns"
  (and clauses
       (every (let ((first-len (length (first (first clauses)))))
		(lambda (x)
		  (= (length (first x)) first-len)))
	      clauses)))
		   
(defun compile-defh-body (clauses)
  "This functions returns a parameter list and body for a defh form"
  (if (not (clauses-sane-p clauses))
      (error "Malformed defh body: ~{~S~}" clauses)

      ;; So we got a correctly formed clause list
      (let ((form-vars (loop 		; Our list of parameters the function takes
			   repeat (length (first (first clauses)))
			 collect (gensym))))
	(values form-vars
		(loop for (patterns body) in (reverse clauses)
		      for code = (compile-pattern-spec patterns form-vars body
						       `(error "No pattern matched"))
		      then (compile-pattern-spec patterns form-vars body old-code)
		      for old-code = code
		      finally (return code))))))
	
(defun parse-defh-clauses (clauses)
  "Parse the raw clauses into the internal form"
  (and clauses
       (aif (pos (position-if (lambda (x) ; avoid exporting '->
				(and (symbolp x)
				     (string= "->" (string x))))
			      clauses))
	    (cons (list (subseq clauses 0 pos)
			(elt clauses (1+ pos)))
		  (parse-defh-clauses (subseq clauses (+ 2 pos))))
	    (error "Malformed defh form: ~S" clauses))))

(defmacro defh (name &rest raw-clauses)
  "Define a function based on patterns"
  (let ((parsed-clauses (parse-defh-clauses raw-clauses)))
    (multiple-value-bind (parameter body)
	(compile-defh-body parsed-clauses)
      `(defun ,name ,parameter 
	,body))))

-------------- next part --------------
(defpackage :pattern-matching-examples
  (:nicknames "PMATCH-EXAMPLES")
  (:use "CL" "PATTERN-MATCHING"))
(in-package "PMATCH-EXAMPLES")

;;; Ok, let's do something funky! H?lli, beware!

;; Implement some predicate logic stuff *g*

;; We need some basic predicates
(defun binaryp (x)
  "Checks whether the argument is a binary operator"
  (funcall (one-of and or) x))

(defun operatorp (x)
  "Checks whether the argument is an operator"
  (funcall (one-of and or not) x))

(defun quantorp (x)
  "Checks whether the argument is a quantor"
  (funcall (one-of forall exists) x))

;; Translate an expression into a very simple form with only unary
;; and binary operators (NOT/AND/OR).
(defh simplify-expression
  ;; 'Implies' and 'Equiv'(valence)
  (implies ?expr1 ?expr2) -> `(or (not ,(simplify-expression expr1)) ,expr2)
  (equiv ?expr1 ?expr2) -> `(or (and expr1 expr2) (not (or expr1 expr2)))

  ;; Pass on quantors
  (?(quantor #'quantorp) ?var ?expr) -> `(,quantor ,var ,(simplify-expression expr))
  
  ;; Pass on unary and binary operators
  (not ?expr) -> `(not ,(simplify-expression expr))
  (?(op #'binaryp) ?expr1 ?expr2) -> `(,op ,(simplify-expression expr1)
					   ,(simplify-expression expr2))

  ;; Reduce not-binary operators to binary
  (?(op #'binaryp) ?expr1 . ?rest) -> `(,op ,expr1 (,op , at rest))
  
  ;; Ignore non-matching
  ?expr -> expr)

;;; We now assume that every expression consists only of NOT/AND/OR with 
;;; atmost two arguments.

;; Perform one praenex transformation step
(defh praenex-transform
  ;; Transform negated quantors
  (not (forall ?var ?expr)) -> `(exists ,var ,(praenex `(not ,expr)))
  (not (exists ?var ?expr)) -> `(forall ,var ,(praenex `(not ,expr)))

  ;; "Lift" a quantor one level
  (?(op #'binaryp) (?(quantor #'quantorp) ?var ?expr1) 
                   ?expr2) 
     -> `(,quantor ,var ,(praenex `(,op ,expr1 
					,expr2)))
  (?(op #'binaryp) ?expr1
                   (?(quantor #'quantorp) ?var ?expr2))
     -> `(,quantor ,var ,(praenex `(,op ,expr1
					,expr2)))
  
  ;; Ignore anything else
  ?expr -> expr)
     
;; Transform an expression into praenex normal form
(defh praenex
  ;; Transform a negated expression
  (not ?expr) -> (praenex-transform `(not ,(praenex expr)))

  ;; Ignore a quantor where it does not hurt
  (?(quantor #'quantorp) ?var ?expr) -> `(,quantor ,var ,(praenex expr))

  ;; Transform 
  (?(op #'binaryp) ?expr1 ?expr2) -> (praenex-transform `(,op ,(praenex expr1)
							      ,(praenex expr2)))
  ?expr -> expr)

;; Perform one skolem transformation step
(defh skolem-transform
  (forall ?var ?expr) ?subst ?vars -> `(forall ,var ,(skolem-transform expr subst (cons var vars)))
  (exists ?var ?expr) ?subst ?vars -> (skolem-transform expr (acons var `(,(gentemp "SKOLEM") ,@(reverse vars)) subst)
					      vars)

  ;; Transform AND/OR/NOT/predicates/functors
  (?op . ?exprs) ?subst ?vars -> `(,op ,@(loop 
					   for expr in exprs
					   collect (skolem-transform expr subst vars)))
 
  ?expr ?subst ?vars -> (aif (subst (assoc expr subst))
			     (cdr subst)
			     expr))

;; Skolemize an expression in praenex normal form
(defh skolem
  ?expr -> (skolem-transform expr nil nil))

;; We would transform an arbitrary expression like this:
#+ ignore
(skolem (praenex (simplify-expression '(implies (and (p 0) (forall x (implies (p x) (p (f x)))))
						(p (f (f 0)))))))

-------------- next part --------------

Regards,
-- 
Julian Stecklina 

Signed and encrypted mail welcome.
Key-Server: pgp.mit.edu         Key-ID: 0xD65B2AB5
FA38 DCD3 00EC 97B8 6DD8  D7CC 35D8 8D0E D65B 2AB5

Any sufficiently complicated C or Fortran program
contains an ad hoc informally-specified bug-ridden
slow implementation of half of Common Lisp.
 - Greenspun's Tenth Rule of Programming