;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: case-constructors.lsp
;;;;    System: Case Viewer
;;;;    Author: Jeff Usher
;;;;   Created: March 17, 2004 21:34:49
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Thursday, March 18, 2004 at 00:06:16 by usher
;;;; ---------------------------------------------------------------------------

(in-package :fire-case-viewer)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Registry of Acceeptable Case-Constructors

(defparameter *case-construction-styles* nil)

(defun def-case-construction-style (style-name)
  "Style-name must be a single symbol."
  (push style-name *case-construction-styles*)
  (setf *case-construction-styles*
    (sort *case-construction-styles* 
          #'string-lessp
          :key #'user-namestring))
  style-name)

(defun case-construction-styles ()
  *case-construction-styles*)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Basic Methods

(defgeneric user-namestring (case-construction-style)
  (:documentation "Returns a string that can be used in user-interfaces to
                   refer to the specified case-construction-style."))

(defmethod user-namestring (case-construction-style)
  (typecase case-construction-style
    (string case-construction-style)
    (symbol (symbol-name case-construction-style))
    (otherwise (write-to-string case-construction-style))))



(defgeneric include-in-casename-completion? (construction-style casename)
  (:documentation "Should return non-nil iff you want the given casename to be
                   included in the list of valid casenames given when the user
                   gets completions on case names as they type."))

(defmethod include-in-casename-completion? (construction-style casename)
  (declare (ignore casename construction-style))
  t)



(defgeneric make-full-casename (construction-style casename)
  (:documentation "Should return a full casename usable by FIRE for case
                   construction."))

(defmethod make-full-casename (construction-style casename)
  (list construction-style casename))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ExplicitCaseFn

(def-case-construction-style 'd::ExplicitCaseFn)



(defmethod user-namestring ((construction-style (eql 'd::ExplicitCaseFn)))
  "ExplicitCaseFn")

(defmethod make-full-casename ((construction-style (eql 'd::ExplicitCaseFn))
                               casename)
  (let ((pred (if (fire:mixed-case?) 'd::ExplicitCaseFn 'd::explicit-case-fn)))
    `(,pred ,casename)))

(defmethod include-in-casename-completion? ((construction-style 
                                             (eql 'd::ExplicitCaseFn))
                                            casename)
  (if (fire:retrieve `(d::isa ,casename d::Case)) t nil))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GroundExplicitCaseFn

(def-case-construction-style 'd::GroundExplicitCaseFn)



(defmethod user-namestring ((construction-style (eql 'd::GroundExplicitCaseFn)))
  "ExplicitCaseFn (Ground Facts Only)")

(defmethod make-full-casename ((construction-style (eql 'd::GroundExplicitCaseFn))
                               casename)
  (let ((pred (if (fire:mixed-case?) 'd::GroundCaseFn 'd::ground-case-fn)))
    `(,pred ,(make-full-casename 'd::ExplicitCaseFn casename))))

(defmethod include-in-casename-completion? ((construction-style 
                                             (eql 'd::GroundExplicitCaseFn))
                                            casename)
  (if (fire:retrieve `(d::isa ,casename d::Case)) t nil))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MinimalCaseFn

(def-case-construction-style 'd::MinimalCaseFn)



(defmethod user-namestring ((construction-style (eql 'd::MinimalCaseFn)))
  "MinimalCaseFn")

(defmethod make-full-casename ((construction-style (eql 'd::MinimalCaseFn))
                               casename)
  (let ((pred (if (fire:mixed-case?) 'd::MinimalCaseFn 'd::minimal-case-fn)))
    `(,pred ,casename)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GroundMinimalCaseFn

(def-case-construction-style 'd::GroundMinimalCaseFn)



(defmethod user-namestring ((construction-style (eql 'd::GroundMinimalCaseFn)))
  "MinimalCaseFn (Ground Facts Only)")

(defmethod make-full-casename ((construction-style (eql 'd::GroundMinimalCaseFn))
                               casename)
  (let ((pred (if (fire:mixed-case?) 'd::GroundCaseFn 'd::ground-case-fn)))
    `(,pred ,(make-full-casename 'd::MinimalCaseFn casename))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code