checking.lisp 1.9 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152
  1. ;;;; checking.lisp
  2. ;;;;
  3. ;;;; Copyright (c) 2020 Samuel W. Flint <swflint@flintfam.org>
  4. (in-package #:lcsp)
  5. ;;; "lcsp" goes here.
  6. (defmethod check-constraint (constraint vvps &key suppress-cc-update-p) :around
  7. (let ((result (call-next-method)))
  8. (unless suppress-cc-update-p
  9. (incf (constraint-checks (problem constraint))))
  10. result))
  11. (defmethod check-constraint ((constraint <constraint-combined>) vvps &key &allow-other-keys)
  12. (let ((value t))
  13. (do* ((constraints (constraints constraint) (rest constraints))
  14. (constr (first constraints) (first constraints)))
  15. ((or (not value) (null constr)) value)
  16. (setf value (check-constraint constr vvps :suppress-cc-update-p t)))))
  17. (defun fix-vvps (vvps constraint)
  18. (let ((variables (variables constraint)))
  19. (mapcar #'(lambda (var)
  20. (if (numberp var)
  21. var
  22. (find var vvps
  23. :key #'car
  24. :test #'equal)))
  25. variables)))
  26. (defmethod check-constraint ((constraint <constraint-extension>) vvps &key &allow-other-keys)
  27. (unless (= (length vvps) (constraint-adicity constraint))
  28. (error "Incorrect number of VVPs (~a vs. ~a)."
  29. (length vvps)
  30. (constraint-adicity constraint)))
  31. (let* ((cvvps (fix-vvps vvps constraint))
  32. (the-values (mapcar #'cdr cvvps))
  33. (is-member-p (member the-values (constraints-list constraint)
  34. :test #'equalp)))
  35. (if (conflictsp constraint)
  36. (not is-member-p)
  37. is-member-p)))
  38. (defmethod check-constraint ((constraint <constraint-intension>) vvps &key &allow-other-keys)
  39. (unless (= (length vvps) (constraint-adicity constraint))
  40. (error "Incorrect number of VVPs (~a vs. ~a)."
  41. (length vvps)
  42. (constraint-adicity constraint)))
  43. (funcall (constraint-function constraint) (fix-vvps vvps constraint)))
  44. ;;; End lcsp