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

;;; cocomo name canonicalization

(let ((names  
       '((xh . 6) (6 . 6) (extremelyhigh . 6)
	 (vh . 5) (5 . 5) (veryhigh      . 5)
	 (h  . 4) (4 . 4) (high          . 4)
	 (n  . 3) (3 . 3) (nominal       . 3)
	 (l  . 2) (2 . 2) (low           . 2)
	 (vl . 1) (1 . 1) (verylow       . 1))))
  
  (defun coco1 (x)
    "Converts a single COCOMO name into canonical form."
    (or (cdr (assoc x names))
	(warn "~a not a known coco-name" x)
	x))
  
  (defun coco (l)
    "Converts a list of COCOMO names into canonical form."
    (mapcar #'coco1 l))
  
  (defun coco-restrict (old new)
    "Returns the intersection of two lists of COCOMO names."
    (let* ((old1 (coco old))
	   (new1 (coco new))
	   (overlap (intersection new1 old1)))
      (or overlap
	  (warn "~a does not intersect with ~a" old new)
          old))))

(egs :coco
     (eg  '(coco '(1 2 3))
	  :of "converting cocomo names to canonical form"
	  :out '(1 2 3))
     (eg '(coco '(vl l n))
	  :of "converting cocomo names to canonical form"
	 :out '(1 2 3))
     (eg '(coco '(vl 2 n))
	  :of "converting cocomo names to canonical form"
	 :out '(1 2 3)))

;;; cocomo tuning parameters

(defstruct one-a line)
(defstruct one-b num)

(defun ?one-a (x)
  "Pulls fixed values from a floating a-line."

  ;; picks a random point on the one-a line
  (let ((line (one-a-line x)))
    (?quantity (line-x1 line) (line-x2 line))))

(defun ?one-b (x &optional
	       (a-val (! 'a))
	       (a-line (one-a-line (geta 'a (db-settings *db*)))))
  "Pulls fixed values from a floating b."

  ;; defined in terms of a
  ;; reduces the y point of one-a line by a random amount
  (let ((inc (?num (one-b-num x))))
    (max 0 (- (line-y a-val a-line) inc))))

;;; cocomo factors

(defstruct (sf (:include bag)) effort rsf dsf csf policies)                  ; scale factor
(defstruct (em (:include bag)) effort rin din cin policies modify-guess-fn)  ; effort multiplier
(defstruct (dr (:include bag)) rout dout cout policies)                      ; defect remover

(defun ?sf (x)
  "Pulls fixed values from a floating scale factor."
  (make-sf :range    (?bag (sf-range  x))
	   :effort   (?num (sf-effort x))
	   :rsf      (?num (sf-rsf    x))
	   :dsf      (?num (sf-dsf    x))
	   :csf      (?num (sf-csf    x))
	   :policies (sf-policies     x)))

(defun ?em (x)
  "Pulls fixed values from a floating effort multiplier."
  (let ((em (make-em :range    (?bag (em-range  x))
                     :effort   (?num (em-effort x))
                     :rin      (?num (em-rin    x))
                     :din      (?num (em-din    x))
                     :cin      (?num (em-cin    x))
                     :policies (em-policies     x)))
        (fn (em-modify-guess-fn x)))
    (if fn
        (funcall fn em)
        em)))

(defun ?dr (x)
  "Pulls fixed values from a floating defect remover."
  (make-dr :range    (?bag (dr-range x))
	   :rout     (?num (dr-rout  x))
	   :dout     (?num (dr-dout  x))
	   :cout     (?num (dr-cout  x))
	   :policies (dr-policies    x)))

;;; cocomo input ranges

(defstruct (r15 (:include bag (range (coco '(1 2 3 4 5  ))))))
(defstruct (r16 (:include bag (range (coco '(1 2 3 4 5 6))))))
(defstruct (r25 (:include bag (range (coco '(  2 3 4 5  ))))))
(defstruct (r26 (:include bag (range (coco '(  2 3 4 5 6))))))
(defstruct (r36 (:include bag (range (coco '(    3 4 5 6))))))

(defmacro range? (x)
  "Returns a range from the *db* settings."
  `(bag-range (bag-range (cdr (assoc ,x (db-settings *db*))))))

(defun range! (x new)
  "Sets a range in the *db* settings."
  (setf (range? x) (as-list new)))

(defmacro kloc? ()
  "Returns the value of kloc in the *db* settings."
  `(cdr (assoc 'kloc (db-settings *db*))))

(defun kloc! (min max)
  "Sets the value of kloc in the *db* settings."
  (setf (kloc?) (make-num :min min :max max)))

;;; cocomo calculations

(defun pivoted-line         (x m) (+ 1 (* m (- x 3))))
(defun hinged-line          (x m) (* m (- x 6)))
(defun hinged-line-coqualmo (x m) (* m (- x 1)))

(defun em2effort (x) (let ((x1 (! x))) (pivoted-line         (em-range x1) (em-effort x1))))
(defun em2rin    (x) (let ((x1 (! x))) (pivoted-line         (em-range x1) (em-rin    x1))))
(defun em2din    (x) (let ((x1 (! x))) (pivoted-line         (em-range x1) (em-din    x1))))
(defun em2cin    (x) (let ((x1 (! x))) (pivoted-line         (em-range x1) (em-cin    x1))))

(defun sf2effort (x) (let ((x1 (! x))) (hinged-line          (sf-range x1) (sf-effort x1))))
(defun sf2rin    (x) (let ((x1 (! x))) (pivoted-line         (sf-range x1) (sf-rsf    x1))))
(defun sf2din    (x) (let ((x1 (! x))) (pivoted-line         (sf-range x1) (sf-dsf    x1))))
(defun sf2cin    (x) (let ((x1 (! x))) (pivoted-line         (sf-range x1) (sf-csf    x1))))

(defun dr2rout   (x) (let ((x1 (! x))) (hinged-line-coqualmo (dr-range x1) (dr-rout   x1))))
(defun dr2dout   (x) (let ((x1 (! x))) (hinged-line-coqualmo (dr-range x1) (dr-dout   x1))))
(defun dr2cout   (x) (let ((x1 (! x))) (hinged-line-coqualmo (dr-range x1) (dr-cout   x1))))

;;; *db* setup

(defun init-db (&optional (settings (cocomo-defaults)))
  "Initializes a db and assigns it to the *db* variable."
  (setf *db* (init-db0 settings)))

(defun init-db0 (&optional (settings (cocomo-defaults)))
  "Initializes and returns a db."
  (make-db :settings settings))

(defun coc-lib-demo1 ()
  "Demonstrates *db* setup and cocomo calculations."
  (init-db)
  (coc-lib-demo2 1))

(defun coc-lib-demo2 (n &optional (*db* *db*))
  "Demonstrates cocomo calculations on an existing db."
  (dotimes (i n)
    (dolist (item (db-settings *db*))
      (print (car item))
      (case (type-of (cdr item))
	(one-a (print (! 'a)))
	(one-b (print (! 'b)))
	(num   (print (?num (cdr item))))
	(em    (print (em2effort (car item)))
	       (print (em2rin    (car item)))
	       (print (em2din    (car item)))
	       (print (em2cin    (car item))))
	(sf    (print (sf2effort (car item)))
	       (print (sf2rin    (car item)))
	       (print (sf2din    (car item)))
	       (print (sf2cin    (car item))))
	(dr    (print (dr2rout   (car item)))
	       (print (dr2dout   (car item)))
	       (print (dr2cout   (car item))))))))