Add fairly simple language compiler

lcsp.asd

@@ -9,8 +9,10 @@
   :license  "GNU GPL v3 or later"
   :version "0.0.1"
   :serial t
-  :depends-on (#:alexandria)
+  :depends-on (#:alexandria
+               #:esrap)
   :components ((:file "package")
                (:file "types")
                (:file "checking")
+               (:file "xcsp-lang")
                (:file "LCSP")))

package.lisp

@@ -23,3 +23,10 @@
            #:<constraint-intension>
            #:constraint-function
            #:<constraint-combined>))
+
+(defpackage #:lcsp-xcsp-lang
+  (:use #:cl
+        #:esrap)
+  (:import-from #:alexandria
+                #:symbolicate)
+  (:export #:parse-xcsp-predicate))

xcsp-lang.lisp

@@ -0,0 +1,143 @@
+;;;; 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 (? #\-) (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\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