;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: gizmo-translation.lsp
;;;;    System: FIRE
;;;;    Author: Jin Yan
;;;;   Created: October 25, 2002 15:54:33
;;;;   Purpose: Handles expression translations between FIRE and GIZMO
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Thursday, January 15, 2004 at 12:51:07 by jinyan
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;;; This subsystem handles translations between gizmo and FIRE.

(defun fire->gizmo (cons)
  (mapcar #'(lambda (con)
              (if (listp con)
                (cond ((check-car con)
                       (cons (car con) (fire->gizmo (cdr con))))
                      ((eql (car con) 'data::biconditional)
                       (cons ':biconditional (fire->gizmo (cdr con))))
                      (t
                       (switch-pred con)))
                con))
    cons))

(defun check-car (con)
  (member (car con) '(data::> data::>= data::<= data::= 
                              data::qprop data::qprop- data::q= 
                              data::i- data::i+ data::- 
                              data::function data::correspondence :=>))) ;;:biconditional 

(defun switch-pred (fact)
  (if (listp fact)
    (cond ((or (equal (car fact) 'data::isa)
               (equal (car fact) 'data::genls))
           (list (switch-pred (caddr fact)) (switch-pred (cadr fact))))
          ((equal (car fact) 'data::self)
           (list (switch-pred (cadr fact)) ':self))
          ((and 
            (listp (car fact))
            (equal (caar fact) 'data::QpQuantityFn))
           (append (cdar fact) (cdr fact)))
          ((and
            (listp (car fact))
            (eql (length fact) 1))
           (list (switch-pred (car fact))))
          (t 
           fact))
    (if (eql fact 'data::Quantity) ;; a better way would be to update all the "quantity" criteria under gizmo.
      'data::quantity
      fact)))

(defun DB->var (args &aux new-arg)
  (mapcar #'(lambda (arg)
              (cond ((listp arg)
                     (DB->var arg))
                    ((numberp arg)
                     arg)
                    (t
                     (progn
                       (setf new-arg (string-left-trim "?DB-" arg))
                       (setf new-arg (string-trim "0 1 2 3 4 5 6 7 8 9" new-arg))
                       (if (not (string-equal new-arg arg))
                         (intern (format nil "?~A" new-arg))
                         arg)))))
    args))

;;;(defun switch-pred (fact)
;;;  (if (listp fact)
;;;    (case (cadr fact)
;;;      ('data::Temperature (subst 'data::Temperature 'data::TemperatureFn fact))
;;;      ('data::PressureFn (subst 'data::Pressure 'data::PressureFn fact))
;;;      ('data::TBoilFn (subst 'data::TBoil 'data::TBoilFn fact))
;;;      ('data::MassFn (subst 'data::Mass 'data::MassFn fact))
;;;      ('data::LevelFn (subst 'data::Level 'data::LevelFn fact))
;;;      ('data::HeatFn (subst 'data::Heat 'data::HeatFn fact))
;;;      ('data::AmountOfFn (subst 'data::AmountOf 'data::AmountOfFn fact))
;;;      ('data::VolumnFn (subst 'data::Volumn 'data::VolumnFn fact))
;;;      ('data::BottomHeightFn (subst 'data::BottomHeight 'data::BottomHeightFn fact))
;;;      ('data::HeatFlowRateFn (subst 'data::HeatFlowRate 'data::HeatFlowRateFn fact))
;;;      ('data::genls (list (switch-pred (caddr fact)) (switch-pred (cadr fact))))
;;;      ('data::isa (list (switch-pred (caddr fact)) (switch-pred (cadr fact))))
;;;      (otherwise fact))
;;;    fact))

;;;(defun collection->var (s)
;;;  (intern (format nil "?~A" s)))

(defun collection->var (s) 
  ;;this function name should be re-considered.
  (case s
    ('data::Substance 'data::?sub)
    ('data::Can 'data::?can)
    ('data::Phase 'data::?ph)
    ('data::Physob 'data::?phob)
    ('data::Path-Generic 'data::?path)
    ('data::Source 'data::?src)
    ('data::Destination 'data::?dst)
    ('data::State 'data::?st)
    ('data::Container 'data::?container)
    ('data::Process 'data::?process)
    ('data::Thing 'data::?thing)
    ('data::Place 'data::?place)))

(defun var->collection (var)
  (case var
    ('data::?thing 'data::Thing)
    ('data::?process 'data::Process)
    ('data::?container 'data::Container)
    ('data::?place 'data::Place)
    ('data::?sub 'data::Substance) ;;PartiallyTangible?
    ('data::?st 'data::State)
    ('data::?ph 'data::Phase)
    ('data::?can 'data::Can)
    ('data::?path 'data::Path-Generic)
    ('data::?src 'data::Source)
    ('data::?dst 'data::Destination) ;;no definition for Source, Destination and Physob in CycL!
    ('data::?phob 'data::Physob)
    ))

;;;(:and (quantity (tboil ?sub ?can))
;;;      (> (tboil ?sub ?can) 0))
;;;
;;;(#$and (#$isa ((#$QpQuantityFn #$TBoil) ?sub ?can) #$Quantity)
;;;       (#$> ((#$QpQuantityFn #$TBoil) ?can ?sub) 0))

(defun gizmo->fire (cons)
  (mapcar #'(lambda (con)
              (cond ((listp con)
                     (transform con))
                    ((symbolp con)
                     (trim con))
                    (t con)))
    cons))

(defun trim (x)
  (let ((new-x (string-left-trim ":" x)))
    (intern (format nil "~A" new-x))))

(defun transform (lst)
  (cond ((symbolp lst)
         (trim lst))
        ((numberp lst)
         lst)
        ((physical-quantity? (car lst))
         (quantity-fn-transform lst))
        ((eql (cadr lst) ':self)
         `(data::self ,(car lst)))
        ((foo-collection? (car lst))
         (->data (make-isa (transform (cadr lst))
                           (convert-to-cyc (car lst)))))
        (t ;;for situations that (car lst) is a predicate.
         (mapcar #'(lambda (x)
                     (transform x))
           lst))))

;;;        ((pred? (car lst))
;;;         (mapcar #'(lambda (x)
;;;                     (transform x))
;;;           lst))))

;;;(defun pred? (x)
;;;  (or (fire::retrieve-references (->data `(isa ,x Predicate)))
;;;      (fire::retrieve-references (->data `(isa ,x OrderingPredicate)))))

(defun foo-collection? (x)
  (or (collection? x)
      (eql x 'data::quantity)))

;;;(defun physical-quantity? (x)
;;;  (retrieve-references (->data `(genls ,x PhysicalQuantity))))

(defun physical-quantity? (x) ;;just for test now.
  (member x '(data::pressure data::heat data::mass data::volumn data::tboil data::height data::mass
                             data::amount-of data::restorative data::temperature data::heat-of data::bottom-height
                             data::top-height data::max-height data::flow-rate data::heat-flow-rate data::liquid-flow-rate
                             data::generation-rate data::heat-generation-rate data::absorbtion data::restorative
                             )))

(defun quantity-fn-transform (con)
  (cons (fire::make-qp-quantity-fn (car con)) (cdr con)))


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

;;;(defun convert-to-cyc (expr)
;;;   ;; takes an arbitrary expression, converts all symbols to cyc-notation, returns the
;;;   ;; converted expression
;;;   (cond ((null expr) nil)
;;;         ((symbolp expr) (transform-symbol-to-cyc expr))
;;;         ((atom expr) expr)
;;;         (t
;;;          (cons (convert-to-cyc (first expr))
;;;            (convert-to-cyc (rest expr))))))

(defun convert-to-cyc (expr &optional (predicate nil))
   ;; takes an arbitrary expression, converts all symbols to cyc-notation, returns the
   ;; converted expression
   (cond ((null expr) nil)
         ((and (symbolp expr) (not predicate))
          (transform-symbol-to-cyc expr))
         ((and (symbolp expr) predicate)
          (transform-symbol-to-predicate expr))
         ((atom expr) expr)
         (t
          (do ((x 0 (1+ x))
               (new-expr nil))
              ((eql x (length expr)) (reverse new-expr))
            (if (and (eql x 0) (not (search "Fn" (format nil "~A" (car expr)))))
              (push (convert-to-cyc (nth x expr) t) new-expr)
              (push (convert-to-cyc (nth x expr)) new-expr))))))

;;;            (if (or (eql x 0) (listp (nth x expr)))
;;;              (push (convert-to-cyc (nth x expr) t) new-expr)
;;;              (push (convert-to-cyc (nth x expr)) new-expr))))))

(defun transform-symbol-to-cyc (symb)
   ;; step through the symbol, captilizing everything after a dash (and removing the dash)
   (remove-dashes (symbol-name symb)))

(defun transform-symbol-to-predicate (expr)
  (let ((new-expr (transform-symbol-to-cyc expr)))
    (read-from-string (string-downcase new-expr :start 0 :end 1))))

;;-------------------------------------------------------;;

;;;(defun convert-to-predicate (expr)
;;;  (cond ((null expr) nil)
;;;        ((symbolp expr) (transform-symbol-to-predicate expr))
;;;        ((atom expr) expr)
;;;        (t 
;;;         (do ((x 0 (1+ x))
;;;              (new-expr nil))
;;;             ((eql x (length expr)) (reverse new-expr))
;;;           (if (or (eql x 0) (listp (nth x expr)))
;;;             (push (convert-to-predicate (nth x expr)) new-expr)
;;;             (push (convert-to-cyc (nth x expr)) new-expr))))))

(defun remove-dashes (str)
  "Remove the dashes from a case-insensitive form and tries to set the capitalization straight"
  (let ((len (length str))
        (*readtable* (copy-readtable))
        (*package* (find-package :cl-user)))
    (setf (readtable-case *readtable*) :preserve)
    (if (<= len 2)
      #+cyc-pound-dollar-sign-ready
      (read-from-string (format nil "#$~A" str) *package*)
      #-cyc-pound-dollar-sign-ready
      (read-from-string (format nil "~A" str) *package*)
      (do ((pos 2 (1+ pos))
           #+cyc-pound-dollar-sign-ready
           (chars (list (char str 0) #\$ #\#))
           #-cyc-pound-dollar-sign-ready
           (chars (list (char-upcase (char str 0))))
           (latest-char (char str 1) (unless (= pos len) (char str pos)))
           (prior-char (char str 0) latest-char))
          ((> pos len)
           (read-from-string (list-to-string (reverse chars)))
           )
        (cond ((null prior-char) nil)
              ((and (eq prior-char #\-)
                    (eq latest-char #\-))
               (push #\- chars))
              ((eq latest-char #\-) nil)
              ((and (eq prior-char #\-)
                    (digit-char-p latest-char))
               (push #\- chars)
               (push latest-char chars))
              ((eq prior-char #\-)
               (push (char-upcase latest-char) chars))
              (t
               (push latest-char chars)))))))
;;;(push (char-downcase latest-char) chars)))))))

(defun remove-dashes-plain-case (str)
   "Removes the dashes from a case-insensitive form but leaves the capitalization alone"
   (let ((len (length str)))
      (if (< len 2)
         (read-from-string str)
         (do ((pos 2 (1+ pos))
              (chars (list (char str 0)))
              (latest-char (char str 1) (unless (= pos len) (char str pos)))
              (prior-char (char str 0) latest-char))
             ((> pos len)
              (read-from-string (list-to-string (reverse chars)))
              )
            (cond ((null prior-char) nil)
                  ((and (eq prior-char #\-)
                        (eq latest-char #\-))
                   (push #\- chars))
                  ((eq latest-char #\-) nil)
                  ((and (eq prior-char #\-)
                        (digit-char-p latest-char))
                   (push #\- chars)
                   (push latest-char chars))
                  ((eq prior-char #\-)
                   (push latest-char chars))
                  (t
                   (push latest-char chars)))))))

;;------------------------------------------------------;;

(defun list-to-string (lst-of-chars)
   (do ((result (make-string (length lst-of-chars)))
        (i 0 (1+ i))
        (char-ptr lst-of-chars (rest char-ptr)))
       ((null char-ptr) result)
      (setf (aref result i) (first char-ptr))))