;;; sift through lists of classes and so on.

(in-package #:cl-user)

(defstruct (cset (:conc-name s-))
  members supers subs gfs)

(defstruct (class-node (:conc-name c-))
  name class own-p supers subs visited-p sets)

(defmacro pushnew-end (object place &rest keys &environment env)
  (multiple-value-bind (temps inits newtemps setform getform)
      (get-setf-expansion place env)
    (let ((objvar (gensym "OBJECT"))
	  (listvar (gensym "LIST")))
      `(let* ((,objvar ,object)
	      ,@(mapcar #'list temps inits)
	      (,listvar ,getform))
	 (cond ((member ,objvar ,listvar ,@keys)
		,listvar)
	       (t
		(multiple-value-bind ,newtemps
		    (append ,listvar (list ,objvar))
		  ,setform
		  (values ,@newtemps))))))))

(defun show-classes (classes)
  (let ((map (make-hash-table)))

    (labels ((getnode (class &optional own-p)
	       (let ((found (gethash class map)))
		 (if found
		     (values found t)
		     (values (setf (gethash class map)
				   (make-class-node :name (class-name class)
						    :class class
						    :own-p own-p))
			     nil))))

	     (gather (class)
	       (let ((node (getnode class)))
		 (dolist (super (class-direct-superclasses class))
		   (unless (member super (append (mapcar #'find-class
							 '(t standard-object
							   structure-object))
						 (class-direct-superclasses
						  (find-class 'condition))))
		     (multiple-value-bind (supernode foundp)
			 (getnode super)
		       (pushnew-end supernode (c-supers node))
		       (pushnew node (c-subs supernode))
		       (unless foundp (gather super)))))))

	     (walk (node &optional (level 0) super)
	       (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)"
		       (* 2 level)
		       (c-own-p node)
		       (c-name node))
	       (cond ((null (cdr (c-supers node))))
		     ((eq (car (c-supers node)) super)
		      (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>"
			      (mapcar #'c-name (c-supers node))))
		     (t
		      (format *standard-output* "*~%")
		      (return-from walk)))
	       (terpri *standard-output*)
	       (dolist (sub (c-subs node))
		 (walk sub (1+ level) node))))

      ;; make nodes for all of the official classes.
      (dolist (class classes)
	(getnode class t))

      ;; build the hierarchy, up and down.  this may drag in classes from
      ;; other packages.
      (dolist (class classes)
	(gather class))

      ;; write the table.
      (dolist (node (sort (loop for node being the hash-values of map
				unless (c-supers node)
				collect node)
			  #'string< :key #'c-name))
	(walk node)))))

(defun check-sets (members)
  (let ((done (make-hash-table)))
    (labels ((check (s)
	       (when (gethash s done)
		 (return-from check))
	       (setf (gethash s done) t)

	       ;; subsets must be proper subsets
	       (dolist (u (s-supers s))
		 (assert (subsetp (s-members s) (s-members u)))
		 (assert (not (subsetp (s-members u) (s-members s))))
		 (assert (member s (s-subs u))))

	       ;; supersets must be proper supersets
	       (dolist (u (s-subs s))
		 (assert (subsetp (s-members u) (s-members s)))
		 (assert (not (subsetp (s-members s) (s-members u))))
		 (assert (member s (s-supers u))))

	       ;; supersets must be minimal
	       (dolist (u (s-supers s))
		 (dolist (v (s-supers s))
		   (assert (or (eq u v)
			       (not (subsetp (s-members u)
					     (s-members v)))))))

	       ;; subsets must be maximal
	       (dolist (u (s-subs s))
		 (dolist (v (s-subs s))
		   (assert (or (eq u v)
			       (not (subsetp (s-members u)
					     (s-members v)))))))

	       ;; members must link to us, directly or indirectly.
	       (dolist (m (s-members s))
		 (labels ((look (u)
			    (or (eq u s) (some #'look (s-supers u)))))
		   (assert (some #'look (c-sets m)))))

	       ;; check supersets and subsets
	       (dolist (u (s-supers s)) (check u))
	       (dolist (u (s-subs s)) (check u))))

      (dolist (m members)
	(dolist (s (c-sets m))

	  ;; sets must contain us
	  (assert (member m (s-members s)))

	  ;; sets must be minimal
	  (dolist (u (c-sets m))
	    (assert (or (eq u s)
			(not (subsetp (s-members u)
				      (s-members s))))))

	  ;; check set
	  (check s))))))

(defmethod print-object ((c class-node) stream)
  (format stream "#[~(~A~)]" (c-name c)))

(defmethod print-object ((s cset) stream)
  (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s)))

(defun ensure-set (members)

  (setf members (remove-duplicates members))
  (check-sets members)

  (let ((subs nil) (supers nil))

    ;; find the maximal subsets and minimal supersets.  if s is not a subset
    ;; then answer nil; otherwise answer t, and recursively process all the
    ;; supersets of s; if none of them answer t then is maximal, so add it to
    ;; the list.
    (labels ((up (s)
	       (cond ((subsetp (s-members s) members)
		      (unless (some #'up (s-supers s)) (pushnew s subs))
		      t)
		     ((subsetp members (s-members s))
		      (pushnew s supers)
		      nil)
		     (t nil))))
      (dolist (m members)
	(mapc #'up (c-sets m))))
    (when (and subs (subsetp members (s-members (car subs))))
      (return-from ensure-set (car subs)))
    (let* ((new (make-cset :members members :supers supers :subs subs)))

      ;; now we have to interpolate ourselves properly.  this is the tricky
      ;; part.
      (dolist (s supers)
	(setf (s-subs s)
	      (cons new (set-difference (s-subs s) subs))))
      (dolist (s subs)
	(setf (s-supers s)
	      (cons new (set-difference (s-supers s) supers))))
      (dolist (m members)
	(unless (some (lambda (s) (subsetp (s-members s) members))
		      (c-sets m))
	  (setf (c-sets m) (cons new
				 (remove-if (lambda (s)
					      (subsetp members
						       (s-members s)))
					    (c-sets m))))))

      ;; done
      (check-sets members)
      new)))

(defun categorize-protocols (generics classes)
  (let ((cmap (make-hash-table)))

    (labels ((getnode (class &optional own-p)
	       (let ((found (gethash class cmap)))
		 (if found
		     (values found t)
		     (values (setf (gethash class cmap)
				   (make-class-node :name (class-name class)
						    :class class
						    :own-p own-p))
			     nil))))

	     (gather (class)
	       (let ((node (getnode class)))
		 (dolist (super (class-direct-superclasses class))
		   (unless (member super (append (mapcar #'find-class
							 '(t standard-object
							   structure-object))
						 (class-direct-superclasses
						  (find-class 'condition))))
		     (multiple-value-bind (supernode foundp)
			 (getnode super)
		       (pushnew-end supernode (c-supers node))
		       (pushnew node (c-subs supernode))
		       (unless foundp (gather super))))))))

      ;; make nodes for all of the official classes.
      (dolist (class classes)
	(getnode class t))

      ;; build the hierarchy, up and down.  this may drag in classes from
      ;; other packages.
      (dolist (class classes)
	(gather class))

      ;; go through the generic functions collecting sets of implementing
      ;; classes.
      (dolist (gf generics)
	(let* ((specs (reduce #'append
			      (mapcar #'method-specializers
				      (generic-function-methods gf))
			      :from-end t))
	       (members (labels ((down (c)
				   (delete-duplicates
				    (cons c (mapcan #'down (c-subs c)))))
				 (gather (spec)
				   (let ((c (gethash spec cmap)))
				     (and c (down c)))))
			  (delete-duplicates (mapcan #'gather specs))))
	       (s (and members (ensure-set members))))
	  (when s
	    (push gf (s-gfs s)))))

      ;; finally dump the list of participating classes.
      (let ((tops nil))

	;; find the top-level sets
	(let ((m (make-hash-table)))
	  (labels ((ascend (s)
		     (unless (gethash s m)
		       (setf (gethash s m) t)
		       (if (s-supers s)
			   (mapc #'ascend (s-supers s))
			   (push s tops)))))
	    (dolist (c classes)
	      (mapc #'ascend (c-sets (gethash c cmap))))))

	(let ((done (make-hash-table)))
	  (labels ((walk (s &optional (level 0))
		     (let ((seen (gethash s done)))
		       (unless seen
			 (setf (gethash s done) t)
			 (dolist (gf (s-gfs s))
			   (format *standard-output* "~v,0T~(~A~)~%"
				   (* 2 level)
				   (generic-function-name gf))))
		       (dolist (c (set-difference
				   (s-members s)
				   (reduce #'union (mapcar #'s-members
							   (s-subs s))
					   :initial-value nil)))
			 (format *standard-output* "~40T~(~A~)~:[~;*~]~%"
				 (c-name c) seen))
		       (dolist (u (s-subs s))
			 (walk u (1+ level))))))
	    (mapc #'walk tops)
	    nil))))))

(defun gather-stuff (package)
  (let ((classes nil)
	(functions nil)
	(generics nil)
	(structs nil)
	(macros nil)
	(methods nil)
	(package (find-package package)))

    ;; find all of the interesting things in the package.
    (do-symbols (sym package)
      (when (eq (symbol-package sym) package)
	(let ((class (find-class sym nil)))
	  (typecase class
	    ((or standard-class sb-pcl::condition-class)
	     (push class classes))
	    (structure-class (push class structs))))
	(when (fboundp sym)
	  (let ((func (symbol-function sym)))
	    (if (typep func 'generic-function)
		(push func generics)
		(push sym functions))))
	(let ((macro (macro-function sym)))
	  (when macro (push sym macros)))))

    ;; sort the lists -- makes things look prettier.
    (macrolet ((frob (list key)
		 `(setf ,list (sort ,list #'string< :key #',key))))
      (frob classes class-name)
      (frob functions identity)
      (frob structs class-name)
      (frob generics generic-function-name)
      (frob macros identity)
      (frob methods (lambda (m)
		      (generic-function-name (method-generic-function m)))))

    ;; present the classes in a vaguely useful way
    (flet ((sep ()
	     (format t "~%-------------------------~2%")))
      (show-classes classes)
      (sep)
      (show-classes structs)
      (sep)
      (categorize-protocols generics classes)
      (loop for title in '("Macros" "Functions")
	    for list in (list macros functions) do
	    (sep)
	    (format t "~{~(~A~)~%~}" list)))))