;;; All the macros for the null model (tree).

(in-package 'USER)

(defmacro while (test-exp body-exp)
  `(loop (unless ,test-exp (return ()))
	 ,body-exp))

;----------------Used in Tree.lisp----------------------------


(defmacro process-an-extinction (ext-pair)
  `(list (round (/ (* (first ,ext-pair) (1+ *max-diversity*)) 100))
	 (/ (* (second ,ext-pair) PROBSCALE) 100)))

(defmacro get-next-extinction-trigger (ext-list)
  `(if (null ,ext-list) *max-diversity*
     (first (first ,ext-list))))

(defmacro get-next-extinction-magnitude (ext-list)
  `(second (pop ,ext-list)))
     
     

(defmacro create-snode (parent)
  `(make-snode ;:phenotype ,pheno
	       ;:prey ,prey
	       ;:generalism ,gen
	       :parent ,parent
	       :id (incf *next-id*)))


;;; Create a new node, integrate it into the extant list,
;;; and increment the *num-species* count.  Finally, return the new
;;; node so that the parent can set its appropriate child pointer.

(defmacro add-snode (parent the-leaf-id)
  `(let* ((rent ,parent)
	  (newbie (create-snode rent)))
     (setf (snode-leaf-id newbie) ,the-leaf-id)
     (iter-insert-node newbie)
     ;(setf (snode-next newbie) (snode-next *extant*))
     ;(setf (snode-next *extant*) newbie)
     (incf *num-species*)
     newbie))


;;; Remove a node.  You must have a pointer to the previous node in
;;; the *extant* list.
;;; *** The nodes aren't actually being removed.  why?

(defmacro remove-node (the-snode)
  `(let* ((dead-node ,the-snode))
     (setf (snode-age dead-node) *clock*)
     (record-event 'extinction dead-node)
     (iter-remove-current)
     ;(setf (snode-next prev-node)
	   ;(snode-next dead-node))
     ;(setf (snode-next dead-node) nil)
     (decf *num-species*)))


(defmacro speciate (the-snode)
  `(let ((node ,the-snode))
     (remove-node node)
     (setf (snode-left node) (add-snode node (snode-leaf-id node)))
     (setf (snode-right node) (add-snode node (incf *next-leaf-id*)))
     (record-event 'speciation node)))

(defmacro flip-bit (locus gene)
  `(logxor (ash 1 ,locus) ,gene))


(defmacro mutation-at (nde loc)
  `(let ((node ,nde))
     (multiple-value-bind (gene-index position) (floor ,loc GENESIZE)
	(cond
	 ((= 0 gene-index)
	  (setf (snode-phenotype node)
		(flip-bit position (snode-phenotype node))))
	 ((= 1 gene-index)
	  (setf (snode-prey node)
		(flip-bit position (snode-prey node))))
	 ((= 2 gene-index)
	  (setf (snode-generalism node)
		(flip-bit position (snode-generalism node))))))))



(defmacro mutate (ptr-to-node)
  `(let ((node ,ptr-to-node)
	 (locus (random GENOMESIZE)))
     (record-event 'mutation node locus)
     (setf (snode-mutations node)
	   (cons (list *clock* locus)
		 (snode-mutations node)))
     (mutation-at node locus)))

     
(defmacro node-was-sampled (the-node)
  `(let ((node ,the-node))
     (when *save-trees*
       (format *sample-file* "~a ~a~%" *clock* (snode-id node)))
     (if (< (snode-first-sample node) 0)
	 (progn
	   (setf (snode-first-sample node) *clock*)
	   (setf (snode-last-sample node) *clock*))
       (when (< (snode-last-sample node) *clock*)
	 (setf (snode-last-sample node) *clock*)))))
	   

;;; Note that species are either allowed to go extinct or be sampled.  A species can
;;; speciate and be sampled in the same time step.  That means that nodes will have
;;; a (pseudo) extinction and a sampling in the same time step.  But since the daughter
;;; species don't get a chance to be sampled until the next time step, the alternative
;;; is to have no samples that time step.

(defmacro step-trial ()
  `(progn
     (incf *clock*)
;     (format t "[~a] ~a~%" *clock* *num-species*)
     ; Check to see if a mass extinction should happen.
     (if (>= *next-leaf-id* (get-next-extinction-trigger *extinct-sched*))
;	 (prog1
	   (setf current-extinction (get-next-extinction-magnitude *extinct-sched*))
;           (setf current-speciation (round (* (- PROBSCALE current-extinction)
;                                                 *speciation*)
;                                       PROBSCALE))
;	   (format t "extinction set to: ~a~%speciation: ~a~%" current-extinction
;		   *speciation*))
       (setf current-extinction *extinction*))
     (do ((current (progn (iter-reset-list)
			   (iter-next-node))
		    (iter-next-node))) ; iterate through extant.
	 
	 ((or (>= *next-leaf-id* *max-diversity*) ;(>= *num-species* *max-diversity*)
	      (null current)))
       
       (if (< (random PROBSCALE) current-extinction)
	     (progn
	       (incf extinctions)
	       (remove-node current)) ;removes snode after current.
	 (progn
	   (when (< (random PROBSCALE) *speciation*)
	       (incf originations)
	       (speciate current))
	   (when (< (random PROBSCALE) *sample*)
	       (node-was-sampled current)))))))

					
	  

(defmacro restore-node (node)
  `(let ((oldnode ,node))
     (unmutate oldnode (snode-mutations oldnode))
     (setf (snode-mutations oldnode) ())
     (setf (snode-left oldnode) ())
     (setf (snode-right oldnode) ())
     (iter-insert-node oldnode)
     ;(setf (snode-next oldnode) (snode-next *extant*))
     ;(setf (snode-next *extant*) oldnode)
     (setf (snode-age oldnode) 0)
     (setf (snode-depth oldnode) 0)
     (setf (snode-tag oldnode) ())))
     

(defmacro first-time (mlist)
  `(first (first ,mlist)))

(defmacro first-locus (mlist)
  `(second (first ,mlist)))


;----------------Used in Analysis.lisp----------------------------

(defmacro mark-dominant (node depth)
  `(push ,depth (snode-dominant ,node)))


(defmacro marked?-and-set (parent mark)
  `(if (or (null ,parent) (eq (snode-tag ,parent) ,mark))
       t
     (progn
       (setf (snode-tag ,parent) ,mark)
       ())))

(defmacro same-depth?-and-set (parent mark)
  `(if (or (null ,parent) (= (snode-depth ,parent) ,mark))
       t
     (progn
       (setf (snode-depth ,parent) ,mark)
       ())))




;----------------Used in Extinction.lisp----------------------------


(defmacro bit-locus (bit-list)
  `(first (first ,bit-list)))

(defmacro bit-state (bit-list)
  `(second (first ,bit-list)))

(defmacro mark-susceptible (node)
  `(setf (snode-tag ,node) t))

(defmacro unmark-non-susceptible (node)
  `(setf (snode-tag ,node) ()))

(defmacro test-bit-in-gene (gene locus state)
  `(let ((bit (logbitp ,locus ,gene)))
     (if bit (= 1 ,state) (= 0 ,state))))

(defmacro test-bit (node locus state)
  `(multiple-value-bind (gene-index position) (floor ,locus GENESIZE)
	(cond
	 ((= 0 gene-index)
	     (test-bit-in-gene (snode-phenotype ,node) position ,state))
	 ((= 1 gene-index)
	     (test-bit-in-gene (snode-prey ,node) position ,state))
	 ((= 2 gene-index)
	     (test-bit-in-gene (snode-generalism ,node) position ,state)))))



;----------------Used in Io.lisp----------------------------



;----------------Used in Debug.lisp----------------------------


;----------------Used in Classify.lisp----------------------------

(defmacro swap (ind1 ind2 simple-array)
  `(let* ((i1 ,ind1)
	  (i2 ,ind2)
	  (simp-array ,simple-array)
	  (temp (svref simp-array i1)))
     (setf (svref simp-array i1) (svref simp-array i2))
     (setf (svref simp-array i2) temp)))

;;; Replaces the nth item in a list with new-car.
(defmacro nthreplace (index list new-car)
  `(rplaca (nthcdr ,index ,list) ,new-car))

(defmacro add-taxon-size (new-size a-list)
  `(push ,new-size ,a-list))

(defmacro a-leaf? (a-node)
  `(and (null (snode-left ,a-node))
	(null (snode-right ,a-node))))

(defmacro taxon-node? (a-node)
  `(let* ((the-node ,a-node)
	  (parent (snode-parent the-node)))
     (or (null parent)
	 (not (= (snode-paraphyle parent)
		 (snode-paraphyle the-node))))))

(defmacro potential-taxon-node? (a-node)
  `(let* ((the-node ,a-node)
	  (parent (snode-parent the-node)))
     (or (null parent)
	 (not (= (snode-leaf-id parent)
		 (snode-leaf-id the-node))))))

(defmacro syst-taxon-node? (a-node)
  `(let* ((the-node ,a-node)
	  (parent (snode-parent the-node)))
     (or (null parent)
	 (not (= (snode-syst-paraphyle parent)
		 (snode-syst-paraphyle the-node))))))

(defmacro select-taxa (indecies a-list max-id)
  `(select-the-taxa ,indecies ,a-list () ,max-id))

(defmacro get-a-taxon (index a-list max-id)
  `(nth (- ,max-id (1+ ,index))
	,a-list))

;----------------Used in Diversity.lisp----------------------------

;(defmacro legal-taxon-id (id arg)
;  `(< -1 ,id ,arg))

(defmacro legal-taxon-id (id forbid)
  `(and (>= ,id 0) (not (svref ,forbid ,id))))

(defmacro record-node  (the-id the-taxa num-taxa)
  `(let ((id ,the-id)
	 (taxa ,the-taxa))
     (if (< id 0)
	 (incf (svref taxa 0))
       (progn
	 (incf (svref taxa id))
	 (when (= (svref taxa id) 1) (incf ,num-taxa))))))

(defmacro match-record-node  (the-id taxa unclassified num-taxa forbiddens)
  `(let ((id ,the-id))
;     (if (< -1 id *next-paraphyle*)
     (if (legal-taxon-id id ,forbiddens)
	 (when (= (svref ,taxa id) 1) (incf ,num-taxa))
       (incf ,unclassified))))

(defmacro record-removal  (the-id the-taxa num-taxa)
  `(let ((id ,the-id)
	 (taxa ,the-taxa))
     (if (< id 0)
	 (decf (svref taxa 0))
       (progn 
	 (decf (svref taxa id))
	 (when (= (svref taxa id) 0)
	   (decf ,num-taxa))))))


(defmacro match-removal  (the-id taxa unclassified num-taxa forbiddens)
  `(let ((id ,the-id))
;     (if (legal-taxon-id id *next-paraphyle*)
     (if (legal-taxon-id id ,forbiddens)
	 (when (= (svref ,taxa id) 0)
	   (decf ,num-taxa))
       (decf ,unclassified))))

(defmacro recap-add-node (the-node)
  `(let ((newbie ,the-node))
     (iter-insert-node newbie)
     ;(setf (snode-next newbie) (snode-next *extant*))
     ;(setf (snode-next *extant*) newbie)
     (incf *diversity*)
     (let ((para (snode-paraphyle newbie)))
       (record-node para *para-taxa* *num-para-taxa*)
       (when (and (> para 0) (= 1 (svref *para-taxa* para)))
	 (incf *no-basal-num-para-taxa*)))
     (record-node (snode-hard-monophyle newbie) *hard-taxa* *num-hard-taxa*)
     (record-node (snode-soft-monophyle newbie) *soft-taxa* *num-soft-taxa*)
     (match-record-node (snode-soft-monophyle newbie) *soft-taxa*
			*unclassifed-soft-match* *num-soft-taxa-match*
			*soft-forbidden*)
     (record-node (snode-syst-monophyle newbie) *syst-soft-taxa* *num-syst-soft-taxa*)
     (match-record-node (snode-syst-monophyle newbie) *syst-soft-taxa*
			 *unclassifed-syst-soft-match* *num-syst-soft-taxa-match*
			 *syst-soft-forbidden*)
     (record-node (snode-full-monophyle newbie) *full-taxa* *num-full-taxa*)
     (record-node (snode-rand-taxon newbie) *rand-taxa* *num-rand-taxa*)
     (record-node (snode-match-rand newbie) *match-rand-taxa* *match-num-rand-taxa*)
     (record-node (snode-distrib-rand newbie) *match-distrib-rand-taxa*
		  *match-distrib-num-rand-taxa*)
     (record-node (snode-distrib-soft newbie) *match-distrib-soft-taxa*
		  *match-distrib-num-soft-taxa*)
     ; *** other recording for classifications goes here.
     ))

(defmacro sample-add-node (the-node)
  `(let ((newbie ,the-node))
     (backup-iter-insert-node newbie)
     ;(setf (snode-next newbie) (snode-next *extant*))
     ;(setf (snode-next *extant*) newbie)
     (incf *samp-diversity*)
     (let ((para (snode-paraphyle newbie)))
       (record-node para *samp-para-taxa* *samp-num-para-taxa*)
       (when (and (> para 0) (= 1 (svref *samp-para-taxa* para)))
	 (incf *samp-no-basal-num-para-taxa*)))
     (record-node (snode-hard-monophyle newbie) *samp-hard-taxa* *samp-num-hard-taxa*)
     (record-node (snode-soft-monophyle newbie) *samp-soft-taxa* *samp-num-soft-taxa*)
     (match-record-node (snode-soft-monophyle newbie) *samp-soft-taxa*
			*samp-unclassifed-soft-match* *samp-num-soft-taxa-match*
			*soft-forbidden*)
     (record-node (snode-syst-monophyle newbie) *samp-syst-soft-taxa*
		  *samp-num-syst-soft-taxa*)
     (match-record-node (snode-syst-monophyle newbie) *samp-syst-soft-taxa*
		  *samp-unclassifed-syst-soft-match* *samp-num-syst-soft-taxa-match*
		  *syst-soft-forbidden*)
     (record-node (snode-full-monophyle newbie) *samp-full-taxa* *samp-num-full-taxa*)
     (record-node (snode-rand-taxon newbie) *samp-rand-taxa* *samp-num-rand-taxa*)
     (record-node (snode-match-rand newbie) *samp-match-rand-taxa*
		  *samp-match-num-rand-taxa*)
     (record-node (snode-distrib-rand newbie) *samp-match-distrib-rand-taxa*
		  *samp-match-distrib-num-rand-taxa*)
     (record-node (snode-distrib-soft newbie) *samp-match-distrib-soft-taxa*
		  *samp-match-distrib-num-soft-taxa*)
     ; *** other recording for classifications goes here.
     ))

;;; I have to first run through the tree, straightening up all the gaps that can be
;;; filled in by inference.  This produces a distorted tree (which should be saved
;;; with its different branch lengths).  Then I need to keep a separate extant list
;;; using the sampling ages to determine extinctions and speciation.

(defmacro recap-step ()
  `(progn
     (incf *time*)
     (do ((current (progn (iter-reset-list)
			   (iter-next-node))
		    (iter-next-node)) ; iterate through extant.
	  (sampled (progn (backup-iter-reset-list)
			   (backup-iter-next-node))
		    (backup-iter-next-node)))
	   	 
	 ((and (null current) (null sampled)))
       (when (and (not (null current)) (= *time* (snode-age current)))
	 (decf *diversity*)
	 (let ((para (snode-paraphyle current)))
	   (record-removal para *para-taxa* *num-para-taxa*)
	   (when (and (> para 0) (= 0 (svref *para-taxa* para)))
	     (decf *no-basal-num-para-taxa*)))
	 (record-removal (snode-hard-monophyle current) *hard-taxa* *num-hard-taxa*)
	 (record-removal (snode-soft-monophyle current) *soft-taxa* *num-soft-taxa*)
	 (match-removal (snode-soft-monophyle current) *soft-taxa*
			*unclassifed-soft-match* *num-soft-taxa-match*
			*soft-forbidden*)
	 (record-removal (snode-syst-monophyle current) *syst-soft-taxa*
			 *num-syst-soft-taxa*)
	 (match-removal (snode-syst-monophyle current) *syst-soft-taxa*
			 *unclassifed-syst-soft-match* *num-syst-soft-taxa-match*
			 *syst-soft-forbidden*)
	 (record-removal (snode-full-monophyle current) *full-taxa* *num-full-taxa*)
	 (record-removal (snode-rand-taxon current) *rand-taxa* *num-rand-taxa*)
	 (record-removal (snode-match-rand current) *match-rand-taxa*
			 *match-num-rand-taxa*)
	 (record-removal (snode-distrib-rand current) *match-distrib-rand-taxa*
			 *match-distrib-num-rand-taxa*)
	 (record-removal (snode-distrib-soft current) *match-distrib-soft-taxa*
			 *match-distrib-num-soft-taxa*)

					; ***other recording for classifications goes here.
	 
	 (iter-remove-current)
					; Record any splitting event info.
	 (let ((left (snode-left current))
	       (right (snode-right current)))
	   (when (not (null left))
	     (recap-add-node left))
	   (when (not (null right))
	     (recap-add-node right))))

       ; Handle the sampled tree...
       (when (and (not (null sampled)) (= *time* (1+ (snode-last-sample sampled))))
	 (decf *samp-diversity*)
	 (let ((para (snode-paraphyle sampled)))
	   (record-removal para *samp-para-taxa* *samp-num-para-taxa*)
	   (when (and (> para 0) (= 0 (svref *samp-para-taxa* para)))
	     (decf *samp-no-basal-num-para-taxa*)))
	 (record-removal (snode-hard-monophyle sampled) *samp-hard-taxa*
			 *samp-num-hard-taxa*)
	 (record-removal (snode-soft-monophyle sampled) *samp-soft-taxa*
			 *samp-num-soft-taxa*)
	 (match-removal (snode-soft-monophyle sampled) *samp-soft-taxa*
			 *samp-unclassifed-soft-match* *samp-num-soft-taxa-match*
			 *soft-forbidden*)
	 (record-removal (snode-syst-monophyle sampled) *samp-syst-soft-taxa*
			 *samp-num-syst-soft-taxa*)	 
	 (match-removal (snode-syst-monophyle sampled) *samp-syst-soft-taxa*
			 *samp-unclassifed-syst-soft-match*
			 *samp-num-syst-soft-taxa-match*
			 *syst-soft-forbidden*)	 
	 (record-removal (snode-full-monophyle sampled) *samp-full-taxa*
			 *samp-num-full-taxa*)
	 (record-removal (snode-rand-taxon sampled) *samp-rand-taxa*
			 *samp-num-rand-taxa*)
	 (record-removal (snode-match-rand sampled) *samp-match-rand-taxa*
			 *samp-match-num-rand-taxa*)
	 (record-removal (snode-distrib-rand sampled) *samp-match-distrib-rand-taxa*
			 *samp-match-distrib-num-rand-taxa*)
	 (record-removal (snode-distrib-soft sampled) *samp-match-distrib-soft-taxa*
			 *samp-match-distrib-num-soft-taxa*)
	 (backup-iter-remove-current)
					
	 (let ((left (snode-left sampled))
	       (right (snode-right sampled)))
	   (unless (or (null left) (< (snode-first-sample left) *time*))
	     (sample-add-node left))
	   (unless (or (null right) (< (snode-first-sample right) *time*))
	     (sample-add-node right)))))))
 


;(defmacro get-branch-t (the-ancestor the-left-time the-right-time)
;  `(let* ((ancestor-time  ,the-ancestor)
;          (left-time ,the-left-time)
;          (right-time ,the-right-time))
;     (if (and (< left-time 0) (< right-time 0))
;         (1+ ancestor-time)
;       (cond
;        ((< left-time 0) right-time)
;        ((< right-time 0) left-time)
;        (t (min left-time right-time))))))


(defmacro get-branch-time (the-ancestor the-left-time the-right-time)
  `(let* ((left-time ,the-left-time)
	  (right-time ,the-right-time))
     (if (and (< left-time 0) (< right-time 0))
	 (1+ (snode-last-sample ,the-ancestor))
       (cond
	((< left-time 0) right-time)
	((< right-time 0) left-time)
	(t (min left-time right-time))))))

;          (the-min (min left-time right-time ancestor-time)))
;     (if (< the-min 0)
;         (if (< (* left-time right-time ancestor-time) 0) ; only one is negative
;             (max (min left-time right-time)
;                  (min left-time ancestor-time)
;                  (min right-time ancestor-time))
;           (max left-time right-time ancestor-time)) ;at least two are negative.
;       the-min)))