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

(in-package :xomo.model)

(defstruct (risk-peak (:include bag)))
(defstruct (risk-peak-guess
             (:constructor make-risk-peak-guess (peak)))
  (peak nil :read-only t))

(defmethod guess ((x risk-peak))
  (make-risk-peak-guess (call-next-method)))

(defclass risk-lookup-table (function-based-lookup-table)
  ((type :initarg :type) ;TL BL TR BR
   (step :initarg :step)
   (height :initarg :height)
   (width :initarg :width)))

(defmethod check-positions :after ((risk-lt risk-lookup-table) positions)
  ;;check correct number
  (unless (= 3 (length positions))
    (error 'invalid-positions :message (format nil "There should be 3 positions (peak, row, height), not ~a" (length positions))))
  (with-slots (height width) risk-lt
    (when (> (second positions) height)
      (error 'invalid-positions :message  (format nil "row (~a) is greater than height (~a)" (second positions) height)))
    (when (> (third positions) width)
      (error 'invalid-positions :message  (format nil "column (~a) is greater than width (~a)" (third positions) width)))))

(defmethod compute-effective-function-based-lookup-table-function-parameter-list ((risk-lookup-table risk-lookup-table) positions)
  (with-slots (type step height width) risk-lookup-table
    (append (list type
                  step
                  height
                  width)
            ;;at this point positions should be (peak row column)
            positions)))

(defun calc-risk-table-value (type step height width peak row column)
  "calculate value for a risk-table"
  (labels ((calc-distance-to (r0 c0)
             (+ (abs (- r0 row))
                (abs (- c0 column))))
           (calc-step (step distance-from-peak)
             (if (listp step)
                 (if (< distance-from-peak
                        (length step))
                     (elt step distance-from-peak)
                     0)
                 (expt step distance-from-peak))))
    (let ((distance-from-peak
           (ecase type
             (tl (calc-distance-to 1      1    ))
             (tr (calc-distance-to 1      width))
             (bl (calc-distance-to height 1    ))
             (br (calc-distance-to height width)))))
      (floor (* peak
                (calc-step step distance-from-peak))))))


(defun make-risk-lookup-table (type step height width)
  "Constructor for risk-lookup-table"
  (make-instance 'risk-lookup-table
                 :type type
                 :step step
                 :height height
                 :width width
                 :function #'calc-risk-table-value))


(defstruct (risk-calc-desc
             (:constructor make-risk-calc-desc (row-attr col-attr db-peak-key risk-lookup-table)))
  row-attr col-attr db-peak-key risk-lookup-table)

(defvar *risk-calc-desc-list* nil)
(let (;;TABLES
      ;;top left table
      (tl-5x5 (make-risk-lookup-table 'tl 0.5 5 5))
      (tl-5x6 (make-risk-lookup-table 'tl 0.5 5 6))
      (tl-6x5 (make-risk-lookup-table 'tl 0.5 6 5))
      (tl-6x6 (make-risk-lookup-table 'tl 0.5 6 6))
      ;;top right table
      (tr-5x5 (make-risk-lookup-table 'tr 0.5 5 5))
      (tr-5x6 (make-risk-lookup-table 'tr 0.5 5 6))
      (tr-6x5 (make-risk-lookup-table 'tr 0.5 6 5))
      (tr-6x6 (make-risk-lookup-table 'tr 0.5 6 6))
      ;;bottom left
      (bl-5x5 (make-risk-lookup-table 'bl 0.5 5 5))
      (bl-5x6 (make-risk-lookup-table 'bl 0.5 5 6))
      (bl-6x5 (make-risk-lookup-table 'bl 0.5 6 5))
      (bl-6x6 (make-risk-lookup-table 'bl 0.5 6 6))
      ;;bottom right
      (br-5x5 (make-risk-lookup-table 'br 0.5 5 5))
      (br-5x6 (make-risk-lookup-table 'br 0.5 5 6))
      (br-6x5 (make-risk-lookup-table 'br 0.5 6 5))
      (br-6x6 (make-risk-lookup-table 'br 0.5 6 6)))
  (declare (ignore tr-6x5 tr-6x6
                   bl-6x6
                   br-5x5 br-5x6 br-6x5 br-6x6))
  (macrolet ((defrcd (row-attr col-attr risk-lookup-table)
               (let ((rlt (gensym))
                     (key (gensym))
                     (db-peak-key (gensym)))
                 `(let ((,rlt ,risk-lookup-table)
                        (,key
                         (intern (nstring-upcase
                                  (format nil "~a-~a"
                                          (symbol-name ',row-attr)
                                          (symbol-name ',col-attr)))))
                        (,db-peak-key
                         (intern (nstring-upcase
                                  (format nil "rp-~a-~a"
                                          (symbol-name ',row-attr)
                                          (symbol-name ',col-attr))))))
                    (cons ,key
                          (make-risk-calc-desc ',row-attr ',col-attr ,db-peak-key ,rlt))))))
    (setf *risk-calc-desc-list*
          (list (defrcd sced rely tr-5x5) ;;from xomo101 paper
            (defrcd sced cplx tr-5x6)
            (defrcd sced time tr-5x6)
            (defrcd sced pvol tr-5x5)
            (defrcd sced tool tl-5x5)
            (defrcd sced plex tl-5x5)
            (defrcd sced pcap tl-5x5)
            (defrcd sced aexp tl-5x5)
            (defrcd sced acap tl-5x5)
            (defrcd sced ltex tl-5x5)
            (defrcd sced pmat tl-5x6)
            (defrcd rely acap bl-5x5)
            (defrcd rely pcap bl-5x5)
            (defrcd cplx acap bl-6x5)
            (defrcd cplx pcap bl-6x5)
            (defrcd cplx tool bl-6x5)
            (defrcd rely pmat bl-5x6)
            (defrcd pmat acap tl-6x5)
            (defrcd stor acap bl-6x5)
            (defrcd time acap bl-6x5)
            (defrcd tool acap tl-5x5)
            (defrcd tool pcap tl-5x5)
            (defrcd ruse aexp bl-6x5)
            (defrcd ruse ltex bl-6x5)
            (defrcd pmat pcap tl-6x5)
            (defrcd stor pcap bl-6x5)
            (defrcd time pcap bl-6x5)
            (defrcd ltex pcap tl-5x5)
            (defrcd pvol plex bl-5x5)
            (defrcd tool pmat tl-5x6)
            (defrcd time tool bl-6x5)
            (defrcd team aexp tl-6x5)
            (defrcd team sced tl-6x5)
            (defrcd team site tl-6x6)))))

(defun threat ()
  "Returns the total threat of schedule overrun."
  (/ (+ (schedule-risk) (product-risk) (personnel-risk)
	(process-risk) (platform-risk) (reuse-risk))
     ;;FIXME weight needs recalculated since peaks are mutated
     3.73))

(defmacro r (key)
  "Returns the product of risk values and the risk multiplier"
  (let ((rcd (gensym)))
    `(let ((,rcd (geta ',key *risk-calc-desc-list*)))
       (* (2risk (risk-calc-desc-row-attr ,rcd))
          (2risk (risk-calc-desc-col-attr ,rcd))
          (macrolet ((attr2table-pos (attr)
                       `(round (bag-range (! ,attr)))))
            (lookup-value-from-table (risk-calc-desc-risk-lookup-table ,rcd)
                                     (risk-peak-guess-peak (! (risk-calc-desc-db-peak-key ,rcd)))
                                     (attr2table-pos (risk-calc-desc-row-attr ,rcd))
                                     (attr2table-pos (risk-calc-desc-col-attr ,rcd))))))))


(defun 2risk (x)
  "Returns the risk value.  For effort multipliers, this is the same as the
   tabled COCOMO value.  For scale factors, see cocomo.c lines 856 to 866."
  (cond ((subtypep (type-of (! x)) 'em)
	 (em2effort x))
	((subtypep (type-of (! x)) 'sf)
	 (let* ((range (sf-range (! x)))
		(power (case range
			 (1 0.02)
			 (2 0.01)
			 (t 0.00))))
	   (expt (! 'kloc) power)))
        ((subtypep (type-of (! x)) 'dr)
         1)
	(t
	 (warn "can't handle ~a of type ~a" x (type-of (! x))))))

(defun schedule-risk ()
  "Calculates schedule risk."
  (+ (r sced-rely) (r sced-time) (r sced-pvol) (r sced-tool)
     (r sced-acap) (r sced-aexp) (r sced-pcap) (r sced-plex)
     (r sced-ltex) (r sced-pmat)))

(defun product-risk ()
  "Calculates product risk."
  (+ (r rely-acap) (r rely-pcap) (r cplx-acap) (r cplx-pcap)
     (r cplx-tool) (r rely-pmat) (r sced-cplx) (r sced-rely)
     (r sced-time) (r ruse-aexp) (r ruse-ltex)))

(defun personnel-risk ()
  "Calculates personnel risk."
  (+ (r pmat-acap) (r stor-acap) (r time-acap) (r tool-acap)
     (r tool-pcap) (r ruse-aexp) (r ruse-ltex) (r pmat-pcap)
     (r stor-pcap) (r time-pcap) (r ltex-pcap) (r pvol-plex)
     (r sced-acap) (r sced-aexp) (r sced-pcap) (r sced-plex)
     (r sced-ltex) (r rely-acap) (r rely-pcap) (r cplx-acap)
     (r cplx-pcap) (r team-aexp)))

(defun process-risk ()
  "Calculates process risk."
  (+ (r tool-pmat) (r time-tool) (r team-aexp) (r team-sced)
     (r team-site) (r sced-tool) (r sced-pmat) (r cplx-tool)
     (r pmat-acap) (r tool-acap) (r tool-pcap) (r pmat-pcap)))

(defun platform-risk ()
  "Calculates platform risk."
  (+ (r sced-time) (r sced-pvol) (r stor-acap) (r time-acap)
     (r stor-pcap) (r pvol-plex) (r time-tool)))

(defun reuse-risk ()
  "Calculates reuse risk."
  (+ (r ruse-aexp) (r ruse-ltex)))

(register-scoring-method-by-parameters 'threat "Threat" #'threat #'<)