;;;-*- Package: :multi-garnet; Syntax: Common-Lisp; Mode: Lisp -*-; 

(in-package :multi-garnet :nicknames '(:mg) :use '(:lisp :kr))

(eval-when (load eval compile) (require :loop))

;; ***** strengths: represented as keywords *****

(defvar *strength-list*
  (list :required :strong :medium :weak :weakest))

(defvar *required-strength* :required)
(defvar *weakest-strength* :weakest)

;; used to check strength rep when input into fn
(defun get-strength (strength)
  (cond	((member strength *strength-list*)
	 strength)
	(t
	 (error "get-strength: bad strength: ~S" strength))))

(defun weaker (s1 s2)
  (let ((pos1 (position s1 *strength-list*))
        (pos2 (position s2 *strength-list*)))
    (cond ((or (null pos1) (null pos2))
           (cerror "return nil" "bad strength name given: (weaker ~S ~S)" s1 s2)
	   nil)
          (t
           (> pos1 pos2))
          )))

;; ***** OS (object slot) objects *****

(defmacro os (obj slot) `(cons ,obj ,slot))

(defmacro os-p (os)
  `(let ((os ,os))
     (and (consp os)
	  (schema-p (car os)))))

(defmacro os-object (os) `(car ,os))
(defmacro os-slot (os) `(cdr ,os))

;; ***** Sky-Blue object definitions *****

;; create basic SkyBlue objects with :override key word so we can reload
;; this file without smashing all existing cns, vars, etc.

(create-instance '*sb-object* nil :override
		 )

(defun sb-object-p (obj)
  (is-a-p obj *sb-object*))

;; Constraint Representation:
;;   
;;   Field         | Type      | Description
;; ----------------+-----------+--------------------------------------------
;;    Fields used mainly by SkyBlue:
;; variables       | Set of    | The variables that this constraint references.
;;                 | Variables |
;; strength        | Strength  | This constraint's level in the constraint
;;                 |           |  hierarchy.
;; methods         | Set of    | The potential methods for satisfying this
;;                 | Methods   | constraint.
;; selected-method | Method    | The method used to satisfy this constraint,
;;                 |           | nil if the constraint is not satisfied.
;;		   |	       | Should only be manipulated by SkyBlue.
;; mark            | Integer   | This constraint's mark value.
;;    Fields used mainly by Multi-Garnet:
;; os              | OS object | object&slot containing this constraint.
;; connection      | keyword   | Connection status of this constraint.
;; variable-paths  | list of paths | Paths for accessing constraint variables.
;; path-slot-list  | list of OS's  | OS's of path slots for this cn

(create-instance 'sbcn *sb-object* :override
		 (:variables       :uninitialized)
		 (:strength        :uninitialized)
		 (:methods         :uninitialized)
		 (:selected-method :uninitialized)
		 (:mark            :uninitialized)
		 (:os              :uninitialized)
		 (:connection      :uninitialized)
                 (:variable-paths  :uninitialized)
		 (:path-slot-list  :uninitialized)
		 )

(defun constraint-p (obj)
  (is-a-p obj sbcn))

(defmacro CN-variables (c) `(get-sb-slot ,c :variables))
(defsetf CN-variables (c) (val) `(set-sb-slot ,c :variables ,val))
(defmacro CN-strength (c) `(get-sb-slot ,c :strength))
(defsetf CN-strength (c) (val) `(set-sb-slot ,c :strength ,val))
(defmacro CN-methods (c) `(get-sb-slot ,c :methods))
(defsetf CN-methods (c) (val) `(set-sb-slot ,c :methods ,val))
(defmacro CN-selected-method (c) `(get-sb-slot ,c :selected-method))
(defsetf CN-selected-method (c) (val) `(set-sb-slot ,c :selected-method ,val))
(defmacro CN-mark (v) `(get-sb-slot ,v :mark))
(defsetf CN-mark (v) (val) `(set-sb-slot ,v :mark ,val))
(defmacro CN-os (v) `(get-sb-slot ,v :os))
(defsetf CN-os (v) (val) `(set-sb-slot ,v :os ,val))
(defmacro CN-connection (v) `(get-sb-slot ,v :connection))
(defsetf CN-connection (v) (val) `(set-sb-slot ,v :connection ,val))
(defmacro CN-variable-paths (c) `(get-sb-slot ,c :variable-paths))
(defsetf CN-variable-paths (c) (val) `(set-sb-slot ,c :variable-paths ,val))
(defmacro CN-path-slot-list (c) `(get-sb-slot ,c :path-slot-list))
(defsetf CN-path-slot-list (c) (val) `(set-sb-slot ,c :path-slot-list ,val))

