lcsp/xcsp-lang.lisp

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

(in-package #:lcsp-xcsp-lang)

;;; "lcsp-xcsp-lang" goes here.

(defrule integral (and (? #\-) (+ (character-ranges (#\0 #\9))))
  (:text t)
  (:function parse-integer))

(defrule bool (or "true" "false")
  (:text t)
  (:lambda (expr)
    (string= expr "true")))

(defrule identifier (+ (character-ranges (#\A #\Z) (#\a #\z) (#\0 #\9)))
  (:text t)
  (:lambda (text)
    (symbolicate (string-upcase text))))

(defrule int-expr (or integral absv neg add sub mul div modr powr minr maxr if-then identifier))

(defrule neg (and "neg(" int-expr ")")
  (:destructure (_ expr __)
    (declare (ignore _ __))
    `(- ,expr)))

(defrule absv (and "abs(" int-expr ")")
  (:destructure (_ expr __)
    (declare (ignore _ __))
    `(abs ,expr)))

(defrule add (and "add(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
    (declare (ignore _ __ ___))
    `(+ ,expr-a ,expr-b)))

(defrule sub
    (and "sub(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(- ,expr-a ,expr-b)))

(defrule mul
    (and "mul(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(* ,expr-a ,expr-b)))

(defrule div
    (and "div(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(/ ,expr-a ,expr-b)))

(defrule modr
    (and "mod(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(mod ,expr-a ,expr-b)))

(defrule powr
    (and "pow(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(expt ,expr-a ,expr-b)))

(defrule minr
    (and "min(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(min ,expr-a ,expr-b)))

(defrule maxr
    (and "max(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(max ,expr-a ,expr-b)))

(defrule if-then (and "if(" bool-expr "," int-expr "," int-expr ")")
  (:destructure (_ condition __ true-case ___ false-case ____)
    (declare (ignore _ __ ___ ____))
    `(if ,condition ,true-case ,false-case)))

(defrule bool-expr (or not-expr and-expr or-expr iff-expr eq-expr neq-expr ge-expr gt-expr le-expr lt-expr bool))

(defrule not-expr (and "not(" bool-expr ")")
  (:destructure (_ bool-expr __)
    (declare (ignore _ __))
    `(not ,bool-expr)))

(defrule and-expr
    (and "and(" bool-expr "," bool-expr ")")
  (:destructure (_ expr-a __ expr-b ___) (declare (ignore _ __ ___))
    `(and ,expr-a ,expr-b)))

(defrule or-expr
    (and "or(" bool-expr "," bool-expr ")")
  (:destructure (_ expr-a __ expr-b ___) (declare (ignore _ __ ___))
    `(or ,expr-a ,expr-b)))

(defun iff (a b)
  (and (or (not a) b)
     (or (not b) a)))

(defrule iff-expr
    (and "iff(" bool-expr "," bool-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(iff ,expr-a ,expr-b)))

(defrule eq-expr
    (and "eq(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(= ,expr-a ,expr-b)))

(defrule neq-expr
    (and "ne(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(not (= ,expr-a ,expr-b))))

(defrule ge-expr
    (and "ge(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(>= ,expr-a ,expr-b)))

(defrule gt-expr
    (and "gt(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(> ,expr-a ,expr-b)))

(defrule le-expr
    (and "le(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(<= ,expr-a ,expr-b)))

(defrule lt-expr
    (and "lt(" int-expr "," int-expr ")")
  (:destructure (_ expr-a __ expr-b ___)
                (declare (ignore _ __ ___))
                `(< ,expr-a ,expr-b)))

(defun parse-xcsp-predicate (expression-string arguments-list &key (compile-p t))
  (let* ((expression (parse 'bool-expr expression-string))
         (xcsp-function-expression `(lambda (,@arguments-list) ,expression)))
    (if compile-p
        (compile nil xcsp-function-expression)
        (eval xcsp-function-expression))))

;;; End lcsp-xcsp-lang