;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: setup-qp-dt.lsp
;;;;    System: FIRE qp-source
;;;;   Version: 1.0
;;;;    Author: Jin Yan
;;;;   Created: March 13, 2003 12:23:11
;;;;   Purpose: Setup dt in CML (QP) way.
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Wednesday, August 13, 2003 at 18:07:41 by jinyan
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;;(defun setup-dt-qtype (qtype-term qtype-args)
;;;  (setf args (DB->var qtype-args))
;;;  (list 'defquantityfunction qtype-term args))

;;;(defun setup-dt-qtype (qtype-term qtype-arity &aux args)
;;;  (cond ((= qtype-arity 1)
;;;         (setf args '(data::?x)))
;;;        ((= qtype-arity 2)
;;;         (setf args (->data '(?x ?y))))
;;;        ((= qtype-arity 3)
;;;         (setf args (->data '(?x ?y ?z)))))
;;;  `(data::defquantityfunction ,qtype-term ,args))

(defun setup-dt-qtype (qtype-term qtype-args)
  `(data::defquantityfunction ,qtype-term ,qtype-args))  

;;;(defun setup-qp-dt-entity (entity-term subclass quantities consequences)
;;;  (append `(data::defentity ,entity-term)
;;;          (when subclass
;;;            `(:subclass-of ,subclass))
;;;          (when quantities
;;;            `(:quantities ,quantities))
;;;          (when consequences
;;;            `(:consequences ,consequences))))

(defun setup-qp-dt-entity (entity-term subclass quantities consequences &aux qs-info)
  (append `(data::defentity ,entity-term)
          (when subclass
            `(:subclass-of ,subclass))
          (when quantities
            (dolist (quantity quantities)
              (push `(,quantity :type ,quantity) qs-info))
            `(:quantities ,qs-info))
          (when consequences
            `(:consequences ,consequences))))

(defun setup-qp-ent-quantity (quantity type dimension)
  (cond (type
         `(,quantity :type ,type))
        (dimension
         `(,quantity :dimension ,dimension))
        (t
         `(,quantity))))

;;;(defun setup-qp-dt-relation (relation-term arity imply-info &aux relation-args)
;;;  (cond ((= arity 1)
;;;         (setf relation-args '(data::?x)))
;;;        ((= arity 2)
;;;         (setf relation-args (->data '(?x ?y))))
;;;        ((= arity 3)
;;;         (setf relation-args (->data '(?x ?y ?z)))))
;;;  (append `(data::defrelation ,relation-term ,relation-args)
;;;          (when imply-info
;;;            (list ':=> (if (equal (car imply-info) 'and)
;;;                         (cons ':and
;;;                               (fire->gizmo (cdr imply-info)))
;;;                         (car (fire->gizmo (list imply-info))))))))

(defun setup-qp-dt-relation (relation-term args imply-info)
  (append `(data::defrelation ,relation-term ,args)
          (when imply-info
            (list ':=> (if (equal (car imply-info) 'and)
                         (cons ':and
                               (fire->gizmo (cdr imply-info)))
                         (car (fire->gizmo (list imply-info))))))))

(defun setup-qp-dt-constant (constant)
  `(data::defcmlconstant ,constant))

(defun setup-qp-dt-uf (univ-fact)
  `(data::defuniversalfact ,univ-fact))

(defun setup-qp-dt-mf (mf-term subclass participants conditions quantities consequences)
  (append (list 'data::defmodelfragment mf-term)
          (when subclass
            (list ':subclass-of subclass))
          (list ':participants participants)
          (list ':conditions conditions)
          (when quantities
            (list ':quantities quantities))
          (list ':consequences consequences)))

(defun setup-qp-mf-participant (part type constraints)
  (append (list part)
          (when type
            (list ':type type))
          (when constraints
            (list ':constraints constraints))))

(defun setup-qp-mf-quantity (quantity quantity-args)
  (append (switch-quantity quantity)
          (when quantity-args
            (list ':arguments quantity-args))))