;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10; Fonts:(MEDFNT) -*-

;;; Intelligent database interface utilities, for ObjectLISP objects.
;;; Really 3 separate concepts that are useful in combination:

;;; [1] Handy interface for generating object-contained edit (choose
;;; variable values) windows; see DEFCLASSMENU.  [Also illustrates one
;;; way to create a CHOOSE-VARIABLE-VALUES variable type that displays a
;;; message on the menu that can't be overwritten by the user; see
;;; PASS-BACK-ERROR-MSG].

;;; [2] Interface for constructing validation routines; see VALID-P.

;;; [3] Combined MAKE-EDIT-VALIDATE function for "enhancing" an object
;;; with a new object class, editing, and validating it.

(export '(defclassmenu
	   menu-edit
	   menu-error-msg
	   valid-p
	   validate
	   make-edit-validate))

;;; -*- [1] -*-
;;;
;;; Menu-editing objects.  A DEFKIND that include the class
;;; MENU-EDITABLE will inherit menu creation methods.  Call
;;; DEFCLASSMENU to set up the menu.  (See example on class
;;; SIMPLE-ANIMAL at bottom.) 
;;

(makunbound 'menu-editable)	 ;Kill the class.

(defkind menu-editable)		 ;Define the menu-editing object class.

(definstancevars menu-editable	 ;Things no menu should be without
  (menu-error-msg "OK")		 ;Current status msg
  (menu-title "Edit menu")	 ;Settable menu title
  (menu-alist			 ;Alist for TV:CHOOSE-VARIABLE-VALUES
    '((menu-error-msg
	"Status" :pass-back-error-msg)))
  (menu-edit-function		 ;Will be closure; this is safe.
    #'(lambda()nil))
  )