(defun create-constraint (&key (name nil)
                               (variables nil)
                               (strength :required)
                               (methods nil)
                               (selected-method nil)
			       (mark 0)
                               (os nil)
                               (connection :unconnected)
                               (variable-paths nil)
			       (path-slot-list nil)
                               )
  (create-instance name sbcn
                   (:strength (get-strength strength))
                   (:methods methods)
                   (:variables variables)
                   (:selected-method selected-method)
		   (:mark mark)
                   (:os os)
                   (:connection connection)
                   (:variable-paths variable-paths)
		   (:path-slot-list path-slot-list)
                   ))

(defun clone-constraint (cn)
  ;; copy ptrs to generally-immutable slots
  ;; (:strength :methods :variable-paths)
  ;; and initialize others
  (create-instance nil sbcn
		   (:strength (CN-strength cn))
		   (:methods (CN-methods cn))
		   (:variables nil)
                   (:selected-method nil)
		   (:mark 0)
                   (:os nil)
                   (:connection :unconnected)
		   (:variable-paths (CN-variable-paths cn))
		   (:path-slot-list nil)))

;; want to associate special :stay property with some cns.
;; eventually may want to have other properties, too,
;; like :linear-cn, so should probably do this generally.

(defun stay-constraint-p (obj)
  (and (schema-p obj)
       (g-value obj :stay-cn-flag)))

