Path: ...!2.eu.feeder.erje.net!feeder.erje.net!eternal-september.org!feeder3.eternal-september.org!news.eternal-september.org!.POSTED!not-for-mail
From: "B. Pym" <Nobody447095@here-nor-there.org>
Newsgroups: comp.lang.lisp,comp.lang.scheme
Subject: Re: Non-determinism
Date: Wed, 24 Jul 2024 04:41:59 -0000 (UTC)
Organization: A noiseless patient Spider
Lines: 154
Message-ID: <v7q0m7$1jrar$1@dont-email.me>
References: <v7pboq$1d67r$1@dont-email.me> <v7peea$1djes$1@dont-email.me>
MIME-Version: 1.0
Content-Type: text/plain; charset=iso-8859-1
Injection-Date: Wed, 24 Jul 2024 06:41:59 +0200 (CEST)
Injection-Info: dont-email.me; posting-host="dc013996b5bb46648d47418209f67001";
	logging-data="1699163"; mail-complaints-to="abuse@eternal-september.org";	posting-account="U2FsdGVkX18Hya/Rt1Tj4/o2APooeoDh"
User-Agent: XanaNews/1.18.1.6
Cancel-Lock: sha1:pc4wnI7x3QTGREHJZZ3lX2XHKb0=
Bytes: 5046

B. Pym wrote:

> Problem 4.42 in SICP
> 
> Five school girls took an exam. As they think thattheir
> parents are too much interested in their score, they promise
> that they write one correct and one wrong informations to
> their parents. Followings are parts of their letters
> concerning their result:
> 
> Betty: 	Kitty was the second and I third.
> Ethel: 	I won the top and Joan the second.
> Joan: 	I was the third and poor Ethel the last.
> Kitty: 	I was the second and Mary the fourth.
> Mary: 	I was the fourth. Betty won the top.
> 
> Guess the real order of the five school girls. 

Shorter:

(define (xor a b)
  (if a (not b) b))

(define (either a m  b n  lst)
  (xor (= m (amb-index a lst))
       (= n (amb-index b lst))))

(define (girls-exam)
  (amb-set-of
    (let* ((girls '(kitty betty ethel joan mary))
           (answer (amb-permutation girls)))
      (amb-assert (either 'kitty 2  'betty 3  answer))
      (amb-assert (either 'kitty 2  'mary 4  answer))
      (amb-assert (either 'mary 4  'betty 1  answer))
      (amb-assert (either 'ethel 1  'joan 2  answer))
      ;; Next line not needed.
      ;;     (amb-assert (either 'joan 3  'ethel 5  answer))
      answer)))

(girls-exam)
  ===>
((kitty joan betty mary ethel))

Supporting code:

;;   Modified from the excellent code found here
;; http://www.shido.info/lisp/scheme_amb_e.html
;;   and written by
;; SHIDO, Takafumi


;; [ SHIDO's comment ]
;; Notice that you cannot use the code shown in this chapter if
;; the searching path has loops. See SICP 4.3. for detailed
;; information on this matter.


;;; This function is re-assigned in `amb-choose' and `amb-fail' itself.
(define amb-fail #f)


;;; function for nondeterminism
(define (amb-choose . ls)
  (if (null? ls)
      (amb-fail)
    (let ((fail0 amb-fail))
      (call/cc
       (lambda (cc)
          (set! amb-fail
                (lambda ()
                  (set! amb-fail fail0)
                  (cc (apply amb-choose (cdr ls)))))
          (cc (car ls)))))))

 ;;; nondeterminism macro operator
 (define-syntax amb
   (syntax-rules ()
     ((_) (amb-fail))
     ((_ a) a)
     ((_ a b ...)
      (let ((fail0 amb-fail))
        (call/cc
  (lambda (cc)
    (set! amb-fail
      (lambda ()
        (set! amb-fail fail0)
        (cc (amb b ...))))
      (cc a)))))))


;;; returning all possibilities
(define-syntax amb-set-of
  (syntax-rules () 
    ((_ s) 
      (let ((acc '())) 
        (amb (let ((v s)) 
               (set! acc (cons v acc)) 
               (amb-fail)) 
             (reverse acc))))))
;;                  (reverse! acc))))))
    

;;; if not bool backtrack
(define (amb-assert bool)
  (or bool (amb)))
    
;;; returns arbitrary number larger or equal to n
(define (amb-integer-starting-from n)
  (amb n (amb-integer-starting-from (+ 1 n))))
    
;;; returns arbitrary number between a and b
(define (amb-number-between a b)
  (let loop ((i a))
    (if (> i b)
        (amb)
      (amb i (loop (+ 1 i))))))
;;       (amb i (loop (1+ i))))))


;;; write following at the end of file
;;; initial value for amb-fail
(call/cc
  (lambda (cc)
    (set! amb-fail
       (lambda ()
         (cc 'no-choice)))))


(define (amb-all-different? . ls)
  (let loop ((obj (car ls)) (ls (cdr ls)))
    (or (null? ls)
        (and (not (member obj ls))
             (loop (car ls) (cdr ls))))))

;; [Written by me.]
(define (amb-permutation lst)
  (let ((tmp (map (lambda(_) (apply amb-choose lst))
                  lst)))
    (amb-assert (apply amb-all-different? tmp))
    tmp))

;; First position is numbered 1.  [Written by me.]
(define (amb-index x xs)
  (let ((tail (member x xs)))
    (and tail (- (length xs) -1 (length tail)))))

;; Takes into consideration that y may appear
;; more than once.  [Written by me.]
(define (amb-before? x y lst)
  (let ((a (member x lst)))
    (and a
         (let ((b (member y lst)))
           (or (not b)
             (> (length a) (length b)))))))