;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsearch keys ((num-trials 200) (best% 0.1))

  ;; start by moving all non-singleton treatments to the closed list
  ;; this simplifies the creation of singleton treatments
  (move-elts (non-singletons? open) open closed)
  (save-state)
  (if *debug-search* (print-state (first-state? path)))
  (loop

   ;; if the solution is fully constrained, return
   (if (= (constrained% (first-state? path)) 1) (return))

   ;; generate num-trials random solutions
   ;; using singleton treatments for unconstrained features
   (dotimes (i num-trials)
     (with-new-path
       (dolist (treatment (coalesce-treatments closed))
	 (let ((feature (car treatment))
	       (range   (cdr treatment)))
	   (unless (find feature open :key #'car)
	     (move-elt (list feature (?elt range)) closed open))))
       (save-state)
       (push path paths)))
   (let (scored-treatments)

     ;; generate a list of new singletons
     ;; in the form of (singleton . energy) pairs
     (dolist (new-path paths)
       (let* ((*monte-carlo-iterations* 5)
	      (new-state                (first-state? new-path))
	      (new-open                 (state-open new-state))
	      (new-singletons           (set-difference new-open open :test #'equal))
	      (score                    (energy? new-state)))
	 (dolist (treatment new-singletons)
	   (push (cons treatment score) scored-treatments))))

     ;; rank the new singletons and select the best one
     (let* ((best    (car (bore-rank scored-treatments)))
	    (feature (car best)))
       (move-elt best closed open)
       (save-state)
       (energy? (first-state? path))
       (if *debug-search* (print-state (first-state? path)))
       (setf paths nil))))
  (if *debug-search* (terpri)))

(defun bore-rank (l &optional (best% 0.1))
  "Ranks a list of items according to BORE given a list of (item . score) pairs."
  (let* ((scores       (mapcar #'cdr l))
	 (cutoff-index (ceiling (* (length l) best%)))
	 (cutoff-score (elt (sort scores #'<) cutoff-index))
	 (best-pairs   (remove-if-not #'(lambda (pair) (<= (cdr pair) cutoff-score)) l))
	 (worst-pairs  (remove-if-not #'(lambda (pair) (>  (cdr pair) cutoff-score)) l))
	 (all          (mapcar #'car l))
	 (best         (mapcar #'car best-pairs))
	 (worst        (mapcar #'car worst-pairs))
	 ranks)
    (dolist (item all)
      (when (not (assoc item ranks :test #'equal))
	(push (cons item (rank-stat item best worst)) ranks)))
    (mapcar #'car (sort ranks #'> :key #'cdr))))

(defun rank-stat (item best worst)
  "Calculates the ranking statistic for an item."
  (let* ((p-e       (/ (+ (count item best :test #'equal)
			  (count item worst :test #'equal))
		       (+ (length best) (length worst))))
	 (p-best    (/ (length best) (+ (length best) (length worst))))
	 (p-e/best  (/ (count item best :test #'equal) (length best)))
	 (p-e+best  (* p-e/best p-best))
	 (p-best/e  (/ p-e+best p-e)))
    (* p-best/e p-e+best)))