;; -*- Mode: LISP; Syntax: Common-lisp; Package: LOOM; Base: 10. -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                             ;
;  Copyright (c) 1999 by the University of Southern California                ;
;  All rights reserved.                                                       ;
;                                                                             ;
;  Permission to use, copy, modify, and distribute this software and its      ;
;  documentation in source and binary forms for non-commercial purposes       ;
;  and without fee is hereby granted, provided that this notice               ;
;  be reproduced in any copy or modification thereof, and that                ;
;  any documentation, advertising materials, and other materials related      ;
;  to such distribution and use acknowledge that the software was             ;
;  developed by the University of Southern California, Information            ;
;  Sciences Institute.  The name of the University may not be used to         ;
;  endorse or promote products derived from this software without             ;
;  specific prior written permission.                                         ;
;                                                                             ;
;  THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT THE   ;
;  SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS PROVIDED   ;
;  "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,          ;
;  WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND          ;
;  FITNESS FOR A PARTICULAR PURPOSE.                                          ;
;                                                                             ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; BEHAVIORS2 (ABOX)


;;; CONTAINS PIECES OF CODE FOR ADDING "deffilter" AND FOR
;;;    GENERATING METHOD SEQUENCES


;;; THIS CODE MAINLY RENAMES :missing-method TO :on-missing-method, ETC.

(setq *operator/option-table*
      '((:filters
	  (:overrides :most-specific :last-one
			:select-one :select-all :error :warning)
	  filters)
	(:on-missing-method
	  (:warning :no-op :error :suspend)
	  on-missing-method-option)
	;; THIS IS JUST A PLACE HOLDER:
	(:on-failed-method				; RMM 12/18/89
	  (:fail :retry)
	  on-failed-method-option)))

(setq *operator/default-option-table*
      '((:filters (:preferences :most-specific :last-one))
	(:on-missing-method :warning)))

(defmacro defoperator (name typesOfParameters
		       &key filters on-missing-method on-failed-method)
  #+TI `(TI-redefine-operator ',name ',typesOfParameters 
			      :filters ',filters :on-missing-method ',on-missing-method)
  #-TI `(redefine-operator ',name ',typesOfParameters 
			   :filters ',filters :on-missing-method ',on-missing-method)
  )

;----------------------------------------------------------------------------
  ;;
;;;;;; Filters
  ;;

;;; *filter-table* is an association list ...
(defparameter *filter-table* nil)

(eval-when (compile load eval)
  (defmacro deffilter (filterKeyword (methodsVariable) &body body)
    ;;
    `(define-filter ',filterKeyword ',`(lambda (,methodsVariable) ,@body)) )
  
  (defun define-filter (filterKeyword lambdaDefinition)
    ;;
    (let ((filtersEntry (assoc :filters *operator/option-table*)))
      (when (not (keywordp filterKeyword))
	(error "Illegal filter name `~S' -- the name of a filter must be a keyword."
	       filterKeyword))
      (pushnew filterKeyword (second filtersEntry))
      ;...
      ))
  ) ;; end eval-when

(deffilter :most-specific (methods)
  ;; Return the most-specific of the methods in "methods", determined
  ;;    by the specificity of their situation patterns;
  (for m in methods do (setf (marked-p m) nil))
  (for m in methods
       when (not (marked-p m))
       do
       (for reject in (less-specific-methods m)
	    do (setf (marked-p reject) t)))
  (for m in methods
       when (not (marked-p m))
       collect m) )


(deffilter :last-one
  :input-variable methods
  :
  (for m in (methods (operator (car methods)))
       when (member m methods)
       do (return (list m))) )



(deffilter :last-one (methods)
  ;; Return the method closest to the front of the list of
  ;;    methods attached the operator -- this was the most
  ;;    recently-defined method; 
  (for m in (methods (operator (car methods)))
       when (member m methods)
       do (return (list m))) )

(defun generate-methods (candidateMethods filters operator arguments &key generator-body)
  ;;
  ;; TO DO: CONSIDER ADDING PARAMETER TO PERFORM ALL SUCCESSFUL METHODS (ORDERED
  ;;    FROM BEST TO WORST) -- POSSIBLY THIS ISN'T OF ANY USE;
  (let ((level 0)
	(deepestLevel (length filters))
	(state (make-array 5))
	(more-to-come-p (make-array 5))
	methods)
    (flet ((apply-ith-filter
	     ()
	     (let (moreToComeP)
	       (multiple-value-setq (methods moreToComeP)
		 (funcall (nth level filters) methods state[level]))
	       (setf more-to-come-p[level] moreToComeP)))
	   (perform-one-method
	     ()
	     (multiple-value-bind (value successP)
		 (apply-operator operator arguments)
	       (when successP
		 (return-from generate-methods value))))
	   (backtrack
	     ()
	     (loop
	       (when (<= level 1)
		 (return-from generate-methods :fail))
	       (decf level)
	       (when more-to-come-p[level]	; successful backtrack
		 (apply-ith-filter)
		 (return)))))
      (setq methods candidateMethods)
      (loop
	(cond
	  ((null methods)
	   (backtrack))
	  ((and (cdr methods)
		(< level deepestLevel))
	   (incf level)
	   (integrity-check (setq state[level] nil))
	   (apply-ith-filter))
	  (t
	   (for m in methods
		do (perform-one-method))))))))


