2019年12月9日

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),其中a0dr分別是初始值,公差,公比。這些函數使用函數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

2019年12月2日

Scheme Tutorial 3

Input/Output

瞭解如何讀寫檔案

Input from Files 自檔案輸入

open-input-file,read-char和eof-object?

(open-input-file filename) 可打開一個文件,回傳 a port of file。

(read-char port)用於從port中讀取一個 char。當讀取到文件結尾(EOF)時,此函數返回eof-object,可以使用eof-object?來檢查。

(close-input-port port)用於關閉輸入 port。

ex: 實作以字符串形式回傳文件內容的函數

(define (read-file file-name)
  (let ((p (open-input-file file-name)))
    (let loop((ls1 '()) (c (read-char p)))
      (if (eof-object? c)
        (begin
          (close-input-port p)
          (list->string (reverse ls1)))
        (loop (cons c ls1) (read-char p)) ))))

(read-file "hello.txt")

begin 是一個集合多個 expression 的語法,當原本的語法中,只能放一個 form/expression 時,就用 begin 包裝多個 form/expression

ex: 每次使用 y 都會加上 1

(+ x 
   (begin (set! y (+ y 1)) y) 
   z)
call-with-input-file, with-input-from-file

(call-with-input-file filename procedure)

將 filename 文件打開後,提供輸入,procedure 接受 input port 為參數,因文件可能會再被使用,procedure 結束後,不會自動關閉 port,必須自己呼叫 (close-input-port p)

(define (read-file file-name)
  (call-with-input-file file-name
    (lambda (p)
      (let loop((ls1 '()) (c (read-char p)))
         (if (eof-object? c)
            (begin
              (close-input-port p)
              (list->string (reverse ls1)))
         (loop (cons c ls1) (read-char p))) ))))

如果是使用 with-input-from-file ,會自動關閉 port

(define (read-file file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop((ls1 '()) (c (read-char)))
        (if (eof-object? c)
          (list->string (reverse ls1))
        (loop (cons c ls1) (read-char)))) )))
read

(read port) 可從 port 讀取 S-expression

ex: paren.txt

'(Hello world!
Scheme is an elegant programming language.)

'(Lisp is a programming language ready to evolve.)
(define (s-read file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop ((ls1 '()) (s (read)))
        (if (eof-object? s)
          (reverse ls1)
        (loop (cons s ls1) (read)))) )))


(s-read "paren.txt")
;Value 2: ((quote (hello world! scheme is an elegant programming language.)) (quote (lisp is a programming language ready to evolve.)))

ex:

編寫函數(read-lines),該函數返回一個由字符串構成的表,分別代表每一行的內容。在Scheme中,換行符是由#\Linefeed表示。下面展示了將該函數用於 hello.txt 的結果。 (read-lines "hello.txt") ⇒ ("Hello world!" "Scheme is an elegant programming language.")

(define (group-list ls sep)
  (letrec ((iter (lambda (ls0 ls1)
       (cond
        ((null? ls0) (list ls1))
        ((eqv? (car ls0) sep)
         (cons ls1 (iter (cdr ls0) '())))
        (else (iter (cdr ls0) (cons (car ls0) ls1)))))))
    (map reverse (iter ls '())) ))


(define (read-lines file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop((ls1 '()) (c (read-char)))
        (if (eof-object? c)
          (map list->string (group-list (reverse ls1) #\Linefeed))  ; *
        (loop (cons c ls1) (read-char)))) )))


(group-list '(1 4 0 3 7 2 0 9 5 0 0 1 2 3) 0)
;Value 3: ((1 4) (3 7 2) (9 5) () (1 2 3))

(read-lines "hello.txt")
;Value 4: ("Hello world!" "Scheme is an elegant programming language.")

Output to files 輸出到檔案

打開用來輸出資料的 port

(open-output-file filename)
打開一個文件用作輸出,取得該輸出的 port

(close-output-port port)
關閉用於輸出的port

(call-with-output-file filename procedure)
打開文件filename用於輸出,並呼叫 procedure。該函數以輸出的 port 為參數。

(with-output-to-file filename procedure)
打開文件filename作為標準輸出,並呼叫 procedure。該 procedure 沒有參數。當控制權從過程procedure中返回時,文件會自動被關閉。

用來輸出的函數

(write obj port)
該函數將obj輸出至port。字串被雙引號括起而字符具有前綴 #\ 。

(display obj port)
該函數將obj輸出至port。字串不被雙引號括起而字符不具有前綴#\。

(newline port)
以新行起始。

(write-char char port)
該函數向port寫入一個 char。

ex: 編寫函數(my-copy-file)實現拷貝文件

(define (my-copy-file from to)
  (let ((pfr (open-input-file from))
        (pto (open-output-file to)))
    (let loop((c (read-char pfr)))
      (if (eof-object? c)
        (begin
          (close-input-port pfr)
          (close-output-port pto))
        (begin
          (write-char c pto)
          (loop (read-char pfr)) ))) ))

ex: 編寫函數(print-line),該函數具有任意多的字串作為參數,並將它們輸出至標準輸出。輸出的字串應該用新行分隔。

(define (print-lines . lines)
  (let loop((ls0 lines))
    (if (pair? ls0)
        (begin
         (display (car ls0))
         (newline)
         (loop (cdr ls0))) ) ))

Assignment 賦值

在 scheme 不常用 assignment,濫用 assignment 會讓程式碼很難懂,除非不得已,否則不要使用 assignment。

某些特別的演算法需要 assignment 語法,例如 internal states 及 continuations

雖然 assignment 語法很常見,容易理解,但卻有些缺陷,因為 assignment 改變了參數的值,具有破壞性。R5RS 中定義 assignment 為 set!set-car!set-cdr!string-set!vector-set!,在 scheme 所有具有破壞性的保留字都是以 ! 結尾。

set!

使用前,該參數要先被定義。跟 Common Lisp 不同,set! 無法給一個 S-expression 賦值。

(define var 1)
(set! var (* var 10))
var
;Value: 10

(let ((i 1))
    (set! i (+ i 3))
    i)
;Value: 4

internal states

scheme 的變數作用範圍,限制在原始程式碼中的括號裡面,稱為 lexical closure 或 static scope。另外有一種稱為 dynamic scope,會在執行時動態決定作用範圍,目前已經沒有使用。

特殊形式 let, lambda, leterc 會產生 closure,lambda expression 的參數只在函數定義內部有效。

另外可使用 lexical closure 實現帶有 internal state 的 process,例如,模擬銀行帳戶存款/提款。

(define bank-account
  (let ((balance 10))
    (lambda (n)
      (set! balance (+ balance n))
      balance) ))


(bank-account -5)
;Value: 5

(bank-account -1)
;Value: 4

只要稍微修改一下,就可以實現多個帳戶

(define (make-bank-account balance)
  (lambda (n)
    (set! balance (+ balance n))
    balance))

;Gates makes a bank account by donating  10 dollars
(define gates-bank-account (make-bank-account 10))
;Value: gates-bank-account

; donating 50 dollars
(gates-bank-account 50)
;Value: 60

; withdrawing 55 dollars
(gates-bank-account -55)
;Value: 5


; Torvalds makes a bank account by donating 100 dollars
(define torvalds-bank-account (make-bank-account 100))
;Value: torvalds-bank-account

; withdrawing 70 dollars
(torvalds-bank-account -70)
;Value: 30

; donating 300 dollars
(torvalds-bank-account 300)
;Value: 330

scheme procedure 會回傳一個 value,其他的用途就稱為 side effect,而 assignment 與 IO 就是一種 side effect。

ex: 修改 make-bank-account,提款超過 balance 時,會發生 error

(define (make-bank-account amount)
  (lambda (n)
    (let ((m (+ amount n)))
      (if (negative? m)
        'error
        (begin
          (set! amount m)
           amount)) )))

list 的破壞性操作 set-car! set-cdr

set-car!set-cdr 分別為一個 cons 單元的 car 與 cdr 部分設定新的值,跟 set!不同,這兩個函數可以為 S-expression 賦值。

(define tree '((1 2) (3 4 5) (6 7 8 9)))

; 把 1 改成 100
(set-car! (car tree) 100)

tree
; ((100 2) (3 4 5) (6 7 8 9))

;把 '(7 8 9) 改為 '(a b c)
(set-cdr! (third tree) '(a b c))

tree
; ((100 2) (3 4 5) (6 a b c))

queue

queue 是一種 FIFO 資料結構,list 則是 FILO。

以下是 queue 的資料結構

這是 enqueue 操作

  1. 將最後一個 cons 單元的 cdr 部分,指向新的元素
  2. 將 cons-cell-top 的 cdr 部分指向新的元素

這是 dequeue 操作

  1. 將queue head 元素存在 local 變數中
  2. 將 cons-cell-top 的 car 部分指向第二個元素

(define (make-queue)
  (cons '() '()))

(define (enqueue! queue obj)
  (let ((lobj (cons 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))


(define q (make-queue))
;Value: q

(enqueue! q 'a)
;Value 12: (a)

(enqueue! q 'b)
;Value 12: (a b)

(enqueue! q 'c)
;Value 12: (a b c)

(dequeue! q)
;Value: a

q
;Value 13: ((b c) c)

char

在某個 char 前面加上 #\ 就表示它是 char,例如 #\a 表示 a

#\Space#\Tab#\Linefeed#\Return分別代表空格(Space)、製表符(Tab),Linefeed和返回(Return)

R5RS中定義了下面的與 char 相關的函數。

  • (char? obj)

    如果obj是一個 char 則返回#t

  • (char=? c1 c3)

    如果c1c2是同一個 char 的話則返回#t

  • (char->integer c)

    c轉化為對應的整數( char 代碼,character code)。

    ex:(char->integer #\a) => 97

  • (integer->char n)

    該函數將一個整數轉化為對應的字符。

  • (char<? c1 c2)(char<= c1 c2)(char> c1 c2)(char>= c1 c2)

    這些函數用於比較 char 。實際上,這些函數比較的是 char 代碼的大小。

    例如,(char<? c1 c2)等同於(< (char->integer c1) (char->integer c2))

  • (char-ci=? c1 c2)(char-ci<? c1 c2)(char-ci<=? c1 c2)(char-ci>? c1 c2)(char-ci>=? c1 c2)

    這些是 case-insensitive 比較函數

  • (char-alphabetic? c)(char-numeric? c)(char-whitespace? c)(char-upper-case? c)(char-lower-case? c)

    這些函數分別用於檢測 c是否為字母、數字、空白、大寫字母或小寫字母。

  • (char-upcase c)(char-downcase c)

    這些函數分別返回 c 對應的大寫或小寫。

string

用雙引號框住的就是字串

  • (string? s)

    如果s是一個字串則返回#t

  • (make-string n c)

    返回由n個 c 組成的字串。參數c 為 optional。

  • (string-length s)

    返回字串s的長度。

  • (string=? s1 s2)

    如果字串s1s2相同的話則返回#t

  • (string-ref s idx)

    返回字串s中索引為idx的 char(索引從0開始計數)。

  • (string-set! s idx c)

    將字符=串s中索引為idx的char設置為c

  • (substring s start end)

    返回字串sstart開始到end-1處的子字串。例如(substring "abcdefg" 1 4) => "b c d"

  • (string-append s1 s2 ...)

    連接兩個字串s1s2

  • (string->list s)

    將字串s轉換為由字符構成的表。

  • (list->string ls)

    將一個由 char 構成的表轉換為字串。

  • (string-copy s)

    複製字串s

ex: 編寫函數 title-style,讓每個單字的首字母大寫

先將 string 轉為 list,把空格後面的字元大寫,再轉回 string

(define (identity x) x)

(define (title-style str)
  (let loop ((ls (string->list str))
         (w #t)
         (acc '()))
    (if (null? ls)
    (list->string (reverse acc))
    (let ((c (car ls)))
      (loop (cdr ls)
        (char-whitespace? c)
        (cons ((if w char-upcase identity) c) acc))))))

;;; Another answer, You can assign caps to the string.
(define (title-style str)
  (let ((n (string-length str)))
    (let loop ((w #t) (i 0))
      (if (= i n)
      str
      (let ((c (string-ref str i)))
        (if w (string-set! str i (char-upcase c)))
        (loop (char-whitespace? c) (1+ i)))))))

(title-style "the cathedral and the bazaar")

symbol

透過 address 管理 string 的資料,symbol 可以被類似 eq? 這樣的函數快速處理,但 string 只能用 equal? 處理,因為 symbol 可被快速比較,常用來作 hash 的 key

以下是跟 symbol 有關的函數

  • (symbol? x)

    如果x是一個符號則返回#t。

  • (string->symbol str)

    str轉換為符號。str應該都是小寫的,否則地址系統可能無法正常運作。在MIT-Scheme中,(string->symbol "Hello")'Hello是不同的。

    (eq? (string->symbol "Hello") 'Hello)
    ;Value: ()
    
    (eq? (string->symbol "Hello") (string->symbol "Hello"))
    ;Value: #t
    
    (symbol->string  (string->symbol "Hello"))
    ;Value: "Hello"
  • (symbol->string sym)

    sym轉換為 string。

ex: 統計文章中的單字數量 wc.scm,裡面有用到 hash table 及 association list

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   wc.scm
;;;   a scheme word-count program
;;;
;;;    by T.Shido
;;;    on August 19, 2005
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; 將 list of chars (ls0) 轉為 symbol
(define (list->symbol ls0)
  (string->symbol (list->string (reverse! ls0))))

; 檢查 c 是否在 list (ls) 裡面,如果有,就回傳 #t
(define (char-in c . ls)
  (let loop((ls0 ls))
    (if (null? ls0)
        #f
      (or (char=? c (car ls0))
          (loop (cdr ls0))))))

; 讀入 fname 檔案,回傳 list of symbols,這個函數會將大寫轉為小寫,並轉會 list of chars(w) 為 symbol,同時添加在 list of symbols (wls) 裡面
(define (read-words fname)
  (with-input-from-file fname
    (lambda ()
      (let loop((w '()) (wls '()))
        (let ((c (read-char)))
          (cond
           ((eof-object? c)
            (reverse! (if (pair? w)
                          (cons (list->symbol w) wls)
                       wls)))
           ((char-in c #\Space #\Linefeed #\Tab #\, #\.  #\ #\( #\) #\= #\? #\! #\; #\:)
            (loop '() (if (pair? w)
                          (cons (list->symbol w) wls)
                        wls)))
       (else
        (loop (cons (char-downcase c) w) wls))))))))

; sorting al,依照出現的頻率
(define (sort-by-frequency al)
  (sort al (lambda (x y) (> (cdr x) (cdr y)))))

; 讀入檔案 fname,回傳 a sorted association list by frequency in descending order
(define (wc fname)
  (let ((wh (make-eq-hash-table)))
    (let loop((ls (read-words fname)))
      (if (null? ls)
          (sort-by-frequency (hash-table->alist wh))
        (begin
         (hash-table/put! wh (car ls) (1+ (hash-table/get wh (car ls) 0)))
         (loop (cdr ls)))))))

Association List and Hash table

資料關聯是用 key , value 組成的 data pair,value 可由唯一的 key 決定。

association list

symbol, string, 數字 常被用來當作 key

'((hi . 3) (everybody . 5) (nice . 3) (to . 10) (meet . 4) (you . 8))
'((1 2 3) (4 5 6) (7 8 9))

assq, assv, assc 可從 association list 中搜尋某一項,如果找到 pair 的 car 等於給定的 key,就回傳該 data pair,找不到就回傳 #f。這些函數分別是使用 eq?, eqv?, equal? ,這表示 assq 速度最快。string, vector, list 應該轉換為 symbol 再當做 key,會提高程式效能。

(define wc '((hi . 3) (everybody . 5) (nice . 3) (to . 10) (meet . 4) (you . 8)))
;Value: wc

(assq 'hi wc)
;Value 2: (hi . 3)

(assq 'you wc)
;Value 3: (you . 8)

(assq 'i wc)
;Value: #f

(define n '((1 2 3) (4 5 6) (7 8 9)))
;Value: n

(assv 1 n)
;Value 4: (1 2 3)

(assv 8 n)
;Value: #f

hash table

hash table 會將 key 轉成整數,將值存放在該整數指到的位置。search, insert, delete 都可在 O(1) 完成

  • (make-eq-hash-table size), (make-eqv-hash-table size), (make-equal-hash-table size), (make-string-hash-table size)

    產生 hash table 的函數,分別是使用eq?eqv?equal?,和string=?比較 key 的值。hash table 的初始 size 是 optional。由於只比較 key 的 address,所以 eq-hash-table是最快的。且由於鍵是序列,所以equal-hash-tablestring-hash-table比較慢。

  • (hash-table/put! hash-table key datum)

    hash-tablekey對應的值設為datum

  • (hash-table/get hash-table key default)

    返回hash-table中的key對應的值。如果key不存在於hash-table中,返回default

  • (hash-table->alist hash-table)

    hash-table轉換為 association list。

ex: 產生密碼

stat-spell.scm

; 可閱讀英文句子,將資料儲存在 hash table,轉換為 association list 並儲存在 stat-spell.data 文件裡面
;;; make an alist of probable spelling from a given english text

; 如果 c 不是圖像 char 或者c是 #\:, #\;, #\', or #\",就返回#t。讀取英文句子時,這些 char 會被跳過。
(define (skip-char? c)
  (or (not (char-graphic? c)) (memv c '(#\: #\; #\' #\" #\`))))

; 有兩個參數;字元的頻率的關聯表(alist)和字元(c)。如果c在alist中,在序對的cdr部分增加一。如果不在,返回 (cons (cons c 1) alist)
(define (ss-make-alist c alist)
  (let ((p (assv c alist)))
    (if p
        (begin
         (set-cdr! p (1+ (cdr p)))
         alist)
      (cons (cons c 1) alist))))

; 由 filename 檔案中讀取 char,使用下一個 char 的出現頻率的 association list,來記錄這些字元
; stat-speel.dat 儲存結果類似:
; (#\v (#\y . 1) (#\a . 3) (#\o . 7) (#\e . 51) (#\i . 15))
; 表示 #\y, #\a, #\o, #\e, 和 #\i 跟隨 #\v 之後出現的次數分別是1, 3, 7, 51, 和15次
(define (ss-make-dat filename)
  (let ((char-hash (make-eqv-hash-table)))
    (with-input-from-file filename
      (lambda ()
    (let loop ((c #\Space))
      (let ((c1 (read-char)))
                 (if (not (eof-object? c1))
                     (if (skip-char? c1)
                         (loop c)
                         (let ((c1 (char-downcase c1)))
               (hash-table/put! char-hash c
                        (ss-make-alist c1 (hash-table/get char-hash c '())))
               (loop c1))))))))
    (with-output-to-file "stat-spell.dat"
      (lambda ()
    (display "(define *stat-spell* \'(")
    (newline)
    (let loop ((alst (sort (hash-table->alist char-hash)
                   (lambda (x y) (char<? (car x) (car y))))))
      (if (pair? alst)
          (begin
        (write (car alst))
        (newline)
        (loop (cdr alst)))))
        (display "))")
        (newline)))))

make-pw.scm

;;; make password from the alist of probable spelling
; 基於 stat-spell.dat 頻率數據產生由9到13個隨機字符組成字串表。#\Space 被添加在表結尾。
; 添加一個00到99之間的隨機數在隨機選取的字符串表的結尾。
; 隨機地將 #\Space 轉換為 #-, #_, #\/, #\Space, #., 或者 #\,。
; 隨機地將30%的字母字符變為大寫。

(load "stat-spell.dat") ; *stat-spell* (alist for following characters) is in.

(define (alist->hash al mode)
  (let ((h (case mode
             ((eq) (make-eq-hash-table))
             ((eqv) (make-eqv-hash-table))
             ((equal) (make-equal-hash-table))
             ((string) (make-string-hash-table)))))
    (for-each (lambda (p)
                (hash-table/put! h (car p) (cdr p)))
              al)
    h))

(define *stat-spell-hash* (alist->hash *stat-spell* 'eqv))

(define (pw-random-select vec)
  (vector-ref vec (random (vector-length vec))))

(define (random00)
  (let loop ((i 0) (acc '()))
    (if (= i 2)
        (list->string acc)
      (loop (1+ i) (cons (pw-random-select '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) acc)))))

(define (occasional-upcase c)
  (if (< (random 10) 3)
      (char-upcase c)
    c))

(define (pw-enhance ls)
  (list->string
   (map (lambda (c)
          (cond
           ((char=? c #\Space)
            (pw-random-select  '#(#\- #\_ #\/  #\Space  #\. #\, #\@ #\? #\( #\))))
           ((char-alphabetic? c)
            (occasional-upcase c))
           (else c)))
        (cdr (reverse! ls)))))


(define (random-following alist)
  (let ((n (random (apply + (map cdr alist)))))
    (let loop ((j 0) (alist alist))
      (if (pair? alist)
      (let* ((pair (car alist))
         (k (+ j (cdr pair))))
        (if (> k n)
        (car pair)
        (loop k (cdr alist))))))))

(define (make-pw h n)
  (let loop ((i 0) (c #\Space) (acc '()))
    (if (= i n)
        (string-append
         (pw-enhance (cons #\Space (cons c acc)))
         (random00))
      (loop (1+ i)
        (random-following (hash-table/get h c '((#\Space . 1))))
        (cons c acc)))))

(define (pw-candidates)
  (let loop ((i 0))
    (if (< i 10)
        (begin
         (display i)
         (display ": ")
         (write (make-pw *stat-spell-hash* (+ 9 (random 4))))
         (newline)
         (loop (1+ i)))
      'done)))

Vectors and Structures

vector 是使用整數索引的資料,可儲存不同資料型別的資料。跟 list 比較,vector資料更緊密且存取時間很短。但是 vector 是透過 side effect 來處理資料,會造成一些問題。

scheme 的 structures 跟 C 語言類似,但更容易使用,因為 scheme 為 structure 提供了讀取及寫入的函數(使用了 Lisp/Scheme 的 macro)。

vector

#( ) 表示,例如 #(1 2 3),作為 literals 時,必須要 quoted

ex:

'#(1 2 3) 整數向量

'#(a 0 #\a) symbol, 整數, char 的向量

R5RS規格中的向量函數

  • (vector? obj)

    如果obj是一個向量則返回#t。

  • (make-vector k) (make-vector k fill)

    返回有 k 個元素的向量。如果指定了第二個參數(fill),那麼所有的元素都會被初始化為fill。

  • (vector obj …)

    返回由參數列表構成的向量。

  • (vector-length vector)

    返回向量 vector 的長度。

  • (vector-ref vector k)

    返回向量 vector 的索引為 k 的元素。(向量的索引從0開始。)

  • (vector-set! vector k obj)

    將向量 vector 的索引為 k 的元素修改為 obj。

  • (vector->list vector)

    將 vector 轉換為 list。

  • (list->vector list)

    將 list 轉換為向量。

  • (vector-fill! vector fill)

    將向量 vector 的所有元素設定為 fill。

ex: 向量加法

(define (vector-add v1 v2)
  (let ((lenv1 (vector-length v1))
          (lenv2 (vector-length v2)))
    (if (= lenv1 lenv2)
          (let ((v (make-vector lenv1)))
            (let loop ((i 0))
              (if (= i lenv1)
                    v
                    (begin
                      (vector-set! v i (+ (vector-ref v1 i) (vector-ref v2 i)))
                      (loop (+ 1 i))))))
        (error "different dimensions."))))

(vector-add #(1 2 3) #(1 2 3))
;Value 2: #(2 4 6)

ex: 向量內積

(define (inner-product vec1 vec2)
  (let ((len1 (vector-length vec1))
          (len2 (vector-length vec2)))
    (if (= len1 len2)
        (let loop ((i 0) (pro 0))
          (if (= i len1)
              pro
              (loop (+ 1 i)
                  (+ pro (* (vector-ref vec1 i) (vector-ref vec2 i))))))
        (error "different dimensions."))))


(inner-product #(1 2 3) #(1 2 3))
;Value: 14

structure

R5RS 沒有定義 structure,但在 scheme 有實作類似於 Common Lisp 的 structure。

structure 本質上就是向量。每一個 slot 都透過 macro 來命名。

scheme 透過 define-structure 定義 structure,例如 定義書籍

(define-structure book title authors publisher year isbn)

(define bazaar 
  (make-book 
   "The Cathedral and the Bazaar"
   "Eric S. Raymond"
   "O'Reilly"
   1999
   0596001088))

但這樣定義,並沒有明確的屬性定義,改用 keyword-constructor 解決這個問題,其中參數 copier可用於為 structure 建立一個拷貝(copier)函數

(define-structure (book keyword-constructor copier) 
  title authors publisher year isbn)

(define bazaar 
  (make-book 
   'title "The Cathedral and the Bazaar"
   'authors "Eric S. Raymond"
   'publisher "O'Reilly"
   'year 1999    
   'isbn 0596001088))

支援 structure 的函數

  • [the name of structure]?的函數用於檢查某對象是否為特定structure。例如,可使用函數book?來檢查bazaar是否為book結構的一個實例。

    (book? bazaar)
    ;Value: #t
  • copy-[structure name] 函數用於拷貝結構。例如將 bazaar 複製到 cathedral

    (define cathedral (copy-book bazaar))
  • [structure name]-[attribute name] 函數用於讀取structure 某屬性的值。例如,讀取bazaartitle屬性。

    (book-title bazaar)
    ;Value 3: "The Cathedral and the Bazaar"
  • set-[結構體名稱]-[屬性名稱]!用於將某屬性設定為特定值

    (set-book-year! bazaar 2001)
    ;Unspecified return value
    
    (book-year bazaar)
    ;Value: 2001

Sample: Mastermind

一個猜對手密碼的遊戲。密碼是由0到9中四個不同的數組成的四位數。對手要通過使用bullscows的數量告知猜謎者猜測的準確程度。

  1. bull的數量(Nbull)是指值和位置都正確的數字的數量。
  2. cow的數量(Ncow)是指值正確但位置錯誤的數字的數量。

例如,密碼是5601,猜測是1685,那麼bullcow和數分別是1和2。

程式和用戶相互猜測對方的密碼。嘗試次數少的為勝利者。如果用戶和電腦在相同的嘗試次數中破解了密碼就是平局。

表示數字的方法:

產生長度為 10 的向量,索引值 k 表示 k 在密碼中的位置,四個位置為 1, 2, 3, 4,如果該數字沒乙出現,就是 0

5601  ->  #(2 1 0 0 0 4 3 0 0 0)   ; 數字0,1,5,和6分別出現在第2,第1,第4和第3位
1685  ->  #(0 4 0 0 0 1 3 0 2 0)

這樣的表示方式,可以快速地比較兩個數字,如果兩個向量,在相同索引位置的值都是正數,如果該值相等,就記為 bull,如果值不相等,就計為 cow。

以 5601 與 1685 為例,索引位置 6 的值都是 3,索引位置 1, 5 的值都是正數,bull, cow 的值是 1 與 2。

程式:
  1. 產生成一個 list,該表包含了所有不同四位數的向量表示。
  2. 從 list 中隨機選取一個數字。
  3. 重洗步驟(1)產生的表。
  4. 程式首次猜用戶的密碼,用戶給出bull和cow的數量。然後用戶猜程序的密碼,程序給出Nnull和Ncow。
  5. 重複步驟(3)直到程式的bull數量變為4為止。如果在同一次雙方的數量都變為4,就是平局。
測試:

先編譯程式再執行

(compile-file "mastermind.scm")
(load "mastermind")
(mastermind)

References

mit-scheme user doc

Yet Another Scheme Tutorial 中文版

Yet Another Scheme Tutorial