Scheme Tutorial 4

Defining Syntax

自訂語法稱為 macro。

macro 是程式碼的代換，程式碼在被求值或編譯前，先進行替換，然後再繼續執行。

scheme 可使用符合 R5RS 規範的 syntax-rules 定義 macro，這個方式比 Common Lisp 簡單，使用 syntax-rules 可直接定義 macro ，而不需要擔心 variable capture 的問題。但 scheme 如果要定義複雜的 macro 就比 Common Lisp 困難。

ex: 一個將變數賦值為'()的 macro

syntax-rules 中第二個參數是變換前和變化後的表達式的序對所構成的表。 _ 代表 macro 的名字。這個 macro 會讓 (nil! x)會變換為(set! x '())

(define-syntax nil!
  (syntax-rules ()
    ((_ x)
     (set! x '()))))

因為 closure 的問題，這種程式不能用函數來實作，函數不能影響外部變數。

(define (f-nil! x)
   (set! x '()))
(define a 1)
;Value: a

(f-nil! a)
;Value: 1

a
;Value: 1           ; the value of a dose not change

ex: 編寫 macro: when，當謂詞求值為真時，求值相應語句

... 代表任意數量的 expressions。

以下的程式，會將 (when pred b1 ...)變換為(if pred (begin b1 ...))

(define-syntax when
  (syntax-rules ()
    ((_ pred b1 ...)
     (if pred (begin b1 ...)))))

因為這個 macro 是將 expression 變換為 if，因此不能用函數來實作，以下是使用 when 的範例

(let ((i 0))
  (when (= i 0)
    (display "i == 0")
    (newline)))

i == 0
;Unspecified return value

ex: 編寫 macro: while, for

(define-syntax while
  (syntax-rules ()
    ((_ pred b1 ...)
     (let loop () (when pred b1 ... (loop))))))

(define-syntax for
  (syntax-rules ()
    ((_ (i from to) b1 ...)
     (let loop((i from))
       (when (< i to)
      b1 ...
      (loop (1+ i)))))))

使用

(let ((i 0))
  (while (< i 10)
    (display i)
    (display #\Space)
    (set! i (+ i 1))))
0 1 2 3 4 5 6 7 8 9
;Unspecified return value


(for (i 0 10)
  (display i)
  (display #\Space))
0 1 2 3 4 5 6 7 8 9
;Unspecified return value

ex: 編寫 when 的相反，當謂詞求值為假時執行相應的表達式

(define-syntax unless
  (syntax-rules ()
    ((_ pred b1 ...)
     (if (not pred)
     (begin
       b1 ...)))))

同時定義多個 macro 模式

incf 可讓變數數值增加，如果沒有增加數量的參數，就直接 +1

(define-syntax incf
  (syntax-rules ()
    ((_ x) (begin (set! x (+ x 1)) x))
    ((_ x i) (begin (set! x (+ x i)) x))))

(let ((i 0) (j 0))
  (incf i)
  (incf j 3)
  (display (list 'i '= i))
  (newline)
  (display (list 'j '= j)))
(i = 1)
(j = 3)
;Unspecified return value

ex: 編寫 decf

(define-syntax decf
  (syntax-rules ()
    ((_ x) (begin (set! x (- x 1)) x))
    ((_ x i) (begin (set! x (- x i)) x))))

ex: 改進 for，可接受參數 step size，如沒有該參數，step size 為 1

(define-syntax for
  (syntax-rules ()
    ((_ (i from to) b1 ...)
     (let loop((i from))
       (when (< i to)
      b1 ...
      (loop (1+ i)))))
                
    ((_ (i from to step) b1 ...)
     (let loop ((i from))
       (when (< i to)
      b1 ...
      (loop (+ i step)))))))

遞迴定義 macro

or 與 and 是透過遞迴定義

(define-syntax my-and
  (syntax-rules ()
    ((_) #t)
    ((_ e) e)
    ((_ e1 e2 ...)
     (if e1
     (my-and e2 ...)
     #f))))

(define-syntax my-or
  (syntax-rules ()
    ((_) #f)
    ((_ e) e)
    ((_ e1 e2 ...)
     (let ((t e1))
       (if t t (my-or e2 ...))))))

ex: 定義 let*

(define-syntax my-let*
  (syntax-rules ()
    ((_ ((p v)) b ...)
     (let ((p v)) b ...))
    ((_ ((p1 v1) (p2 v2) ...) b ...)
     (let ((p1 v1))
       (my-let* ((p2 v2) ...)
        b ...)))))

使用保留字

syntax-rule 的第一個參數是保留字的 list，例如 cond 的定義中， else 是保留字

(define-syntax my-cond
  (syntax-rules (else)
    ((_ (else e1 ...))
     (begin e1 ...))
    ((_ (e1 e2 ...))
     (when e1 e2 ...))
    ((_ (e1 e2 ...) c1 ...)
     (if e1 
     (begin e2 ...)
     (cond c1 ...)))))

local syntax

scheme 可使用 let-syntax, leterc-syntax 定義 local syntax，這種形式的用法跟 define-syntax 類似

相依於 macro 定義的實作

有些 macro 無法用 syntax-rules 實作，但在不同的 scheme implementation 裡面有其他定義這種 macro 的方法。例如 MIT-scheme 的 sc-macro-transformer，可讓使用者用跟 Common Lisp 相似的方法實作 macro，` 以及 ,@的要參考 Common Lisp HyperSpec

ex: show-vars用於顯示變數的值

(define-syntax show-vars
  (sc-macro-transformer
    (lambda (exp env)
      (let ((vars (cdr exp)))
           `(begin
              (display
                (list
                  ,@(map (lambda (v)
                            (let ((w (make-syntactic-closure env '() v)))
                                 `(list ',w ,w)))
                          vars)))
      (newline))))))

(let ((i 1) (j 3) (k 7))
  (show-vars i j k))
((i 1) (j 3) (k 7))
;Unspecified return value

ex: random-choice被用於從參數中隨機選擇一個值或者過程

(define-syntax random-choice
  (sc-macro-transformer
   (lambda (exp env)
     (let ((i -1))
       `(case (random ,(length (cdr exp)))
      ,@(map (lambda (x)
           `((,(incf i)) ,(make-syntactic-closure env '() x)))
         (cdr exp)))))))

(define (turn-right) 'right)
(define (turn-left) 'left)
(define (go-ahead) 'straight)
(define (stop) 'stop)

(random-choice (turn-right) (turn-left) (go-ahead) (stop))
;Value: right

這是展開的結果

(case (random 4)
  ((0) (turn-right))
  ((1) (turn-left))
  ((2) (go-ahead))
  ((3) (stop)))

ex: anaphoric macro，謂詞的結果可以被指為it。變量it被捕獲，以使得第二個參數make-syntactic-closure變為'(it)

(define-syntax aif
  (sc-macro-transformer
   (lambda (exp env)
     (let ((test (make-syntactic-closure env '(it) (second exp)))
       (cthen (make-syntactic-closure env '(it) (third exp)))
       (celse (if (pair? (cdddr exp))
              (make-syntactic-closure env '(it) (fourth exp))
              #f)))
       `(let ((it ,test))
      (if it ,cthen ,celse))))))

(let ((i 4))
  (aif (memv i '(2 4 6 8))
       (car it)))
;Value: 4

這是展開的結果

(let ((it (memv i '(2 4 6 8))))
  (if it
      (car it)
      #f))

Continuation

Continuation 這是 scheme 特有的資料型別，其他程式語言沒有實作這種資料型別。

Continuation 的一般定義

Continuation 是回到 Top Level 以前，所需要執行的運算。例如 (* 3 (+ 1 2))，在求值 (+ 1 2)後，應該計算{ (* 3 []) } 乘以3，但是大部分的程式語言都不支援這樣的語法。

Continuation-Passing-Style(CPS)

CPS 是一種 programming style，這會將目前函數結果的後續函數，作為參數傳給現在的函數。

ex: CPS style 的加法與乘法

(define (return x)
  x)

(define (k+ a b k)
  (k (+ a b)))

(define (k* a b k)
  (k (* a b)))

; 計算 (* 3 (+ 1 2))
(k+ 1 2 (lambda (x) (k* x 3 return)))

Scheme的普通形式中，值在括號內被計算並向括號外傳遞。但 CPS 與此相反，值向括號內傳遞。上面的例子中，k+把(+ 1 2)的值傳遞給(lambda (x) (k* x 3 return))，而k*把(* (+ 1 2) 3)的結果傳給return。

以 CPS 方式撰寫遞迴函數

;;; normal factorial
(define (fact n)
  (if (= n 1)
      1
      (* n (fact (- n 1)))))

;;; CPS factorial
(define (kfact n k)
  (if (= n 1)
      (k 1)
      (kfact (- n 1) (lambda (x) (k (* n x))))))

; 3 + 4!
(+ 3 (fact 4))
;Value: 27

(kfact 4 (lambda (x) (k+ x 3 return)))
;Value: 27

ex: 用普通方式和CPS編寫計算表中元素之積的函數。在CPS函數中，後繼函數儲存在局部變量break中，因此當元素乘以0時，可以立即退出。

;;; normal
(define (product ls)
  (let loop ((ls ls) (acc 1))
    (cond
     ((null? ls) acc)
     ((zero? (car ls)) 0)
     (else (loop (cdr ls) (* (car ls) acc))))))

;;; CPS
(define (kproduct ls k)
  (let ((break k))
    (let loop ((ls ls) (k k))
      (cond
       ((null? ls) (k 1))
       ((zero? (car ls)) (break 0))
       (else (loop (cdr ls) (lambda (x) (k (* (car ls) x)))))))))

(+ 100 (product '(2 4 7)))
;Value: 156

(kproduct '(2 4 7) (lambda (x) (k+ x 100 return)))
;Value: 156

CPS 在這樣的例子中並不實用，但在 natural language parsing 與 logical programming 很有用。因 CPS 可靈活改變後續的過程。

exception handling

kproduct 的錯誤處理版本，當 list 出現非數字時，計算會終止

(define (non-number-value-error x)
  (display "Value error: ")
  (display  x)
  (display " is not number.")
  (newline)
  'error)

(define (kproduct ls k k-value-error)
  (let ((break k))
    (let loop ((ls ls) (k k))
      (cond
       ((null? ls) (k 1))
       ((not (number? (car ls))) (k-value-error (car ls)))
       ((zero? (car ls)) (break 0))
       (else (loop (cdr ls) (lambda (x) (k (* (car ls) x)))))))))


(kproduct '(2 4 7)
      (lambda (x) (k+ x 100 return))
      non-number-value-error)
;Value: 156

(kproduct '(2 4 7 hoge)
      (lambda (x) (k+ x 100 return))
      non-number-value-error)
Value error: hoge is not number.
;Value: error

Scheme 的 Continuation

Continuation 有以下特性

1. 存在於整個計算過程中
2. 函數式程序設計語言和CPS可以顯式地處理它

Scheme 將 Continuation 以 first class object 實作，這是普通的資料型別。任何時候都可以呼叫call-with-current-continuation。由於繼續是普通數據類型，你可以隨心所欲地重用。考慮到call-with-current-continuation名字過長，通常使用其縮名call/cc。

(define call/cc call-with-current-continuation)

函數call-with-current-continuation (call/cc)接受一個參數。該參數是一個函數，函數的參數接收當前繼續。

; 沒有呼叫 continuation，跟一般 S-expression 一樣
(* 3 (call/cc (lambda (k) (+ 1 2))))
;Value: 9

; 有使用 continuation，參數跳過了 call/cc 的處理，escape 到 call/cc 的外面
; k是一個一元函數，等同於 (lambda (x) (* 3 x))
(* 3 (call/cc (lambda (k) (+ 1 (k 2)))))
;Value: 6

目前的 continuation 可以像其它數據類型那樣被儲存起來，並隨心所欲地重用。由於目前的 continuation 是回到頂層的處理過程，它的返回會忽略周圍的S-表達式

(define cc)
  (* 3 (call/cc (lambda (k)
                  (set! cc k)
                  (+ 1 2))))
  
;Value: 9

(+ 100 (cc 3))
;Value: 9

(+ 100 (cc 10))
;Value: 30

Throwing values using call/cc

要從一個計算過程中 esacpe，最簡單的方式是使用 call/cc。

ex: 從 tree 裡面搜尋 leaf 元素

(define (find-leaf obj tree)
  (call/cc
    (lambda (cc)
       (letrec ((iter
                   (lambda (tree)
                      (cond
                        ((null?  tree) #f)
                        ((pair? tree)
                           (iter (car tree))
                           (iter (cdr tree)))
                        (else
                          (if (eqv? obj tree)
                            (cc obj)))))))
         (iter tree)))))

(find-leaf 7 '(1 (2 3) 4 (5 (6 7))))
;Value: 7

(find-leaf 8 '(1 (2 3) 4 (5 (6 7))))
;Value: #f

ex: 支援 throw 的語法 block

(define-syntax block
  (syntax-rules ()
    ((_ tag e1 ...)
     (call-with-current-continuation
       (lambda (tag)
          e1 ...)))))

(block break
   (map (lambda (x)
           (if (positive? x)
           (sqrt x)
           (break x)))
    '(1 2 3)))
;Value: (1 1.4142135623730951 1.7320508075688772)

(block break
   (map (lambda (x)
           (if (positive? x)
           (sqrt x)
           (break x)))
    '(1 -2 3)))
;Value: -2

generator

如何用 call/cc 實作一個 tree generator，該 generator 以一個 tree 為參數，回傳一個 function，每次呼叫後會傳回後續的 leaves。

(define (leaf-generator tree)
  (let ((return '()))     ; 定義 local 變數 return
    (letrec ((continue    ; 用 letrec 定義 continue。continue 會將 leaf 回傳，把 continue 設定給 continue 並停止
      (lambda ()
        (let rec ((tree tree))                                      ; 用 rec 定義 named let
          (cond                                                     ; 用 cond 實現分支
           ((null? tree) 'skip)                                     ; 如果是空的 list，就不處理
           ((pair? tree) (rec (car tree)) (rec (cdr tree)))         ; 如果是序對，遞迴地將 car, cdr 設定給 rec
           (else                                                    ; 如果是 leaf
            (call/cc (lambda (lap-to-go)                            ; 呼叫 call/cc 取得目前狀態 lap-to-go
                   (set! continue (lambda () (lap-to-go 'restart))) ; 將目前狀態賦值給 continue。除了原本的 continue，lap-to-go 也包含目前的狀態。呼叫 lap-to-go 就是 (car tree)
                   (return tree))))))                               ; 函數將找到的 leaf 返回到呼叫函數的地方
        (return '()))))                                             ; 搜尋後，找不到，回傳空 list
    (lambda ()                                                  ; 回傳 leaf-generator 的生成器
      (call/cc (lambda (where-to-go)                            ; 呼叫 call/cc
                 (set! return where-to-go)                      ; 將返回值的目前狀態，賦值給 return
                 (continue)))))))



(define tr '((1 2) (3 (4 5))))
(define p (leaf-generator tr))

(p)
;Value: 1

(p)
;Value: 2

(p)
;Value: 3

(p)
;Value: 4

(p)
;Value: 5

(p)
;Value: ()

coroutine

因 continue 記錄了後續的計算過程，可用於多個工作同時執行的 coroutine

ex: 交替列印數字和字母

;;; abbreviation
(define call/cc call-with-current-continuation)

;;; 實作 queue 的部分
(define (make-queue)
  (cons '() '()))

(define (enqueue! queue obj)
  (let ((lobj (list obj)))
    (if (null? (car queue))
  (begin
    (set-car! queue lobj)
    (set-cdr! queue lobj))
  (begin
    (set-cdr! (cdr queue) lobj)
    (set-cdr! queue lobj)))
    (car queue)))

(define (dequeue! queue)
  (let ((obj (car (car queue))))
    (set-car! queue (cdr (car queue)))
    obj))


;;; 實作 coroutine
; 過程的queue
(define process-queue (make-queue))

; 在process-queue末尾添加thunk
(define (coroutine thunk)
  (enqueue! process-queue thunk))

; 取得process-queue的第一個過程並執行它
(define (start)
   ((dequeue! process-queue)))

; 將當前繼續添加到process-queue的末尾並執行隊列裡的第一個過程。這個函數將控制權交給另外一個coroutine。
(define (pause)
  (call/cc
   (lambda (k)
     (coroutine (lambda () (k #f)))
     (start))))


;;; example 如何使用
(coroutine (lambda ()
       (let loop ((i 0))
         (if (< i 10)
       (begin
         (display (1+ i))
         (display " ")
         (pause)
         (loop (1+ i)))))))

(coroutine (lambda ()
       (let loop ((i 0))
         (if (< i 10)
       (begin
         (display (integer->char (+ i 97)))
         (display " ")
         (pause)
         (loop (1+ i)))))))

(newline)
(start)


(load "coroutine.scm")

;Loading "test.scm"...
1 a 2 b 3 c 4 d 5 e 6 f 7 g 8 h 9 i 10 j
;... done
;Unspecified return value

Lazy evaluation

Lazy evaluation 是在需要時才進行求值的計算方式。

R5RS中定義支援 lazy evaluation 的函數

中間狀態被稱為延時對象（promise），它表示求值方法已經定義好了，但求值還未執行。

最終的值通過對延時對象（promise）呼叫 force 計算出來。

• (delay proc)

  以proc創建一個延時對象（promise）。

• (promise? obj)

  如果obj是一個延時對象就返回 #t。

• (force promise)

  對延時對象求值，執行求值操作。

ex: 延時對象（promise）透過對(1 + 2) 呼叫 delay產生，然後透過函數force對延時對象求值。

force 沒有副作用 side effect，因此可以重複使用 laz

(define laz (delay (+ 1 2)))
;Value: laz

laz
;Value 11: #[promise 11]

(promise? laz)
;Value: #t

(force laz)
;Value: 3

(* 10 (force laz))
;Value: 30

以 lazy evaluation 表示無窮數列

可用 lazy evaluation 來代表無窮數列。

無窮數列可用 cons cell ( 與 ) 處理，cons 部分透過強制求值 cdr 產生，可無限重複這個過程來產生無窮數列。

無窮數列的函數與 macro

lazy-map包含一個特殊delay構造用於lazy evaluation，所以它需要被定義為 macro

ex: 等差和等比數列分別被定義為(ari a0 d)和(geo a0 r)，其中a0，d和r分別是初始值，公差，公比。這些函數使用函數inf-seq定義。

;;;;  sequences

;;; infinite sequences represented by a_(n+1) = f(a_n)
(define (inf-seq a0 f)
  (lazy-cons a0 (inf-seq (f a0) f)))

;;; arithmetic sequence 等差數列
(define (ari a0 d)
  (inf-seq a0 (lambda (x) (+ x d))))

;;; geometric sequence 等比數列
(define (geo a0 r)
  (inf-seq a0 (lambda (x) (* x r))))

(define g1 (geo 1 2))
(head g1 10)
;Value 12: (1 2 4 8 16 32 64 128 256 512)

(define g2 (geo 1 (/ 1 2)))

(head g2 10)
;Value 13: (1 1/2 1/4 1/8 1/16 1/32 1/64 1/128 1/256 1/512)

(head (lazy-map * g1 g2) 10)
;Value 14: (1 1 1 1 1 1 1 1 1 1)

(define ar1 (ari 1 1))
;;Value: ar1

(head ar1 10)
;;Value 15: (1 2 3 4 5 6 7 8 9 10)

(head (lazy-filter even? ar1) 10)
;;Value 16: (2 4 6 8 10 12 14 16 18 20)

ex: 費伯納西數列

fib(1) = 1
fib(2) = 1
fib(n+1) = fib(n) + fib(n-1)

(define fib
  (lazy-cons 1
             (lazy-cons 1
                        (lazy-map + fib (lazy-cdr fib)))))

(head fib 20)
;Value 5: (1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765)

(lazy-ref fib 100)

;Value: 573147844013817084101

ex: 牛頓法求平方根

a(n+1) =  (a(n) + N/a(n)) / 2

a =  (a +  N/a) / 2
⇒
      2a = a +  N/a
      a =  N/a
      a*a = N
      a =  √N

;;; Newton-Raphson method
(define (newton-raphson n)
  (inf-seq 1 (lambda (x) (/ (+ x (/ n x)) 2))))

;;; returning a reasonable answer.
;;; If the ratio of successive terms is in (1 - eps) and (1 + eps),
;;; or the following term is zero,
;;; the function returns it.
(define (lazylist->answer ls eps)
  (let ((e1 (- 1.0 eps))
        (e2 (+ 1.0 eps)))
    (let loop ((val (lazy-car ls))
               (ls1 (lazy-cdr ls)))
      (let ((val2 (lazy-car ls1)))
        (if  (or (zero? val2) (< e1 (/ val val2) e2))
            (exact->inexact val2)
          (loop val2 (lazy-cdr ls1)))))))

;;;
(define (my-sqrt n eps)
  (lazylist->answer (newton-raphson n) eps))

; 在相對誤差eps下，計算n的平方根
(my-sqrt 9 0.0000001)
; Value: 3.

Nondeterminism 不確定性

Nondeterminism 是一種透過定義問題來解決問題的方法。不確定性程式自動選擇符合條件的選項。這項技術很適合邏輯編程。

ex: 以下代碼返回一對數，其和是一個質數。其中一個數從'(4 6 7)選取，另一個從'(5 8 11)選取。

;;; abbreviation for call-with-current-continuation
(define call/cc call-with-current-continuation)

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

(define (prime? n)
  (let ((m (sqrt n)))
    (let loop ((i 2))
      (or (< m i)
          (and (not (zero? (modulo n i)))
               (loop (+ i (if (= i 2) 1 2))))))))


(define-syntax amb
  (sc-macro-transformer
   (lambda (exp env)
     (if (null? (cdr exp))
         `(fail)
       `(let ((fail0 fail))
          (call/cc
           (lambda (cc)
             (set! fail
                   (lambda ()
                     (set! fail fail0)
                     (cc (amb ,@(map (lambda (x)
                                       (make-syntactic-closure env '() x))
                                     (cddr exp))))))
             (cc ,(make-syntactic-closure env '() (second exp))))))))))

(let ((i (amb 4 6 7))
      (j (amb 5 8 11)))
  (if (prime? (+ i j))
      (list i j)
      (amb)))

;Value 23: (6 5)

(amb 4 6 7) 從4，6和7中返回一個合適的數，(amb 5 8 11)從5，8和11中返回一個合適的數。如果沒有選出合適的值，(amb)返回假。

ex: 邏輯編程

五位女同學參加一場考試。她們的家長對考試結果過分關心。為此她們約定，在給家裡寫信談到考試時，每個姑娘都要寫一句真話和一句假話。下面是從她們的信中摘出的句子：

貝蒂：“凱迪考第二，我只考了第三。” 艾賽爾：“你們應該高興地聽到我考了第一，瓊第二。” 瓊：“我考第三，可憐的艾賽爾考得最差。” 凱蒂：“我第二，瑪麗只考了第四。” 瑪麗：“我是第四，貝蒂的成績最高。”

這五位同學的實際排名是什麼？

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;      Nondeterminsm usint macro amb
;;;      T.Shido
;;;      November 15, 2005
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; abbreviation for call-with-current-continuation
(define call/cc call-with-current-continuation)

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


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; for MIT-Scheme only
; use it if you don't like warning during compilation
; (define-syntax amb
;   (sc-macro-transformer
;    (lambda (exp env)
;      (if (null? (cdr exp))
;          `(fail)
;        `(let ((fail0 fail))
;           (call/cc
;            (lambda (cc)
;              (set! fail
;                    (lambda ()
;                      (set! fail fail0)
;                      (cc (amb ,@(map (lambda (x)
;                                        (make-syntactic-closure env '() x))
;                                      (cddr exp))))))
;              (cc ,(make-syntactic-closure env '() (second exp))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

;;; if not pred backtrack
(define (assert pred)
  (or pred (amb)))

;;; returns arbitrary number larger or equal to n
(define (an-integer-starting-from n)
  (amb n (an-integer-starting-from (1+ n))))

;;; returns arbitrary number between a and b
(define (number-between a b)
  (let loop ((i a))
    (if (> i b)
        (amb)
      (amb i (loop (1+ i))))))


;;; small functions for SICP Exercise 4.42
(define (xor a b)
  (if a (not b) b))

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

;;; SICP Exercise 4.42
(define (girls-exam)
  (let ((kitty (number-between 1 5))
        (betty (number-between 1 5)))
    (assert (xor (= kitty 2) (= betty 3)))
    (let ((mary (number-between 1 5)))
      (assert (xor (= kitty 2) (= mary 4)))
      (assert (xor (= mary 4) (= betty 1)))
      (let ((ethel (number-between 1 5))
            (joan (number-between 1 5)))
        (assert (xor (= ethel 1) (= joan 2)))
        (assert (xor (= joan 3) (= ethel 5)))
        (assert (all-different? kitty betty ethel joan mary))
        (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))))

;;; Bad answer for ex 4.42
(define (girls-exam-x)
  (let ((kitty (number-between 1 5))
        (betty (number-between 1 5))
        (mary (number-between 1 5))
        (ethel (number-between 1 5))
        (joan (number-between 1 5)))
    (assert (xor (= kitty 2) (= betty 3)))
    (assert (xor (= kitty 2) (= mary 4)))
    (assert (xor (= mary 4) (= betty 1)))
    (assert (xor (= ethel 1) (= joan 2)))
    (assert (xor (= joan 3) (= ethel 5)))
    (assert (all-different? kitty betty ethel joan mary))
    (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))


;;; to show cpu time
(define-syntax cpu-time/sec
  (syntax-rules ()
    ((_ s)
     (with-timings
     (lambda () s)
       (lambda (run-time gc-time real-time)
     (write (internal-time/ticks->seconds run-time))
     (write-char #\space)
     (write (internal-time/ticks->seconds gc-time))
     (write-char #\space)
     (write (internal-time/ticks->seconds real-time))
     (newline))))))


;;; initializing fail
(call/cc
 (lambda (cc)
   (set! fail
         (lambda ()
           (cc 'no-choise)))))



(cpu-time/sec (girls-exam))
.01 0. .021
;Value 2: ((kitty 1) (betty 3) (ethel 5) (joan 2) (mary 4))

(cpu-time/sec (girls-exam-x))
.13 0. .203
;Value 3: ((kitty 1) (betty 3) (ethel 5) (joan 2) (mary 4))

References

mit-scheme user doc

Yet Another Scheme Tutorial 中文版

Yet Another Scheme Tutorial