(defclass patfrag ()
  ((pattern :reader pattern :initarg :pattern)
   (binding :reader binding :initarg :binding)))

(defclass headfrag (patfrag) nil)
(defclass wholefrag (patfrag) nil)
(defclass partfrag (patfrag) nil)

(defun pattern-clause-start (pattern data-var outer-block-tag clause-body)
  (let ((fail-tag (gensym)))
    (let ((match `(return-from ,outer-block-tag (progn ,@clause-body)))
	  (fail `(return-from ,fail-tag)))
      `(block ,fail-tag
	 ,(cond ((symbolp pattern) ;special case symbol at top level
		 ;; so that it names a type, not a variable.
		 ;; Not consistent, but convenient
		 `(if (typep ,data-var (quote ,pattern))
		      ,match
		      ,fail))
		((consp pattern)
		 (pattern-clause
		  (list
		   (make-instance 'wholefrag
				  :pattern pattern
				  :binding data-var))
		  fail
		  match))
		(t (error "Patterns such as ~A are not implemented."
			  pattern)))))))

(defun pattern-clause (pat-frag-list fail match)
  (if (endp pat-frag-list) match
      (build-clause (first pat-frag-list)
		    (rest pat-frag-list)
		    fail
		    match)))

(defmethod build-clause ((frag wholefrag) more-patterns fail match)
  (if (symbolp (pattern frag)) ;a variable, always match
      `(let ((,(pattern frag) ,(binding frag)))
	 ,(pattern-clause more-patterns fail match))
      (let ((car-var (gensym))
	    (cdr-var (gensym)))
	`(if (consp ,(binding frag))
	     (let ((,car-var (car ,(binding frag)))
		   (,cdr-var (cdr ,(binding frag))))
	       ,(pattern-clause
		  (list* (make-instance
			  'headfrag
			  :pattern (car (pattern frag))
			  :binding car-var)
			 (make-instance
			  'partfrag
			  :pattern (cdr (pattern frag))
			  :binding cdr-var)
			 more-patterns)
		  fail
		  match))
	     ,fail))))

(defmethod build-clause ((frag headfrag) more-patterns fail match)
  (cond ((symbolp (pattern frag))
	 ;;classic headcase - the symbol at the head of a list
	 `(if (eql (quote ,(pattern frag)) ,(binding frag))
	      ,(pattern-clause more-patterns fail match)
	      ,fail))
	((consp (pattern frag))
	 ;; the lisp-1 case with the head of the list itself a list
	 (pattern-clause (cons (change-class frag 'whole) more-patterns)
			 fail
			 match))
	(t (error "Pattern ~A not implemented for head position."
		  (pattern frag)))))

(defmethod build-clause ((frag partfrag) more-patterns fail match)
  (cond ((null (pattern frag)) ; reached the end of a true list
	 `(if (null ,(binding frag))
	      ,(pattern-clause more-patterns fail match)
	      ,fail))
	((symbolp (pattern frag)) ; reached the dot of a dotted list
	 ;; match always succeeds
	 `(let ((,(pattern frag) ,(binding frag)))
	    ,(pattern-clause more-patterns fail match)))
	((consp (pattern frag)) ;recurse down the list
	 (let ((car-var (gensym))
	       (cdr-var (gensym)))
	   `(if (consp ,(binding frag))
		(let ((,car-var (car ,(binding frag)))
		      (,cdr-var (cdr ,(binding frag))))
		  ,(pattern-clause
		     (list* (make-instance
			     'wholefrag
			     :pattern (car (pattern frag))
			     :binding car-var)
			    (make-instance
			     'partfrag
			     :pattern (cdr (pattern frag))
			     :binding cdr-var)
			    more-patterns)
		     fail
		     match))
		,fail)))
	(t (error "Pattern ~A not implemented as a part-list pattern."
		  (pattern frag)))))

(defmacro headcase (form &body match-clauses)
  (let ((data-var (gensym))
	(outer-block-tag (gensym)))
    `(block ,outer-block-tag
       (let ((,data-var ,form))
	 ,@(loop for (pattern . code) in match-clauses
	      collect (pattern-clause-start pattern data-var outer-block-tag code))))))

(defun compute (expression)
  (headcase expression
    (number expression)
    ((add x y) (+ (compute x) (compute y)))
    ((mul x y) (* (compute x) (compute y)))))

;;; I'm astonished that this headcase macro seems to work
;;; just fine. I'm written sop = Sum Of Producs
;;; to expand out an expression of sums and products
;;; Is it really this complicated? I'm barely convinced
;;; that this code even terminates.

;;; This is isomorphic to a conversion in logic,
;;; from negated normal form to disjunctive normal form
;;; so I can check in Harrison

;;; My big doubts are about (mul (mul a b) c)
;;; I have to convert (mul a b) to see if it ends up with
;;; adds inside a and b bubbling to the top.

;;; But when I come to multiply two expressions that have already
;;; been put into sum-of-product form I suspect I should be using
;;; a different function. Once I have recursed down through the adds
;;; and reached a multiply, then I know I'm done, there are no buried
;;; adds underneath to bubble up later

;;; I suspect that this code is doing some kind of tree recursion,
;;; repeatedly checking the same old trees of multiplications to
;;; see if any adds have sneaked in impossibly.
(defun sop (expression)
  (headcase expression
    ((mul (add u v) w)
     (list 'add
	   (sop (list 'mul u w))
	   (sop (list 'mul v w))))
    ((mul u (add v w))
     (list 'add
	   (sop (list 'mul u v))
	   (sop (list 'mul u w))))
    ((add x y)
     (list 'add
	   (sop x)
	   (sop y)))
    (number expression)
    ((mul x y)
     (let ((left (sop x))
	   (right (sop y)))
       (headcase left
	 ((add u v)
	  (headcase right
	    ((add r s)
	     (list 'add
		   (list 'add
			 (sop (list 'mul u r))
			 (sop (list 'mul u s)))
		   (list 'add
			 (sop (list 'mul v r))
			 (sop (list 'mul v s)))))
	    (t (list 'add
		     (sop (list 'mul u right))
		     (sop (list 'mul v right))))))
	 (t
	  (headcase right
	    ((add r s)
	     (list 'add
		   (sop (list 'mul left r))
		   (sop (list 'mul left s))))
	    (t (list 'mul left right)))))))))