Data commit

Task/Amb/Common-Lisp/amb-1.lisp

@@ -0,0 +1,35 @@
+(define-condition amb-failure () ()
+  (:report "No amb alternative succeeded."))
+
+(defun invoke-ambiguously (function thunks)
+  "Call function with successive values produced by successive
+functions in thunks until some invocation of function does not signal
+an amb-failure."
+  (do ((thunks thunks (rest thunks)))
+      ((endp thunks) (error 'amb-failure))
+    (let ((argument (funcall (first thunks))))
+      (handler-case (return (funcall function argument))
+        (amb-failure ())))))
+
+(defmacro amblet1 ((var form) &body body)
+  "If form is of the form (amb {form}*) then amblet1 is a convenient
+syntax for invoke-ambiguously, by which body is evaluated with var
+bound the results of each form until some evaluation of body does not
+signal an amb-failure. For any other form, amblet binds var the result
+of form, and evaluates body."
+  (if (and (listp form) (eq (first form) 'amb))
+    `(invoke-ambiguously
+      #'(lambda (,var) ,@body)
+      (list ,@(loop for amb-form in (rest form)
+                    collecting `#'(lambda () ,amb-form))))
+    `(let ((,var ,form))
+       ,@body)))
+
+(defmacro amblet (bindings &body body)
+  "Like let, except that if an init-form is of the form (amb {form}*),
+then the corresponding var is bound with amblet1."
+  (if (endp bindings)
+    `(progn ,@body)
+    `(amblet1 ,(first bindings)
+       (amblet ,(rest bindings)
+         ,@body))))

Task/Amb/Common-Lisp/amb-2.lisp

@@ -0,0 +1,50 @@
+(defparameter *amb-ops* nil)
+(defparameter *amb-hist* nil)
+
+(setf *random-state* (make-random-state t))
+(defun shuffle (items)
+  (loop for i from 0 with r = items with l = (length r) while (< i l) do
+	(rotatef (elt r i) (elt r (+ i (random (- l i)))))
+	finally (return r)))
+
+;;; (assert '(mess in, mess out))
+(defmacro amb (a &rest rest)
+  (let ((f (first rest))
+	(rest (rest rest)))
+    (if (not f)
+      `(let ((items (shuffle ,a)))
+	   (let ((y (car (last *amb-hist*)))
+		 (o (car (last *amb-ops*))))
+	     (loop for x in items do
+		   (if (or (not *amb-ops*)
+			   (funcall o y x))
+			   (return (append *amb-hist* (list x))))
+	   (elt items (random (length items))))))
+
+      `(let ((items (shuffle ,a)))
+	   (let ((y (car (last *amb-hist*)))
+		 (o (car (last *amb-ops*))))
+	     (loop for x in items do
+		   (if (or (not *amb-ops*)
+			   (funcall o y x))
+		     (let ((*amb-hist* (append *amb-hist* (list x)))
+			   (*amb-ops*  (append *amb-ops* (list ,f))))
+		       (let ((r ,@rest))
+			 (if r (return r)))))))))))
+
+;; test cases
+(defun joins (a b)
+  (char= (char a (1- (length a))) (char b 0)))
+
+(defun w34()
+  (amb '("walked" "treaded" "grows") #'joins
+       (amb '("slowly" "quickly"))))
+
+(print
+  (amb '("the" "that" "a") #'joins
+       (amb '("frog" "elephant" "thing") #'joins
+	    (w34))))
+
+(print (amb '(1 2 5) #'<
+	    (amb '(2 3 4) #'=
+		 (amb '(3 4 5))))) ; 1 4 4, 2 3 3, etc

Task/Amb/Common-Lisp/amb-3.lisp

@@ -0,0 +1,26 @@
+;; 22.11.18  Ajout macro
+
+(defvar *stack* nil)
+(defvar *assert* t)
+
+(defun ambnew ()
+  (setf *stack* nil)
+  (setf *assert* t))
+
+(defmacro ambsel (name domain)
+  `(progn (defparameter ,name (first ,domain))
+          (pushnew ',name *stack*)
+          (setf (get ',name 'domain) ,domain)))
+
+(defun ambassert (assert)
+  (setf *assert* (list 'and assert *assert*))
+  (if (eval *assert*)
+      t
+      (labels ((probe (&optional (stack *stack*))
+                 (let* ((name (first stack))
+                        (domain (get name 'domain)))
+                   (dolist (value domain)
+                     (set name value)
+                     (cond ((eval *assert*) (return t))
+                           ((probe (rest stack)) (return t)))))))
+               (probe))))

Task/Amb/Common-Lisp/amb-4.lisp

@@ -0,0 +1,2 @@
+(defun match (a b)
+  (equal (elt (reverse a) 0) (elt b 0)))

Task/Amb/Common-Lisp/amb-5.lisp

@@ -0,0 +1,10 @@
+(defun magic-square (a b c d e f g h i)
+  (and (/= a b c d e f g h i)
+       (= (+ a b c)
+          (+ d e f)
+          (+ g h i)
+          (+ a d g)
+          (+ b e h)
+          (+ c f i)
+          (+ a e i)
+          (+ c e g))))