(define (make-symbol-table)
  (let ((alist '()))
    (lambda (sym . val)
      (if (null? val)
	  (let ((result (assq sym alist)))
	    (if result (cdr result) #f))
	  (set! alist (cons (cons sym (car val)) alist))))))

(define is-a-table (make-symbol-table))

(define (any? x) #t)

(define (is-a? derived base)
  (if (eq? derived base)
      #t
      (let ((d (is-a-table derived)))
	(if (and d (memq base (cdr d)))
	    #t
	    #f))))

(define (is-a derived base)
  (if (is-a? base derived)
      (error 'is-a
	     "declaring a ~a to be a ~a creates circularity"
	     derived
	     base)
      (let ((d (is-a-table derived)))
	(if d
	    (if (and (not (null? (cdr d)))
		     (not (eq? (cadr d) base)))
		(warning 'is-a
			 "~a is-a ~a replaces ~a is-a ~a"
			 derived base derived (cadr d)))
	    (begin
	      (set! d (cons derived '()))
	      (is-a-table derived d)))
	(let ((b (is-a-table base)))
	  (if (not b)
	      (begin
		(set! b (cons base '()))
		(is-a-table base b)))
	  (set-cdr! d b)))))

(define (generic-tree-insert tree full-name preds)
  (if (null? tree)
      (set! tree (cons #f '())))
  (if (null? preds)
      (begin
	(if (car tree)
	    (warning 'define-generic "redefining ~a" full-name))
	(set-car! tree full-name))
      (let* ((choices (cdr tree))
	     (rest (assq (car preds) choices)))
	(if rest
	    (set-cdr! rest (generic-tree-insert (cdr rest)
						full-name
						(cdr preds)))
	    (set-cdr! tree
		      ;; chez scheme sort is (sort pred list)
		      ;; macscheme sort is (sort list pred)

		      (sort
		       (lambda (a b) (is-a? (car a) (car b)))
		       (cons (cons (car preds)
				   (generic-tree-insert
				    '() full-name (cdr preds)))
			     choices)
		       )))))
  tree)

(define generic-trees (make-symbol-table))

(define (generic-data-add name full-name preds)
  (let ((tree (generic-trees name)))
    (if (not tree)
	(set! tree '()))
    (set! tree (generic-tree-insert tree full-name preds))
    (generic-trees name tree)))

(define (generic-build-name name predicates)
  (letrec ((build-predlist
	    (lambda (preds)
	      (if (null? preds)
		  ""
		  (string-append "-"
				 (symbol->string (car preds))
				 (build-predlist (cdr preds)))))))
    (string->symbol
     (string-append (symbol->string name)
		    "<"
		    (if (null? predicates)
			""
			(string-append (symbol->string (car predicates))
				       (build-predlist (cdr predicates))))
		    ">"))))

(define (generic-forms name)
  (let ((tree (generic-trees name))
	(forms '()))
    (let tree-loop ((tree tree)
		    (args '()))
      (if (car tree)
	  (set! forms (cons (cons (car tree) (reverse args)) forms)))
      (if (not (null? (cdr tree)))
	  (let type-loop ((types (cdr tree)))
	    (if (not (null? types))
		(begin
		  (tree-loop (cdar types) (cons (caar types) args))
		  (type-loop (cdr types)))))))
    forms))

(define (generic-print-error name supplied)
  (newline)
  (printf "Mismatched arguments for ~a.~%" name)
  (printf "Supplied: ~a~%" supplied)
  (printf "Expected: ~%")
  (for-each (lambda (x) (printf " ~a~%" x))
	    (generic-forms name))
  (error name ""))

(define (build-next-arg-clause tree arg-names)
  (if (null? tree)
      `#f
      (let* ((arg (gensym))
	     (arg-names (cons arg arg-names)))
	`(let ((,arg (car args))
	       (args (cdr args)))
	   (or ,@(map (lambda (t)
			(build-pred-clause t arg-names)) tree))))))

(define (build-pred-clause tree arg-names)
  (if (null? tree)
      `#f
      `(and (,(car tree) ,(car arg-names))
	    ,(build-match-clause (cdr tree) arg-names))))

(define (build-match-clause tree arg-names)
  `(if (null? args)
       ,(if (car tree)
	    `(begin
	       (set! result (,(car tree) ,@(reverse arg-names)))
	       #t)
	    `#f)
       ,(if (null? (cdr tree))
	    `#f
	    (build-next-arg-clause (cdr tree) arg-names))))

(define (generic-form name)
  (let ((tree (generic-trees name)))
    `(lambda args
       (let ((result #f))
	 (if ,(build-match-clause tree '())
	     result
	     (generic-print-error (quote ,name) args))))))

(define (type-heritage type)
  (let ((t (is-a-table type)))
    (if (not t)
	(begin
	  (set! t (cons type '()))
	  (is-a-table type t)))
    t))

(define-syntax define-generic
  (lambda (x)
    (syntax-case x ()
      ( (_ (name (predicate binding) ...) body ...)
	(andmap identifier? (syntax (name predicate ... binding ...)))
	(with-syntax ((dots (datum->syntax-object
			     (syntax _)
			     '...))
		      (full-name (datum->syntax-object
				  (syntax name)
				  (generic-build-name
				   (syntax-object->datum
				    (syntax name))
				   (syntax-object->datum
				    (syntax (predicate ...)))))))
	  (with-syntax ((dummy (generic-data-add
				(syntax-object->datum (syntax name))
				(syntax-object->datum (syntax full-name))
				(syntax-object->datum 
				 (syntax (predicate ...))))))
	    (syntax
	     (begin
	       (define (full-name binding ...) body ...)
	       (define-syntax name
		 (lambda (x)
		   (syntax-case x ()
		     (id
		      (identifier? x)
		      (with-syntax ((form (datum->syntax-object
					   (syntax id)
					   (generic-form
					    (syntax-object->datum
					     (syntax name))))))
		        (syntax form)))
		     ((id . arg-list)
		      (with-syntax ((result (datum->syntax-object
					     (syntax id)
					     (gensym)))
				    ((raw-args dots) (syntax arg-list))
				    ((args dots) (datum->syntax-object
						  (syntax id)
						  (map (lambda (d)
							 (gensym))
						       (syntax-object->datum
							(syntax arg-list))))))
		        (with-syntax ((method-body (datum->syntax-object
						    (syntax id)
						    (build-or-clause
						     (generic-trees
						      (syntax-object->datum
						       (syntax name)))
						     (syntax-object->datum
						      (syntax (args dots)))
						     (syntax-object->datum
						      (syntax (raw-args dots)))
						     (syntax-object->datum
						      (syntax (args dots)))
						     (syntax-object->datum
						      (syntax result))))))
			  (syntax
			   (let ((result #f))
			     (let ((args raw-args)
				   dots)
			       method-body
			       (if result
				   result
				   (generic-print-error
				    'name
				    (list args dots)))))))))
		     )))))))))))

(define (generic-method-at-depth? d tree)
  (if (positive? d)
      (if (or (null? tree)
	      (null? (cdr tree)))
	  #f
	  (ormap (lambda (x)
		   (generic-method-at-depth? (- d 1) (cdr x)))
		 (cdr tree)))
      (car tree)))

(define (generic-tree-depth tree)
  (if (or (null? tree)
	  (null? (cdr tree)))
      0
      (+ 1
	 (apply max (map (lambda (x)
			   (generic-tree-depth (cdr x)))
			 (cdr tree))))))

(define (build-or-clause tree args raw-args full-args return-arg)
  (if (null? args)
      `(begin (set! ,return-arg (,(car tree) ,@full-args))
	      #t)
      (let ((and-clause (build-and-clause (cdr tree)
					  args
					  raw-args
					  full-args
					  return-arg)))
	(if (null? and-clause)
	    #f
	    `(or ,@and-clause)))))

(define (build-and-clause clauses args raw-args full-args return-arg)
  (if (null? clauses)
      '()
      (let ((clause (car clauses))
	    (l (length args))
	    (rest (build-and-clause (cdr clauses)
				    args
				    raw-args
				    full-args
				    return-arg)))
	(let ((or-clause (build-or-clause (cdr clause)
					  (cdr args)
					  (cdr raw-args)
					  full-args
					  return-arg)))
	  (if (generic-method-at-depth? (- l 1) (cdr clause))
	      (if ((eval (car clause)) (car raw-args))
		  (cons or-clause rest)
		  (if (and (symbol? (car raw-args))
			   or-clause)
		      (cons `(and (,(car claus) ,(car args))
				  ,or-clause)
			    rest)
		      rest))
	      rest)
	  ))))

(is-a 'integer? 'rational?)
(is-a 'rational? 'real?)
(is-a 'real? 'complex?)
(is-a 'complex? 'number?)
(is-a 'list? 'pair?)