導入
Scheme でいろいろなパズルを解いてみよう。
用意するもの
AMB評価器を使います。AMB 評価器については「計算機プログラムの構造と解釈」第4章を参照してください。
https://sicp.iijlab.net/fulltext/x400.html
評価器のプログラム
;;; 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))
AMB 評価器だけではパズルは解けません。AMB 評価器で実行するパズルのプログラムを用意する必要があります。
パズルその1「エイトクイーンパズル」
みんな大好きエイトクイーンパズルです。クイーンがお互いに共食いしないように配置するにはどこに置けばいいか？というバズルです。クイーンは縦横斜めに移動できるので、通り道になる場所には他のクイーンは置くことは出来ません。
パズルのプログラム
(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)))))))))
コードがたくさんの入れ子になっているのは理由があります。AMB評価器はすべての可能性を網羅的に探索するため、探索を早期に打ち切ることで処理時間を短縮するためです。
実行
まずAMB評価器をScheme処理系(ここではGauche)にロードしてください。
次にパズルのプログラムをロードします。AMB 評価器にロードするには、専用の load-file 手続きを使ってください。
gosh> (load-file "queens.scm")
#t
true が返ればエラーなしで読み込み成功です。
評価器を起動します。
gosh> (driver-loop)
パズルを解く準備が出来ました。ここでは 4x4 マスのパズルにしています。
;;; AMB-Eval input:
(4-queens-puzzle)
;;; Starting a new problem
;;; AMB-Eval value:
(2 4 1 3)
答えの1つを表示しました。数字の位置(行でも列でも良いです)にクイーンを置くことが出来ます。
さらに答えを表示したい場合は、try-again とします。
;;; AMB-Eval input:
try-again
;;; AMB-Eval value:
(3 1 4 2)
別解を表示します。
もっとあるでしょうか？ さらに try-again します。
;;; AMB-Eval input:
try-again
;;; There are no more values of
(4-queens-puzzle)
今回は「解なし」と答えました。
4x4 マスの場合、クイーンの置き方は 2 通りしか無いことがわかりました。
AMB評価器を終了するときは (exit) としてください。
なお、手抜きなので Gauche 処理系まで終了しますw
;;; AMB-Eval input:
(exit)
;;; Starting a new problem
Process scheme finished
パズルその2「アインシュタインパズル」
これは 3x3 のマスの中に 1-9 の数字を一つずつ入れて、縦横斜めの合計を全部 15 にするというパズルです。いわゆる魔法陣です。
パズルのプログラム
(define nil '())
(define (require p)
(if (not p) (amb)))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence) (filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (remove items sequence)
(filter (lambda (x) (false? (memv x items)))
sequence))
(define (an-element-of items)
(require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
;; a b c
;; d e f
;; g h i
(define (einstein-puzzle)
(define numbers '(1 2 3 4 5 6 7 8 9))
(let ((a (an-element-of numbers))
(b (an-element-of numbers)))
(require (not (= a b)))
(let ((c (an-element-of (remove (list a b) numbers))))
(require (= (+ a b c) 15))
(let ((d (an-element-of (remove (list a b c) numbers))))
(let ((e (an-element-of (remove (list a b c d) numbers))))
(let ((f (an-element-of (remove (list a b c d e) numbers))))
(require (= (+ d e f) 15))
(let ((g (an-element-of (remove (list a b c d e f) numbers))))
(let ((h (an-element-of (remove (list a b c d e f g) numbers))))
(let ((i (an-element-of (remove (list a b c d e f g h) numbers))))
(require (= (+ g h i) 15))
(require (= (+ a d g) 15))
(require (= (+ b e h) 15))
(require (= (+ c f i) 15))
(require (= (+ a e i) 15))
(require (= (+ c e g) 15))
(list a b c d e f g h i))))))))))
実行
;;; AMB-Eval input:
(einstein-puzzle)
;;; Starting a new problem
;;; AMB-Eval value:
(2 7 6 9 5 1 4 3 8)
マス目に並べるとこうなります。
2 7 6
9 5 1
4 3 8
縦横斜めの合計がすべて 15 になっています。
別解はひっくり返したようなものばかりなので省略します。
パズルその3「SEND MORE MONEYパズル」
SEND
+ MORE
------
MONEY
各アルファベットに数字を当てはめて、足し算の式が正しくなるようにするバズルです。例えば「E」には同じ数字が入ります。
プログラム
(define nil '())
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence) (filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (remove items sequence)
(filter (lambda (x) (false? (memv x items)))
sequence))
(define (require p)
(if (not p) (amb)))
(define (an-element-of items)
(require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
(define (sn num)
(if (>= num 10)
(- num 10)
num))
(define (cn num)
(if (>= num 10)
1
0))
(define (alphametic-puzzle)
(define numbers '(1 2 3 4 5 6 7 8 9 0))
(let ((d (an-element-of numbers))
(e (an-element-of numbers)))
(require (not (= d e)))
(let ((y (an-element-of (remove (list d e) numbers))))
(require (= (sn (+ d e)) y))
(let ((c-y (cn (+ d e)))
(n (an-element-of (remove (list d e y) numbers))))
(let ((r (an-element-of (remove (list d e y n) numbers))))
(require (= (sn (+ n r c-y)) e))
(let ((c-e (cn (+ n r c-y)))
(o (an-element-of (remove (list d e y n r) numbers))))
(require (= (sn (+ e o c-e)) n))
(let ((c-n (cn (+ e o c-e)))
(s (an-element-of (remove (list d e y n r o) numbers))))
(require (not (= s 0)))
(let ((m (an-element-of (remove (list d e y n r o s) numbers))))
(require (= (sn (+ s m c-n)) o))
(let ((c-o (cn (+ s m c-n))))
(require (= m c-o 1))
(list s e n d '+ m o r e '= m o n e y))))))))))
実行
;;; AMB-Eval input:
(alphametic-puzzle)
;;; Starting a new problem
;;; AMB-Eval value:
(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2)
それぞれの文字にこのように数字を当てはめるのが答えです。
;;; AMB-Eval input:
try-again
;;; There are no more values of
(alphametic-puzzle)
別解はありませんでした。