;; base types
(defvar *regex-null*  nil)
(defvar *regex-empty* t)

;; predicates
(defun regex-alt? (re)
  (and (consp re) (eq (car re) 'alt)))
(defun regex-seq? (re)
  (and (consp re) (eq (car re) 'seq)))
(defun regex-rep? (re)
  (and (consp re) (eq (car re) 'rep)))

(defun regex-null? (re)
  (eq re *regex-null*))
(defun regex-empty? (re)
  (eq re *regex-empty*))

(defun regex-atom? (re)
  (or (characterp re) (symbolp re)))

;; deconstructors
(defun match-seq (re f)
  (and (regex-seq? re)
       (funcall f (cadr re) (caddr re))))
(defun match-alt (re f)
  (and (regex-alt? re)
       (funcall f (cadr re) (caddr re))))
(defun match-rep (re f)
  (and (regex-rep? re)
       (funcall f (cadr re))))

;; simplified
(defun seq (pat1 pat2)
  (cond ((regex-null? pat1) *regex-null*)
	((regex-null? pat2) *regex-null*)
	((regex-empty? pat1) pat2)
	((regex-empty? pat2) pat1)
	(t (list 'seq pat1 pat2))))

(defun alt (pat1 pat2)
  (cond ((regex-null? pat1) pat2)
	((regex-null? pat2) pat1)
	(t (list 'alt pat1 pat2))))

(defun rep (pat)
  (cond ((regex-null? pat) *regex-empty*)
	((regex-empty? pat) *regex-empty*)
	(t (list 'rep pat))))

;; matching
(defun regex-empty (re)
  (cond ((regex-empty? re) *regex-empty*)
	((regex-null? re) *regex-null*)
	((regex-atom? re) *regex-null*)
	((match-seq re (lambda (pat1 pat2)
			 (seq (regex-empty pat1) (regex-empty pat2)))))
	((match-alt re (lambda (pat1 pat2)
			 (alt (regex-empty pat1) (regex-empty pat2)))))
	((regex-rep? re) *regex-empty*)
	(t *regex-null*)))

(defun regex-deriv (re c)
  (cond ((regex-empty? re) *regex-null*)
	((regex-null? re) *regex-null*)
	((eq c re) *regex-empty*)
	((regex-atom? re) *regex-null*)
	((match-seq re (lambda (pat1 pat2)
			 (alt (seq (regex-deriv pat1 c) pat2)
			      (seq (regex-empty pat1) (regex-deriv pat2 c))))))
	((match-alt re (lambda (pat1 pat2)
			 (alt (regex-deriv pat1 c)
			      (regex-deriv pat2 c)))))
	((match-rep re (lambda (pat)
			 (seq (regex-deriv pat c) (rep pat)))))
	(t *regex-null*)))

(regex-deriv '(seq #\a #\b #\c)
	     #\a)