;;; This holds the procedures for analyzing the null hypothesis phyologenies.


;;; First label each node with its depth.
;;; Then to find all the n-taxa, collect all the nodes you get by
;;; following the extant taxa back n steps, but halting at any node
;;; that has a depth >= n.
;;; To collect the extant members of an n-taxa (which might have a > n
;;; depth), follow the children nodes, but don't follow those with
;;; depth = n.


(defvar *survey-before* ())
(defvar *survey-after-selection* ())
(defvar *survey-second-epoch-selection* ())
(defvar *selection-turnover* ())
(defvar *survey-after-random* ())
(defvar *survey-second-epoch-random* ())
(defvar *random-turnover* ())
(defvar *max-depth* 0)



(defun analyze-first-epoch ()
  (assign-depth (rest *first-epoch*) 1)
  (setf *max-depth* (snode-depth *root*))
  (setf *survey-before* (make-array *max-depth*
				    :initial-element 0))
  (setf *survey-after-selection* (make-array *max-depth*
				   :initial-element 0))
  (setf *survey-second-epoch-selection* (make-array *max-depth*
				   :initial-element 0))
  (setf *selection-turnover* (make-array *max-depth*
				   :initial-element ()))
  (setf *survey-after-random* (make-array *max-depth*
				   :initial-element 0))
  (setf *survey-second-epoch-random* (make-array *max-depth*
				   :initial-element 0))
  (setf *random-turnover* (make-array *max-depth*
				   :initial-element ()))
  (survey-taxa *survey-before* t))


(defun survey-taxa (survey dominant-analysis &optional (turnover-vect ()))
  (clear-tags *root*)
  (setf (svref survey 0) *num-species*)
  (dotimes (i (1- *max-depth*))
	   (let* ((n-trees (list-n-depth-trees (1+ i)))
		  (dominants (find-largest-clade n-trees (1+ i))))
	     (setf (svref survey (1+ i)) (length n-trees))
	     (when dominant-analysis
		(if (not turnover-vect)
		    (dolist (clade (third dominants)) ; mark dominants
			    (dolist (extant clade)
				    (mark-dominant extant (1+ i))))
					; check for turnover
		  (dolist (clade (third dominants))
			  (when (check-turnover (first clade) (1+ i))
				(setf (svref turnover-vect (1+ i)) t)
				(return t))))))))


(defun check-turnover (node depth)
  (cond
   ((null node) t)
   ((< 0 (snode-age node) (first *first-epoch*)) t)
   ((member depth (snode-dominant node)) ())
   (t (check-turnover (snode-parent node) depth))))


;;; 
(defun analyze-second-epoch (selective)
  (when *save-info*
	(record-tree *root* #'snode-id
		     (if selective (format () "select-tree-~a.dat"
					   *run-number*)
		       (format () "random-tree-~a.dat"
			       *run-number*))))
  (clear-depths *root*)
  (assign-depth (copy-extant-list (snode-next *extant*) ()) 1)
  (if selective
      (survey-taxa *survey-second-epoch-selection* t *selection-turnover*)
    (survey-taxa *survey-second-epoch-random* t *random-turnover*)))



(defun get-n-trees (node-list current-depth max-depth)
  (if (= current-depth max-depth) node-list
    (get-n-trees (get-unmarked-parents node-list () max-depth)
		 (1+ current-depth) max-depth)))



(defun get-unmarked-parents (node-list parent-list mark)
  (if (null node-list) parent-list
    (let ((node (first node-list)))
      (if (>= (snode-depth node) mark)
	  (get-unmarked-parents (rest node-list)
				(cons node parent-list)
				mark)
	(let ((parent (snode-parent (first node-list))))
	  (get-unmarked-parents (rest node-list)
			    (if (marked?-and-set parent mark)
				parent-list
			      (cons parent parent-list))
			    mark))))))


;;; This returns a list of the nodes that are roots of n depth taxa as
;;; well as the roots of greater depth when one sub-branch is also an
;;; n depth taxon.

(defun list-n-depth-trees (n)
  (get-n-trees (copy-extant-list (snode-next *extant*) ()) 0 n))

(defun assign-depth (node-list n)
  (unless (null node-list)
      (assign-depth (get-parent-nodes node-list () n) (1+ n))))



(defun get-parent-nodes (node-list parent-list depth)
  (if (null node-list) parent-list
    (let ((parent (snode-parent (first node-list))))
      (get-parent-nodes (rest node-list)
			(if (same-depth?-and-set parent depth)
				parent-list
			      (cons parent parent-list))
			depth))))



;;; Given a list of parental nodes, return a list of lists, where each
;;; sublist is the extant species of an original parent node.

(defun get-lists-of-descendents (node-list)
  (let ((result ()))
    (dolist (node node-list (reverse result))
       (push (get-extant-descendents (list node) () t)
			   result))))


;;; 
(defun get-extant-descendents (node-list result-list done)
  (if (null node-list)
      (if done result-list
	(get-extant-descendents result-list () t))
   (let ((node (first node-list)))
     (if (= 0 (snode-age node))
	 (get-extant-descendents (rest node-list)
				 (cons node result-list) done)
       (progn
	 (when (not (null (snode-left node)))
	       (push (snode-left node) result-list))
	 (when (not (null (snode-right node)))
	       (push (snode-right node) result-list))
	 (get-extant-descendents (rest node-list) result-list ()))))))


(defun get-exta-clade (node-list result-list done depth)
  (if (null node-list)
      (if done result-list
	(get-exta-clade result-list () t depth))
   (let ((node (first node-list)))
     (cond
      ((= 0 (snode-age node))
	 (get-exta-clade (rest node-list)
			 (cons node result-list) done depth))
      ((>= (snode-depth node) depth)
          (get-exta-clade (rest node-list) result-list done depth))
      (t (progn
	   (when (not (null (snode-left node)))
		 (push (snode-left node) result-list))
	   (when (not (null (snode-right node)))
		 (push (snode-right node) result-list))
	   (get-exta-clade (rest node-list) result-list ()
			   depth)))))))

(defun get-extant-clade (node depth)
  (get-exta-clade (list (snode-left node) (snode-right node))
		  () t depth))
    


(defun find-largest-clade (ancestor-list depth)
  (let ((max-size 0)
	(max-clades ())
	(max-ancestors ()))
    (dolist (ancestor ancestor-list (list max-size
					  max-ancestors
					  max-clades))
       (let* ((descendents (get-extant-clade ancestor depth))
	      (clade-size (length descendents)))
	 (when (= clade-size max-size)
	       (push ancestor max-ancestors)
	       (push descendents max-clades))
	 (when (> clade-size max-size)
	       (setf max-size clade-size)
	       (setf max-ancestors (list ancestor))
	       (setf max-clades (list descendents)))))))


;(defun mark-largest-clades (depth)
;  (let ((dominants (third (find-largest-clade (list-n-depth-trees
;                                               depth)))))
;    (dolist (clade dominants)
;            (mark