(defobfun (add-menu-alist menu-editable) ;This adds new menu elements
	  (alist)		 ;Takes a menu alist
  (loop for elt in alist
	with newalist = menu-alist
	as newvar = (if (listp elt)
			(car elt)
		      elt)
	do (setq newalist
		 (if (listp elt)
		     (remove newvar newalist :key #'car-safe)
		   (remove newvar newalist)))
	finally (have 'menu-alist
		      (append newalist alist)))
  menu-alist)

(defobfun (add-menu-choice menu-editable)
	  (choice-list)
  (format t "~&Adding menu choice ~s" choice-list)
  (setq menu-alist (append menu-alist (ncons choice-list)))
  (make-menu))

(defobfun (make-menu menu-editable) ())	 ;No-op here.

(defobfun (exist menu-editable)	 ;When creating new menu object,
	  (&rest ignore)
  (shadowed-exist)
  (make-menu))			 ;...make the menu

(defobfun (expand-alist menu-editable)	 ;This creates the edit-function
	  ()
  (let* ((vars (remove nil (mapcar #'car-safe menu-alist)))
	 (svars (mapcar #'string vars))
	 (lvars (mapcar #'make-symbol svars)))
	  (list 'let
		(mapcar #'(lambda(v i)
			    (list v
				  (list 'ask
					'(current-obj)
					i)))
			    lvars vars)
		`(declare(special ,@vars))
		`(declare(special ,@lvars))
		`(catch 'abort
		   (tv:choose-variable-values
		     ',(loop for old in vars
			     for new in lvars
			     with l = menu-alist
			     do (setf l (subst new old l))
			     finally (return l))
		     :margin-choices
		     '("Exit"
		       ("Abort" (throw 'abort (values nil :abort))))
		     :near-mode '(:point 400 400)
		     :label (ask (current-obj) menu-title))
		   ,@(mapcar #'(lambda (var val)
				 (list 'ask '(current-obj)
				       (list 'have
					     (list 'quote var)
					     val)))
			     vars lvars)
		   t)		 ;catching 'abort
		)))

(defmacro defclassmenu(class title alist)
  "Does all the work of defining MENU-EDITABLE obfun's for class CLASS
(which really should inherit from the MAKE-EDITABLE class).

 -  TITLE is the initial menu heading title.
 -  ALIST is the (unquoted) variables/options list, suitable for
      passing to TV:CHOOSE-VARIABLE-VALUES.

An example is:

  (defkind myclass)
  (definstancevars myvar anothervar)
  (DEFCLASSMENU myclass \"My menu\"
     ((myvar \"My var\" :number)
      (anothervar \"Another variable\" :string)))
  "
    (once-only(class)
    `(progn
       'compile
	 (defobfun (make-menu ,class) () ;Build the menu
	   (shadowed-make-menu)
	   (have 'menu-title ,title)
	   (add-menu-alist ',alist)
	   (have 'menu-edit-function
		 (eval `(lambda() ,(expand-alist)))))
	 (defobfun (menu-edit ,class) () ;User interface
	   (funcall menu-edit-function))
	 )))

;;; The data is already set up, but we need the obfun's:

(defclassmenu menu-editable "Edit menu"
  ((menu-error-msg "Status" :pass-back-error-msg)
   "------"))

;;; Utility routines for LMI window system

;;; Set-up a special keyword for TV:CHOOSE-VARIABLE-VALUES menus.

;; If the TYPE on a variable list is :PASS-BACK-ERROR-MSG, then that
;; variable (the current object's instance variable MENU-ERROR-MSG) will be
;; (re)displayed, when selected, with the value of the current object's
;; MENU-ERROR-MSG. 

;; This just means that the status line for the error message
;; can be dealt with dynamically, and won't be user-overwritable.

;; Usage: in the menu alist in a call to TV:CHOOSE-VARIABLE-VALUES,
;;      '(...(menu-error-msg "Status" :pass-back-error-msg)...)

;; This defines the function to be used when a menu (re)displays the
;; MENU-ERROR-MSG:

(defun tv:pass-back-error-msg(&rest ignore)
"CHOOSE-VARIABLE-VALUES type for handling an object variable MENU-ERROR-MSG."
  (declare(special menu-error-msg))
  (ask (current-obj) menu-error-msg))

;; This tells the window s/w to handle the keyword :PASS-BACK-ERROR-MSG

(defprop :pass-back-error-msg
  	 (princ					  ;Print w/out quotes
	   tv:pass-back-error-msg		  ;See above
	   nil nil nil				  ;Crufty TV stuff
	   "Status message")			  ;Who-line doc msg
  tv:choose-variable-values-keyword)

;;; -*- [2] -*-
;;;
;;; Self-validating objects.
;;;
;;; All About object validation:

;;; A class obfun VALID-P as used here is expected to return two values:
;;; VALIDITY and MENU-ERROR-MSG. VALIDITY should be non-NIL for an
;;; object that is "valid" -- e.g., its instance vars don't violate the
;;; internal "rules" for that object class, etc.  If VALIDITY is NIL,
;;; MENU-ERROR-MSG should be a string indicating the reason for the
;;; validity exception. (MENU-ERROR-MSG should also be a variable
;;; binding for the object being validated, as with a
;;; MENU-EDITABLE.)

;;; The obfun VALIDATE as used here calls VALID-P and if the result is
;;; non-NIL, proceeds to call a routine that allows the user to correct
;;; the error condition.

;;; For the sake of completeness, we define validity functions for the
;;; "global object" (what is not prohibited, is permitted):

(defobfun valid-p (&rest ignore) t)

(defobfun validate (&rest ignore)
  (multiple-value-bind (validity msg) (valid-p)
    (or validity
      (format t
	      "~&>> Invalid object signaled by (VALIDATE): ~s~%"
	      msg))))

;;; -*- [3] -*-
;;;
;;; How to turn an object of one class into one that takes on the
;;; bindings, etc., of another class... then edit its (presumably
;;; enlarged) menu, and validate it.

(defmacro transform-thing(obj class)
  `(let((newclass (oneof ,class)))
     (ask newclass (exist))
     (make-obj ,obj newclass)))

(defmacro make-edit-validate (obj class
			      &optional
			      (edit-fun (intern 'menu-edit))
			      (validate-fun (intern 'validate)))
  "Returns object from OBJ \"transformed\" into another CLASS;
preserves existing bindings, etc., and edits, and validates it.
EDIT-FUN can be a specified object function binding that will let 'edit'
the object, VALIDATE-FUN one that validates it; EDIT-FUN default to the
name created by DEFCLASSMENU, and VALIDATE-FUN defaults to VALIDATE."
  `(progn 'compile
	  (let((newobj (transform-thing ,obj ,class)))
	    (and
	      (ask newobj (make-menu))
	      (ask newobj (,edit-fun))
	      (ask newobj (,validate-fun))
	      newobj))))

;;; Testing and example code:

(defkind unknown-thing menu-editable)
(defkind typed-thing unknown-thing)
(defkind animal-thing typed-thing)
(defkind mineral-thing typed-thing)
(defkind vegetable-thing typed-thing)
(defkind small-thing unknown-thing)
(defkind big-thing unknown-thing)
(defkind known-thing)

(defobfun (exist unknown-thing) (&rest ignore)
  (shadowed-exist))

(definstancevars unknown-thing
  (type 'animal))

(definstancevars known-thing guess)

(definstancevars typed-thing
  bigthing)

(defclassmenu unknown-thing "Tell me about the thing"
  ((type "Is it animal, mineral, or vegetable?"
	 :choose (animal vegetable mineral))))

(defclassmenu typed-thing "Tell me more..."
  ((type "It's")
   ""
   (bigthing "Is it bigger than a bread-box?" :boolean)))

(defclassmenu known-thing "My guess is it's one of..."
  ((guess :sexp)))

(defun what-is-it?()
  (let((thing (oneof unknown-thing)))
    (ask thing (menu-edit))
    (setq thing (make-edit-validate thing typed-thing))
    (setq thing
	  (if (ask thing bigthing)
	      (transform-thing thing big-thing)
	    (transform-thing thing small-thing)))
    (case (ask thing type)
      (animal (setq thing (transform-thing thing animal-thing)))
      (mineral (setq thing (transform-thing thing mineral-thing)))
      (vegetable (setq thing (transform-thing thing vegetable-thing))))
    (let*((possibles '((animal (elephant giraffe bear)
			      (mouse chipmunk frog))
		      (mineral (mountain sea-shore menhir)
			       (diamond pebble grain-of-sand))
		      (vegetable (tree corn-stalk greensward)
				 (flower carrot blade-of-grass))))
	 (choices (assoc (ask thing type) possibles))
	 (mychoice (list 'guess :choose
			 (if (ask thing bigthing)
		       (car choices)
		     (cadr choices)))))
      (declare(special mychoice))
      (setq thing (transform-thing thing known-thing))
      (ask thing (show))
      (ask thing (have 'guess (cddr mychoice)))
      (ask thing (add-menu-choice mychoice))
      (ask thing (menu-edit)))
    thing
    ))