用scheme宏写个通用图灵机(universal turing-machine),顺带写个有限状态机(DFA)
lisp语言哲学就是:你不该写代码,你应该写宏,让这些宏来为你自动生成代码
作为lisp家族的主要成员之一的scheme拥有最先进的现代宏系统,利用模式匹配写个通用图灵机是非常简单的,下面就是完整代码:
#!r6rs
(import (rnrs))
(define (get-state configuration) (car configuration))
(define (get-tape configuration) (cadr configuration))
(define (get-position configuration) (caddr configuration))
(define-syntax compile-transition-rules
(lambda (x)
(syntax-case x ()
[(c ((Q (r w L/R ->Q)...)...))
#`(lambda (configuration)
(let ([state (get-state configuration)]
[tape (get-tape configuration)]
[pos (get-position configuration)])
(letrec
([show-configuration (lambda() (for-each display (list tape pos " " state "\n")))]
[move ;L/R
(lambda (direction)
(cond [(eq? direction 'L) (set! pos (- pos 1))]
[(eq? direction 'R) (set! pos (+ pos 1))]
[else (newline) (display "incorrect move direction\n")]))]
[#,(datum->syntax #'c 'H) ;halt state, accept and reject can be added easily
(lambda ()
(set! state 'H);just set for show-configuration
(show-configuration)
(display "halt\n"))]
[Q ;states
(lambda ()
(set! state 'Q);just set for show-configuration,can be removed for performance
(cond [(eq? r (vector-ref tape pos))
(vector-set! tape pos w);write to tape
(move 'L/R)
(show-configuration)
(->Q)]...))]...)
(cond [(eq? 'Q state)(Q)]...
[(eq? 'H state)(#,(datum->syntax #'c 'H))]
[else (for-each display `("no such state:" ,state "\n"))]))))])))
(import (rnrs))
(define (get-state configuration) (car configuration))
(define (get-tape configuration) (cadr configuration))
(define (get-position configuration) (caddr configuration))
(define-syntax compile-transition-rules
(lambda (x)
(syntax-case x ()
[(c ((Q (r w L/R ->Q)...)...))
#`(lambda (configuration)
(let ([state (get-state configuration)]
[tape (get-tape configuration)]
[pos (get-position configuration)])
(letrec
([show-configuration (lambda() (for-each display (list tape pos " " state "\n")))]
[move ;L/R
(lambda (direction)
(cond [(eq? direction 'L) (set! pos (- pos 1))]
[(eq? direction 'R) (set! pos (+ pos 1))]
[else (newline) (display "incorrect move direction\n")]))]
[#,(datum->syntax #'c 'H) ;halt state, accept and reject can be added easily
(lambda ()
(set! state 'H);just set for show-configuration
(show-configuration)
(display "halt\n"))]
[Q ;states
(lambda ()
(set! state 'Q);just set for show-configuration,can be removed for performance
(cond [(eq? r (vector-ref tape pos))
(vector-set! tape pos w);write to tape
(move 'L/R)
(show-configuration)
(->Q)]...))]...)
(cond [(eq? 'Q state)(Q)]...
[(eq? 'H state)(#,(datum->syntax #'c 'H))]
[else (for-each display `("no such state:" ,state "\n"))]))))])))
compile-transition-rules就是个universal turing-machine,它接收对特定图灵机的描述(transition-rules),生成(compile)指定的图灵机.描述的格式见下面的flip machine
之所以叫"compile",是因为compile-transition-rules把描述编译成scheme语言运行.实际上,scheme宏系统又被称为"轻量级编译接口" (light weght compile API)
这里有一个没有用宏的解释运行版本.
下面是使用这个turing-machine的例子:
;------------------------------flip machine--------------------------------
(define flip-TM (compile-transition-rules
((s1 (1 1 L s1) (0 1 R s2))
(s2 (1 0 R s2) (0 1 L s3))
(s3 (0 0 L s3) (1 1 R s4))
(s4 (0 0 L H)))))
(define tape1
(list->vector '(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)))
(define config1 (list 's1 tape1 17))
(flip-TM config1);run the flip-machine
;----------------------------------------------------------------------------
(define flip-TM (compile-transition-rules
((s1 (1 1 L s1) (0 1 R s2))
(s2 (1 0 R s2) (0 1 L s3))
(s3 (0 0 L s3) (1 1 R s4))
(s4 (0 0 L H)))))
(define tape1
(list->vector '(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)))
(define config1 (list 's1 tape1 17))
(flip-TM config1);run the flip-machine
;----------------------------------------------------------------------------
flip machine把给他的带子(tape)上的所有1翻转成0
输出执行过程:
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)16 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)15 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)14 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)13 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)12 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)11 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)10 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)9 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)8 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)7 s1
#(_ _ _ _ _ _ _ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)8 s1
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)9 s2
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)10 s2
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)11 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)12 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)13 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)14 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)15 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)16 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)17 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)18 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)19 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)20 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)21 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)22 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)23 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)24 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)25 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)26 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)25 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)24 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)23 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)22 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)21 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)20 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)19 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)18 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)17 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)16 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)14 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)13 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)12 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)11 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)10 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)9 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)8 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)7 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)8 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)7 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)7 H
halt
再来个例子耍耍:
;---------------------------------doubler------------------------------------
(define doubler (compile-transition-rules
((s1 (1 1 L s1) (0 1 R s2))
(s2 (1 0 R s3) (0 0 L s8))
(s3 (0 0 R s4) (1 1 R s3))
(s4 ('_ 1 L s5) (1 1 R s4))
(s5 (0 0 L s6) (1 1 L s5))
(s6 (0 0 R s8) (1 1 L s7))
(s7 (0 0 R s2) (1 1 L s7))
(s8 (0 0 R s8) (1 0 R s8) ('_ 0 L s9))
(s9 (0 0 L s10))
(s10 (0 1 L s10) (1 0 R s11))
(s11 (0 0 L H) (1 1 L H)))))
(define tape2
(list->vector '(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)))
(define config2 (list 's1 tape2 11))
(doubler config2)
;----------------------------------------------------------------------------
(define doubler (compile-transition-rules
((s1 (1 1 L s1) (0 1 R s2))
(s2 (1 0 R s3) (0 0 L s8))
(s3 (0 0 R s4) (1 1 R s3))
(s4 ('_ 1 L s5) (1 1 R s4))
(s5 (0 0 L s6) (1 1 L s5))
(s6 (0 0 R s8) (1 1 L s7))
(s7 (0 0 R s2) (1 1 L s7))
(s8 (0 0 R s8) (1 0 R s8) ('_ 0 L s9))
(s9 (0 0 L s10))
(s10 (0 1 L s10) (1 0 R s11))
(s11 (0 0 L H) (1 1 L H)))))
(define tape2
(list->vector '(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)))
(define config2 (list 's1 tape2 11))
(doubler config2)
;----------------------------------------------------------------------------
doubler把tape上的1的个数翻倍
输出执行过程:
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)10 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)9 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)8 s1
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)7 s1
#(_ _ _ _ _ _ _ 1 1 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)8 s1
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)9 s2
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)10 s3
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)11 s3
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)12 s3
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)13 s3
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)14 s3
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 _ _ _ _ _ _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)14 s4
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)13 s5
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)12 s6
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)11 s7
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)10 s7
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)9 s7
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)8 s7
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)9 s7
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)10 s2
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)11 s3
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)12 s3
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)13 s3
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)14 s3
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 _ _ _ _ _ _ _ _ _ _)16 s4
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)15 s4
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)14 s5
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)13 s5
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)12 s6
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)11 s7
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)10 s7
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)9 s7
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)10 s7
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)11 s2
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)12 s3
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)13 s3
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)14 s3
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)16 s4
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 _ _ _ _ _ _ _ _ _)17 s4
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)16 s4
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)15 s5
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)14 s5
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)13 s5
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)12 s6
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)11 s7
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)10 s7
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 0 1 1 1 _ _ _ _ _ _ _ _)11 s7
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)12 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)13 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)14 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)16 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)17 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 _ _ _ _ _ _ _ _)18 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)17 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)16 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)15 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)14 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)13 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)12 s6
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)11 s7
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 0 1 1 1 1 _ _ _ _ _ _ _)12 s7
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)13 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)14 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)16 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)17 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)18 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 _ _ _ _ _ _ _)19 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)18 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)17 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)16 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)15 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)14 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)13 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)12 s6
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 0 1 1 1 1 1 _ _ _ _ _ _)13 s7
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)14 s2
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)15 s3
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)16 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)17 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)18 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)19 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _ _)20 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)19 s4
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)18 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)17 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)16 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)15 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)14 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)13 s5
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)14 s6
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 1 _ _ _ _ _)15 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 1 1 1 1 1 _ _ _ _ _)16 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 1 1 1 1 _ _ _ _ _)17 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 1 1 1 _ _ _ _ _)18 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 1 1 _ _ _ _ _)19 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 1 _ _ _ _ _)20 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 _ _ _ _ _)21 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 _ _ _ _)20 s8
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 _ _ _ _)19 s9
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 _ _ _ _)18 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 0 1 1 0 0 _ _ _ _)17 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 _ _ _ _)16 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 0 1 1 1 1 0 0 _ _ _ _)15 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 0 1 1 1 1 1 0 0 _ _ _ _)14 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 _ _ _ _)13 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 0 1 1 1 1 1 1 1 0 0 _ _ _ _)12 s10
#(_ _ _ _ _ _ _ 1 0 0 0 0 1 1 1 1 1 1 1 1 0 0 _ _ _ _)11 s10
#(_ _ _ _ _ _ _ 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)10 s10
#(_ _ _ _ _ _ _ 1 0 0 1 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)9 s10
#(_ _ _ _ _ _ _ 1 0 1 1 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)8 s10
#(_ _ _ _ _ _ _ 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)7 s10
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)8 s10
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)7 s11
#(_ _ _ _ _ _ _ 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 _ _ _ _)7 H
halt
写个有限状态机(DFA)就更简单了,用syntax-rules就够了:
!#r5rs
(define true #t)
(define false #f)
(define-syntax make-DFA
(syntax-rules (: ->)
((_ init-state (state : result (symbol -> next) ...) ...)
(letrec
((state
(lambda(sigma)
(cond
((null? sigma) result)
(else
(case (car sigma)
((symbol)
(next (cdr sigma)))...
(else false))))))... )
init-state))))
这个DFA可以用来识别字符串(正则表达式也可以,不过需要再写个函数把正则表达式翻译成图):
(define machine
(make-DFA q1
(q1 : true (#\a -> q2)
(#\b -> q3))
(q2 : false (#\a -> q1)
(#\b -> q4))
(q3 : false (#\a -> q4)
(#\b -> q1))
(q4 : true (#\a -> q3)
(#\b -> q2))))
(machine (string->list "ababa"))
;=>#f 拒绝"ababa"
(make-DFA q1
(q1 : true (#\a -> q2)
(#\b -> q3))
(q2 : false (#\a -> q1)
(#\b -> q4))
(q3 : false (#\a -> q4)
(#\b -> q1))
(q4 : true (#\a -> q3)
(#\b -> q2))))
(machine (string->list "ababa"))
;=>#f 拒绝"ababa"
如果用没有模式匹配的传统lisp宏系统(defmacro)来写,代码应该会长不少,而且可读性也会更差 .
