(in-package "PQKIF")

;;; KIF functions defined in the ontology PHYSICAL-QUANTITY

;;;;;;;;;;;;;;;;;;;;;;


(defmacro = (elt1 elt2)
  (let ((int-elt1 (intern-and-try-eval elt1))
	(int-elt2 (intern-and-try-eval elt2)))
    `(if (and (numberp ',int-elt1) (numberp ',int-elt2))
	(cl::=  ',int-elt1 ',int-elt2)
	(cv::ucf= ',int-elt1 ',int-elt2))))

;;
(defmacro dimension (qty)
  `(values (intern-object (cv::ucf-dimension (intern-and-try-eval ',qty)) *package*)))

;;
(defmacro compatible-quantities (q1 q2)
  `(cv::ucf-compatible-quantities (intern-and-try-eval ',q1) (intern-and-try-eval ',q2)))

;;
(defmacro + (q1 q2)
  (let ((int-q1 (intern-and-try-eval q1))
	(int-q2 (intern-and-try-eval q2)))
    `(if (and (numberp ',int-q1) (numberp ',int-q2))
	(cl::+  ',int-q1 ',int-q2)
	(print (values (intern-object (cv::ucf+ ',int-q1 ',int-q2) *package*))))))

 
;;
(defmacro - (q1 q2)
   (let ((int-q1 (intern-and-try-eval q1))
	 (int-q2 (intern-and-try-eval q2)))
     `(if (and (numberp ',int-q1) (numberp ',int-q2))
       (cl::-  ',int-q1 ',int-q2)
       (values (intern-object (cv::ucf- ',int-q1 ',int-q2) *package*)))))


;;
(defmacro expt (q alpha)
  (let ((int-q (intern-and-try-eval q))
	 (int-alpha (intern-and-try-eval alpha)))
    `(if (and (numberp ',int-q) (numberp ',int-alpha))
      (cl::expt  ',int-q ',int-alpha)
      (values (intern-object (cv::ucf-expt ',int-q ',int-alpha) *package*)))))


;;
(defmacro * (q1 q2)
  (let ((int-q1 (intern-and-try-eval q1))
	(int-q2 (intern-and-try-eval q2)))
    `(if (and (numberp ',int-q1) (numberp ',int-q2))
      (cl::*  ',int-q1 ',int-q2)
      (values (intern-object (cv::ucf* ',int-q1 ',int-q2) *package*)))))


;;
(defmacro / (q1 q2)
  (let ((int-q1 (intern-and-try-eval q1))
	(int-q2 (intern-and-try-eval q2)))
    `(if (and (numberp ',int-q1) (numberp ',int-q2))
      (cl::/  ',int-q1 ',int-q2)
      (values (intern-object (cv::ucf/',int-q1 ',int-q2) *package*)))))


;;
(defmacro definition (elt)
  `(cv::ucf-definition (intern-and-try-eval ',elt)))

;;
(defmacro magnitude (q unit)
  `(cv::ucf-magnitude (intern-and-try-eval ',q) (intern-and-try-eval ',unit)))


;;
(defmacro add-unit (qty-name qty)
  (let ((qty-interned (intern-and-try-eval qty))
	(complete-name (intern-and-try-eval qty-name)))
    `(when
      (oli::define-instance
	  ,complete-name
	  (ol-user::unit-of-measure) 
	:= ,qty-interned 
	:implementation :kif 
	:theory ol-user::standard-units-and-dimensions)
      (values ',qty-name))))

;;
(defmacro base-units (sys)
  (let ((system (intern-and-try-eval sys)))
    `(intern-object (cv::ucf-base-units ',system) *package*)))

;;
(defmacro standard-unit (system dimension)
  `(values (intern-object
	    (cv::ucf-standard-unit
	     (intern-and-try-eval ',system)
	     (intern-and-try-eval ',dimension))
	    *package*)))

;;
(defmacro system-of-units (set-unit)
  (let* ((int-set-unit (intern-and-try-eval set-unit))
	 (unit-list (if (cv::symbol-equal (car int-set-unit) 'setof) (cadr int-set-unit) nil)))
    `(when ',unit-list
      (cv::ucf-system-of-units ',unit-list))))

;;
(defmacro fundamental-dimension-set (set-dim)
    (let* ((int-set-dim (intern-and-try-eval set-dim))
	 (list-dim (if (cv::symbol-equal (car int-set-dim) 'setof) (cadr int-set-dim) nil)))
    `(when ',list-dim
      (cv::ucf-fundamental-dimension-set ',list-dim))))

;;
(defmacro dimension-decomposable-from (dim set-dim)
  (let* ((int-set-dim (intern-and-try-eval set-dim))
	 (list-dim (if (cv::symbol-equal (car int-set-dim) 'setof) (cadr int-set-dim) nil)))
    `(when ',list-dim
      (cv::ucf-dimension-decomposable-from (intern-and-try-eval ',dim) ',list-dim))))


(defmacro setof (&rest l)
  `(append '(setof) ',l))




;;;;;;;;;;;;;;

;;
(defun intern-and-try-eval (l)
  (intern-object (try-eval l) cv::*ontology-package*))

;;
(defun try-eval (l)
  (flet ((int-try-eval (x) 
		       (let ((mvl (multiple-value-list (ignore-errors (eval x)))))
			 (if (typep (cadr mvl) 'error) x (car mvl)))))
    (let ((ll (if (listp l)
		  (if (equal (car l) 'quote)
		      (cons 'quote (list l))
		      (mapcar #'(lambda (x) (intern-object (try-eval x) 'pqkif)) l))
		  (int-try-eval l))))
      (int-try-eval ll))))


;;
(defun intern-object (a package)
  (typecase a
    (number a)
    (symbol (intern (string a) package))
    (list (mapcar #'(lambda (elt)
		      (intern-object elt package))
		  a))))