(defpackage :pcond
  (:use :common-lisp :cl-user :cl-ppcre :lisp-unit)
  (:export pcond add-conditional))

(in-package :pcond)

(define-test cond
  (assert-eq 'right
	     (pcond
	      (nil 'wrong)
	      (t 'right))))

(define-test cond2
  (assert-eq 'right
	     (pcond
	      (nil 'wrong)
	      ((:re "ab(c)" "abc")
	       'right)
	      (t nil))))

(define-test cond3
  (assert-eq 'right
	     (pcond
	      (nil 'wrong)
	      ((and t (:re "ab(c)" "abc"))
	       'right)
	      (t nil))))

(define-test cond4
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((:re "ab(c)" "abc" (c))
	       (when (equal "c" c)
		 'right))
	      (t 't-wrong))))

(define-test cond5
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((and t (:re "ab(c)" "abc" (c)))
	       (when (equal "c" c)
		 'right))
	      (t 't-wrong))))

(define-test cond6
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((and t (:re "ab(d+)" "abddddd" (d)) (:re "ab(c)" "abc" (c)))
	       (when (and (equal "c" c) (= 5 (length d)))
		 'right))
	      (t 't-wrong))))

(define-test cond7
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((and t (:re "ab(\\w+)" "ababc" (d)) (:re "ab(c)" d (c)))
	       (when (and (equal "c" c))
		 'right))
	      (t 't-wrong))))

(define-test cond8
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((and t (:re "(\\d+)" "123" ((#'parse-integer d))))
	       (when (= 123 d)
		 'right))
	      (t 't-wrong))))

(define-test cond9
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((:pat ?x 1)
	       (when (= ?x 1)
		 'right))
	      (t 't-wrong))))

(define-test cond10
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((:pat (?x) '(1))
	       (when (= ?x 1)
		 'right))
	      (t 't-wrong))))

(define-test cond11
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((:pat (?x ?y) '(1 2))
	       (when (and (= ?x 1) (= ?y 2))
		 'right))
	      (t 't-wrong))))

(define-test cond12
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((:pat (?x . ?xs) '( 1))
	       (when (= ?x 1)
		 'right))
	      (t 't-wrong))))

(define-test cond13
  (assert-eq 'right
	     (pcond
	      (nil 'nil-wrong)
	      ((and (:pat (?x . ?xs) '( 1)) (eq ?xs 'p))
	       'wrong)
	      ((and (:pat (?first ?last)
			  '("Eric" "Normand"))
		    (:re "^Nor" ?last))
	       'right)
	      
	      (t 't-wrong))))

(defmacro pcond (&rest exprs)
  (recur exprs))

(defun recur (ls)
  (when ls
    `(let (,@(remove-duplicates (vars-in (first (first ls)))))
      ,@(loop for v in (remove-duplicates (vars-in (first (first ls))))
	      collecting `(declare (special ,v)))
      (if ,(expand (first (first ls)))
	  (progn
	    ,@(rest (first ls)))
	  ,(recur (rest ls))))))

(defun expand (test)
  (funcall (expander 
	    (find-if 
	     #'(lambda (c)
		 (funcall (dispatcher c)
			  test))
	     *conditionals*))
	   test))


(defun vars-in (expr)
  (funcall (vars
	    (find-if 
	     #'(lambda (c)
		 (funcall (dispatcher c)
			  expr))
	     *conditionals*))
	   expr))

(defun varsym-p (v)
  (and (symbolp v) (eq (char (symbol-name v) 0) #\?)))

(defun pat-vars (exp)
  (cond
    ((null exp)
     nil)
    ((varsym-p exp)
     (list exp))
    ((consp exp)
     (append (pat-vars (first exp))
	     (pat-vars (rest exp))))
    ((vectorp exp)
     (loop for v across exp
	   nconc (pat-vars v)))
    (t nil)))

(defun re-vars (frm)
  (if (null frm)
      nil
      (if (listp (first frm))
	  (append (copy-list (rest (first frm)))
		  (re-vars (rest frm)))
	  (cons (first frm) (re-vars (rest frm))))))

(defun normalize-re-vars (vars)
  (loop for v in vars
	if (consp v)
	nconc (loop for x in (rest v)
		    collect (list (first v)
				     x))
	else
	collect (list '(function identity) v)))

(defparameter *conditionals* (list (make-instance 'conditional
					    :dispatcher (constantly t)
					    :vars (lambda (expr)
						    (if (consp expr)
							(mapcan #'vars-in expr)
							nil))
					    :expander (lambda (test)
							(if (consp test)
							    (cons (first test)
								  (mapcar #'expand (rest test)))
							    test)))))

(defclass conditional ()
  ((dispatcher :reader dispatcher
	       :initarg :dispatcher)
   (vars :reader vars
	 :initarg :vars)
   (expander :reader expander
	   :initarg :expander)))

(defun add-conditional (dispatcher vars expand)
  (push (make-instance 'conditional :dispatcher dispatcher
		       :vars vars :expander expand)
	*conditionals*))


(add-conditional 
 #'(lambda (expr)
     (and (consp expr)
	  (eq :re (first expr))))
 #'(lambda (expr)
     (re-vars (fourth expr)))
 #'(lambda (test)
     `(multiple-value-bind (match values)
       (scan-to-strings ,(second test)
	,(third test))
       (when match
	 ,@(loop for (fun var) in (normalize-re-vars (fourth test))
		 for vi upfrom 0
		 collect `(set ',var (funcall ,fun (elt values ,vi))))
	 match))))

(add-conditional 
 #'(lambda (expr)
     (and (consp expr)
	  (eq :pat (first expr))))
 #'(lambda (expr)
     (pat-vars (second expr)))
 #'(lambda (test)
     `(ignore-errors
       (let ((match (unify:unify ',(second test) ,(third test))))
	 ,@ (loop for var in (pat-vars (second test))
		  collect `(set ',var (unify:find-variable-value ',var match)))
	 match))))

(run-all-tests :pcond)