;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: evalfns.lsp
;;;;    System: FIRE
;;;;   Version: v1
;;;;    Author: Praveen Paritosh
;;;;   Created: Mar 20, 2002 2:57:13
;;;;   Purpose: Provide evaluation of functions in FIRE
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, May 31, 2004 at 20:07:18 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :data)

;;; This file contains the definitions of eval functions for FIRE.
;;; Others can be added using the defEvalFn.  How these are turned into
;;; the appropriate code and KB facts is described in evaluate.lsp.

;;; ****** An inefficiency: Any EvalFn that calls Ask must keep track
;;; ****** of dependency information, returning it as a second value
;;; ****** so that the justifications produced by ASK are correct.  Doing
;;; ****** this typically means calling Ask twice, once for the antecedents
;;; ****** and once (with an appropriate response variable) to extract the
;;; ****** bit of the pattern that constitutes the answer.  It could be a lot
;;; ****** more efficient to just Ask once, for the antecedent, and do the
;;; ****** pattern extraction locally on that answer.

;;; EvaluatableFunctions in the FIRE KB (QRG-GENERAL). Only a few are implemented. 
;;; Feel free to extend as needed. 

;;;(ActiveSubjectForRelnInArgFn AgentivePluralFormFn AgentiveSingFormFn
;;; AlgebraicSimplifyFn CombineViaFn ComputeImplicitISObjectFn CycELVariableFn
;;; DateAfterFn DateBeforeFn DateFromIntegerFn EnglishSuffixationFn ExponentFn
;;; ExtractViaFn FirstInListFn FormulaArgFn FormulaArgSetFn FormulaArityFn
;;; IdentityFn JoinListsFn LastInListFn LengthOfListFn LengthOfStringFn
;;; MaxQuantValueFn MaxRangeFn MemberFn MinQuantValueFn MinRangeFn NonThirdSingFn
;;; NthInListFn Percent PluralFormFn PlusFn PositionInListFn
;;; PositionOfItemInListFn PositionsInListFn QuantityConversionFn
;;; RelationTuplesFn RestOfListFn ReverseListFn RoundClosestFn RoundDownFn
;;; RoundUpFn SetOfListMembersFn SetOrCollectionIntersection SingularFormFn
;;; SqrPlusFn StringToIntegerFn SubLStringConcatenationFn SublistFromToFn
;;; SubstituteFormulaFn SubstituteFromListFn SubstringFn TermOverlapFn
;;; ThirdSingFn TimeElapsedFn ToleranceFn)

;; Lisp functions

