;;;; checking.lisp
;;;;
;;;; Copyright (c) 2020 Samuel W. Flint <swflint@flintfam.org>

(in-package #:lcsp)

;;; "lcsp" goes here.

(defmethod check-constraint (constraint vvps &key suppress-cc-update-p) :around
  (let ((result (call-next-method)))
    (unless suppress-cc-update-p
      (incf (constraint-checks (problem constraint))))
    result))

(defmethod check-constraint ((constraint <constraint-combined>) vvps &key &allow-other-keys)
  (let ((value t))
    (do* ((constraints (constraints constraint) (rest constraints))
          (constr (first constraints) (first constraints)))
         ((or (not value) (null constr)) value)
      (setf value (check-constraint constr vvps :suppress-cc-update-p t)))))

(defun fix-vvps (vvps constraint)
  (let ((variables (variables constraint)))
    (mapcar #'(lambda (var)
                (if (numberp var)
                    var
                    (find var vvps
                          :key #'car
                          :test #'equal)))
            variables)))

(defmethod check-constraint ((constraint <constraint-extension>) vvps &key &allow-other-keys)
  (unless (= (length vvps) (constraint-adicity constraint))
    (error "Incorrect number of VVPs (~a vs. ~a)."
           (length vvps)
           (constraint-adicity constraint)))
  (let* ((cvvps (fix-vvps vvps constraint))
         (the-values (mapcar #'cdr cvvps))
         (is-member-p (member the-values (constraints-list constraint)
                              :test #'equalp)))
    (if (conflictsp constraint)
        (not is-member-p)
        is-member-p)))

(defmethod check-constraint ((constraint <constraint-intension>) vvps &key &allow-other-keys)
  (unless (= (length vvps) (constraint-adicity constraint))
    (error "Incorrect number of VVPs (~a vs. ~a)."
           (length vvps)
           (constraint-adicity constraint)))
  (funcall (constraint-function constraint) (fix-vvps vvps constraint)))

;;; End lcsp