From 5b69379de159e0f612e41777416bafff301fcc06 Mon Sep 17 00:00:00 2001
From: Dane Johnson <daneallenjohnson@protonmail.com>
Date: Mon, 16 Dec 2024 10:35:33 -0600
Subject: [PATCH] Add amb and distinct?

---
 d-.scm   | 34 +++++++++++++++++++++++++++++++++-
 test.scm | 19 +++++++++++++++++++
 2 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/d-.scm b/d-.scm
index 40f1afc..95e3bd7 100644
--- a/d-.scm
+++ b/d-.scm
@@ -13,8 +13,12 @@
    argmin
    iterate
    upply
+   distinct?
    generator
-   macro-expand))
+   macro-expand
+   amb
+   amb-reset
+   amb-require))
 
 (define-syntax ~>
   (syntax-rules ()
@@ -77,6 +81,12 @@
   (let ([arm-f (apply compose fs)])
     (cmp (arm-f a) (arm-f b))))
 
+(define (distinct? . a)
+  (if (or (null? a) (null? (cdr a)))
+      #t
+      (and (not (any (lambda (x) (eq? (car a) x)) (cdr a)))
+	   (apply distinct? (cdr a)))))
+
 ;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
 (define (make-generator f)
   (define tag (make-prompt-tag))
@@ -100,3 +110,25 @@
 
 ;; Why wasn't this included?
 (define macro-expand (compose tree-il->scheme macroexpand))
+
+;; This is the "classic" implementation of McCarthy's `amb'
+;; Would rather it use delimited continuations, but I'm too dumb
+(define (*fail*) (error "Could not satisfy amb"))
+(define-syntax amb
+  (syntax-rules ()
+    [(amb) (*fail*)]
+    [(amb a) a]
+    [(amb a b ...)
+     (let ([fail0 *fail*])
+       (call/cc
+	(lambda (cc)
+	  (set! *fail*
+		(lambda ()
+		  (set! *fail* fail0)
+		  (cc (amb b ...))))
+	  (cc a))))]))
+(define (amb-reset)
+  ;; Shouldn't be necessary, but prompts are hard and I'm dumb dumb dummy
+  (set! *fail* (lambda () (error "Could not satisfy amb"))))
+(define (amb-require pred)
+  (or pred (amb)))
diff --git a/test.scm b/test.scm
index d7b3525..5d46d7a 100644
--- a/test.scm
+++ b/test.scm
@@ -80,3 +80,22 @@
     (assert-equal 2 (number-generator))
     (assert-equal 3 (number-generator))
     (assert-equal 4 (number-generator))))
+
+(define-test-suite "amb"
+  (define-test "liars"
+    (define (liars)
+      (amb-reset)
+      (let ([betty (amb 1 2 3 4 5)]
+	    [ethel (amb 1 2 3 4 5)]
+	    [joan  (amb 1 2 3 4 5)]
+	    [kitty (amb 1 2 3 4 5)]
+	    [mary  (amb 1 2 3 4 5)])
+	;; The "Liars" problem
+	(amb-require (distinct? betty ethel joan kitty mary))
+	(amb-require (or (= kitty 1) (= betty 3)))
+	(amb-require (or (= ethel 1) (= joan  2)))
+	(amb-require (or (= joan  3) (= ethel 5)))
+	(amb-require (or (= kitty 2) (= mary  4)))
+	(amb-require (or (= mary  4) (= betty 1)))
+	(list betty ethel joan kitty mary)))
+    (assert-equal '(3 5 2 1 4) (liars))))