(defun create-stay-constraint (&rest rest)
  (let* ((cn (apply 'create-constraint rest)))
    (set-sb-slot cn :stay-cn-flag t)
    cn))

(defun set-constraint-stay (cn flag)
  (set-sb-slot cn :stay-cn-flag flag))

;; Methods:
;;   A method represents one possible procedure for satisfying a constraint.
;;   Fields of a method representation are initialized at the constraint
;;   creation time and never modified.
;;
;;   Field        | Type      | Description
;;   -------------+-----------+--------------------------------------------
;;   code         | Procedure | The procedure to be called to execute this
;;                |           | method (passed the constraint whose selected
;;                |           | method this is).
;; output-indices | list of   | List of indices in constraint's variable list
;;                |  integers | of the output variables of this method.

(create-instance 'sbmt *sb-object* :override
		 (:code           :uninitialized)
		 (:output-indices :uninitialized)
		 )

(defun method-p (obj)
  (is-a-p obj sbmt))

(defmacro MT-code (m) `(get-sb-slot ,m :code))
(defsetf MT-code (m) (val) `(set-sb-slot ,m :code ,val))
(defmacro MT-output-indices (m) `(get-sb-slot ,m :output-indices))
(defsetf MT-output-indices (m) (val) `(set-sb-slot ,m :output-indices ,val))

(defun create-method (&key (name nil)
                           (code #'(lambda (cn) cn))
			   (output-indices nil))
  (create-instance name sbmt
                   (:code code)
                   (:output-indices output-indices)
		   ))

;; Variables:
;;
;;   Field        | Type        | Description
;;  --------------+-------------+--------------------------------------------
;;  constraints   | Set of      | All the constraints that reference this
;;                | Constraints | variable.
;;  determined-by | Constraint  | The constraint that determines this
;;                |             | variable's value.
;;  walk-strength | Strength    | The walkabout strength of this variable.
;;  mark          | Integer     | This variable's mark value.
;;  os            | OS object   | object&slot containing the value of
;;                |             | this variable.
;;  valid         | Boolean     | True if this variable value is valid

(create-instance 'sbvar *sb-object* :override
		 (:constraints   :uninitialized)
		 (:determined-by :uninitialized)
		 (:walk-strength :uninitialized)
		 (:mark          :uninitialized)
		 (:os            :uninitialized)
		 (:valid         :uninitialized)
		 )

(defun variable-p (obj)
  (is-a-p obj sbvar))

(defmacro VAR-constraints (v) `(get-sb-slot ,v :constraints))
(defsetf VAR-constraints (v) (val) `(set-sb-slot ,v :constraints ,val))
(defmacro VAR-determined-by (v) `(get-sb-slot ,v :determined-by))
(defsetf VAR-determined-by (v) (val) `(set-sb-slot ,v :determined-by ,val))
(defmacro VAR-walk-strength (v) `(get-sb-slot ,v :walk-strength))
(defsetf VAR-walk-strength (v) (val) `(set-sb-slot ,v :walk-strength ,val))
(defmacro VAR-mark (v) `(get-sb-slot ,v :mark))
(defsetf VAR-mark (v) (val) `(set-sb-slot ,v :mark ,val))
(defmacro VAR-os (v) `(get-sb-slot ,v :os))
(defsetf VAR-os (v) (val) `(set-sb-slot ,v :os ,val))
(defmacro VAR-valid (v) `(get-sb-slot ,v :valid))
(defsetf VAR-valid (v) (val) `(set-sb-slot ,v :valid ,val))

(defun create-variable (&key (name nil)
                             (constraints nil)
                             (determined-by nil)
                             (walk-strength :weakest)
                             (mark 0)
			     (os nil)
			     (valid t)
                             )
  (create-instance name sbvar
                   (:constraints constraints)
                   (:determined-by determined-by)
                   (:walk-strength (get-strength walk-strength))
                   (:mark mark)
		   (:os os)
		   (:valid valid)
		   ))

;; useful macros

(defmacro cn-connection-p (cn val)
  `(eq (CN-connection ,cn) ,val))

(defmacro enforced (c)
  `(CN-selected-method ,c))

(defmacro cn-index-to-var (c n)
  `(nth ,n (CN-variables ,c)))

(defmacro method-output-vars (c m)
  `(let ((cn ,c)
         (mt ,m))
     (loop for index in (MT-output-indices mt)
           collect (cn-index-to-var cn index))))

(defmacro selected-method-output-vars (c)
  `(let ((cn ,c))
     (method-output-vars cn (CN-selected-method cn))))

(defmacro do-consuming-constraints ((constraint-var var-form) . body)
  (let ((var-var (gentemp))
	(var-determined-by-var (gentemp)))
    `(let* ((,var-var ,var-form)
	    (,var-determined-by-var (VAR-determined-by ,var-var)))
       (loop for ,constraint-var in (VAR-constraints ,var-form)
	when (and (not (eq ,constraint-var ,var-determined-by-var))
		  (enforced ,constraint-var))		  
	do (progn ,@body)))
    ))

(defmacro do-inputs ((var-var constraint-form) . body)
  (let ((constraint-var (gentemp))
        (output-indices-var (gentemp))
	(var-index-var (gentemp)))
    `(let* ((,constraint-var ,constraint-form)
            (,output-indices-var
             (MT-output-indices (CN-selected-method ,constraint-var))))
       (loop for ,var-var in (CN-variables ,constraint-var)
             as ,var-index-var from 0 by 1
             unless (member ,var-index-var ,output-indices-var)
             do (progn ,@body)))
    ))

(defmacro inputs-always ((var-var constraint-form) . body)
  (let ((constraint-var (gentemp))
        (output-indices-var (gentemp))
	(var-index-var (gentemp)))
    `(let* ((,constraint-var ,constraint-form)
            (,output-indices-var
             (MT-output-indices (CN-selected-method ,constraint-var))))
       (loop for ,var-var in (CN-variables ,constraint-var)
             as ,var-index-var from 0 by 1
             always (or (member ,var-index-var ,output-indices-var)
			(progn ,@body))))
    ))

;; returns all _enforced_ cns that use the variable v, except for the one
;; that sets it (if any) (this is inefficient: all calls should be replaced
;; by calls to the above macros)
(defun consuming-constraints (v)
  (loop for cn in (VAR-constraints v)
        when (and (enforced cn)
                  (not (eql cn (VAR-determined-by v))))
        collect cn))

