match pattern

Discussion of Common Lisp
Post Reply
mautorrejon
Posts: 2
Joined: Wed Oct 10, 2012 7:28 pm

match pattern

Post by mautorrejon » Tue Oct 30, 2012 8:14 pm

I am having problems with this function. What I have worked so far is that it checks for variable that are denoted by "?" For instance variable x is denoted by (? x). so what Im looking to do with it is given two list for instance:
 (match '(A (? X) (? Y)) '(A (E F) G))
(T ((X (E F)) (Y G)))
 (match '(A (? X) (? X)) '(A (E F) G))
(NIL ((X (E F))))
 (match '(A (? X) (? Y (numberp Y))) '(A (E F) 7))
(T ((X (E F)) (Y 7)))
 (match '(A (? X) (? Y (numberp Y))) '(A (E F) G))
(NIL ((X (E F))))
 (match '(A (? X) (? Y (numberp Y) (> Y 10))) '(A (E F) 15))
(T ((X (E F)) (Y 15)))
 (match '(A (? X) (? Y (numberp Y) (my-predicate Y 10))) '(A (E F) 7))
(NIL ((X (E F))))
So far my code works half the way..i think. could anyone help me...to get this right. I feel like i go over and over and do no improvement.

Code: Select all

(defun match (p s &optional (binds () ))
	(let ( (temp nil) )
		(cond 	((atom p) 	(cond 	((equal p s) (list t binds))
									(t (list nil nil))))
				((equal (first p) '?) (setf temp (test-binds (second p) s binds)) 	(cond 	(temp (list t p))
																							(t (list nil nil))
																					)
				)
				((atom s) (list nil nil))
				(t					(setf temp (match (first p) (first s) binds))
									; temp = (flag binds)
									(cond 		((first temp) (match (rest p) (rest s) (second temp)))
									; (first p) and (first s) match
												(t (list nil nil))
									)
				)
		)
	)
)

Code: Select all

(defun test-binds (x v binds)
	;; returns nil or the binds updated by the addition of the pair (x v)
	(let ( (y nil) )
		(setf y (assoc x binds))
		(cond 
			(y (cond ((equal (second y) v) binds)(t nil)))
			(t (setf binds (append binds (list (list x v)))))
		)
	)
)

Konfusius
Posts: 62
Joined: Fri Jun 10, 2011 6:38 am

Re: match pattern

Post by Konfusius » Thu Nov 01, 2012 3:46 am

Code: Select all

(define-condition pattern-maching-failed (error) ())

(defun rxvarp (exp)
  (if (and (consp exp)
		   (= 2 (length exp))
		   (eq '? (car exp))
		   (symbolp (cadr exp)))
	(cadr exp)))

(defun bind-rxvar (var exp bind)
  (let ((ent (assoc var bind)))
	(if ent
	  (if (equalp (cdr ent) exp)
		bind
		(error 'pattern-maching-failed))
	  (acons var exp bind))))

(defun match* (rx exp bind)
  (let ((var (rxvarp rx)))
	(cond (var
			(bind-rxvar var exp bind))
		  ((and (consp rx) (consp exp))
			(if (= (length rx) (length exp))
			  (reduce (lambda (bind-acc pair) (match* (car pair) (cdr pair) bind-acc))
					  (mapcar #'cons rx exp)
					  :initial-value bind)
			  (error 'pattern-maching-failed)))
		  (t
			(if (equalp rx exp)
			  bind
			  (error 'pattern-maching-failed))))))

(defun match (rx exp)
  (handler-case (match* rx exp nil)
	(pattern-maching-failed () :doesnt-match)))

Post Reply