;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This file is part of "NOVA":  NOVA = search + COCOMO tools
; Copyright, 2008, Tim Menzies tim@menzies.us
;
; NOVA is free software: you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
;
; NOVA is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
; You should have received a copy of the GNU General Public License
; a long with NOVA.  If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; treatments stuff
;;; a treatment is a list in the form (feature range)
;;; the treatments (flex 3) (flex 4) (flex 5) are "separated" or "singletons"
;;; the treatment (flex 3 4 5) is "coalesced"

(defun coalesce-treatments (treatments)
  "Coalesces treatments so that each feature only appears once."
  (let (out)
    (dolist (treatment treatments out)
      (let* ((feature (car treatment))
             (range   (cdr treatment))
             (current (assoc feature out)))
        (if current
            (setf (cdr (assoc feature out)) (append (cdr current) range))
            (push (cons feature range) out))))))

(defun separate-treatments (treatments)
  "Separates treatments into singletons."
  (let (out)
    (dolist (treatment treatments out)
      (let ((feature (car treatment))
	    (range   (cdr treatment)))
	(dolist (value range)
	  (push (list feature value) out))))))

(egs :treatments
     (eg '(coalesce-treatments '((flex 1) (flex 2) (pmat 1) (pmat 2)))
	 :of "coalescing treatments"
	 :out '((pmat 1 2) (flex 1 2)))
     (eg '(separate-treatments '((flex 1 2) (pmat 1 2)))
	 :of "separating treatments"
	 :out '((pmat 2) (pmat 1) (flex 2) (flex 1))))

(defun apply-treatments (treatments)
  "Restricts COCOMO ranges in the *db* to the specified treatments."
  (dolist (treatment (coalesce-treatments treatments))
    (let* ((feature (car treatment))
	   (range   (cdr treatment))
	   (old     (range? feature))
	   (new     (coco-restrict old range)))
      (range! feature new))))

(defun force-treatments (treatments)
  "Forces COCOMO ranges in the *db* to the specified treatments."
  (dolist (treatment (coalesce-treatments treatments))
    (let ((feature (car treatment))
	  (range   (cdr treatment)))
      (range! feature range))))

(defun singleton-p (treatment)
  "Returns whether the treatment is a singleton."
  (= 2 (length treatment)))

(defun singletons-p (treatments)
  "Returns whether all the given treatments are singletons."
  (every #'singleton-p (coalesce-treatments treatments)))

(defun singletons? (treatments)
  "Returns a list of singletons from the given treatments."
  (remove-if-not #'singleton-p (coalesce-treatments treatments)))

(defun non-singletons? (treatments)
  "Returns a list of non-singletons from the given treatments."
  (let ((singletons (singletons? treatments)))
    (remove-if #'(lambda (treatment) (find treatment singletons :test #'equal)) treatments)))

;;; case study and policy stuff
;;; a case study is a list of treatments like ((flex 3 4 5) (pmat 1 2) ...)
;;; and possibly a kloc constraint such as (kloc 100 200)
;;; case studies limit the search space to the ranges they specify

(defun default-case-study ()
  "Returns the default case study (constructed from COCOMO defaults)."
  (let (out)
    (dolist (default (cocomo-defaults) out)
      (let ((feature (car default))
	    (value   (cdr default)))
	(cond ((eq feature 'kloc)
	       (push (list 'kloc (num-min value) (num-max value)) out))
	      ((or (eq (type-of value) 'sf)
		   (eq (type-of value) 'em)
		   (eq (type-of value) 'dr))
	       (push (append (list feature) (bag-range (bag-range value))) out)))))))

(defun complete-case-study (case-study)
  "Completes a case study by supplying COCOMO default ranges for any features
   that are not present."
  (let ((old (coalesce-treatments (default-case-study)))
	(new (coalesce-treatments case-study))
	out)
    (dolist (old-treatment old out)
      (let* ((feature       (car old-treatment))
	     (new-treatment (find feature new :key #'car)))
	(push (or new-treatment old-treatment) out)))))

(defun feature-policies (feature)
  "Returns the list of policies that the given COCOMO feature belongs to."
  (let ((value (geta feature (cocomo-defaults))))
    (case (type-of value)
      (sf (sf-policies value))
      (em (em-policies value))
      (dr (dr-policies value)))))

;;; completion stuff

(defvar *monte-carlo-iterations* 100)

(defun monte-carlo (&key (fn #'energy) (n *monte-carlo-iterations*))
  "Runs n random completions and returns the median, spread, and quartiles."
  (let (results)
    (dotimes (i n (multiple-value-list (median results)))
      (zaps)
      (push (funcall fn) results))))

;;; state and path stuff
;;; a state is a snapshot of a search at a particular instant
;;; containing the treatments being searched and any scores assigned by the search engine
;;; a path is a chronological list of states representing one complete run of a search engine

(defstruct state

  tick    ; time that the state was created
  ignore  ; treatments to be ignored because their policy is not being searched
  open    ; treatments that have not been discarded by the search
  closed  ; treatments that have been discarded by the search

  ;; minimum and maximum kloc
  kloc-min kloc-max

  ;; median, spread, and quartiles
  effort months defects threat energy

  ;; dummy slot to be used as needed by a search engine
  score

)

(defun make-state0 (kloc-min kloc-max ignore open closed)
  "Creates a state using the provided data."
  (make-state :tick     (get-internal-run-time)
	      :ignore   ignore
	      :open     open
	      :closed   closed
	      :kloc-min kloc-min
	      :kloc-max kloc-max))

;;; solution complexity is measured by "constraints"
;;; constraints are made by reducing the number of available ranges for a feature
;;; so (flex 1 2 3 4 5) represents 0 constraints and (flex 5) represents 4
;;; note that having all of a feature's treatments on the open list is the same
;;; as having them all on the closed list...both situations represent 0 constraints

(defun constraints? (state)
  "Returns a list of treatments for features that are constrained in the given state."
  (let (constraints)
    (dolist (treatment (state-open state) (nreverse constraints))
      (let ((feature (car treatment)))
	(if (find feature (state-closed state) :key #'car)
	    (push treatment constraints))))))

(defun constraint-count (state &key (which :ranges))
  "Counts the features or ranges that are constrained in the given state."
  (let ((fcount 0)
	(rcount 0))
    (dolist (treatment (coalesce-treatments (state-open state))
	     (cond ((eq which :features) fcount)
		   ((eq which :ranges)   rcount)
		   (t                    (error "unsupported value ~a for which" which))))
      (let* ((feature      (car treatment))
	     (open-range   (cdr treatment))
	     (closed-range (cdr (find feature (coalesce-treatments (state-closed state)) :key #'car))))
	(when (and open-range closed-range)
	  (incf fcount)
	  (incf rcount (length closed-range)))))))

(defun max-constraints (state &key (which :ranges))
  "Returns the maximum number of constraints for the given state."
  (cond ((eq which :features)
	 (length (coalesce-treatments (non-singletons? (append (state-open   state)
							       (state-closed state))))))
	((eq which :ranges)
	 (- (+ (length (state-open   state))
	       (length (state-closed state)))
	    (length (coalesce-treatments (append (state-open   state)
						 (state-closed state))))))
	(t
	 (error "unsupported value ~a for which" which))))

(defun constrained% (state &key (which :ranges))
  "Returns the number of constraints as a percentage of the maximum."
  (/ (constraint-count state :which which)
     (max-constraints  state :which which)))

(labels ((calculate (state fn)
	   (init-db)
	   (kloc! (state-kloc-min state) (state-kloc-max state))
	   (apply-treatments (append (state-ignore state)
				     (state-open   state)
				     (state-closed state)))
	   (apply-treatments (state-open state))
	   (monte-carlo :fn fn)))

  (defun effort? (state)
    "Calculates and caches effort or returns the cached value."
    (unless (state-effort state)
      (setf (state-effort state) (calculate state #'effort)))
    (car (state-effort state)))

  (defun months? (state)
    "Calculates and caches months or returns the cached value."
    (unless (state-months state)
      (setf (state-months state) (calculate state #'months)))
    (car (state-months state)))

  (defun defects? (state)
    "Calculates and caches defects or returns the cached value."
    (unless (state-defects state)
      (setf (state-defects state) (calculate state #'defects)))
    (car (state-defects state)))

  (defun threat? (state)
    "Calculates and caches threat or returns the cached value."
    (unless (state-threat state)
      (setf (state-threat state) (calculate state #'threat)))
    (car (state-threat state)))

  (defun energy? (state)
    "Calculates and caches energy or returns the cached value."
    (unless (state-energy state)
      (setf (state-energy state) (calculate state #'energy)))
    (car (state-energy state))))

(defstruct path

  start   ; search start time
  end     ; search end time
  states  ; search states

)

(defmacro states?      (path) `(path-states ,path))
(defmacro first-state? (path) `(car (path-states ,path)))
(defmacro last-state?  (path) `(car (last (path-states ,path))))

(labels ((extreme-energy0 (states fn)
	   (let ((e (apply fn (mapcar #'energy? states))))
	     (find e states :key #'energy?)))
	 (extreme-energy (paths fn)
	   (extreme-energy0 (apply #'append (mapcar #'(lambda (path)
							(states? path))
						    (as-list paths))) fn)))
  
  (defun max-energy? (p)
    "Returns the state with the maximum energy from a path or list of paths."
    (extreme-energy p #'max))

  (defun min-energy? (p)
    "Returns the state with the minimum energy from a path or list of paths."
    (extreme-energy p #'min)))

(defun min-energy-ttest? (p)
  "Returns the state with the minimum energy, back-selected for statistical sameness."
  (let* ((min-e-state (min-energy? p))
         (min-e       (state-energy min-e-state)))
    (dolist (path (as-list p))
      (when (= (energy? (min-energy? path))
               (energy? min-e-state))
        (dolist (state (path-states path))
          (let ((state-e (state-energy state)))
            (when (= 0 (ttest (fifth min-e)
                              (sixth min-e)
                              (seventh min-e)
                              (fifth state-e)
                              (sixth state-e)
                              (seventh state-e)))
              (return-from min-energy-ttest? state))))
        (error "statistically same minimum energy not found")))))

;;; search stuff

(defvar *debug-search* nil)  ; whether to print debugging information while searching

;;; the following three macros are not generally usable outside of a (defsearch ...) form
;;; but we define them globally so we get nice formatting inside our search engine code

(defmacro save-state ()
  "Creates a new state using the search lists and adds it to the current path."
  `(push (make-state0 kloc-min kloc-max ignore open closed) (states? path)))

(defmacro with-new-path (&body body)
  "Creates a temporary search context."
  `(let ((path   (copy-path path))
	 (ignore ignore)
	 (open   open)
	 (closed closed))
    ,@body))

(defmacro switch-path (new-path)
  "Updates the search lists and path variable to match the provided path."
  `(progn
    (setf path   ,new-path)
    (setf ignore (state-ignore (first-state? path)))
    (setf open   (state-open   (first-state? path)))
    (setf closed (state-closed (first-state? path)))))

(defmacro defsearch (name parameters &body body)
  "Defines a search engine."
  (let ((kloc     (gensym))
	(runs     (gensym))
	(iterator (gensym)))
    `(defun ,name (&key (num-runs 20) (case-study (default-case-study)) policies file ,@parameters)

      ;; clear the output file
      (if file (with-open-file (str file :direction :output :if-exists :supersede)))
      (let (,kloc kloc-min kloc-max ignore open closed path paths ,runs)

	;; determine kloc range from the provided (or default) case study
	(setf ,kloc    (find 'kloc (complete-case-study case-study) :key #'car)
	      kloc-min (second ,kloc)
	      kloc-max (third  ,kloc))

	;; iterate num-runs times
	(dotimes (,iterator num-runs (nreverse ,runs))

	  ;; initialize the search lists
	  (setf open (separate-treatments (remove 'kloc (complete-case-study case-study) :key #'car)))
	  (when policies
	    (dolist (treatment open)
	      (if (not (intersection policies (feature-policies (car treatment))))
		  (move-elt treatment open ignore))))
	  (setf closed nil
		path   (make-path :start (get-internal-run-time))
		paths  nil)

	  ;; cache the minimum and maximum effort/months/defects/threat for this search
	  (when (zerop ,iterator)
	    (init-db)
	    (kloc! kloc-min kloc-max)
	    (apply-treatments (append ignore open))
	    (cache-min-max))

	  ;; run the provided search code
	  (format t "Run #~a~%" (1+ ,iterator))
	  ,@body

	  ;; save and output the run
	  (setf (path-end path) (get-internal-run-time)
		(states? path)  (nreverse (states? path)))
	  (push path ,runs)
	  (if file (with-open-file (str file :direction :output :if-exists :append)
		     (format str "~a~%" path))))))))

;;; reporting stuff

(defun print-state (state)
  "Prints a state's energy and constraints."
  (format t "~,6f " (energy? state))
  (let ((constraints (constraints? state)))
    (dotimes (i (length constraints))
      (if (and (> i 0)
	       (zerop (mod i 9)))
	  (format t "~%~9t"))
      (format t "~8a " (elt constraints i))))
  (terpri))

(defun print-path (path)
  "Prints all of a path's states according to print-state."
  (dolist (state (states? path))
    (print-state state))
  (terpri))

(defun print-paths (paths &key (which :best))
  "Prints a specific state from each path in a list of paths."
  (macrolet ((s () `(case which
		     (:first (first-state? path))
		     (:last  (last-state?  path))
		     (:best  (min-energy?  path))
		     (t      (error "unsupported value ~a for which" which)))))
    (cond ((zerop (length paths)))
	  ((> (length paths) 5)
	   (dotimes (i (ceiling (length paths) 5))
	     (print-paths (subseq paths
				  (* i 5)
				  (min (* (1+ i) 5)
				       (length paths))) :which which)))
	  (t
	   (dotimes (i (apply #'max (mapcar #'(lambda (path)
						(length (coalesce-treatments (constraints? (s)))))
					    paths)))
	     (dolist (path paths)
	       (format t "~18a " (if (> (length (coalesce-treatments (constraints? (s)))) i)
				     (elt (coalesce-treatments (constraints? (s))) i)
				     "")))
	     (terpri))
	   (dolist (path paths)
	     (format t "~,6f~11a" (energy? (s)) ""))
	   (terpri) (terpri)))))