;;; BEHAVIORS2 (ABOX)


;;; CONTAINS PIECES OF CODE FOR ADDING "deffilter" AND FOR
;;;    GENERATING METHOD SEQUENCES


;;; THIS CODE MAINLY RENAMES :missing-method TO :on-missing-method, ETC.

(setq *operator/option-table*
      '((:filters
	  (:overrides :most-specific :last-one
			:select-one :select-all :error :warning)
	  filters)
	(:on-missing-method
	  (:warning :no-op :error :suspend)
	  on-missing-method-option)
	;; THIS IS JUST A PLACE HOLDER:
	(:on-failed-method				; RMM 12/18/89
	  (:fail :retry)
	  on-failed-method-option)))

(setq *operator/default-option-table*
      '((:filters (:preferences :most-specific :last-one))
	(:on-missing-method :warning)))

(defmacro defoperator (name typesOfParameters
		       &key filters on-missing-method on-failed-method)
  #+TI `(TI-redefine-operator ',name ',typesOfParameters 
			      :filters ',filters :on-missing-method ',on-missing-method)
  #-TI `(redefine-operator ',name ',typesOfParameters 
			   :filters ',filters :on-missing-method ',on-missing-method)
  )

;----------------------------------------------------------------------------
  ;;
;;;;;; Filters
  ;;

;;; *filter-table* is an association list ...
(defparameter *filter-table* nil)

(eval-when (compile load eval)
  (defmacro deffilter (filterKeyword (methodsVariable) &body body)
    ;;
    `(define-filter ',filterKeyword ',`(lambda (,methodsVariable) ,@body)) )
  
  (defun define-filter (filterKeyword lambdaDefinition)
    ;;
    (let ((filtersEntry (assoc :filters *operator/option-table*)))
      (when (not (keywordp filterKeyword))
	(error "Illegal filter name `~S' -- the name of a filter must be a keyword."
	       filterKeyword))
      (pushnew filterKeyword (second filtersEntry))
      ;...
      ))
  ) ;; end eval-when

(deffilter :most-specific (methods)
  ;; Return the most-specific of the methods in "methods", determined
  ;;    by the specificity of their situation patterns;
  (for m in methods do (setf (marked-p m) nil))
  (for m in methods
       when (not (marked-p m))
       do
       (for reject in (less-specific-methods m)
	    do (setf (marked-p reject) t)))
  (for m in methods
       when (not (marked-p m))
       collect m) )


(deffilter :last-one
  :input-variable methods
  :
  (for m in (methods (operator (car methods)))
       when (member m methods)
       do (return (list m))) )



(deffilter :last-one (methods)
  ;; Return the method closest to the front of the list of
  ;;    methods attached the operator -- this was the most
  ;;    recently-defined method; 
  (for m in (methods (operator (car methods)))
       when (member m methods)
       do (return (list m))) )

(defun generate-methods (candidateMethods filters operator arguments &key generator-body)
  ;;
  ;; TO DO: CONSIDER ADDING PARAMETER TO PERFORM ALL SUCCESSFUL METHODS (ORDERED
  ;;    FROM BEST TO WORST) -- POSSIBLY THIS ISN'T OF ANY USE;
  (let ((level 0)
	(deepestLevel (length filters))
	(state (make-array 5))
	(more-to-come-p (make-array 5))
	methods)
    (flet ((apply-ith-filter
	     ()
	     (let (moreToComeP)
	       (multiple-value-setq (methods moreToComeP)
		 (funcall (nth level filters) methods state[level]))
	       (setf more-to-come-p[level] moreToComeP)))
	   (perform-one-method
	     ()
	     (multiple-value-bind (value successP)
		 (apply-operator operator arguments)
	       (when successP
		 (return-from generate-methods value))))
	   (backtrack
	     ()
	     (loop
	       (when (<= level 1)
		 (return-from generate-methods :fail))
	       (decf level)
	       (when more-to-come-p[level]	; successful backtrack
		 (apply-ith-filter)
		 (return)))))
      (setq methods candidateMethods)
      (loop
	(cond
	  ((null methods)
	   (backtrack))
	  ((and (cdr methods)
		(< level deepestLevel))
	   (incf level)
	   (integrity-check (setq state[level] nil))
	   (apply-ith-filter))
	  (t
	   (for m in methods
		do (perform-one-method))
	   ;; if we reach here, none of the methods succeeded
	   (when more-to-come-p[level]
	     (apply-ith-filter))))) )))

