From 2944298c10918da40a3b4ccbf850029a317375a0 Mon Sep 17 00:00:00 2001
From: Aria Shrimpton <me@aria.rip>
Date: Thu, 25 Jan 2024 13:44:49 +0000
Subject: support constraint checking on mappings

---
 src/racket_specs/combinators.rkt   |  9 +++++++-
 src/racket_specs/mapping-setup.rkt | 47 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 55 insertions(+), 1 deletion(-)
 create mode 100644 src/racket_specs/mapping-setup.rkt

(limited to 'src/racket_specs')

diff --git a/src/racket_specs/combinators.rkt b/src/racket_specs/combinators.rkt
index a74296b..016a44f 100644
--- a/src/racket_specs/combinators.rkt
+++ b/src/racket_specs/combinators.rkt
@@ -74,5 +74,12 @@
     [(< (length l) 2) null]
     [else (append (list (take l 2)) (consecutive-pairs (drop l 1)))]))
 
+; Mapping helpers
+
+; (is-map? lst) -> boolean?
+(define (is-map? l)
+  (and (list? l)
+       (andmap pair? l)))
+
 ; Export procedures
-(provide for-all-unique-pairs for-all-consecutive-pairs for-all-elems elem-and not-equal? leq? geq? unique-count?)
\ No newline at end of file
+(provide for-all-unique-pairs for-all-consecutive-pairs for-all-elems elem-and not-equal? leq? geq? unique-count? is-map?)
diff --git a/src/racket_specs/mapping-setup.rkt b/src/racket_specs/mapping-setup.rkt
new file mode 100644
index 0000000..6b6fc48
--- /dev/null
+++ b/src/racket_specs/mapping-setup.rkt
@@ -0,0 +1,47 @@
+#lang rosette
+
+(define (check-spec-len prop pre spec xs)
+  (assume (and (prop xs) (pre xs)))
+  (assert (prop (car (spec xs)))))
+
+(define (check-spec-is-empty prop pre spec xs)
+  (assume (and (prop xs) (pre xs)))
+  (assert (prop (car (spec xs)))))
+
+(define (check-spec-contains prop pre spec xs x)
+  (assume (and (prop xs) (pre xs)))
+  (assert (prop (car (spec xs x)))))
+
+(define (check-spec-insert prop pre spec xs x)
+  (assume (and (prop xs) (pre xs)))
+  (assert (prop (spec xs x))))
+
+(define (check-spec-remove prop pre spec xs x)
+  (assume (and (prop xs) (pre xs)))
+  (assert (prop (car (spec xs x)))))
+
+(define (check-spec-clear prop pre spec xs)
+  (assume (and (prop xs) (pre xs)))
+  (assert (prop (spec xs))))
+
+(define (check-not-contradict prop pre xs)
+  (assert (and (prop xs) (pre xs) (> (length xs) 1))))
+
+(define (check prop pres specs xs k v)
+  (cond 
+    [(or (unsat? (solve (check-not-contradict prop (first pres) xs)))
+         (unsat? (solve (check-not-contradict prop (second pres) xs)))
+         (unsat? (solve (check-not-contradict prop (third pres) xs)))
+         (unsat? (solve (check-not-contradict prop (fourth pres) xs)))
+         (unsat? (solve (check-not-contradict prop (fifth pres) xs)))
+         (unsat? (solve (check-not-contradict prop (sixth pres) xs)))
+         ) #f]
+    [else (and (unsat? (verify (check-spec-clear prop (first pres) (first specs) xs)))
+               (unsat? (verify (check-spec-contains prop (second pres) (second specs) xs k)))
+               (unsat? (verify (check-spec-insert prop (third pres) (third specs) xs k v)))
+               (unsat? (verify (check-spec-is-empty prop (fourth pres) (fourth specs) xs)))
+               (unsat? (verify (check-spec-len prop (fifth pres) (fifth specs) xs)))
+               (unsat? (verify (check-spec-remove prop (sixth pres) (sixth specs) xs k)))
+               )]))
+
+(provide check)
-- 
cgit v1.2.3