12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152 |
- ;;;; 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
|