• #### Non-determinism

From B. Pym@21:1/5 to All on Tue Jul 23 22:44:48 2024
XPost: comp.lang.scheme

From: Jeffrey Mark Siskind
Subject: Re: Permutations - lisp like
Date: 1998/10/12
Newsgroups: comp.lang.lisp

One elegant way of generating permutations (or any other form of combinatoric enumeration) is to write a nondeterministic description of the combinatoric structure. This can be done with Screamer, a nondeterministic extension to Common Lisp.

(defun a-split-of-internal (x y)
(if (null? y)
(list x y)
(either (list x y)
(a-split-of-internal (append x (list (first y))) (rest y)))))

(defun a-split-of (l) (a-split-of-internal '() l))

(defun a-permutation-of (l)
(if (null l)
l
(let ((split (a-split-of (a-permutation-of (rest l)))))
(append (first split) (cons (first l) (second split))))))

(defun permutations-of (l) (all-values (a-permutation-of l)))

Using Takafumi SHIDO's "amb". (Tested with Gauche Scheme
and Racket Scheme.)

(define (a-split-of-internal x y)
(if (null? y)
(list x y)
(amb (list x y)
(a-split-of-internal (append x (list (car y))) (cdr y)))))

(define (a-split-of l)
(a-split-of-internal '() l))

(define (a-permutation-of l)
(if (null? l)
l
(let ((split (a-split-of (a-permutation-of (cdr l)))))
(append (car split) (cons (car l) (cadr split))))))

(define (permutations-of l)
(amb-set-of (a-permutation-of l)))

(permutations-of '(a b c))

===>
((a b c) (b a c) (b c a) (a c b) (c a b) (c b a))

(permutations-of '(a b c d))

===>
((a b c d) (b a c d) (b c a d) (b c d a) (a c b d) (c a b d) (c b a d)
(c b d a) (a c d b) (c a d b) (c d a b) (c d b a) (a b d c) (b a d c)
(b d a c) (b d c a) (a d b c) (d a b c) (d b a c) (d b c a) (a d c b)
(d a c b) (d c a b) (d c b a))

;; 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)))))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)
• From B. Pym@21:1/5 to B. Pym on Tue Jul 23 23:30:24 2024
XPost: comp.lang.scheme

B. Pym wrote:

;; 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)))))

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.

;; ----------------------------------------------
;; Extra functions that don't involve
;; non-determinism.
;; ----------------------------------------------

(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))))))

;; 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)))))))

Now the problem.

(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))
(apply amb-choose girls)
(apply amb-choose girls)
(apply amb-choose girls)
(apply amb-choose girls)
(apply amb-choose 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))

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)
• From B. Pym@21:1/5 to B. Pym on Wed Jul 24 04:41:59 2024
XPost: comp.lang.scheme

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))
(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))

(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)))))))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)
• From Kaz Kylheku@21:1/5 to B. Pym on Wed Jul 24 08:18:24 2024
XPost: comp.lang.scheme

On 2024-07-24, B. Pym <Nobody447095@here-nor-there.org> wrote:
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:

[ snip astonishing 130 line continuation-driven spaghetti behemoth ]

((kitty joan betty mary ethel))

\$ txr girls.tl
#(kitty joan betty mary ethel)

\$ cat girls.tl
(defun one-truth (g i1 n1 i2 n2)
(neq (eq [g i1] n1) (eq [g i2] n2)))

(each ((g (perm #(kitty ethel joan mary betty) 5)))
(when (and (one-truth g 1 'kitty 2 'betty)
(one-truth g 0 'ethel 1 'joan)
(one-truth g 2 'joan 4 'ethel)
(one-truth g 1 'kitty 3 'mary)
(one-truth g 3 'mary 0 'betty))
(prinl g)))

--
TXR Programming Language: http://nongnu.org/txr
Cygnal: Cygwin Native Application Library: http://kylheku.com/cygnal
Mastodon: @Kazinator@mstdn.ca

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)
• From B. Pym@21:1/5 to B. Pym on Mon Aug 5 21:35:07 2024
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.

newLISP

;; Iterate over all permutations of a list, and
;; call a function on each.
(define (permute permute.seq permute.func (permute.built '()))
(if (null? permute.seq)
(permute.func permute.built)
(let (seq (copy permute.seq))
(dotimes (i (length seq))
(unless (zero? i) (rotate seq -1))
(permute
(rest seq)
permute.func
(cons (first seq) permute.built))))))

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

(define (find* x xs) (+ 1 (find x xs)))

(define (either a m b n lst)
(xor (= m (find* a lst))
(= n (find* b lst))))

(if
(and
(either 'kitty 2 'betty 3 answer)
(either 'kitty 2 'mary 4 answer)
(either 'mary 4 'betty 1 answer)
(either 'ethel 1 'joan 2 answer))