8クイーン問題*1です。
1. 普通な実装
(define nil '()) (define (enumerate-interval low high) (if (> low high) nil (cons low (enumerate-interval (+ low 1) high)))) (define (filter predicate sequence) (cond ((null? sequence) nil) ((predicate (car sequence)) (cons (car sequence) (filter predicate (cdr sequence)))) (else (filter predicate (cdr sequence))))) (define (accumulate op initial sequence) (if (null? sequence) initial (op (car sequence) (accumulate op initial (cdr sequence))))) (define (flatmap proc seq) (accumulate append nil (map proc seq))) (define (remove item sequence) (filter (lambda (x) (not (eq? x item))) sequence)) (define (permutations s) (if (null? s) (list nil) (flatmap (lambda (x) (map (lambda (p) (cons x p)) (permutations (remove x s)))) s))) (define (contain-zero? lst) (not (eq? (memv 0 (cdr lst)) #f))) (define (rotate lst) (map - lst (enumerate-interval 0 (- (length lst) 1)))) (define (translate lst) (map - lst (make-list (length lst) (car lst)))) (define (safe? lst) (cond ((null? lst) #t) ((contain-zero? (rotate (map abs (translate lst)))) #f) (else (safe? (cdr lst))))) (define (queens n) (filter (lambda (x) (safe? x)) (permutations (enumerate-interval 1 n))))
結果
gosh> (begin (map print (queens 8)) 'done) (1 5 8 6 3 7 2 4) (1 6 8 3 7 4 2 5) (1 7 4 6 8 2 5 3) (1 7 5 8 2 4 6 3) (2 4 6 8 3 1 7 5) (2 5 7 1 3 8 6 4) (2 5 7 4 1 8 6 3) (2 6 1 7 4 8 3 5) (2 6 8 3 1 4 7 5) (2 7 3 6 8 5 1 4) (2 7 5 8 1 4 6 3) (2 8 6 1 3 5 7 4) (3 1 7 5 8 2 4 6) (3 5 2 8 1 7 4 6) (3 5 2 8 6 4 7 1) (3 5 7 1 4 2 8 6) (3 5 8 4 1 7 2 6) (3 6 2 5 8 1 7 4) (3 6 2 7 1 4 8 5) (3 6 2 7 5 1 8 4) (3 6 4 1 8 5 7 2) (3 6 4 2 8 5 7 1) (3 6 8 1 4 7 5 2) (3 6 8 1 5 7 2 4) (3 6 8 2 4 1 7 5) (3 7 2 8 5 1 4 6) (3 7 2 8 6 4 1 5) (3 8 4 7 1 6 2 5) (4 1 5 8 2 7 3 6) (4 1 5 8 6 3 7 2) (4 2 5 8 6 1 3 7) (4 2 7 3 6 8 1 5) (4 2 7 3 6 8 5 1) (4 2 7 5 1 8 6 3) (4 2 8 5 7 1 3 6) (4 2 8 6 1 3 5 7) (4 6 1 5 2 8 3 7) (4 6 8 2 7 1 3 5) (4 6 8 3 1 7 5 2) (4 7 1 8 5 2 6 3) (4 7 3 8 2 5 1 6) (4 7 5 2 6 1 3 8) (4 7 5 3 1 6 8 2) (4 8 1 3 6 2 7 5) (4 8 1 5 7 2 6 3) (4 8 5 3 1 7 2 6) (5 1 4 6 8 2 7 3) (5 1 8 4 2 7 3 6) (5 1 8 6 3 7 2 4) (5 2 4 6 8 3 1 7) (5 2 4 7 3 8 6 1) (5 2 6 1 7 4 8 3) (5 2 8 1 4 7 3 6) (5 3 1 6 8 2 4 7) (5 3 1 7 2 8 6 4) (5 3 8 4 7 1 6 2) (5 7 1 3 8 6 4 2) (5 7 1 4 2 8 6 3) (5 7 2 4 8 1 3 6) (5 7 2 6 3 1 4 8) (5 7 2 6 3 1 8 4) (5 7 4 1 3 8 6 2) (5 8 4 1 3 6 2 7) (5 8 4 1 7 2 6 3) (6 1 5 2 8 3 7 4) (6 2 7 1 3 5 8 4) (6 2 7 1 4 8 5 3) (6 3 1 7 5 8 2 4) (6 3 1 8 4 2 7 5) (6 3 1 8 5 2 4 7) (6 3 5 7 1 4 2 8) (6 3 5 8 1 4 2 7) (6 3 7 2 4 8 1 5) (6 3 7 2 8 5 1 4) (6 3 7 4 1 8 2 5) (6 4 1 5 8 2 7 3) (6 4 2 8 5 7 1 3) (6 4 7 1 3 5 2 8) (6 4 7 1 8 2 5 3) (6 8 2 4 1 7 5 3) (7 1 3 8 6 4 2 5) (7 2 4 1 8 5 3 6) (7 2 6 3 1 4 8 5) (7 3 1 6 8 5 2 4) (7 3 8 2 5 1 6 4) (7 4 2 5 8 1 3 6) (7 4 2 8 6 1 3 5) (7 5 3 1 6 8 2 4) (8 2 4 1 7 5 3 6) (8 2 5 3 1 7 4 6) (8 3 1 6 2 5 7 4) (8 4 1 3 6 2 7 5) done
2. 無限ストリームによる実装
(define-syntax cons-stream (syntax-rules () ((_ a b) (cons a (delay b))))) (define (stream-car stream) (car stream)) (define (stream-cdr stream) (force (cdr stream))) (define (stream-null? stream) (null? stream)) (define (display-stream s) (stream-for-each display-line s)) (define (display-line x) (newline) (display x)) (define (stream-enumerate-interval low high) (if (> low high) the-empty-stream (cons-stream low (stream-enumerate-interval (+ low 1) high)))) (define the-empty-stream '()) (define (stream-filter pred stream) (cond ((stream-null? stream) the-empty-stream) ((pred (stream-car stream)) (cons-stream (stream-car stream) (stream-filter pred (stream-cdr stream)))) (else (stream-filter pred (stream-cdr stream))))) (define (stream-map proc . argstreams) (if (null? (car argstreams)) the-empty-stream (cons-stream (apply proc (map stream-car argstreams)) (apply stream-map (cons proc (map stream-cdr argstreams)))))) (define (stream-for-each proc s) (if (stream-null? s) 'done (begin (proc (stream-car s)) (stream-for-each proc (stream-cdr s))))) (define (stream-flatmap proc s) (flatten-stream (stream-map proc s))) (define (flatten-stream stream) (if (stream-null? stream) the-empty-stream (interleave-delayed (stream-car stream) (delay (flatten-stream (stream-cdr stream)))))) (define (interleave-delayed s1 delayed-s2) (if (stream-null? s1) (force delayed-s2) (cons-stream (stream-car s1) (interleave-delayed (force delayed-s2) (delay (stream-cdr s1)))))) (define (permutations s) (if (stream-null? s) (cons-stream the-empty-stream the-empty-stream) (stream-flatmap (lambda (x) (stream-map (lambda (p) (cons x p)) (permutations (stream-remove x s)))) s))) (define (stream-remove x s) (stream-filter (lambda (y) (not (eq? y x))) s)) (define (queens board-size) (display-stream (stream-filter safe? (permutations (stream-enumerate-interval 1 board-size))))) (define (safe? positions) (cond ((null? (cdr positions)) #t) ((safe1? positions) (safe? (cdr positions))) (else #f)))
先程の普通の実装では、すべての解答が得られるまで結果が表示されませんが、
無限ストリームによる実装では、すべての解答が得られなくても、見つけた解答から順次表示できます。
詳しい無限ストリームの解説は SICP 3.5.2 節*2を参照してください。
結果
gosh> (queens 8) (1 5 8 6 3 7 2 4) (1 6 8 3 7 4 2 5) (1 7 4 6 8 2 5 3) (3 1 7 5 8 2 4 6) (1 7 5 8 2 4 6 3) (2 4 6 8 3 1 7 5) (2 6 1 7 4 8 3 5) (2 5 7 1 3 8 6 4) (4 1 5 8 2 7 3 6) (2 5 7 4 1 8 6 3) (2 6 8 3 1 4 7 5) (4 1 5 8 6 3 7 2) (4 2 8 6 1 3 5 7) (2 7 3 6 8 5 1 4) (2 8 6 1 3 5 7 4) (2 7 5 8 1 4 6 3) (3 5 2 8 1 7 4 6) (4 2 5 8 6 1 3 7) (3 5 2 8 6 4 7 1) (3 5 7 1 4 2 8 6) (3 6 2 7 1 4 8 5) (5 1 4 6 8 2 7 3) (3 5 8 4 1 7 2 6) (3 6 2 5 8 1 7 4) (3 6 4 1 8 5 7 2) (5 3 1 6 8 2 4 7) (3 6 2 7 5 1 8 4) (3 6 4 2 8 5 7 1) (4 2 8 5 7 1 3 6) (3 7 2 8 5 1 4 6) (4 2 7 3 6 8 1 5) (3 6 8 1 4 7 5 2) (4 2 7 5 1 8 6 3) (3 6 8 1 5 7 2 4) (3 6 8 2 4 1 7 5) (4 2 7 3 6 8 5 1) (3 7 2 8 6 4 1 5) (3 8 4 7 1 6 2 5) (4 6 1 5 2 8 3 7) (5 1 8 4 2 7 3 6) (5 1 8 6 3 7 2 4) (5 3 1 7 2 8 6 4) (5 2 4 6 8 3 1 7) (6 1 5 2 8 3 7 4) (4 8 1 3 6 2 7 5) (5 2 6 1 7 4 8 3) (5 2 8 1 4 7 3 6) (5 2 4 7 3 8 6 1) (4 8 1 5 7 2 6 3) (6 3 1 8 5 2 4 7) (4 7 1 8 5 2 6 3) (4 7 5 2 6 1 3 8) (4 6 8 2 7 1 3 5) (4 6 8 3 1 7 5 2) (4 7 3 8 2 5 1 6) (4 8 5 3 1 7 2 6) (4 7 5 3 1 6 8 2) (7 1 3 8 6 4 2 5) (5 3 8 4 7 1 6 2) (6 3 1 8 4 2 7 5) (5 7 2 6 3 1 4 8) (6 2 7 1 3 5 8 4) (6 3 1 7 5 8 2 4) (5 7 1 4 2 8 6 3) (5 7 1 3 8 6 4 2) (7 2 4 1 8 5 3 6) (8 2 4 1 7 5 3 6) (6 2 7 1 4 8 5 3) (5 8 4 1 3 6 2 7) (5 7 2 4 8 1 3 6) (5 7 2 6 3 1 8 4) (6 4 1 5 8 2 7 3) (5 7 4 1 3 8 6 2) (5 8 4 1 7 2 6 3) (6 3 5 7 1 4 2 8) (6 3 5 8 1 4 2 7) (6 3 7 2 4 8 1 5) (6 3 7 4 1 8 2 5) (8 2 5 3 1 7 4 6) (6 4 7 1 3 5 2 8) (8 3 1 6 2 5 7 4) (6 3 7 2 8 5 1 4) (6 4 2 8 5 7 1 3) (7 2 6 3 1 4 8 5) (6 4 7 1 8 2 5 3) (8 4 1 3 6 2 7 5) (7 3 1 6 8 5 2 4) (6 8 2 4 1 7 5 3) (7 4 2 5 8 1 3 6) (7 4 2 8 6 1 3 5) (7 3 8 2 5 1 6 4) (7 5 3 1 6 8 2 4)done
3. AMB 評価器による実装。
まず AMB 評価器のコードから。
;; AMB Evaluator (use math.mt-random) ;; common (define nil '()) (define true #t) (define false #f) (define (true? x) (not (eq? x false))) (define (false? x) (eq? x false)) ;; apply (define (apply proc args succeed fail) ;; dummy ) (define apply-in-underlying-scheme (with-module scheme apply)) ;; debugging (define debugging false) (define (debug-on) (set! debugging true) true) (define (debug-off) (set! debugging false) false) (define (debug-print . msg) (define (debug-print-iter m) (cond ((null? m) (newline)) (else (display (car m)) (display " ") (debug-print-iter (cdr m))))) (if debugging (begin (display "*** DEBUG *** ") (debug-print-iter msg)))) ;; tagging (define (attach-tag type-tag contents) (cons type-tag contents)) (define (type-tag datum) (if (pair? datum) (car datum) (error "Bad tagged datum -- TYPE-TAG" datum))) (define (contents datum) (if (pair? datum) (cdr datum) (error "Bad tagged datum -- CONTENTS" datum))) ;; table object (define (make-table t) (define (filter predicate sequence) (cond ((null? sequence) nil) ((predicate (car sequence)) (cons (car sequence) (filter predicate (cdr sequence)))) (else (filter predicate (cdr sequence))))) (define (get op type) (let ((item (filter (lambda (x) (and (eq? (car x) op) (equal? (cadr x) type))) t))) (if (null? item) false (caddr (car item))))) (define (put op type item) (set! t (cons (list op type item) (filter (lambda (x) (not (and (eq? (car x) op) (equal? (cadr x) type)))) t)))) (define (dispatch m) (cond ((eq? m 'get) get) ((eq? m 'put) put) (else (error "Unknown request -- MAKE-TABLE" m)))) dispatch) (define table (make-table nil)) (define (get op type) ((table 'get) op type)) (define (put op type item) ((table 'put) op type item)) (define (apply-generic op . args) (let ((type-tags (map type-tag args))) (let ((proc (get op type-tags))) (if proc (apply-in-underlying-scheme proc (map contents args)) (error "No method for these types -- APPLY-GENERIC" (list op type-tags)))))) ;; (define (install-quote-package) ;; internals (define (text-of-quotation exp) (cadadr exp)) ;; interfaces (define (tag x) (attach-tag 'quote x)) (put 'make-exp 'quote (lambda (exp) (tag (list exp)))) (put 'analyze 'quote (lambda (exp) (let ((qval (text-of-quotation exp))) (lambda (env succeed fail) (succeed qval fail))))) 'done) (define (install-assignment-package) ;; internals (define (assignment-variable exp) (cadr exp)) (define (assignment-value exp) (caddr exp)) ;; interfaces (define (tag x) (attach-tag 'set! x)) (put 'make-exp 'set! (lambda (exp) (tag (make-assignment (assignment-variable exp) (assignment-value exp))))) (put 'analyze 'set! (lambda (exp) (let ((var (assignment-variable exp)) (vproc (analyze (assignment-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) (let ((old-value (lookup-variable-value var env))) (set-variable-value! var val env) (succeed 'ok (lambda () (set-variable-value! var old-value env) (fail2))))) fail))))) 'done) (define (install-permanent-assignment-package) ;; internals (define (assignment-variable exp) (cadr exp)) (define (assignment-value exp) (caddr exp)) ;; interfaces (define (tag x) (attach-tag 'permanent-set! x)) (put 'make-exp 'permanent-set! (lambda (exp) (tag (make-assignment (assignment-variable exp) (assignment-value exp))))) (put 'analyze 'permanent-set! (lambda (exp) (let ((var (assignment-variable exp)) (vproc (analyze (assignment-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) (set-variable-value! var val env) (succeed 'ok fail2)) fail))))) 'done) (define (install-definition-package) ;; internals (define (definition-variable exp) (if (symbol? (cadr exp)) (cadr exp) (caadr exp))) (define (definition-value exp) (if (symbol? (cadr exp)) (caddr exp) (make-lambda (cdadr exp) ; parameters (cddr exp)))) ; body ;; interfaces (define (tag x) (attach-tag 'define x)) (put 'make-exp 'define (lambda (exp) (tag (make-definition (definition-variable exp) (definition-value exp))))) (put 'definition-variable 'define (lambda (exp) (definition-variable exp))) (put 'definition-value 'define (lambda (exp) (definition-value exp))) (put 'analyze 'define (lambda (exp) (let ((var (definition-variable exp)) (vproc (analyze (definition-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) (define-variable! var val env) (succeed 'ok fail2)) fail))))) 'done) (define (install-lambda-package) ;; internals (define (lambda-parameters exp) (cadr exp)) (define (lambda-body exp) (cddr exp)) ;; interfaces (define (tag x) (attach-tag 'lambda x)) (put 'make-exp 'lambda (lambda (exp) (tag exp))) (put 'analyze 'lambda (lambda (exp) (let ((vars (lambda-parameters exp)) (bproc (analyze-sequence (lambda-body exp)))) (lambda (env succeed fail) (succeed (make-procedure vars bproc env) fail))))) 'done) (define (install-let-package) ;; internals (define (let-parameters exp) (cadr exp)) (define (let-body exp) (cddr exp)) (define (named-let-parameters exp) (let-parameters (cdr exp))) (define (named-let-body exp) (let-body (cdr exp))) (define (named-let-variable exp) (let-parameters exp)) (define (parameter-variables parameters) (map car parameters)) (define (parameter-exps parameters) (map cadr parameters)) (define (named-let? exp) (not (pair? (let-parameters exp)))) (define (let->combination exp env succeed fail) (let ((aprocs (map analyze (parameter-exps (let-parameters exp))))) (get-args aprocs env (lambda (args fail2) (succeed (apply (make-procedure (parameter-variables (let-parameters exp)) (analyze-sequence (let-body exp)) env) args succeed fail2) fail2)) fail))) (define (named-let->combination exp env succeed fail) (let ((ext-env (extend-environment (list (named-let-variable exp)) (list '*unassigned*) env))) (let ((var (named-let-variable exp)) (vproc (make-procedure (parameter-variables (named-let-parameters exp)) (analyze-sequence (named-let-body exp)) ext-env))) (define-variable! var vproc ext-env) (let ((pproc (analyze (named-let-variable exp))) (aprocs (map analyze (parameter-exps (named-let-parameters exp))))) (pproc ext-env (lambda (proc fail2) (get-args aprocs ext-env (lambda (args fail3) (succeed (apply proc args succeed fail3) fail3)) fail2)) fail))))) ;; interfaces (define (tag x) (attach-tag 'let x)) (put 'make-exp 'let (lambda (exp) (tag exp))) (put 'analyze 'let (lambda (exp) (if (named-let? exp) (lambda (env succeed fail) (named-let->combination exp env succeed fail)) (lambda (env succeed fail) (let->combination exp env succeed fail))))) 'done) (define (install-let*-package) ;; internals (define (let*-parameters exp) (cadr exp)) (define (let*-body exp) (cddr exp)) (define (first exp) (car exp)) (define (rests exp) (cdr exp)) (define (last-parameter? exp) (null? exp)) (define (let*->nested-lets parameters body) (if (last-parameter? parameters) body (make-let (list (first parameters)) (let*->nested-lets (rests parameters) body)))) ;; interfaces (define (tag x) (attach-tag 'let* x)) (put 'make-exp 'let* (lambda (exp) (tag exp))) (put 'analyze 'let* (lambda (exp) (let ((aproc (analyze (let*->nested-lets (let*-parameters exp) (make-sequence (let*-body exp)))))) (lambda (env succeed fail) (succeed (aproc env succeed fail) fail))))) 'done) (define (install-letrec-package) ;; internals (define (letrec-parameters exp) (cadr exp)) (define (letrec-body exp) (cddr exp)) (define (first exp) (car exp)) (define (rests exp) (cdr exp)) (define (variable param) (car param)) (define (expression param) (cadr param)) (define (last-parameter? exp) (null? exp)) (define (letrec->defines parameters body) (if (last-parameter? parameters) body (cons (make-definition (variable (first parameters)) (expression (first parameters))) (letrec->defines (rests parameters) body)))) ;; interfaces (define (tag x) (attach-tag 'letrec x)) (put 'make-exp 'letrec (lambda (exp) (tag exp))) (put 'analyze 'letrec (lambda (exp) (let ((body (analyze-sequence (letrec->defines (letrec-parameters exp) (letrec-body exp))))) (lambda (env succeed fail) (succeed (apply (make-procedure nil body env) nil succeed fail) fail))))) 'done) (define (install-if-package) ;; internals (define (if-predicate exp) (cadr exp)) (define (if-consequent exp) (caddr exp)) (define (if-alternative exp) (if (not (null? (cdddr exp))) (cadddr exp) 'false)) ;; interfaces (define (tag x) (attach-tag 'if x)) (put 'make-exp 'if (lambda (exp) (tag (make-if (if-predicate exp) (if-consequent exp) (if-alternative exp))))) (put 'analyze 'if (lambda (exp) (let ((pproc (analyze (if-predicate exp))) (cproc (analyze (if-consequent exp))) (aproc (analyze (if-alternative exp)))) (lambda (env succeed fail) (pproc env (lambda (pred-value fail2) (if (true? pred-value) (cproc env succeed fail2) (aproc env succeed fail2))) fail))))) 'done) (define (install-if-fail-package) ;; internals (define (if-succeed exp) (cadr exp)) (define (if-fail exp) (caddr exp)) (define (make-if-fail if-succeed if-fail) (list 'if-fail if-succeed if-fail)) ;; interfaces (define (tag x) (attach-tag 'if-fail x)) (put 'make-exp 'if-fail (lambda (exp) (tag (make-if-fail (if-succeed exp) (if-fail exp))))) (put 'analyze 'if-fail (lambda (exp) (let ((sproc (analyze (if-succeed exp))) (fproc (analyze (if-fail exp)))) (lambda (env succeed fail) (sproc env (lambda (val fail2) (succeed val fail2)) (lambda () (fproc env succeed fail))))))) 'done) (define (install-and-package) ;; internals (define (first-exp exp) (car exp)) (define (rest-exps exp) (cdr exp)) (define (last-exp? exp) (null? (cdr exp))) (define (make-and exps) (tag exps)) (define (analyze-and aexp env succeed fail) ((first-exp aexp) env (lambda (val fail2) (cond ((last-exp? aexp) (succeed val fail2)) (else (if (true? val) (analyze-and (rest-exps aexp) env succeed fail2) (succeed val fail2))))) fail)) ;; interfaces (define (tag x) (attach-tag 'and x)) (put 'make-exp 'and (lambda (exps) (make-and exps))) (put 'analyze 'and (lambda (exp) (let ((aexp (map analyze (cdr exp)))) (lambda (env succeed fail) (if (last-exp? aexp) (succeed true fail) (analyze-and aexp env succeed fail)))))) 'done) (define (install-or-package) ;; internals (define (first-exp exp) (car exp)) (define (rest-exps exp) (cdr exp)) (define (last-exp? exp) (null? (cdr exp))) (define (make-or exps) (tag exps)) (define (analyze-or aexp env succeed fail) ((first-exp aexp) env (lambda (val fail2) (cond ((last-exp? aexp) (succeed val fail2)) (else (if (false? val) (analyze-or (rest-exps aexp) env succeed fail2) (succeed true fail2))))) fail)) ;; interfaces (define (tag x) (attach-tag 'or x)) (put 'make-exp 'or (lambda (exps) (make-or exps))) (put 'analyze 'or (lambda (exp) (let ((aexp (map analyze (cdr exp)))) (lambda (env succeed fail) (if (last-exp? aexp) (succeed false fail) (analyze-or aexp env succeed fail)))))) 'done) (define (install-cond-package) ;; internals (define (cond-clauses exp) (cdr exp)) (define (cond-predicate clause) (car clause)) (define (cond-actions clause) (cdr clause)) (define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else)) (define (cond-extended-syntax? clause) (if (pair? clause) (eq? (cond-predicate clause) '=>) false)) (define (cond-extended-operator clause) (cadr clause)) (define (expand-clauses clauses) (if (null? clauses) false (let ((first (car clauses)) (rest (cdr clauses))) (if (cond-else-clause? first) (if (null? rest) (make-sequence (cond-actions first)) (error "ELSE clause isn't last -- EXPAND-CLAUSES" clauses)) (if (cond-extended-syntax? (cond-actions first)) (make-if (cond-predicate first) (list (cond-extended-operator (cond-actions first)) (cond-predicate first)) (expand-clauses rest)) (make-if (cond-predicate first) (make-sequence (cond-actions first)) (expand-clauses rest))))))) (define (make-cond clauses) (tag clauses)) ;; interfaces (define (tag x) (attach-tag 'cond x)) (put 'make-exp 'cond (lambda (exp) (make-cond exp))) (put 'analyze 'cond (lambda (exp) (let ((aproc (analyze (expand-clauses (cond-clauses exp))))) (lambda (env succeed fail) (succeed (aproc env succeed fail) fail))))) 'done) (define (install-sequence-package) ;; internals (define (first-exp exp) (car exp)) (define (rest-exps exp) (cdr exp)) (define (last-exp? exp) (null? (cdr exp))) (define (sequence-actions exp) (cdr exp)) ;; interfaces (define (tag x) (attach-tag 'sequence x)) (put 'make-exp 'sequence (lambda (seq) (tag seq))) (put 'analyze 'sequence (lambda (exp) (let ((aproc (analyze-sequence (sequence-actions exp)))) (lambda (env succeed fail) (aproc env succeed fail))))) 'done) (define (install-begin-package) ;; internals (define (first-exp exp) (car exp)) (define (rest-exps exp) (cdr exp)) (define (last-exp? exp) (null? (cdr exp))) (define (begin-actions exp) (cdr exp)) ;; interfaces (define (tag x) (attach-tag 'begin x)) (put 'make-exp 'begin (lambda (exp) (tag exp))) (put 'analyze 'begin (lambda (exp) (let ((aproc (analyze-sequence (begin-actions exp)))) (lambda (env succeed fail) (aproc env succeed fail))))) 'done) (define (install-application-package) ;; internals (define (operator exp) (car exp)) (define (operands exp) (cdr exp)) (define (execute-application proc args succeed fail) (define (procedure-parameters proc) (cadr proc)) (define (procedure-body proc) (caddr proc)) (define (procedure-environment proc) (cadddr proc)) ((procedure-body proc) (extend-environment (procedure-parameters proc) args (procedure-environment proc)) succeed fail)) ;; interfaces (define (tag x) (attach-tag 'application x)) (put 'make-exp 'application (lambda (exp) (tag exp))) (put 'analyze 'application (lambda (exp) (let ((pproc (analyze (operator exp))) (aprocs (map analyze (operands exp)))) (lambda (env succeed fail) (pproc env (lambda (proc fail2) (get-args aprocs env (lambda (args fail3) (execute-application proc args succeed fail3)) fail2)) fail))))) 'done) (define (install-delay-package) ;; internals (define (delay-body exp) (if (pair? exp) (cadr exp) exp)) ;; interfaces (define (tag x) (attach-tag 'delay x)) (put 'make-exp 'delay (lambda (exp) (tag exp))) (put 'analyze 'delay (lambda (exp) (let ((body (analyze-sequence (cdr exp)))) (lambda (env succeed fail) (succeed (make-procedure nil body env) fail))))) 'done) (define (install-force-package) ;; interfaces (define (tag x) (attach-tag 'force x)) (put 'make-exp 'force (lambda (exp) (tag exp))) (put 'analyze 'force (lambda (exp) (let ((aproc (analyze (cadr exp)))) (lambda (env succeed fail) (aproc env (lambda (proc fail2) (succeed (apply proc nil succeed fail2) fail2)) fail))))) 'done) (define (install-amb-package) ;; internals (define (amb-choices exp) (cdr exp)) ;; interfaces (define (tag x) (attach-tag 'amb x)) (put 'make-exp 'amb (lambda (exp) (tag exp))) (put 'analyze 'amb (lambda (exp) (let ((cprocs (map analyze (amb-choices exp)))) (lambda (env succeed fail) (define (try-next choices) (if (null? choices) (fail) ((car choices) env succeed (lambda () (try-next (cdr choices)))))) (try-next cprocs))))) 'done) (define (install-ramb-package) ;; internals (define (amb-choices exp) (cdr exp)) (define mt (make <mersenne-twister> :seed (sys-time))) (define (remove lst idx) (define (iter l nl i) (if (null? l) nl (if (= i idx) (iter (cdr l) nl (+ i 1)) (iter (cdr l) (append nl (cons (car l) nil)) (+ i 1))))) (iter lst nil 0)) ;; interfaces (define (tag x) (attach-tag 'ramb x)) (put 'make-exp 'ramb (lambda (exp) (tag exp))) (put 'analyze 'ramb (lambda (exp) (let ((cprocs (map analyze (amb-choices exp)))) (lambda (env succeed fail) (define (try-next choices) (if (null? choices) (fail) (let ((idx (mt-random-integer mt (length choices)))) ((list-ref choices idx) env succeed (lambda () (try-next (remove choices idx))))))) (try-next cprocs))))) 'done) (define (install-environment-package) ;; internals (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment nil) (define (make-frame variables values) (define (vars-vals->var-val-list vars vals) (if (null? vars) nil (cons (list (car vars) (car vals)) (vars-vals->var-val-list (cdr vars) (cdr vals))))) (let ((len-vars (length variables)) (len-vals (length values))) (cond ((= len-vars len-vals) (vars-vals->var-val-list variables values)) ((< len-vars len-vals) (error "Too many arguments supplied" variables values)) (else (error "Too few arguments supplied" variables values))))) (define (frame-variables frame) (map car frame)) (define (frame-values frame) (map cadr frame)) (define (variable var-val) (car var-val)) (define (value var-val) (cadr var-val)) (define (assigned? val) (not (eq? val '*unassigned*))) (define (add-binding-to-frame! var val frame) (set-car! frame (cons (list var val) (car frame)))) (define (extend-environment vars vals base-env) (cons (make-frame vars vals) base-env)) (define (setup-environment) (let ((initial-env (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment))) (define-variable! 'true true initial-env) (define-variable! 'false false initial-env) initial-env)) (define (scan-frame var frame) (cond ((null? frame) nil) ((eq? var (variable (car frame))) (car frame)) (else (scan-frame var (cdr frame))))) (define (scan-env var env f-frame-proc nf-frame-proc nf-env-proc) (cond ((eq? env the-empty-environment) (nf-env-proc)) (else (let ((var-val (scan-frame var (first-frame env)))) (if (not (null? var-val)) (f-frame-proc var-val env) (if (not (null? nf-frame-proc)) (nf-frame-proc env) (scan-env var (enclosing-environment env) f-frame-proc nf-frame-proc nf-env-proc))))))) (define (lookup-variable-value var env) (scan-env var env (lambda (var-val env) (let ((v (value var-val))) ;; (if (assigned? v) v ;; (error "unassigned variable")) )) nil (lambda () (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var)))) (define (set-variable-value! var val env) (scan-env var env (lambda (var-val env) (set-cdr! var-val (cons val nil))) nil (lambda () (error "Unbound variable -- SET!" var)))) (define (define-variable! var val env) (scan-env var env (lambda (var-val env) (set-cdr! var-val (cons val nil))) (lambda (env) (add-binding-to-frame! var val env)) nil)) (define (make-unbound! var env) (define (remove-var-val frame) (if (null? frame) nil (if (eq? var (variable (car frame))) (remove-var-val (cdr frame)) (cons (car frame) (remove-var-val (cdr frame)))))) (scan-env var env (lambda (var-val env) (set-car! env (remove-var-val (first-frame env)))) (lambda (env) (error "Unbound variable -- MAKE-UNBOUND!" var)) nil)) ;; interfaces (define (tag x) (attach-tag 'environment x)) (put 'make 'environment (lambda (vars vals) (make-frame vars vals))) (put 'extend 'environment (lambda (var val base-env) (extend-environment var val base-env))) (put 'lookup 'environment (lambda (var env) (lookup-variable-value var env))) (put 'set! 'environment (lambda (var val env) (set-variable-value! var val env))) (put 'define 'environment (lambda (var val env) (define-variable! var val env))) (put 'make-unbound! 'environment (lambda (var env) (make-unbound! var env))) (put 'setup 'environment (lambda () (setup-environment))) 'done) (define (install-procedure-package) ;; internals (define (procedure-parameters proc) (cadr proc)) (define (procedure-body proc) (caddr proc)) (define (procedure-environment proc) (cadddr proc)) ;; interfaces (define (tag x) (attach-tag 'procedure x)) (put 'make-exp 'procedure (lambda (exp) (tag exp))) (put 'apply 'procedure (lambda (procedure arguments succeed fail) (debug-print "APPLY PROCEDURE INVOKED" ) (let ((ext-env (extend-environment (procedure-parameters procedure) arguments (procedure-environment procedure)))) ((procedure-body procedure) ext-env succeed fail)))) (put 'user-print 'procedure (lambda (object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) '<procedure-env>)))) 'done) (define (install-primitive-package) ;; internals (define (operator exp) (car exp)) (define (operands exp) (cdr exp)) (define (primitive-implementation proc) (cadr proc)) (define primitive-procedures (list (list 'list list) (list 'cons cons) (list 'car car) (list 'cadr cadr) (list 'cdr cdr) (list 'cddr cddr) (list 'list-ref list-ref) (list 'make-list make-list) (list 'append append) (list 'length length) (list 'assoc assoc) (list 'sort sort) (list 'true? true?) (list 'false? false?) (list 'null? null?) (list '> >) (list '< <) (list '>= >=) (list '<= <=) (list '= =) (list '+ +) (list '- -) (list '* *) (list '/ /) (list 'not not) (list 'eq? eq?) (list 'equal? equal?) (list 'string->symbol string->symbol) (list 'symbol->string symbol->string) (list 'string-append string-append) (list 'memv memv) (list 'memq memq) (list 'odd? odd?) (list 'even? even?) ;; (list 'prime? prime?) (list 'abs abs) (list 'display display) (list 'newline newline) (list 'exit exit) )) (define (primitive-procedure? proc-name) (not (eq? (assoc proc-name primitive-procedures) false))) (define (primitive-procedure-names) (map car primitive-procedures)) (define (primitive-procedure-objects) (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures)) (define (apply-primitive-procedure proc args) (debug-print "APPLY PRIMITIVE INVOKED") (apply-in-underlying-scheme (primitive-implementation proc) args)) ;; interfaces (define (tag x) (attach-tag 'primitive x)) (put 'primitive-procedure? 'primitive (lambda (proc-name) (primitive-procedure? proc-name))) (put 'primitive-procedure-names 'primitive (lambda () (primitive-procedure-names))) (put 'primitive-procedure-objects 'primitive (lambda () (primitive-procedure-objects))) (put 'make-exp 'primitive (lambda (exp) (tag exp))) (put 'apply 'primitive (lambda (procedure arguments succeed fail) (apply-primitive-procedure procedure arguments))) (put 'analyze 'primitive (lambda (exp) (let ((pproc (analyze (operator exp))) (aprocs (map analyze (operands exp)))) (lambda (env succeed fail) (pproc env (lambda (proc fail2) (get-args aprocs env (lambda (args fail3) (succeed (apply-primitive-procedure proc args) fail3)) fail2)) fail))))) (put 'user-print 'primitive (lambda (object) (display object))) 'done) (define (install-evaluator-package) ;; internals (define input-prompt ";;; AMB-Eval input:") (define output-prompt ";;; AMB-Eval value:") (define succeed-proc (lambda (value fail) value)) (define fail-proc (lambda () 'failed)) (define (make-exp exp) (define (operator exp) (car exp)) (if (not (pair? exp)) exp (let ((proc (get 'make-exp (operator exp)))) (if (closure? proc) (proc exp) (if (primitive-procedure? (operator exp)) ((get 'make-exp 'primitive) exp) ((get 'make-exp 'application) exp)))))) (define (ambeval exp env succeed fail) (debug-print "AMBEVAL exp=" exp) ((analyze exp) env succeed fail)) (define (get-args aprocs env succeed fail) (if (null? aprocs) (succeed nil fail) ((car aprocs) env (lambda (arg fail2) (get-args (cdr aprocs) env (lambda (args fail3) (succeed (cons arg args) fail3)) fail2)) fail))) (define (apply procedure arguments succeed fail) (define (tagged-list? proc tag) (if (pair? proc) (eq? (car proc) tag) false)) (define (compound-procedure? proc) (tagged-list? proc 'procedure)) (define (primitive-procedure? proc) (tagged-list? proc 'primitive)) (if (or (compound-procedure? procedure) (primitive-procedure? procedure)) ((get 'apply (type-tag procedure)) procedure arguments succeed fail) procedure)) (define (prompt-for-input string) (newline) (newline) (display string) (newline)) (define (announce-output string) (newline) (display string) (newline)) (define (driver-loop) (define (internal-loop try-again) (prompt-for-input input-prompt) (let ((input (read))) (cond ((eq? input 'try-again) (try-again)) (else (newline) (display ";;; Starting a new problem ") (ambeval input the-global-environment (lambda (val next-alternative) (announce-output output-prompt) (user-print val) (internal-loop next-alternative)) (lambda () (announce-output ";;; There are no more values of") (user-print input) (driver-loop))))))) (internal-loop (lambda () (newline) (display ";;; There is no current problem") (driver-loop)))) (define (load-file file) (define (load-file-iter port) (let ((chunk (read port))) (cond ((eof-object? chunk) (close-input-port port) true) (else (ambeval chunk the-global-environment succeed-proc fail-proc) (load-file-iter port))))) (load-file-iter (open-input-file file))) ;interfaces (define (tag x) (attach-tag 'evaluator x)) (put 'make-exp 'evaluator (lambda (exp) (make-exp exp))) (put 'ambeval 'evaluator (lambda (exp env succeed fail) (ambeval exp env succeed fail))) (put 'get-args 'evaluator (lambda (aprocs env succeed fail) (get-args aprocs env succeed fail))) (put 'apply 'evaluator (lambda (proc args succeed fail) (apply proc args succeed fail))) (put 'loop 'evaluator (lambda () (driver-loop))) (put 'load-file 'evaluator (lambda (file) (load-file file))) 'done) (define (install-analyze-package) ;; internals (define (operator exp) (car exp)) (define (operands exp) (cdr exp)) (define (self-evaluating? exp) (cond ((number? exp) true) ((string? exp) true) (else false))) (define (variable? exp) (symbol? exp)) (define (quoted? exp) (eq? (type-tag exp) 'quote)) (define (unassigned? exp) (eq? exp '*unassigned*)) (define (analyze-self-evaluating exp) (lambda (env succeed fail) (succeed exp fail))) (define (analyze-unassigned exp) (lambda (env succeed fail) (succeed exp fail))) (define (analyze-variable exp) (lambda (env succeed fail) (succeed (lookup-variable-value exp env) fail))) (define (scan-out-defines exps) (define (first-exp exp) (car exp)) (define (rest-exps exp) (cdr exp)) (define (definition? exp) (if (pair? exp) (eq? (car exp) 'define) false)) (define (scan-out-defines-iter exp params body) (if (not (definition? (first-exp exp))) (list (make-let params (append body exp))) (scan-out-defines-iter (rest-exps exp) (append params (list (list (definition-variable (first-exp exp)) '*unassigned*))) (append body (list (make-assignment (definition-variable (first-exp exp)) (definition-value (first-exp exp)))))) )) (if (definition? (first-exp exps)) (scan-out-defines-iter exps nil (list 'begin)) exps)) (define (analyze-sequence exps) (define (sequentially proc1 proc2) (lambda (env succeed fail) (proc1 env (lambda (proc1-value fail2) (proc2 env succeed fail2)) fail))) (define (loop first-proc rest-procs) (if (null? rest-procs) first-proc (loop (sequentially first-proc (car rest-procs)) (cdr rest-procs)))) (let ((procs (map analyze (scan-out-defines exps)))) (if (null? procs) (error "Empty sequence -- ANALYZE")) (loop (car procs) (cdr procs)))) (define (analyze exp) (let ((texp (make-exp exp))) (debug-print "ANALYZE exp=" exp) (cond ((self-evaluating? texp) (analyze-self-evaluating texp)) ((unassigned? texp) (analyze-unassigned texp)) ((variable? texp) (analyze-variable texp)) ((quoted? texp) ((get 'analyze 'quote) texp)) (else (let ((e (get 'analyze (operator texp)))) (if (closure? e) (e (operands texp)) (error "Unknown expression type -- ANALYZE" texp))))))) ;; interfaces (define (tag x) (attach-tag 'analyze x)) (put 'analyze-sequence 'analyze (lambda (exps) (analyze-sequence exps))) (put 'analyze 'analyze (lambda (exp) (analyze exp))) 'done) ;; install packages (install-quote-package) (install-assignment-package) (install-permanent-assignment-package) (install-definition-package) (install-lambda-package) (install-let-package) (install-let*-package) (install-letrec-package) (install-if-package) (install-if-fail-package) (install-and-package) (install-or-package) (install-cond-package) (install-begin-package) (install-sequence-package) (install-application-package) (install-delay-package) (install-force-package) (install-amb-package) (install-environment-package) (install-procedure-package) (install-primitive-package) (install-evaluator-package) (install-analyze-package) (define (make-definition variable value) (list 'define variable value)) (define (make-assignment variable value) (list 'set! variable value)) (define (make-lambda parameters body) (cons 'lambda (cons parameters body))) (define (make-if predicate consequent alternative) (list 'if predicate consequent alternative)) (define (make-let parameters body) (list 'let parameters body)) (define (make-procedure parameters body env) (list 'procedure parameters body env)) ;; (define (make-sequence exp) ((get 'make-exp 'sequence) exp)) (define (make-frame vars vals) ((get 'make 'environment) vars vals)) (define (extend-environment var val base-env) ((get 'extend 'environment) var val base-env)) (define (lookup-variable-value var env) ((get 'lookup 'environment) var env)) (define (set-variable-value! var val env) ((get 'set! 'environment) var val env)) (define (define-variable! var val env) ((get 'define 'environment) var val env)) (define (definition-variable exp) ((get 'definition-variable 'define) exp)) (define (definition-value exp) ((get 'definition-value 'define) exp)) (define (make-unbound! var env) ((get 'make-unbound! 'environment) var env)) (define (setup-environment) ((get 'setup 'environment))) (define (primitive-procedure? proc-name) ((get 'primitive-procedure? 'primitive) proc-name)) (define (primitive-procedure-names) ((get 'primitive-procedure-names 'primitive))) (define (primitive-procedure-objects) ((get 'primitive-procedure-objects 'primitive))) (define (make-exp exp) ((get 'make-exp 'evaluator) exp)) (define (ambeval exp env succeed fail) ((get 'ambeval 'evaluator) exp env succeed fail)) (define (get-args aprocs env succeed fail) ((get 'get-args 'evaluator) aprocs env succeed fail)) (define (analyze-sequence exps) ((get 'analyze-sequence 'analyze) exps)) (define (analyze exp) ((get 'analyze 'analyze) exp)) (define (apply proc args succeed fail) ((get 'apply 'evaluator) proc args succeed fail)) (define (driver-loop) ((get 'loop 'evaluator))) (define (load-file file) ((get 'load-file 'evaluator) file)) (define (user-print object) (define (tagged-list obj) (car obj)) (if (not (pair? object)) (display object) (let ((proc (get 'user-print (tagged-list object)))) (if (closure? proc) (proc object) (display object))))) ;; (define the-global-environment (setup-environment))
評価器は Scheme 処理系に普通にロードしてください。
(Emacs な人は、コードバッファでたぶん C-c C-l です。)
解説は SICP 4.3.3 節 amb 評価器の実装 *3 を参照してください。
なお、第 4 章を読むためには、SICP 第 1 ～ 3 章を読まないと理解は難しいです。
いきなり第 4 章から読んでスラスラ理解できる人は、
SICP から得られるものは何も無いと思われるので読まなくて良いです。
時間の無駄でしょう。
さて、次に AMB 評価器に読み込ませるプログラム(queens.scm)です。
;;8 queens puzzle (define nil '()) (define (map1 p lst) (if (null? lst) nil (cons (p (car lst)) (map1 p (cdr lst))))) (define (map2 p lst1 lst2) (if (null? lst1) nil (cons (p (car lst1) (car lst2)) (map2 p (cdr lst1) (cdr lst2))))) (define (require p) (if (not p) (amb))) (define (distinct? lst) (define (iter l) (if (null? (cdr l)) true (if (= (car l) (cadr l)) false (iter (cdr l))))) (iter (sort lst))) (define (enumerate-interval low high) (if (> low high) nil (cons low (enumerate-interval (+ low 1) high)))) (define (contain-zero? lst) (not (eq? (memv 0 (cdr lst)) false))) (define (rotate lst) (map2 (lambda (a b) (- a b)) lst (enumerate-interval 0 (- (length lst) 1)))) (define (translate lst) (map2 (lambda (a b) (- a b)) lst (make-list (length lst) (car lst)))) (define (safe? lst) (cond ((null? lst) true) ((contain-zero? (rotate (map1 (lambda (x) (abs x)) (translate lst)))) false) (else (safe? (cdr lst))))) (define (4-queens-puzzle) (let ((q1 (amb 1 2 3 4)) (q2 (amb 1 2 3 4))) (require (distinct? (list q1 q2))) (require (safe? (list q1 q2))) (let ((q3 (amb 1 2 3 4))) (require (distinct? (list q1 q2 q3))) (require (safe? (list q1 q2 q3))) (let ((q4 (amb 1 2 3 4))) (require (distinct? (list q1 q2 q3 q4))) (require (safe? (list q1 q2 q3 q4))) (list q1 q2 q3 q4))))) (define (6-queens-puzzle) (let ((q1 (amb 1 2 3 4 5 6)) (q2 (amb 1 2 3 4 5 6))) (require (distinct? (list q1 q2))) (require (safe? (list q1 q2))) (let ((q3 (amb 1 2 3 4 5 6))) (require (distinct? (list q1 q2 q3))) (require (safe? (list q1 q2 q3))) (let ((q4 (amb 1 2 3 4 5 6))) (require (distinct? (list q1 q2 q3 q4))) (require (safe? (list q1 q2 q3 q4))) (let ((q5 (amb 1 2 3 4 5 6))) (require (distinct? (list q1 q2 q3 q4 q5))) (require (safe? (list q1 q2 q3 q4 q5))) (let ((q6 (amb 1 2 3 4 5 6))) (require (distinct? (list q1 q2 q3 q4 q5 q6))) (require (safe? (list q1 q2 q3 q4 q5 q6))) (list q1 q2 q3 q4 q5 q6))))))) (define (8-queens-puzzle) (let ((q1 (amb 1 2 3 4 5 6 7 8)) (q2 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2))) (require (safe? (list q1 q2))) (let ((q3 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2 q3))) (require (safe? (list q1 q2 q3))) (let ((q4 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2 q3 q4))) (require (safe? (list q1 q2 q3 q4))) (let ((q5 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2 q3 q4 q5))) (require (safe? (list q1 q2 q3 q4 q5))) (let ((q6 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2 q3 q4 q5 q6))) (require (safe? (list q1 q2 q3 q4 q5 q6))) (let ((q7 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2 q3 q4 q5 q6 q7))) (require (safe? (list q1 q2 q3 q4 q5 q6 q7))) (let ((q8 (amb 1 2 3 4 5 6 7 8))) (require (distinct? (list q1 q2 q3 q4 q5 q6 q7 q8))) (require (safe? (list q1 q2 q3 q4 q5 q6 q7 q8))) (list q1 q2 q3 q4 q5 q6 q7 q8)))))))))
結果
gosh> (load-file "./queens.scm") #t gosh> (driver-loop) ;;; AMB-Eval input: (8-queens-puzzle) ;;; Starting a new problem ;;; AMB-Eval value: (1 5 8 6 3 7 2 4) ;;; AMB-Eval input: try-again ;;; AMB-Eval value: (1 6 8 3 7 4 2 5) ;;; AMB-Eval input: try-again ;;; AMB-Eval value: (1 7 4 6 8 2 5 3) ;;; AMB-Eval input:
答えを全部求めるには「try-again」をひたすら繰り返さないといけないので省略します。
答えが少ない 4 queens 問題を試してみます。
gosh> (load-file "./queens.scm") #t gosh> (driver-loop) ;;; AMB-Eval input: (4-queens-puzzle) ;;; Starting a new problem ;;; AMB-Eval value: (2 4 1 3) ;;; AMB-Eval input: try-again ;;; AMB-Eval value: (3 1 4 2) ;;; AMB-Eval input: try-again ;;; There are no more values of (4-queens-puzzle) ;;; AMB-Eval input:
4 クイーン問題の答えは、
(2 4 1 3) (3 1 4 2)
の 2 つです。
このように try-again する度に別解を表示して、もう解が無くなると
;;; There are no more values of (4-queens-puzzle)
と表示します。