(defEvalFn LengthOfListFn 
  :documentation "Computes the length of a list"
  :args (?list)
  :lispcode (if (and (listp ?list)
                     (eql (car ?list) 'TheList)
                     (listp (cdr ?list)))
              (1- (length ?list)) ;; dont count TheList
              :eval-error)
  :axioms ((arg1Isa LengthOfListFn List) 
           (resultIsa LengthOfListFn NonNegativeInteger)))

(defEvalFn CardinalityFn
  :documentation "Computes the cardinality of a set implemented in a list"
  :args (?list)
  :lispcode (if (and (listp ?list)
                     (eql (car ?list) 'TheSet) )
              (1- (length ?list)) ;; dont count TheSet
              :eval-error)
  :axioms ((arg1Isa CardinalityFn Set) 
           (resultIsa CardinalityFn NonNegativeInteger)))

(defEvalFn ListFn
  :documentation "Creates a form thats Cyc's representation of a list from the arguments passed to it, e.g. evaluating (ListFn foo bar) returns (TheList foo bar)"
  :args (:n-ary ?arglist)
  :axioms ((resultIsa ListFn List))
  :lispcode `(TheList ,@ ?arglist))

(defEvalFn MemberFn
  :args (?elt ?lst)
  :lispcode (if (and (or (eql (car ?lst) 'TheList)
                         (eql (car ?lst) 'TheSet))
                     (listp ?lst)
                     (listp (cdr ?lst)))
              (if (member ?elt (cdr ?lst))
                t
                nil)
              :eval-error)
  :documentation "(MemberFn ?elt ?lst) returns t or nil depending upon whether ?elt is present in ?lst"
  :axioms ((arg1Isa MemberFn Thing)))

(defEvalFn SublistFromToFn
  :args (?list ?from ?to)
  :lispcode (if (or (not (integerp ?from))
                    (not (integerp ?to))
                    (not (listp ?list))                        
                    (> ?from ?to) 
                    (> ?from (- (length ?list) 1))
                    (not (eql (car ?list) 'TheList)))
              :eval-error
              `(TheList ,@ (subseq (cdr ?list) (- ?from 1) ?to)))
  :axioms ((resultIsa SublistFromToFn List))
  :documentation "(SublistFromToFn ?list ?from ?to) extracts a subset of a list."
  )
  
(defEvalFn NthInListFn 
  :args (?n ?list)
  :lispcode (if (eql (car ?list) 'TheList)
              (nth (- ?n 1) (cdr ?list))
              :eval-error)
  :documentation "(NthInListFn ?n ?list) returns the ?nth element of ?list.)"
  :axioms ((resultIsa NthInListFn Thing)))

(defEvalFn TheList
  :args (:n-ary ?arglist)
  :lispcode (values `(TheList ,@ ?arglist))
  :documentation "(TheList <stuff>) refers to the list of <stuff>"
  :axioms ((resultIsa TheList List)))

(defEvalFn TheSet
    :args (:n-ary ?arglist)
  :lispcode (values `(TheSet ,@ (remove-duplicates ?arglist
                                                   :test 'equal)))
  :documentation "(TheSet <stuff>) refers to the set of <stuff>"
  :axioms ((resultIsa TheSet Set)))

;; Arithmetic, or Cyc's #$FunctionFromQuantitiesToQuantities

(defEvalFn PlusFn 
    :args (:n-ary ?arglist)
  :lispcode (if (and (listp ?arglist)
                     (every #'numberp ?arglist))
              (apply #'+ ?arglist)
              :eval-error)
  :documentation "PlusFn is n-ary addition."
  :axioms ((resultIsa PlusFn Number)))

(defEvalFn TimesFn 
    :args (:n-ary ?arglist)
  :lispcode (if (and (listp ?arglist)
                     (every #'numberp ?arglist))
              (apply #'* ?arglist)
              :eval-error)
  :documentation "TimesFn is n-ary multiplication."
  :axioms ((resultIsa TimesFn Number)))

(defEvalFn DifferenceFn 
    :args (?minuend ?subtrahend)
  :lispcode (if (and (numberp ?minuend)
                     (numberp ?subtrahend))
              (- ?minuend ?subtrahend)
              :eval-error)
  :documentation "DifferenceFn is binary subtraction."
  :axioms ((resultIsa DifferenceFn Number)))

(defEvalFn QuotientFn 
    :args (?dividend  ?divisor)
  :lispcode (if (and (numberp ?dividend)
                     (numberp ?divisor))
              (/ ?dividend ?divisor)
              :eval-error)
  :documentation "QuotientFn is division."
  :axioms ((resultIsa QuotientFn Number)))

(defEvalFn AbsoluteValueFn
    :args (?num)
  :lispcode (if (numberp ?num) 
              (abs ?num)
              :eval-error)
  :documentation "AbsoluteValueFn is absolute value."
  :axioms ((resultIsa AbsoluteValueFn Number)))

(defEvalFn ExponentFn 
    :args (?base ?exp)
  :lispcode (if (and (numberp ?base) 
                     (numberp ?exp))
              (expt ?base ?exp)
              :eval-error)
  :documentation "(ExponentFn ?base ?number) is ?base to the ?number."
  :axioms ((resultIsa ExponentFn Number)))

(defEvalFn ExpFn 
    :args (?exp)
  :lispcode (if (numberp ?exp) 
              (exp ?exp)
              :eval-error)
  :documentation "(ExpFn ?exp) is E to the ?exp."
  :axioms ((resultIsa ExpFn Number)))

(defEvalFn LogFn 
    :args (?num)
  :lispcode (if (numberp ?num) 
              (log ?num)
              :eval-error)
  :documentation "(LogFn ?num) is the logarithm of ?num."
  :axioms ((resultIsa LogFn Number)))

;; Some examples of queries, make a shakedown
;;;cl-user(4): (fire::ask-it '(evaluate ?x (PlusFn 4 5)))
;;;((evaluate 9 (PlusFn 4 5)))
;;;nil
;;;cl-user(5): (fire::ask-it '(evaluate ?x (PlusFn 4 5 (TimesFn 4 5))))
;;;((evaluate 29 (PlusFn 4 5 (TimesFn 4 5))))
;;;nil
;;;cl-user(6): (fire::ask-it '(evaluate ?x (PlusFn 4 5 (TimesFn 4 5) 30)))
;;;((evaluate 59 (PlusFn 4 5 (TimesFn 4 5) 30)))
;;;nil
;;;cl-user(7): (fire::ask-it '(evaluate ?x (PlusFn 4 5 (TimesFn 4 5) 30 (LengthOfListFn (TheList Foo Bar Baz)))))
;;;((evaluate 62 (PlusFn 4 5 (TimesFn 4 5) 30 (LengthOfListFn (TheList Foo Bar Baz)))))
;;;nil
;;;cl-user(8): (fire::ask-it '(evaluate ?x (PlusFn (PlusFn 3 8) 2)))
;;;((evaluate 13 (PlusFn (PlusFn 3 8) 2)))
;;;nil
;;;cl-user(11): (fire::ask-it '(evaluate ?x (ListFn (SublistFromToFn (TheList a b c d e f) 2 4) (PlusFn 100 200))))
;;;((evaluate (TheList (b c d) 300) (ListFn (SublistFromToFn (TheList a b c d e f) 2 4) (PlusFn 100 200))))
;;;nil
;;;cl-user(12): 
;;;nil
;;;cl-user(13): (fire::ask-it '(evaluate ?x (SublistFromToFn (TheList a b c d e f) 2 4))) 
;;;((evaluate (TheList b c d) (SublistFromToFn (TheList a b c d e f) 2 4)))

(defEvalFn MaximumFn
    :args (?set ?function)
  :lispcode (multiple-value-bind (numbers units)
                (convert-list-to-same-units 
                 (mapcar ?function (cdr ?set)))
              (cond ((eq numbers :eval-error) :eval-error)
                    (t (let ((the-max (apply 'max numbers)))
                         (if units
                           (list units the-max)
                           the-max)))))
  :documentation "(MaximumFn ?set ?function) finds the largest element of ?function mapped over ?set."
  :axioms ((resultIsa MaximumFn Thing)))
  
(defEvalFn PlusAll 
    :args (?set ?function)
  :lispcode (multiple-value-bind (numbers units)
                (convert-list-to-same-units 
                 (mapcar ?function (cdr ?set)))
              (cond ((eq numbers :eval-error) :eval-error)
                    (t (let ((the-sum (apply '+ numbers)))
                         (if units
                           (list units the-sum)
                           the-sum)))))
  :documentation "(PlusAll ?set ?function) sums the result of mapping ?function over ?set."
  :axioms ((resultIsa PlusAll Number)))

(defun convert-list-to-same-units (maybe-units-and-numbers)
  (let ((units nil))
    (values 
     (delete nil 
             (mapcar #'(lambda (elt)
                         (cond ((numberp elt) ;; No dimension
                                (cond (units ;; But others have units, so punt
                                       (return-from convert-list-to-same-units
                                         (values :eval-error)))
                                      (t elt)))
                               ((or (not (listp elt))
                                    (cddr elt) ;; must be (<units> <value>)
                                    (not (numberp (cadr elt)))
                                    (not (symbolp (car elt)))
                                    (not (fire::instance-of? (car elt) 'd::UnitOfMeasure fire:*reasoner*)))
                                nil) ;; Ignore missing data.
                               ((null units) ;; First thing with units
                                (setq units (car elt))
                                (cadr elt))
                               ((equal units (car elt)) ;; Same units case
                                (cadr elt))
                               (t (let ((converted-value
                                         (convert-to-units units (car elt) (cadr elt))))
                                    (cond ((not (numberp converted-value))
                                           (return-from convert-list-to-same-units (values :eval-error)))
                                          (t converted-value))))))
               maybe-units-and-numbers))
             units)))

(defun convert-to-units (desired-units given-units value)
  ;; This really needs to use the KB.  But not here and now
  (case desired-units
    (SquareMile (case given-units
                  (SquareKilometer (* 0.386102 value))
                  (Acre (/ value 640.0))
                  (t :eval-error)))
    (SquareKilometer (case given-units
                       (SquareMile (* 2.589988 value))
                       (Acre (/ value 247.105381))
                       (t :eval-error)))
    (Acre (case given-units
            (SquareKilometer (* value 247.105381))
            (SquareMile (* value 640))
            (t :eval-error)))
    (t :eval-error)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Quantifiers and selectors
;;;
;;; FunctionToArg
;;; (FunctionToArg N PRED) denotes the function defined by treating all but the Nth
;;; arguments to PRED as inputs, and the Nth one as being the output.

(defEvalFn FunctionToArg
    :args (?nth ?predicate)
  :lispcode (let ((arity (fire:arity ?predicate)))
              (cond ((or (not (integerp arity))
                         (not (integerp ?nth))
                         (< ?nth 0)
                         (> ?nth arity))
                     :eval-error)
                    (t ;; Need to make the lambda
                     (make-lambda-for-FunctionToArg arity ?nth ?predicate))))
  :documentation "(FunctionToArg N PRED) denotes the function defined by treating all but the Nth arguments to PRED as inputs, and the Nth one as being the output."
  :axioms ((resultIsa FunctionToArg Function)))
  
(defun make-lambda-for-FunctionToArg (arity ?nth ?predicate)
  (multiple-value-bind (inputs output args)
      (create-extractor-function-arg-lists arity ?nth)
    (let* ((form (append (list ?predicate)
                         (mapcar #'(lambda (var)
                                     (if (eq var output)
                                       `(quote ,var)
                                       var))
                           args)))
           (body (car (fire::ask-it form :response output :number 1)))
           (ante (car (fire:ask-it form :number 1))))
      (cond ((null ante) (return-from make-lambda-for-FunctionToArg
                           (values :eval-error nil)))
            (t (values 
                (eval `(lambda ,inputs ,body))
                (list ante)))))))

(defun create-extractor-function-arg-lists (arity nth)
  (let ((all-vars nil)
        (input-vars nil)
        (output-var nil))
    (dotimes (i arity (values (nreverse input-vars) output-var (nreverse all-vars)))
      (let* ((this (1+ i))
             (this-var (intern (format nil "?v~D" this))))
        (cond ((= this nth) 
               (setq output-var this-var))
              (t (push this-var input-vars)))
        (push this-var all-vars)))))

(defEvalFn TheClosedRetrievalSetOf
    :args (?var ?statement)
  :lispcode (let ((time-cwa (fire::make-closed-retrieval-set-cwa ?var ?statement))
                  (antes (fire::ask-it ?statement))
                  (members (remove-duplicates 
                            (fire:ask-it ?statement :response ?var))))
              (fire::tell time-cwa fire::*reasoner* :closed-set-retrieval-cwa
                          :WM)
              (values `(TheSet ,@ members) (cons time-cwa antes)))
  :documentation "(TheClosedRetrievalSetOf ?var ?statement) is evaluated by using ASK."
  :axioms ((resultIsa TheClosedRetrievalSetOf Set)))

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