;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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 :wvu-lib.tricks)

;;;;LOOKUP TABLE
;; Lookup tables are a generic way of defining a table that a user may
;; look up values.  The implementation can be based on an array, or could
;; based on a function.
(defclass lookup-table ()
  ()
  (:documentation "A class that represents a table used for looking up values based on 1 based positions"))

;;; external protocol
(define-condition invalid-positions (error)
  ((message :initarg :key :reader message))
  (:documentation "Condition signalled when positions aren't valid"))

(defgeneric lookup-value-from-table (lookup-table &rest positions)
  (:documentation "Lookup a value in a lookup table based on the specified positions which are based on the offset")
  (:method (lookup-table &rest positions)
    "check positions and then call lookup-value-from-table-with-validated-positions"
    ;;check positions
    (check-positions lookup-table positions)
    ;;lookup value
    (lookup-value-from-table-with-validated-positions lookup-table positions)))


;;; internal protocol
(defgeneric check-positions (lookup-table positions)
  (:documentation "Used by lookup-value-from-table to make sure that positions is valid before calling.  This function should return (values valid reason-not-valid ")
  (:method (lookup-table positions)
    "Check that positions are >= 1"
    (when (some #'(lambda (x) (< x 1)) positions)
      (error 'invalid-positions :message "positions must be >= 1"))))

(defgeneric lookup-value-from-table-with-validated-positions (lookup-table valid-positions)
    (:documentation "This method is to be implemented by each implementation of lookup-table"))


;;; ARRAYs
(defmethod check-positions :after ((array array) positions)
  ;;check number of positions
  (let ((current-n (length positions))
        (correct-n (length (array-dimensions array))))
    (unless (= current-n correct-n)
      (error 'invalid-positions :message (format nil "There must be ~a positions, not ~a" correct-n current-n))))
  ;;check positions values
  (do* ((pos-ittr positions                (rest pos-ittr))
        (dim-ittr (array-dimensions array) (rest dim-ittr))
        (pos      (first pos-ittr)         (first pos-ittr))
        (max-pos  (first dim-ittr)         (first dim-ittr)))
       ((or (null pos)
            (null max-pos)))
    (when (> pos max-pos)
      (error 'invalid-positions :message "Position ~a can't be greater than max-position ~a" pos max-pos))))

(defmethod lookup-value-from-table-with-validated-positions ((array array) positions)
  (apply #'aref (cons array positions)))


;;;;ARRAY BASED LOOKUP TABLE
;; Lookup table implementation based on an array.  All lookups come from
;; the internal array.
(defclass array-based-lookup-table (lookup-table)
  ((array :initarg :array
          :type array
          :documentation "The array the lookup-table is based on"))
  (:documentation "This lookup table pulls values based on an array"))

(defmethod check-positions ((ab-lookup-table array-based-lookup-table) positions)
  (with-slots (array) ab-lookup-table
    (check-positions array positions)))

(defmethod lookup-value-from-table-with-validated-positions ((ab-lookup-table array-based-lookup-table) positions)
  (with-slots (array) ab-lookup-table
    (lookup-value-from-table-with-validated-positions array positions)))

(defun make-array-based-lookup-table (array)
  "Create an instance of array-based-lookup-table"
  (make-instance 'array-based-lookup-table :array array))


;;;;FUNCTION BASED LOOKUP TABLE
;; Lookup table implementation based on a function.
(defclass function-based-lookup-table (lookup-table)
  ((function :initarg :function
             :type function
             :documentation "Function that will be called by lookup-value-from-table.")))

(defgeneric compute-effective-function-based-lookup-table-function-parameter-list (function-based-lookup-table positions)
  (:documentation "Computes the paramaters (as a list) to be passed to the function of a function based lookup table when called by lookup-value-from-table"))

(defmethod compute-effective-function-based-lookup-table-function-parameter-list ((function-based-lookup-table function-based-lookup-table) positions)
  (declare (ignore function-based-lookup-table))
  positions)

(defmethod lookup-value-from-table-with-validated-positions ((fb-lookup-table function-based-lookup-table) positions)
  (with-slots (function) fb-lookup-table
    (apply function (compute-effective-function-based-lookup-table-function-parameter-list fb-lookup-table positions))))

(defun make-function-based-lookup-table (function)
  "Create an instance of function-based-lookup-table"
  (make-instance 'function-based-lookup-table :function function))