;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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.guess)

(defstruct
    (db)
      ;(:print-object  ; hide struct details
       ;  (lambda (db stream)
        ;   (print-unreadable-object (db stream :type t :identity t)))))
  default-configurations  ; design time : space of all possibilities
  current-configurations  ; setup time  : modifications made during a search
  cache     ; run time    : cached by the ! function
  )

(defun copy-configurations (configurations)
  (mapcar #'(lambda (attr-conf)
              (cons (car attr-conf)
                    (copy-structure (cdr attr-conf))))
          configurations))

(defun full-copy-db (db)
  (let ((copy-db (make-db)))
    ;;default configurations
    (setf (db-default-configurations copy-db)
          (mapcar #'copy-alist
                  (db-default-configurations db)))
    ;;curent configurations
    (setf (db-current-configurations copy-db)
          (copy-configurations (db-current-configurations db)))
    ;; cache
    (setf (db-cache copy-db)
          (mapcar #'copy-list
                  (db-cache db)))
    copy-db))

(defvar *db* (make-db))

(define-condition key-not-in-db (error)
  ((key :initarg :key :reader key))
  (:documentation "Condition signalled when a key is not found in the db"))

;;; accessing current-configurations
(defun get-current-attribute-configuration (attribute)
  "Retrieve current configuration for specfied attribute"
  (multiple-value-bind (value foundp) (geta attribute (db-current-configurations *db*))    
    (unless foundp
      (error 'key-not-in-db :key attribute))
    value))

(defun set-current-attribute-configuration (attribute new-configuration)
  "Set current configuration for specified attribute"
  (get-current-attribute-configuration attribute); check key in db
  (puta attribute new-configuration (db-current-configurations *db*)))

;;; guessing and caching values in *db*

(defun ? (key)
  "Guess a value for a key in the *db* settings."
  (guess (get-current-attribute-configuration key)))

(defun ! (key)
  "Retrieve from the cache, or guess and cache a value for a key."
  (let ((value (geta key (db-cache *db*))))
    (unless value
      (setf value (? key))
      (puta key value (db-cache *db*)))
    value))

(defun zap (key)
  "Removes key from the *db* cache."
  (let ((old-value (geta key (db-cache *db*))))
    (setf (db-cache *db*) (remove key (db-cache *db*) :key #'car))
    old-value))

(defun zaps ()
  "Removes all keys from the *db* cache."
  (setf (db-cache *db*) nil))

;;; initializing the db

(defun register-db-default-configuration-list (key default-configuration-list)
  "Registers a configuration list identified by the key. Previous
default configurations will be overwritten."
  (puta key default-configuration-list (db-default-configurations *db*)))

(defun init-db ()
  "Initializes a database by clearing the cache and resetting current-configurations to their defaults"
  (zaps)
  (setf (db-current-configurations *db*)
        (copy-configurations (apply #'append
                                    (mapcar #'cdr
                                            (db-default-configurations *db*))))))

;;; helpers

(defmacro with-new-db (&body body)
  "Creates a temporary db with the same db-settings as the current db."
    `(let ((*db* (full-copy-db *db*)))
       ,@body))

(defun all-db-keys ()
  "All keys of db current configurations"
  (mapcar #'car
          (db-current-configurations *db*)))

(defun all-db-cache-keys ()
  "All keys of db cache"
  (mapcar #'car
          (db-cache *db*)))

(defun cache-all ()
  "Cache all values in the current configurations"
  (dolist (attribute (all-db-keys))
    (! attribute)))

(defun dump-cache (&optional (keys-to-dump (all-db-keys)))
  (mapcar #'(lambda (attr-cvalue)
              (cons (car attr-cvalue)
                    (if (typep (cdr attr-cvalue) 'structure-object)
                        (copy-structure (cdr attr-cvalue))
                        (cdr attr-cvalue))))
          (remove-if #'(lambda (attr-conf)
                         (not (member (car attr-conf) keys-to-dump)))
                     (db-cache *db*))))