;;; -*- Mode:Common-Lisp; Package:CONVERSION; Base:10 -*-

;;  Functions on Units and Dimensions
;;  Author : Yves PELIGRY
;;  08/02/93
;;





(in-package "CONVERSION")


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


;; 0000
;;
(defun load-unit-ontology(&key (file "~/unit-and-dim/standard-units-and-dimensions.lisp")
			       (package (find-package "CONVERSION")))
   (let ((*package* package))
     (setq *ucv-all-ontologies* (remove-duplicates (cons (list (list file package) t) *ucv-all-ontologies*)
				  :from-end t :key #'car :test #'equal))
     (ol::in-implementation :kif)
     (ol::onto-load file)))

;;
(defvar *ucv-all-ontologies*    nil)
(defvar *ucv-system-units*      nil)
(defvar *ucv-all-units*         nil)
(defvar *ucv-all-dimensions*    nil)
(defvar *ucv-all-dimensions2*   nil)
(defvar *ucv-dimension-matrix*  nil)
(defvar *ucv-dimension-matrix2* nil)
(defvar *ucv-unit-matrix*       nil)

(setq *theory* 'ontolingua-user::standard-units-and-dimensions)
(setq *stream-output* (make-string-output-stream))
(defvar *ontology-package* (find-package "ONTOLINGUA-USER"))

;; 000
;; reads the theory, builds the matrix and checks the completeness, the consistency and the 'orthogonality' of the system
;;
(defmacro read-unit-theory (&key  
                            (unit '(ontolingua-user::unit-of-measure)) 
                            (dimension '(ontolingua-user::physical-dimension ontolingua-user::fundamental-dimension)) 
                            (system 'ontolingua-user::SI-unit)
                            (theory *theory*)
                            (identity-unit 'ontolingua-user::identity-unit)
			    (identity-dimension 'ontolingua-user::identity-dimension)
                            (package (find-package "CONVERSION")))
  (let ((*package* package))
    `(ucf-read-unit-theory  ',theory ',system ',unit ',dimension ',identity-unit ',identity-dimension)))
  
;;
(defun ucf-read-unit-theory (theory system unit dimension id-unit id-dim) 
  
  (let ((all-units (ucf-all unit theory)))

    (ucm-in-list *ucv-system-units* theory system
		 (lambda (th sys) (intersection (ucf-get-sys-units th sys) all-units)))

    (ucm-in-list *ucv-all-units* theory system 
		 (lambda (th sys) (append (set-difference all-units (ucf-get-variable th sys *ucv-system-units*)) 
					  (ucf-get-variable th sys *ucv-system-units*))))

    (ucm-in-list *ucv-all-dimensions* theory system 
		 (lambda (th sys) (ucf-all-dim  (ucf-get-variable th sys *ucv-all-units*) dimension th)))

    (ucm-in-list *ucv-all-dimensions2* theory system 
		 (lambda (th sys) (ucf-all-dim2  (ucf-get-variable th sys *ucv-all-units*) dimension th)))

    (ucm-in-list *ucv-dimension-matrix* theory system
		 (lambda (th sys) (ucf-check-dim-mat 
				    (ucf-trig 
				      (ucf-add-lines
					(ucf-dim-mat
					  (ucf-get-variable th sys *ucv-all-dimensions*) th sys id-unit id-dim))))))
		 
    (ucm-in-list *ucv-dimension-matrix2* theory system
		 (lambda (th sys) (ucf-check-dim-mat2 
				    (ucf-trig 
				      (ucf-add-lines
					(ucf-dim-mat
					  (ucf-get-variable th sys *ucv-all-dimensions2*) th sys id-unit id-dim))))))
    
    (ucm-in-list *ucv-unit-matrix* theory system
		 (lambda (th sys) (ucf-check-unit-mat 
				    (ucf-trig
				      (ucf-add-lines
					(ucf-unit-mat 
					  (ucf-get-variable th sys *ucv-all-units*) th id-unit))))))

    (and system 
	 (ucf-check-exist-system theory system)
	 (ucf-check-system (ucf-get-variable theory system *ucv-dimension-matrix*)
			   (ucf-get-variable theory system *ucv-unit-matrix*)
			   (length (ucf-get-variable theory system *ucv-system-units*))))

    (if (ucf-check-completeness 
	  (ucf-get-variable theory system *ucv-unit-matrix*)
	  (ucf-get-variable theory system *ucv-dimension-matrix*))

	(values (ucf-get-variable theory system *ucv-all-units*) 
		(ucf-get-variable theory system *ucv-all-dimensions*))

	nil)))


;; 00.i
;; conversion from unit to unit
;;
(defmacro conversion-into-unit (quantity1 quantity2 quantity3 
				&key
				(package (find-package "CONVERSION"))
				(theory *theory*))
  (let ((*package* package)
	(system (ucf-get-system theory)))
    `(ucf-conversion-into-unit ',quantity1 ',quantity2 ',quantity3
			        ',theory ',system)))

(defun ucf-conversion-into-unit (unit0 unit1 unit2 theory system)
  
  (let ((ucv-dvp-expr (ucf-dvp-expr unit0 unit1 unit2)))
   
    (and

      (if (and (ucf-get-variable theory system *ucv-all-units*)
	       (ucf-get-variable theory system *ucv-all-dimensions*) 
	       (ucf-get-variable theory system *ucv-dimension-matrix*)
	       (ucf-get-variable theory system *ucv-dimension-matrix2*) 
	       (ucf-get-variable theory system *ucv-unit-matrix*))
	  t
	  (and (format *stream-output* "~%  load the theory first") nil))
      
      (ucf-check-exist-expr ucv-dvp-expr (ucf-get-variable theory system *ucv-all-units*))
	 
      (ucf-check-equal-dim 
       (ucf-can-dim ucv-dvp-expr (ucf-get-variable theory system *ucv-all-dimensions*)) 
       (ucf-get-variable theory system *ucv-dimension-matrix*))
	 
      (ucf-get-conv
       (ucf-can-unit ucv-dvp-expr 
		     (ucf-get-variable theory system *ucv-all-units*))
       (ucf-get-variable theory system *ucv-unit-matrix*)))))


;; 00.ii
;; conversion from unit to system
;;
(defmacro conversion-into-system (quantity1 quantity2 
				  &key 
				  (package (find-package "CONVERSION"))
				  (system 'ontolingua-user::SI-unit)
				  (theory *theory*))
  (let ((*package* package))
    `(ucf-conversion-into-system ',quantity1 ',quantity2 ',system ',theory)))


(defun ucf-conversion-into-system (q1 q2 system theory)
 
  (let ((ucv-dvp-expr (ucf-dvp-expr q1 q2 1)))

   (and 

     (or system (and (format *stream-output* "~%  a system has to be specified") nil))

     (ucf-check-exist-system theory system)

     (if (and (ucf-get-variable theory system *ucv-system-units*) 
	      (ucf-get-variable theory system *ucv-all-units*)
	      (ucf-get-variable theory system *ucv-all-dimensions*) 
	      (ucf-get-variable theory system *ucv-dimension-matrix*)
	      (ucf-get-variable theory system *ucv-dimension-matrix2*) 
	      (ucf-get-variable theory system *ucv-unit-matrix*))
	 t
	 (and (format *stream-output* "~%  load the theory first") nil))
     
     (ucf-check-exist-expr ucv-dvp-expr (ucf-get-variable theory system *ucv-all-units*))	 

     (ucf-solve-sys
       (ucf-get-variable theory system *ucv-unit-matrix*)
       (ucf-can-unit ucv-dvp-expr (ucf-get-variable theory system *ucv-all-units*)) 
       (length (ucf-get-variable theory system *ucv-system-units*))))))

  

;; 0
;; get all the units and dimensions

;; 0.1
;; get the list of the elements of a class in the list-of-class
;; the search is made in the theory and in the package specified in the main function
;;                  
(defun ucf-all (list-of-class theory)
  (sort (mapcan #'(lambda (elt) 
		    (when (member (ucf-get-class elt theory) list-of-class) (list elt)))
		(oli::theory-index (oli::find-theory theory :kif nil)))
	#'string-lessp))

;; 0.2.a
;; get the list of the dimensions and sorts the list in a way that
;; the first dimensions do not correspond to any unit in the system
;;
(defun ucf-all-dim (all-units dimension theory)
  (let ((all-dim (ucf-all dimension theory)))
    (append all-dim all-units)))

;; 0.2.b
;; get the list of the dimensions and sorts the list in a way that
;; the first dimensions do not correspond to the units in the system
;;
(defun ucf-all-dim2 (all-units dimension theory)
  (let ((all-dim (ucf-all dimension theory)))
    (append all-units all-dim)))

;; 0.1.a 
;; return the class of the element
(defun ucf-get-class (elt theory)
  (let ((int-def (oli::get-forms-for-kif-constant elt theory)))
    (if (eq (third (car int-def)) ':=)
	(car (second int-def))
	(car (third (car int-def))))))


;; I 
;; transformation of the request in a first internal format


;; I.1 
;; develops the units in a first internal format :
;; unit0 unit1 unit2 -> ((base-unit0 alpha0)(base-unit1 alpha1) ... (1 magnitude)
;; where base-unit is a an elementary unit (i.e. not composed) and alpha is the power of the unit
;; e.g. 18 (KIF:* (KIF:EXPT meter 2) (KIF:* second kilogram))  (KIF:* pound-mass (KIF:* (KIF:EXPT mile 2) hour))
;;          -> ((hour -1)(kilogram 1)(meter 2)(mile -2)(pound-mass -1)(second 1)(1 18)
;;

(defun ucf-dvp-expr (unit0 unit1 unit2)
  (mapcar #'(lambda (x) (if (numberp (car x))
			    x
			    (cons (read-from-string (format nil "ontolingua-user::~a" (car x))) (cdr x))))
	  (ucf-sort (ucf-dvp-rel (list 'KIF:/ (list 'KIF:* unit0 unit1) unit2)))))

;; I.1.a & IV.*...
;; develops one unit or dimension : translate operations of units into a list of units and their exponent
;; (KIF:* 'meter 'second) -> ((meter 1)(second 1))
;;
(defun ucf-dvp-rel (l &optional l-int (exp 1))
  (cond
    ((not (listp l))   
     (setq l-int (cons (list l exp) l-int)))
    ((ucf-listnumberp (cdr l))
     (setq l-int (cons (list (eval l) exp) l-int)))
    ((equal (symbol-name (car l)) "*")
     (setq l-int (append (ucf-dvp-rel (second l) l-int exp) (ucf-dvp-rel (third l) l-int exp))))
    ((equal (symbol-name (car l)) "/")
     (setq l-int (append (ucf-dvp-rel (second l) l-int exp) (ucf-dvp-rel (third l) l-int (* -1 exp)))))
    ((equal (symbol-name (car l)) "EXPT")
     (setq l-int (ucf-dvp-rel (second l) l-int (* (third l) exp))))))

;; in order to evaluate numerical expressions entered in the ontology

(defun kif:expt (a b) (expt a b))

(defun kif:* (a b) (* a b))

(defun kif:/ (a b) (/ a b))
    
;; I.1.a
(defun ucf-listnumberp (l)
  (eval (cons 'and (mapcar #'numberp l))))


;;;;;;;;;
;; I.1.b
;; sorts and compile the list of units of a relation
;; ((meter 1)(3 1)(4 2)(meter -1)(second 2)) -> ((second 2)(1 48))
;;
(defun ucf-sort (l)
  (append (ucf-compile (sort  (mapcan #'(lambda (x) (unless (numberp (car x)) (list x))) l) #'string-lessp :key #'car))
	  (list (list 1 (ucf-get-coeff l)))))

;; I.1.b.i
;; warning : Texas doesn't have the same typep (it takes only one argument) 
;;
(defun ucf-get-coeff(ll)
  (let ((caarll (caar ll)))
    (cond (ll
	   (if (numberp caarll)
	       (* (ucf-get-coeff (cdr ll)) (expt 
					      (if (typep caarll 'float) 
						  (coerce caarll 'double-float)
						  caarll)
					      (cadar ll)))
	       (ucf-get-coeff (cdr ll))))
	  (t 1))))


;; I.1.b.ii & I.2.b
;; ((a 1)(a 2)(b 3)) -> ((a 3)(b 3)) 
;;
(defun ucf-compile (l)
  (when l
    (cond ((eq (caar l) (caadr l))
	   (if (zerop (+ (cadar l) (cadadr l))) 
	       (ucf-compile (cddr l))
	       (ucf-compile (cons (list (caar l) (+ (cadar l) (cadadr l))) (cddr l)))))
	  (t
	   (cons (car l) (ucf-compile (cdr l)))))))
   


;; I.2
;; get the dimension of a given unit if it is defined in the ontology (not to be confounded with 'dimension')
;;
(defun ucf-get-dim (unit theory)
  (let ((int-def (oli::get-forms-for-kif-constant unit theory)))
    (if (numberp unit)
	1
	(third (find-if #'(lambda(x) (and (consp x) (member (car x) (list 'ontolingua-user::dimension
									  'onto-user::dimension
									  'ol-user::dimension))))
			(if (member (third (car int-def)) (list 'ontolingua-user::=
								'onto-user::=
								'ol-user::=))
			    (cdr int-def)
			    (car int-def)))))))

;; II
;; checks if the basics elements of the composition are included in the ontology


;; II.1
;;
(defun ucf-check-exist-expr (dvp-list all-elt)
  (let ((ghosts (mapcan #'(lambda(x) (when (null (member (car x) (cons 1 all-elt))) (list (car x)))) dvp-list)))
    (if (null ghosts)
	t
	(and
	  (format *stream-output* "~%  unit(s) unknown : ~a"  ghosts)
	  nil))))

;;
;; should check if the theory exists, if class of unit and dimensions exist within this theory 
;(defun ucf-check-exist-datas (theory) 
;  (if (theory-p theory)
;      t
;      (and (format *stream-output* "~%  theory ~a is unknown" theory) nil)))
   
     

;; III
;; transformation of the request into a second internal format

;; III.1
;; for the units
;;
(defun ucf-can-unit (dvp-unit all-units)
  (ucf-can dvp-unit (append all-units (list 1))))

;; III.2
;; for the dimensions
;;
(defun ucf-can-dim (dvp-dim all-dim)
  (ucf-can dvp-dim  (append all-dim (list 1))))

;; III.*.a
;; the new format can be used more easily for computation.
;; ((a 1)(c 3)(d 2)) (a b c d e) -> (1 0 3 2 0)
;;
(defun ucf-can (dvp all)
  (let* ((elt (car all))
	 (queue (cdr all))
	 (duo (or (cadr (find-if #'(lambda(x) (and (consp x) (eq (car x) elt))) dvp)) 0)))
    (if queue
	(append (list duo) (ucf-can dvp (cdr all)))
	(list duo))))


;; IV
;; building of matrix which are a new form of all the relations included in the ontology   
;; a first matrix is built which is the direct translation of the relations
;; this matrix is then triangulated 
   
;; IV.1
;; for the dimensions
;;
(defun ucf-dim-mat (all-dim theory system id-unit id-dim)
  (let ((order (append all-dim (list 1))))
    (append
      (ucf-dim-unif (ucf-mat all-dim all-dim theory))
      (list (ucf-can (list (list id-dim 1) '(1 1)) order)
	    (ucf-can (list (list id-unit 1) '(1 1)) order))
      (mapcan #'(lambda(x) (let ((dim (ucf-get-dim x theory)))
			     (when dim (list (ucf-can (append (ucf-dvp-rel (list 'KIF:/ dim x)) '((1 1))) order)))))
	      (ucf-get-variable theory system *ucv-all-units*)))))

;;
;;
(defun ucf-dim-unif (mat)
  (flet ((bigcar (x) (reverse (cdr (reverse x)))))
    (mapcar #'(lambda (x) (append (bigcar x) '(1))) mat)))


;; IV.2
;; for the units
;;
(defun ucf-unit-mat (all-units theory id-unit)
  (append (ucf-mat all-units all-units theory) 
	  (list (ucf-can (list (list id-unit 1) '(1 1)) (append all-units (list 1))))))

;; IV.*.a
;; get the first matrix
;; for both units and dimensions
;; e.g.   a = (* 5 (* e (expt b 2)))
;;        d = (* 2 a)
;;        (a b c d e)
;;                 -> ((-1 2 0 0 1 5)
;;                     (1 0 0 -1 0 2))
;; 
(defun ucf-mat (order all theory)
  (mapcar #'(lambda(x) (ucf-can (ucf-sort (ucf-dvp-rel (list 'KIF:/ (cadr x)(car x)))) (append order (list 1))))
	  (mapcan #'(lambda(x) (ucf-get-rel x theory)) all)))

;; IV.*.a.i
;; get the relations included in the definition of the unit or the dimension
;; e.g. newton -> ((newton (KIF:* kilogram (KIF:* meter (KIF:EXPT second -2))))(newton (KIF:/ watt meter)))
;;
(defun ucf-get-rel (elt theory)
  (flet ((int-get-rel (def)
		      (mapcan #'(lambda(x)
				  (and (listp x) (member (car x) (list '= 'KIF:=)) (list (list elt (car (last x)))))) def)))
    (let ((int-def (oli::get-forms-for-kif-constant elt theory 'oli::onto-instance)))
      (cond ((member (third (car int-def)) (list ':= 'KIF:=))
	     (cons (list elt (fourth (car int-def))) (int-get-rel int-def)))
	    (t
	     (int-get-rel (car int-def)))))))


;; IV.*.b
;; triangulate the matrix 
;; but look at these 3 properties :
;;   look at the operation on line definition!
;;   when the elt on the diagonal is null put a null line
;;   the elt on the diagonal is either 1 or 0
;
(defun ucf-trig (mat) 
  (let ((int-mat
	  (cond
	    ((null mat)
	     '((1)))
	    ((null (cdar mat))  
	     mat)
	    (t
	     (ucf-zero mat)))))
    (if (null (and mat (cdar mat)))
	int-mat
	(if (zerop (caar int-mat))
	   (ucf-rebuild (make-list (length (car int-mat)) :initial-element 0)(ucf-trig (ucf-less-col int-mat)))
	   (ucf-rebuild (car int-mat) (ucf-trig (ucf-extract int-mat)))))))

;; IV.*.b.i
;; do operations on the lines of the matrix to get zero on the first column for all 
;;
(defun ucf-zero (mat &optional(compt 0)) 
  (let ((alpha (caar mat))
	(carmat (car mat)))
    (cond
      ((and (zerop alpha) (< compt (length mat)))
       (setq compt (1+ compt))
       (ucf-zero (append (cdr mat) (list carmat)) compt))
      ((= (length mat) compt)
       (cons (make-list (length carmat) :initial-element 0) mat))
      (t
       (cons (ucf-line-unif carmat)     
	     (mapcar #'(lambda (line) (if (zerop (car line))
					  line
					  (ucf-line-op line carmat (* (car line) (/ -1 alpha)))))
		     (cdr mat)))))))

;; IV.*.b.ii
;; extract a matrix (n-1,p-1) from a matrix (n,p)
;;
(defun ucf-extract (mat)
  (mapcar #'cdr (cdr mat)))

;; IV.*.b.iii
;; build a matrix (n,p) from one vector (1 p) and a matrix (n-1,p-1)
;;
(defun ucf-rebuild (line mat)
  (cons line (mapcar #'(lambda(x) (cons 0 x)) mat)))

;; IV.*.b.iv
;; suppress the first column of a matrix
;;
(defun ucf-less-col (mat)
  (mapcar #'cdr mat))

;; IV.*.b.i.i
;; uniformisation of a line (not a simple one, look at the last element)
;; e.g. (3 3 6 27) -> (1 1 2 3)
;;
(defun ucf-line-unif (line)
  (flet ((cut-queue (li) (reverse (cdr (reverse li))))
	 (queue (li) (car (last li))))
    (let ((alpha (car line)))
      (if (zerop alpha) 
	  line
	  (append 
	    (mapcar #'(lambda(x) (/ x alpha)) (cut-queue line))
	    (list (expt (queue line) (/ 1 alpha))))))))

;; IV.*.b.i.ii
;;  L1 -> L1 + alpha L2
;;  operation on lines  (not a simple one, look at the last element)
;; the operators '+' and '*' could not be used simply because
;; for the last element an addition corresponds to a multiplication
;; -the logarithm could have been used but we would have lost precision in the calculus- )
;; e.g. L L -1 -> (0 0 ... 0 1) !
;;
(defun ucf-line-op (line1 line2 alpha)
  (flet ((cut-queue (line) (reverse (cdr (reverse line))))
	 (queue (line) (car (last line))))
    (append
      (mapcar #'(lambda(x y) (+ x (* alpha y))) (cut-queue line1) (cut-queue line2))
      (list (* (queue line1) (expt (queue line2) alpha))))))



;; V
;; Verification of the constitency of the system
;; i.e. if definitions of units or dimension are not contradictory
;; e.g. meter = (KIF:/ kilometer 1000) & kilometer = (KIF:/ meter 1000)
;; The system is inconsistent if and only if
;;                      the matrix of the system is (n+k,n) ,k>0
;;                      and the k+1 last lines are different from (0 ... 0) or (0 ... 0 1)
;; note that a consistent system may still be incomplete 

;; V.1
;; for the dimensions
;;
(defun ucf-check-dim-mat (ucv-dim-mat)
  (when (ucf-check-mat ucv-dim-mat "dimension") (ucf-square ucv-dim-mat)))

;;
(defun ucf-check-dim-mat2 (ucv-dim-mat)
  (when (ucf-check-mat ucv-dim-mat nil) (ucf-square ucv-dim-mat)))

;; V.2
;; for the units
;;  
(defun ucf-check-unit-mat (ucv-unit-mat)
  (when (ucf-check-mat ucv-unit-mat "unit") (ucf-square ucv-unit-mat)))

;; V.*.a
;; for both
;;
(defun ucf-check-mat (mat type)
  (flet ((checker(line) (consp (member (car (last line)) '(0 1 1.0 1.0d0)))))
    (let ((last-lines (nthcdr (max (1- (length (car mat))) 0) mat)))
      (or (null last-lines)
	  (or (eval (cons 'and (mapcar #'checker last-lines)))
	      (and (when type (format *stream-output* "~%warning : the system of ~a is inconsistent~%" type)) nil))))))

;; V.*.b
;; remove the last lines of the matrix to make it square
;;
(defun ucf-square (mat)
  (reverse (nthcdr (- (length mat) (length (car mat))) (reverse mat))))

;; V.*.c
;; add lines to make the matrix square
;;
(defun ucf-add-lines (mat)
  (if (< (length mat) (length (car mat))) 
      (ucf-add-lines (cons (make-list (length (car mat)) :initial-element 0) mat))
      mat))

;; VI
;; "Confrontation" of the system and the request

;; VI.1
;; Check the dimensions of the units
;; 
(defun ucf-check-equal-dim (ucv-can-dim ucv-dim-mat)
  (let ((answer (numberp (ucf-solve ucv-dim-mat ucv-can-dim))))
    (unless answer (format *stream-output* "~%  check the dimensions of the units"))
    answer))

;; VI.2
;; At last the conversion itself
;; 
(defun ucf-get-conv (ucv-can-unit ucv-unit-mat)
  (let ((answer (ucf-solve ucv-unit-mat ucv-can-unit)))
    (if (numberp answer)
	(coerce answer 'single-float)
	(format *stream-output* "~%  sorry, the conversion cannot be completed, reload the ontology"))
    answer))

;; VI.*.a
;; "move to the right" the vector  
;;
(defun ucf-solve (mat vect)
  (let ((alpha (caar mat))
	(coeff (car vect)))
    (cond
      ((null (cdr mat)) 
       (coerce coeff 'single-float)) 
      ((zerop coeff)
       (ucf-solve (ucf-extract mat) (cdr vect)))
      ((zerop alpha)  
       nil)
      (t
       (ucf-solve (ucf-extract mat) (ucf-line-op (cdr vect) (cdar mat) (/ coeff (* -1 alpha))))))))


;; VII 
;; check the completeness of the system
;;
(defun ucf-check-completeness (mat-unit mat-dim)
  (if 
    (eq (ucf-freedom-deg (ucf-iter-extract mat-dim (- (length mat-dim) (length mat-unit))))
	(ucf-freedom-deg mat-unit))
    t
    (and (format *stream-output* "~%warning : the system is incomplete") nil)))

;; VII.1
;;
(defun ucf-iter-extract (mat n)
  (cond 
    ((< 0 n)
     (ucf-iter-extract (ucf-extract mat) (1- n)))
    (t mat)))

;; VII.2
;; get the freedom degree of a matrix
;;
(defun ucf-freedom-deg (mat)
  (flet ((free-deg (l l0) (if (equal (butlast l) l0) 0 1)))
    (let ((line0 (make-list (length (cdar mat)) :initial-element 0)))
   	      (apply #'+ (mapcar #'(lambda(x) (free-deg x line0)) mat)))))






;; VIII functions specific to the conversion from unit to system

;; check if the system is composed of orthogonal units :
;;  if the dimension of the space generated by the system of units is equal to the number of units
;;  if all units can be expressed in terms of units of the system
;;
(defun ucf-check-system (dim-mat unit-mat nb-sys-unit)
  (ucf-check-orth-system dim-mat nb-sys-unit)
  (ucf-check-generation unit-mat nb-sys-unit))

(defun ucf-check-orth-system (dim-mat nb-sys-unit)
  (if (zerop (ucf-freedom-deg (ucf-iter-extract dim-mat (- (length dim-mat) (1+ nb-sys-unit)))))
      t
      (and (format *stream-output* "~%error :  the system of unit is not composed by orthogonal units") nil)))

(defun ucf-check-generation (unit-mat nb-sys-unit)
  (if (eq nb-sys-unit (1- (ucf-freedom-deg unit-mat)))
      t
      (and (format *stream-output* "~%warning :  the system of unit does not generate all units") nil)))

;;
;; check if a system is defined in the ontology
;;
(defun ucf-check-exist-system (theory system)
  (if (member (car (third (car (oli::get-forms-for-kif-constant system theory)))) (list 'ontolingua-user::system-of-units
											'onto-user::system-of-units
											'ol-user::system-of-units))
      t
      (and (format *stream-output* "~%warning : the system ~a is unknown" system) nil)))

;; I don't think it is checked anywhere that the system of units corresponds to the system defined by its instances :
;; nowhere it is read that meter is an SI-UNIT .

;; 
;; "move to the right" the vector for the unit/system conversion 
;;
(defun ucf-solve-sys (mat vect dim-sys)
  (let ((alpha (caar mat))
	(coeff (car vect)))
    (cond
      ((null (cdr mat)) 
       (coerce coeff 'single-float))
      ((zerop coeff)
       (ucf-solve-sys (ucf-extract mat) (cdr vect) dim-sys))
      ((zerop alpha) 
       (if (< (length mat) (+ 2 dim-sys))
	   (ucf-solve-sys (ucf-extract mat) (cdr vect) dim-sys)
	   (format *stream-output* "~%the unit entered cannot be expressed in the system")))
      (t
       (ucf-solve-sys (ucf-extract mat) (ucf-line-op (cdr vect) (cdar mat) (/ coeff (* -1 alpha))) dim-sys)))))


;;
;; given a theory and a system finds out the units of the system
;;
(defun ucf-get-sys-units (theory system) 
  (flet ((car-eq (x y) (and (consp x) (eq (car x) y))))
    (cdr (find-if #'(lambda(x) (car-eq x 'kif:setof))
		  (find-if #'(lambda(x) (car-eq x 'kif:=)) (car (oli::get-forms-for-kif-constant system theory)))))))


;;; IX
;; get "global variables" for a given theory, system, ontology

(defun ucf-car-equal (x y)
  (and (consp x) (equal (car x) y)))

(defun ucf-get-system (theory)
  (cadar (find-if #'(lambda (x) (ucf-car-equal (car x) theory)) *ucv-system-units*))) 

(defun ucf-get-variable (theory system global-var)
  (cadr (find-if #'(lambda (x) (ucf-car-equal x (list theory system))) global-var)))


(defun ucf-get-vaariable (index global-var)
  (cadr (find-if #'(lambda (x) (ucf-car-equal (car x) index)) global-var)))

(defmacro ucm-in-list (glob theory system func)
  `(setq ,glob (remove-duplicates (cons (list (list ,theory ,system)(,func ,theory ,system)) ,glob) 
				  :from-end t :key #'car :test #'equal)))


;;; X
;; dedicated to the research of the dimension of a quantity
;;
(defun ucf-solve-dim (mat vect nb-dim &optional (rest nil))
  (let ((alpha (caar mat))
	(coeff (car vect)))
    (cond
      ((null (cdr mat))   ;; derniere ligne de la matrice
       (append rest (list coeff)))
      ((zerop coeff)      ;; pas cette dimension ds le vecteur
       (ucf-solve-dim (ucf-extract mat) (cdr vect) nb-dim (append rest '(0))))
      ((zerop alpha)      ;; 
       (if (< (length mat) (+ 2 nb-dim))
	   (ucf-solve-dim (ucf-extract mat) (cdr vect) nb-dim (append rest (list coeff)))
	   (format *stream-output* "~%the dimension of the quantity entered is not defined")))
      (t
       (ucf-solve-dim (ucf-extract mat)
		      (ucf-line-op (cdr vect) (cdar mat) (/ coeff (* -1 alpha))) 
		      nb-dim 
		      (append rest '(0)))))))



(defun ucf-decan-dim (vector all)
  (let ((vect (butlast vector)))
    (if (eval (cons 'and (mapcar #'zerop vect))) 
	'identity-dimension
	(ucf-loop-decan vect all))))


(defun ucf-decan-unit (vector all default)
  (list * (last vector) (ucf-decan vector all default)))


(defun ucf-decan (vector all default)
  (let ((vect (butlast vector)))
    (if (eval (cons 'and (mapcar #'zerop vect))) 
	default
	(ucf-loop-decan vect all))))


(defun ucf-loop-decan (vect all &optional (answer nil))
  (flet ((get-name (l) (read-from-string (symbol-name (car l)))))
    (let ((carvect (car vect)))
      (if vect
	  (cond
	    ((zerop carvect)
	     (ucf-loop-decan (cdr vect) (cdr all) answer))
	    ((= carvect 1)
	     (if answer 
		 (ucf-loop-decan (cdr vect) (cdr all) (list '* (get-name all) answer))  
		 (ucf-loop-decan (cdr vect) (cdr all) (get-name all))))
	    ((= carvect -1)
	     (if answer 
		 (ucf-loop-decan (cdr vect) (cdr all) (list '/ answer (get-name all)))
		 (ucf-loop-decan (cdr vect) (cdr all) (list 'expt (get-name all) carvect))))
	    (t
	     (if answer
		 (ucf-loop-decan (cdr vect) (cdr all) (list '* (list 'expt (get-name all) carvect) answer))  
		 (ucf-loop-decan (cdr vect) (cdr all) (list 'expt (get-name all) carvect)))))
	  answer))))

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

(defun ucf-unit-delist (l)
  (let ((factor  (cadar (last l)))
	(delist (ucf-delist (ucf-order (butlast l)))))
    (if (zerop factor)
	0
	(if delist
	    (if (= factor 1)
		delist
		(list '* factor delist))
	    factor))))


(defun ucf-dim-delist (l)
  (ucf-delist (ucf-order l)))


(defun ucf-delist (l)
  (let ((num  (ucf-dvp-mult (car l)))
	(denum (ucf-dvp-mult (cadr l))))
    (cond
      ((and num denum)
       (list '* num denum))
      (num
       num)
      (denum
        denum)
      (t
       nil))))
       
      
(defun ucf-dvp-mult (l &optional ll)
  (if l
      (ucf-dvp-mult (cdr l)
	 (if ll
	     (list '* (if (= (abs (cadar l)) 1)
			  (caar l)
			  (list 'expt (caar l) (cadar l)))
		   ll)
	     (if (= (abs (cadar l)) 1)
		 (caar l)
		 (list 'expt (caar l) (cadar l)))))	     
      ll))

(defun ucf-order (l &optional (lp nil) (ln nil))
  (if l
      (if (> (cadar l) 0)
	  (ucf-order (cdr l) (cons (car l) lp) ln)
	  (ucf-order (cdr l) lp (cons (car l) ln)))
      (list lp ln)))
	  


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



(defmacro conversion (arg1 arg2 &optional arg3)
  `(if ',arg3 
    (conversion-into-unit ,arg1 ,arg2 ,arg3)
    (conversion-into-system ,arg1 ,arg2)))


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





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


(defun ucf= (elt1 elt2 &optional (theory *theory*))
  (let* ((system (ucf-get-system theory))
	  (all-units (ucf-get-variable theory system *ucv-all-units*))
	  (all-dim (ucf-get-variable theory system *ucv-all-dimensions*))
	  (unit-mat (ucf-get-variable theory system *ucv-unit-matrix*))
	  (dim-mat (ucf-get-variable theory system *ucv-dimension-matrix*))
	  (dvp-exp (ucf-dvp-expr 1 elt1 elt2)))

     (or
       (and (ucf-check-exist-expr dvp-exp all-units)
	    (ucf-check-equal-dim (ucf-can-unit dvp-exp all-dim) dim-mat)
	    (= 1 (ucf-get-conv (ucf-can-unit dvp-exp all-units) unit-mat)))

       (and (ucf-check-exist-expr dvp-exp (set-difference all-dim all-units))
	    (ucf-check-equal-dim (ucf-can-unit dvp-exp all-dim) dim-mat)))))



(defun ucf-magnitude (q unit)
  (ucf-conversion-into-unit q 1 unit *theory* (ucf-get-system *theory*)))


(defun ucf-dimension (qty &optional (theory *theory*) )
  (let* ((system  (ucf-get-system theory))
	  (mat-dim (ucf-get-variable theory system *ucv-dimension-matrix2*))
	  (all-dim (ucf-get-variable theory system *ucv-all-dimensions2*))
	  (all-unit (ucf-get-variable theory system *ucv-all-units*))
	  (ucv-dvp-expr (ucf-dvp-expr qty 1 1)))
     (ucf-decan-dim
       (ucf-solve-dim
	 mat-dim
	 (ucf-can-unit ucv-dvp-expr all-dim)
	 (- (length all-dim)
	    (length all-unit)))
       all-dim)))
  


(defun ucf-compatible-quantities (q1 q2	&optional (theory *theory*))
  (let* ((system (ucf-get-system theory))
	  (all-units (ucf-get-variable theory system *ucv-all-units*))
	  (all-dim (ucf-get-variable theory system *ucv-all-dimensions*))
	  (dim-mat (ucf-get-variable theory system *ucv-dimension-matrix*))
	  (dvp-exp (ucf-dvp-expr 1 q1 q2)))
    (and (ucf-check-exist-expr dvp-exp all-units)
	 (equal (ucf-dimension q1) (ucf-dimension q2)))))


(defun ucf+ (q1 q2)
  (if (ucf-compatible-quantities q1 q2)
      (ucf-unit-delist (ucf-dvp-expr
			(1+ (ucf-conversion-into-unit 1 q2 q1 *theory* (ucf-get-system *theory*)))
			q1
			1))))


(defun ucf- (q1 q2)
  (if (ucf-compatible-quantities q1 q2)
      (ucf-unit-delist (ucf-dvp-expr
			(- 1 (ucf-conversion-into-unit 1 q2 q1 *theory* (ucf-get-system *theory*)))
			q1
			1))))



(defun ucf-expt (q alpha &key (theory *theory*))
  (let* ((system (ucf-get-system theory))
	 (all-units (ucf-get-variable theory system *ucv-all-units*))
	 (all-dim (ucf-get-variable theory system *ucv-all-dimensions*))
	 (dvp-exp (when (realp alpha) (ucf-dvp-expr (list 'expt q alpha) 1 1))))
    (when dvp-exp
      (cond ((ucf-check-exist-expr dvp-exp all-units)
	     (values (ucf-unit-delist dvp-exp)))
	    ((ucf-check-exist-expr dvp-exp (set-difference all-dim all-units))
	     (values (ucf-dim-delist dvp-exp)))))))




(defun ucf* (elt1 elt2 &key (theory *theory*))
   (let* ((system (ucf-get-system theory))
	  (all-units (ucf-get-variable theory system *ucv-all-units*))
	  (all-dim (ucf-get-variable theory system *ucv-all-dimensions*))
	  (dvp-exp (ucf-dvp-expr elt1 elt2 1)))
     (cond ((ucf-check-exist-expr dvp-exp all-units)
	    (values (ucf-unit-delist dvp-exp)))
	   ((ucf-check-exist-expr dvp-exp (set-difference all-dim all-units))
	    (values (ucf-dim-delist dvp-exp))))))



(defun ucf/ (elt1 elt2 &key (theory *theory*))
  (let* ((system (ucf-get-system theory))
	   (all-units (ucf-get-variable theory system *ucv-all-units*))
	   (all-dim (ucf-get-variable theory system *ucv-all-dimensions*))
	   (dvp-exp (ucf-dvp-expr elt1 1 elt2)))
     (cond ((ucf-check-exist-expr dvp-exp all-units)
	    (values (ucf-unit-delist dvp-exp)))
	   ((ucf-check-exist-expr dvp-exp (set-difference all-dim all-units))
	    (values (ucf-dim-delist dvp-exp))))))



(defun ucf-base-units (system)
  (and system 
       (ucf-check-exist-system *theory* system)
       (ucf-check-orth-system (or (ucf-get-variable *theory* system *ucv-dimension-matrix*)
				  (progn (ucf-read-unit-theory :system system)
					 (ucf-get-variable *theory* system *ucv-dimension-matrix*)))
			      (length (ucf-get-variable *theory* system *ucv-system-units*)))
       (ucf-get-variable *theory* system *ucv-system-units*)))


(defun ucf-standard-unit (system dimension)
  (ucf-get-unit-for-dim (ucf-base-units
			 (intern-object system *ontology-package*))
			(intern-object dimension 'cv)))

(defun ucf-get-unit-for-dim (unit-list dim)
  (when unit-list 
    (if (ucf= (ucf-dimension (car unit-list)) dim)
	(car unit-list)
	(ucf-get-unit-for-dim (cdr unit-list) dim))))



(defun ucf-system-of-units (unit-list &optional (theory *theory*))
    (= (length unit-list) 
       (ucf-freedom-unit-list unit-list theory)))

(defun ucf-fundamental-dimension-set (list-dim &optional (theory *theory*))
    (= (length list-dim) 
       (ucf-freedom-dim-list list-dim theory)))

(defun ucf-dimension-decomposable-from (dim list-dim &optional (theory *theory*))
  (= (ucf-freedom-dim-list list-dim theory)
     (ucf-freedom-dim-list (cons dim list-dim) theory)))

(defun ucf-freedom-dim-list (list-dim theory)
 (let* ((system (ucf-get-system theory))
	 (mat-dim (ucf-get-variable theory system *ucv-dimension-matrix*))
	 (all-dim (ucf-get-variable theory system *ucv-all-dimensions*))
	 (all-units (ucf-get-variable theory system *ucv-all-units*))
	 (nb-units (length all-units))
	 (nb-dim (- (length all-dim) nb-units)))
   (ucf-freedom-deg
     (ucf-square
       (ucf-trig
	 (ucf-add-lines
	   (mapcar #'(lambda (x)
		       (nthcdr nb-units
			       (ucf-solve-dim
				 mat-dim
				 (ucf-can-unit (ucf-dvp-expr x 1 1) all-dim)
				 nb-dim)))
		   list-dim)))))))


(defun ucf-freedom-unit-list (unit-list theory)
 (let* ((system (ucf-get-system theory))
	 (unit-mat (ucf-get-variable theory system *ucv-unit-matrix*))
	 (all-units (ucf-get-variable theory system *ucv-all-units*))
	 (nb-units (length all-units)))
   (ucf-freedom-deg
     (ucf-square
       (ucf-trig
	 (ucf-add-lines
	   (mapcar #'(lambda (x)
		       (ucf-solve-dim
			 unit-mat
			 (ucf-can-unit (ucf-dvp-expr x 1 1) all-units)
			 nb-units))
		   unit-list)))))))

(defun ucf-definition (elt)
  (oli::get-forms-for-kif-constant 
   (intern-object elt *ontology-package*) *theory*))