逆行列を求める

逆行列を計算するプログラムです。

まず共通処理から。

(define nil '())

(define *stack* nil)
(define level-ratio 100)

(define (last-pushed)
  (if (empty?)
      nil
      (car *stack*)))

(define (after-popped)
  (if (empty?)
      nil
      (cdr *stack*)))

(define (init)
  (set! *stack* nil))

(define (empty?)
  (null? *stack*))

(define (push x)
  (set! *stack* (cons x *stack*)))

(define (pop)
  (if (empty?)
      nil
      (let ((result (last-pushed)))
        (set! *stack* (after-popped))
        result)))

(define (pop-all level)
  (define (iter operators)
    (if (or (empty?) (< (priority (last-pushed)) (* level level-ratio)))
        operators
        (iter (append operators (cons (operator (pop)) nil)))))
  (iter nil))

;; r.p.n. procedures

(define (make-priority op level)
  (let ((priority
         (cond ((eq? op '**) 30)
               ((eq? op '*)  20)
               ((eq? op '/)  20)
               ((eq? op '+)  10)
               ((eq? op '-)  10)
               (else 0))))
    (cons op (+ priority (* level level-ratio)))))

(define (operator p)
  (car p))

(define (priority p)
  (if (null? p)
      0
      (cdr p)))

(define (operator? x)
  (or (eq? x '+) (eq? x '-) (eq? x '*) (eq? x '/) (eq? x '**)))

(define (exp->rpn exp)
  (define (iter e r level)
    (if (null? e)
        (append r (pop-all level))
        (if (list? (car e))
            (iter (cdr e) (iter (car e) r (+ level 1)) level)
            (cond ((operator? (car e))
                   (cond ((> (priority (last-pushed)) (priority (make-priority (car e) level)))
                          (let ((p (list (operator (pop)))))
                            (push (make-priority (car e) level))
                            (iter (cdr e) (append r p) level)))
                         (else
                          (push (make-priority (car e) level))
                          (iter (cdr e) r level))))
                  (else (iter (cdr e) (append r (list (car e))) level))))))
  (init)
  (iter exp nil 0))

(define (rpn->s-exp rpn)
  (define (iter r)
      (if (null? r)
          (pop)
          (let ((e (car r)))
            (cond ((eq? e '+) (let ((augend (pop)))
                                (push (make-sum (pop) augend))))
		  ((eq? e '-) (let ((subtrahend (pop)))
				(push (make-sub (pop) subtrahend))))
                  ((eq? e '*) (let ((multiplicand (pop)))
                                (push (make-product (pop) multiplicand))))
		  ((eq? e '/) (let ((divisor (pop)))
				(if (and (number? divisor) (= divisor 0))
				    (error "attempt to calculate a division by zero")
				    (push (make-division (pop) divisor)))))
                  ((eq? e '**) (let ((exponent (pop)))
                                 (push (make-exponentiation (pop) exponent))))
                  (else (push e)))
            (iter (cdr r)))))
  (init)
  (iter rpn))

次は、記号微分の処理。今回は微分はしないですし、いらない処理がたくさんあります。

(define (deriv exp var)
  (define (deriv-iter exp var)
    (cond ((number? exp) 0)
          ((variable? exp)
           (if (same-variable? exp var) 1 0))
          ((sum? exp)
           (make-sum (deriv-iter (addend exp) var)
                     (deriv-iter (augend exp) var)))
          ((product? exp)
           (make-sum
            (make-product (multiplier exp)
                          (deriv-iter (multiplicand exp) var))
            (make-product (deriv-iter (multiplier exp) var)
                          (multiplicand exp))))
          ((exponentiation? exp)
           (make-product
            (make-product (exponent exp)
                          (make-exponentiation (base exp) (make-sum (exponent exp) -1)))
            (deriv-iter (base exp) var)))
          (else
           (error "unknown expression type -- DERIV" exp))))
  (deriv-iter (rpn->s-exp (exp->rpn exp)) var))

(define (variable? x) (symbol? x))

(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (=number? exp num)
  (and (number? exp) (= exp num)))

(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (list '+ a1 a2))))

(define (make-sub a1 a2)
  (cond ((=number? a1 0) (* -1 a2))
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (- a1 a2))
        (else (list '- a1 a2))))

(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (list '* m1 m2))))

(define (make-division m1 m2)
  (cond ((=number? m1 0) 0)
	((=number? m2 0) (error "attempt to calculate a division by zero"))
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (/ m1 m2))
        (else (list '/ m1 m2))))

(define (make-exponentiation e1 e2)
  (cond ((=number? e2 0) 1)
        ((=number? e2 1) e1)
        (else (list '** e1 e2))))

(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))

(define (addend s) (cadr s))

(define (augend s) (caddr s))

(define (product? x)
  (and (pair? x) (eq? (car x) '*)))

(define (multiplier p) (cadr p))

(define (multiplicand p) (caddr p))

(define (exponentiation? x)
  (and (pair? x) (eq? (car x) '**)))

(define (base e) (cadr e))

(define (exponent e) (caddr e))

最後に逆行列を計算するプログラム。

(define (make-key r c)
  `(,r ,c))

(define (square-matrix? matrix)
  (let ((row (length matrix)))
    (equal? (make-list row row) (map length matrix))))
  
(define (make-unit-matrix matrix)
  (define (iter i lst mat)
    (if (= i 0)
	mat
	(iter (- i 1) (append (cdr lst) (cons 0 nil)) (cons lst mat))))
  (let ((len (length matrix)))
    (iter len (append (make-list (- len 1) 0) '(1)) nil)))

(define (matrix->hash-table matrix)
  (define ht (make-hash-table 'equal?))
  (define (col-iter r c cols)
    (if (null? cols)
	'done
	(begin
	  (hash-table-set! ht (make-key r c) (car cols))
	  (col-iter r (+ c 1) (cdr cols)))))
  (define (row-iter r rows)
    (if (null? rows)
	ht
	(begin
	  (col-iter r 1 (car rows))
	  (row-iter (+ r 1) (cdr rows)))))
  (row-iter 1 matrix))

(define (hash-table->row ht size row)
  (define (iter c row-list)
    (if (> c size)
        row-list
        (iter (+ c 1) (append row-list (cons (hash-table-get ht (make-key row c)) nil)))))
  (iter 1 nil))

(define (hash-table->matrix ht size)
  (define (r-iter r matrix)
    (if (> r size)
        matrix
        (r-iter (+ r 1) (append matrix (cons (hash-table->row ht size r) nil)))))
  (r-iter 1 nil))

(define (solve-main ht1 ht2 size)
  (define (change-row row1 row2)
    (define (iter c r1 r2 r3 r4)
      (if (> c size)
          'done
          (begin
            (hash-table-set! ht1 (make-key row1 c) (car r2))
            (hash-table-set! ht1 (make-key row2 c) (car r1))
            (hash-table-set! ht2 (make-key row1 c) (car r4))
            (hash-table-set! ht2 (make-key row2 c) (car r3))
            (iter (+ c 1) (cdr r1) (cdr r2) (cdr r3) (cdr r4)))))
    (let ((r1 (hash-table->row ht1 size row1))
          (r2 (hash-table->row ht1 size row2))
          (r3 (hash-table->row ht2 size row1))
          (r4 (hash-table->row ht2 size row2)))
      (iter 1 r1 r2 r3 r4)))
    
  (define (irekae pivot-col)
    (define (r-iter r max-r max-val)
      (if (> r size)
          (change-row pivot-col max-r)
          (let ((val (hash-table-get ht1 (make-key r pivot-col))))
            (if (and (number? val) (> (abs val) max-val))
                (r-iter (+ r 1) r val)
                (r-iter (+ r 1) max-r max-val)))))
    (r-iter pivot-col pivot-col (hash-table-get ht1 (make-key pivot-col pivot-col))))
  
  (define (taikaku pivot-col)
    (define (iter val c)
      (if (> c size)
	  'done
          (begin
	    (hash-table-set! ht1 (make-key pivot-col c) (make-division (hash-table-get ht1 (make-key pivot-col c)) val))
	    (hash-table-set! ht2 (make-key pivot-col c) (make-division (hash-table-get ht2 (make-key pivot-col c)) val))
	    (iter val (+ c 1)))))
    (let ((val (hash-table-get ht1 (make-key pivot-col pivot-col))))
      (and (not (= val 1)) (iter val 1))))

  (define (hitaikaku pivot-col)
    (define (c-iter val row col)
      (if (> col size)
          'done
          (begin
            (hash-table-set! ht1
                             (make-key row col)
                             (make-sum (hash-table-get ht1 (make-key row col))
                                       (make-product (hash-table-get ht1 (make-key pivot-col col))
                                                     val)))
            (hash-table-set! ht2
                             (make-key row col)
                             (make-sum (hash-table-get ht2 (make-key row col))
                                       (make-product (hash-table-get ht2 (make-key pivot-col col))
                                                     val)))
            (c-iter val row (+ col 1)))))
    
    (define (r-iter row)
      (if (> row size)
          'done
          (begin
            (let ((val (hash-table-get ht1 (make-key row pivot-col))))
              (and (not (= row pivot-col)) (c-iter (make-product -1 val) row 1)))
            (r-iter (+ row 1)))))
    (r-iter 1))
  
  (define (iter pivot-col)
    (if (> pivot-col size)
        ht2
        (begin
          (irekae pivot-col)
          (taikaku pivot-col)
          (hitaikaku pivot-col)
          (iter (+ pivot-col 1)))))
  (iter 1)
  )

(define (solve matrix)
  (let ((size (length matrix)))
    (hash-table->matrix (solve-main (matrix->hash-table matrix)
                                    (matrix->hash-table (make-unit-matrix matrix))
                                    size)
                        size)))

(define (inverse-matrix matrix)
  (if (not (square-matrix? matrix))
      (error "Require square matrix.")
      (solve matrix)))

掃き出し法です。部分ピボット機能付き。
早速、逆行列を求めてみます。

gosh> (inverse-matrix '((1 3 2) (-1 0 1) (2 3 0)))
((1 -2 -1) (-2/3 4/3 1) (1 -1 -1))

検算してみます。
行列の逆行列逆行列は、元の行列になります。

gosh> (inverse-matrix (inverse-matrix '((1 3 2) (-1 0 1) (2 3 0))))
((1 3 2) (-1 0 1) (2 3 0))

はい。元に戻りました。問題なさそうです。

gosh> (inverse-matrix '((1 2 7 6) (2 4 4 2) (1 8 5 2) (2 4 3 3)))
((-1/6 7/12 -1/3 1/6) (-1/15 -13/60 1/6 1/6) (1/10 9/20 0 -1/2) (1/10 -11/20 0 1/2))

n x n の行列も計算できます。
Gauche有理数をサポートするので結果が見やすく誤差が生じず素晴らしいです。


なお、デバッグで以下のサイトを利用させていただきました。
ありがとうございます。
keisan.casio.jp


応用編
数字だけじゃつまんないですよね?
というかこっちがメインです。

例えば、技術士試験 平成 30 年度の基礎科目 I-3-3 に出題されたような行列の逆行列を求めてみます。
技術士試験の過去問題は、日本技術士会のホームページで公開されています。
www.engineer.or.jp

gosh> (inverse-matrix '((1 0 0) (a 1 0) (b c 1)))
((1 0 0) ((* -1 a) 1 0) ((+ (* -1 b) (* (* -1 a) (* -1 c))) (* -1 c) 1))

式の最適化に少し難があり課題が残りますが解けました。
結果は常に前置記法です。プログラムが LISP ですから。


なお、中間記法は以下のように前置記法に変換できます。
(注 LISP ではべき乗は「**」ではないので、この式は変数 x を定義しても LISP 処理系では実行できません。)

gosh> (rpn->s-exp (exp->rpn '(x ** 2 + 4 * x + 3)))
(+ (** x 2) (+ (* 4 x) 3))


しかし、こんなプログラムを書いていたのでは、試験の勉強が捗りませんな!
まったく困ったものです。


以下蛇足
式の微分も出来ます。

gosh> (deriv '(x ** 2 + 4 * x + 3) 'x)
(+ (* 2 x) 4)

詳しくは SICP の 2.3.2 節「例:記号微分」を参照ください。
https://sicp.iijlab.net/fulltext/xcont#s232

L-99 P98 再び

お絵かきロジックを、より人間らしく解く!

とは言っても、普通の人間には簡単にできる
・解法を自ら学習する
・新たな解法を発見する
とかは出来ません。

というか、そんなのが出来たら怖いです。

人類を敵と見做して核攻撃とかしそう!
人形ロボットを作って人類抹殺とか始めそう!!
親指立てて溶鉱炉に沈みそう!!!
マジ怖い!!!!(SF映画の見すぎですw)


・・・さて、まずは共通処理から。

(define nil '())

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (accumulate op initial seq)
  (if (null? seq)
      initial
      (op (car seq)
	  (accumulate op initial (cdr seq)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (remove item seq)
  (filter (lambda (x) (not (eq? x item))) seq))

(define (permutations s c)
  (if (or (= c 0) (null? s))
      (list nil)
      (flatmap (lambda (x)
		 (map (lambda (p) (cons x p))
		      (permutations (remove x s) (- c 1))))
	       s)))

(define (repeated-permutations s n)
  (if (= n 0)
      (list nil)
      (flatmap (lambda (x)
		 (map (lambda (p) (cons x p)) (repeated-permutations s (- n 1))))
	       s)))

(define (uniq lis)
  (define ht (make-hash-table 'equal?))
  (define (iter l)
    (if (null? l)
	(hash-table-keys ht)
	(let ((key (hash-table-get ht (car l) nil)))
	  (and (null? key) (hash-table-put! ht (car l) (car l)))
	  (iter (cdr l)))))
  (iter lis))

お絵かきロジックを解くプログラム。

(define *matrix* nil)
(define *rows* 0)
(define *cols* 0)
(define *row-states* nil)
(define *col-states* nil)

(define (make-matrix r c)
  (make-s8vector (* r c) -1))

(define (matrix-set! r c val)
  (s8vector-set! *matrix* (+ (* r *cols*) c) val))

(define (matrix-ref r c)
  (s8vector-ref *matrix* (+ (* r *cols*) c)))

(define (matrix->list row-or-col idx)
  (define (iter i r c lis)
    (if (= i 0)
	lis
	(if (eq? row-or-col 'row)
	    (iter (- i 1) r (+ c 1) (append lis (cons (matrix-ref r c) nil)))
	    (iter (- i 1) (+ r 1) c (append lis (cons (matrix-ref r c) nil))))))
  (if (eq? row-or-col 'row)
      (iter *cols* idx 0 nil)
      (iter *rows* 0 idx nil)))

(define (matrix->sublist row-or-col idx pos)
  (define (iter p lis)
    (if (null? p)
	lis
	(if (eq? row-or-col 'row)
	    (iter (cdr p) (append lis (cons (matrix-ref idx (car p)) nil)))
	    (iter (cdr p) (append lis (cons (matrix-ref (car p) idx) nil))))))
  (iter pos nil))

;;

(define (matrix-debug)
  (define (iter-c r c)
    (if (= c *cols*)
	'done
	(begin
	  (matrix-set! r c (+ (* r 10) c))
	  (iter-c r (+ c 1)))))
  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
	  (iter-c r 0)
	  (iter-r (+ r 1)))))
  (iter-r 0))

(define (print-matrix)
  (define (iter-c r c)
    (if (= c *cols*)
	'done
	(begin
	  (let ((val (matrix-ref r c)))
	    (if (= val -1)
		(display "_")
		(display val))
	    (display " ")
	    (iter-c r (+ c 1))))))

  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
;;	  (display r)
;;	  (display " ")
	  (iter-c r 0)
	  (newline)
	  (iter-r (+ r 1)))))
;;  (display "  0 1 2 3 4 5 6 7")
;;  (newline)
  (iter-r 0))

;;

(define (init row-states col-states)
  (set! *row-states* row-states)
  (set! *col-states* col-states)
  (set! *rows* (length row-states))
  (set! *cols* (length col-states))
  (set! *matrix* (make-matrix *rows* *cols*))
  )

(define (get-state row-or-col i)
  (if (eq? row-or-col 'row)
      (list-ref *row-states* i)
      (list-ref *col-states* i)))

(define (state->list state)
  (define (iter n lst result)
    (if (null? lst)
	result
	(iter (+ n 1) (cdr lst) (append result (if (null? result) nil '(0)) (make-list (car lst) n)))))
  (iter 1 state nil))

(define (matrix-set-list! row-or-col row col lst)
  (define (iter l r c)
    (if (null? l)
	'done
	(if (or (>= r *rows*) (>= c *cols*))
	    (error (format #f "OUT OF MATRIX r=~d c=~d" r c))
	    (begin
	      ;; for debug
	      ;;(matrix-set! r c (car l))
	      (and (= (matrix-ref r c) -1) (matrix-set! r c (if (>= (car l) 1) 1 0)))
	      (iter (cdr l)
		    (if (eq? row-or-col 'col) (+ r 1) r)
		    (if (eq? row-or-col 'row) (+ c 1) c))))))
  (iter lst row col))

(define (total-state state)
  (+ (apply + state) (- (length state) 1)))

(define (find-masu lst pred)
  (define (iter l i result1 result2)
    (if (null? l)
	(if (null? result1)
	    result2
	    (append result2 `(,result1)))
	(if (pred (car l))
	    (iter (cdr l) (+ i 1) (append result1 (cons i nil)) result2)
	    (iter (cdr l) (+ i 1) nil (if (null? result1) result2 (append result2 `(,result1))))
	    )))
  (iter lst 0 nil nil))

(define (find-kuromasu lst)
  (find-masu lst (lambda (x) (= x 1))))

(define (find-mi-kakutei lst)
  (find-masu lst (lambda (x) (= x -1))))

(define (find-kuro-and-mi-kakutei lst)
  (find-masu lst (lambda (x) (not (= x 0)))))

(define (find-shiro lst)
  (find-masu lst (lambda (x) (= x 0))))

;; 部分確定  (左右につめた時に生じる共通の黒マスを処理する。白マスがある場合は処理する範囲を狭める。)
(define (bubun-kakutei row-or-col index)
  (define (bubun-kakutei-main row-or-col index nakami-list)
    (define (kaburi-state row-or-col index pos left-state right-state)
      (define (iter left right i)
	(if (null? left)
	    'done
	    (begin 
	      (and (> (car left) 0) (> (car right) 0) (= (car left) (car right))
		   (if (eq? row-or-col 'row)
		       (matrix-set! index i 1)
		       (matrix-set! i index 1)))
	      (iter (cdr left) (cdr right) (+ i 1)))))
      (iter left-state right-state pos))
  
    (define (make-state-list row-or-col left-or-right state-list matrix-list)
      (let ((husoku (- (length matrix-list) (length state-list))))
	(if (eq? left-or-right 'left)
	    (append (make-list husoku 0) state-list)
	    (append state-list (make-list husoku 0)))))

    (if (eq? row-or-col 'row)
	(let ((state (get-state 'row index)))
	  (and (> (total-state state) (floor (/ (length nakami-list) 2)))
	       (let* ((state-list (state->list state))
		      (left (make-state-list 'row 'left state-list nakami-list))
		      (right (make-state-list 'row 'right state-list nakami-list)))
		 (kaburi-state row-or-col index (car nakami-list) left right))))
	(let ((state (get-state 'column index)))
	  (and (> (total-state state) (floor (/ (length nakami-list) 2)))
	       (let* ((state-list (state->list state))
		      (left (make-state-list 'column 'left state-list nakami-list))
		      (right (make-state-list 'column 'right state-list nakami-list)))
		 (kaburi-state row-or-col index (car nakami-list) left right))))
	))

  (let* ((matrix-list (matrix->list row-or-col index))
	 (nakami-list (find-kuro-and-mi-kakutei matrix-list)))
    (and (= (length nakami-list) 1)
	 (bubun-kakutei-main row-or-col index (car nakami-list)))
    ))

;;

(define (solve-1)
  ; 最高値を処理
  (define (kakutei row-or-col index)
    (if (eq? row-or-col 'row)
	(let ((state (get-state 'row index)))
	  (and (= (total-state state) *cols*)
	       (matrix-set-list! 'row index 0 (state->list state))))
	(let ((state (get-state 'col index)))
	  (and (= (total-state state) *rows*)
	       (matrix-set-list! 'col 0 index (state->list state))))))
  
  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
	  (kakutei 'row r)
	  (bubun-kakutei 'row r)
	  (iter-r (+ r 1)))))

  (define (iter-c c)
    (if (= c *cols*)
	'done
	(begin
	  (kakutei 'col c)
	  (bubun-kakutei 'col c)
	  (iter-c (+ c 1)))))
  
  (iter-r 0)
  (iter-c 0))

(define (solve-2)
  ;; 列が確定したか調べる
  (define (kakutei? row-or-col index)
    (= (length (filter (lambda (x) (= x -1)) (matrix->list row-or-col index))) 0))

  ;; 全黒マス、全白マスが確定した列の処理
  (define (kakutei row-or-col index)
    (define (umeru-zero row-or-col index matrix-list)
      (let ((mat-lis (map (lambda (x) (if (= x -1) 0 x)) matrix-list)))
	(if (eq? row-or-col 'row)
	    (matrix-set-list! 'row index 0 mat-lis)
	    (matrix-set-list! 'col 0 index mat-lis))))
    
    (let* ((state (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index))
	   (kakutei-su (length (filter (lambda (x) (= x 1)) matrix-list))))
;      (print ";;kakutei row-or-col=" row-or-col " index=" index " state=" state " matrix-list=" matrix-list " kakutei-su=" kakutei-su)
      (and (= (apply + state) kakutei-su)
	   (umeru-zero row-or-col index matrix-list))))

  ;; 黒マスの両隣を埋める処理
  (define (kuromasu row-or-col index)
    (define (find-state matrix-list state)
      (define (search-list lis1 lis2)
	(define (iter-2 st ed lis)
	  (if (null? lis)
	      st
	      (if (= (list-ref lis1 ed) (car lis))
		  (iter-2 st (+ ed 1) (cdr lis))
		  #f)))
	(define (iter-1 st)
	  (if (> st (- (length lis1) (length lis2)))
	      #f
	      (or (iter-2 st st lis2) (iter-1 (+ st 1)))))
	(iter-1 0))
      (search-list matrix-list (make-list state 1)))
    
    (define (kuromasu-zero row-or-col index st-pos ed-pos)
      (and (> st-pos 0) (< ed-pos (- (if (eq? row-or-col 'row) *cols* *rows*) 1))
	   (let ((st (- st-pos 1))
		 (ed (+ ed-pos 1)))
	     (if (eq? row-or-col 'row)
		 (begin
		   (and (= (matrix-ref index st) -1) (matrix-set! index st 0))
		   (and (= (matrix-ref index ed) -1) (matrix-set! index ed 0)))
		 (begin
		   (and (= (matrix-ref st index) -1) (matrix-set! st index 0))
		   (and (= (matrix-ref ed index) -1) (matrix-set! ed index 0)))))))
  
    (let* ((max-state (apply max (get-state row-or-col index)))
	   (matrix-list (matrix->list row-or-col index)))
      (let ((start-pos (find-state matrix-list max-state)))
	(and start-pos
	     (kuromasu-zero row-or-col index start-pos (+ start-pos max-state -1))))))

  ;; 端の処理
  (define (hashi row-or-col index)
    (let ((state (get-state row-or-col index))
	  (matrix-list (matrix->list row-or-col index)))
;;      (print ";;row-or-col=" row-or-col " index=" index " matrix-list=" matrix-list)
      (if (= (car matrix-list) 1)
	  (let ((state-list (append (make-list (car state) 1) '(0))))
	    (if (eq? row-or-col 'row)
		(matrix-set-list! row-or-col index 0 state-list)
		(matrix-set-list! row-or-col 0 index state-list))))
      (if (= (last matrix-list) 1)
	  (let ((state-list (append '(0) (make-list (last state) 1))))
	    (if (eq? row-or-col 'row)
		(matrix-set-list! row-or-col index (- *cols* (length state-list)) state-list)
		(matrix-set-list! row-or-col (- *rows* (length state-list)) index state-list))))
      ))

  ;; 端の処理 (白マスで分割される場合を考慮する)
  (define (bubun-hashi row-or-col index pos state matrix-list)
    (define (make-state-list left-or-right)
      (if (eq? left-or-right 'left)
	  (if (> (length matrix-list) state)
	      (append (make-list state 1) '(0))
	      (make-list state 1))
	  (if (> (length matrix-list) state)
	      (append '(0) (make-list state 1))
	      (make-list state 1))))

    (if (< (length matrix-list) state)
	'done
	(begin
	  (if (= (car matrix-list) 1)
	      (let ((state-list (make-state-list 'left)))
;;		(print ";;111 index=" index " matrix-list=" matrix-list " pos=" pos " state=" state " state-list=" state-list)
		(if (eq? row-or-col 'row)
		    (matrix-set-list! row-or-col index pos state-list)
		    (matrix-set-list! row-or-col pos index state-list))))
	  (if (= (last matrix-list) 1)
	      (let ((state-list (make-state-list 'right)))
;;		(print ";;222 index=" index " matrix-list=" matrix-list " pos=" pos " state=" state " state-list=" state-list)
		(if (eq? row-or-col 'row)
		    (matrix-set-list! row-or-col index (+ pos (- (length matrix-list) (length state-list))) state-list)
		    (matrix-set-list! row-or-col (+ pos (- (length matrix-list) (length state-list))) index state-list)))))))

  ;; 狭小マスの処理
  (define (kyosho row-or-col index)
    (define (nagasa lst)
      (define (iter l i st len result)
	(if (null? l)
	    (if (> len 0)
		(append result (cons (cons st len) nil))
		result)
	    (if (= (car l) 0)
		(iter (cdr l)
		      (+ i 1)
		      (+ i 1)
		      0
		      (if (> len 0) (append result (cons (cons st len) nil)) result))
		(iter (cdr l)
		      (+ i 1)
		      st
		      (+ len 1)
		      result))))
      (iter lst 0 0 0 nil))
    
    (define (umeru-kyosho row-or-col index state nagasa-list)
      (define (iter lst)
	(if (null? lst)
	    'done
	    (let ((st (caar lst))
		  (len (cdar lst)))
	      (and (< len state)
		   (if (eq? row-or-col 'row)
		       (matrix-set-list! row-or-col index st (make-list len 0))
		       (matrix-set-list! row-or-col st index (make-list len 0))))
	      (iter (cdr lst)))))
      (iter nagasa-list))
    
    (let ((states (get-state row-or-col index)))
      (if (> (length states) 1)
	  'done
	  (let* ((matrix-list (matrix->list row-or-col index))
		 (nagasa-list (nagasa matrix-list)))
	    (umeru-kyosho row-or-col index (car states) nagasa-list)))))

  ;; 確実に黒マスが届くマス、届かないマスを処理
  (define (todoku row-or-col index)
    (define (todoku-1 row-or-col index state kuro-index)
      (let ((l (- (last kuro-index) state))
	    (r (+ (car kuro-index) state)))
	
;;      (print ";;row-or-col=" row-or-col " index=" index " state=" state " kuro-index=" kuro-index)
;;      (print ";;l=" l " r=" r)
	(let ((max-index (if (eq? row-or-col 'row) *cols* *rows*)))
	  (if (eq? row-or-col 'row)
	      (begin
		(and (>= l 0) (matrix-set-list! row-or-col index 0 (make-list (+ l 1) 0)))
		(and (< r max-index) (matrix-set-list! row-or-col index r (make-list (- max-index r) 0))))
	      (begin
		(and (>= l 0) (matrix-set-list! row-or-col 0 index (make-list (+ l 1) 0)))
		(and (< r max-index) (matrix-set-list! row-or-col r index (make-list (- max-index r) 0))))
	      ))))
  
    (let ((states (get-state row-or-col index)))
      (if (> (length states) 1)
	  'done
	  (let* ((matrix-list (matrix->list row-or-col index))
		 (kuro (find-kuromasu matrix-list)))
	    (and (not (null? kuro)) (= (length kuro) 1) (todoku-1 row-or-col index (car states) (car kuro)))
	    ))))

  ;; 最高値の更新に対する処理
  (define (kakutei-2 row-or-col index)
    (define (kakutei-2? states mi-kakutei-list)
      (define (iter s lst)
	(if (null? s)
	    #t
	    (if (not (= (car s) (length (car lst))))
		#f
		(iter (cdr s) (cdr lst)))))
      (if (= (length states) (length mi-kakutei-list))
	  (iter states mi-kakutei-list)
	  #f))

    (define (kaku-2 row-or-col index mi-kakutei-list)
      (define (iter lst)
	(if (null? lst)
	    'done
	    (let* ((elem (car lst))
		   (st (car elem))
		   (len (length elem)))
	      (if (eq? row-or-col 'row)
		  (matrix-set-list! row-or-col index st (make-list len 1))
		  (matrix-set-list! row-or-col st index (make-list len 1)))
	      (iter (cdr lst)))))
      (iter mi-kakutei-list))
    
    (let* ((states (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index))
	   (kuro-list (find-kuromasu matrix-list))
	   (mi-kakutei-list (find-kuro-and-mi-kakutei matrix-list)))
;;      (print ";;kakutei-2 row-or-col=" row-or-col " index=" index " matrix-list=" matrix-list " kuro-list=" kuro-list " mi-kakutei-list=" mi-kakutei-list)
      (and (kakutei-2? states mi-kakutei-list)
	   (kaku-2 row-or-col index mi-kakutei-list))))

  ;; 0 で分割されている場合に範囲を狭めて確定する処理
  (define (kakutei-3 row-or-col index)
    (define (iter sub-pos states)
      (if (or (null? sub-pos) (null? states))
	  'done
	  (begin
	    (bubun-hashi row-or-col index (caar sub-pos) (car states) (matrix->sublist row-or-col index (car sub-pos)))
	    (iter (cdr sub-pos) (cdr states)))))
    (let* ((states (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index)))
;;      (print ";; kakutei-3 row-or-col=" row-or-col " index=" index " states=" states " matrix-list=" matrix-list)
      (and (= (length (filter (lambda (x) (= x 0)) matrix-list)) 1)
	   (iter (find-kuro-and-mi-kakutei matrix-list) states))))

  ;; 端から 0 が続いて 1 が表われる場合に確定する処理 (端に 0 が無くても処理可能)
  (define (kakutei-4 row-or-col index)
    (define (ryo-hashi-shiro? row-or-col lst)
      (define (mae l i)
	(if (null? l)
	    #t
	    (if (> (car l) i)
		#f
		(mae (cdr l) (+ i 1)))))
      (define (ushiro l i)
	(if (null? l)
	    #t
	    (if (< (car l) i)
		#f
		(ushiro (cdr l) (- i 1)))))
      (if (or (null? lst) (not (= (length lst) 2)))
	  #f
	  (begin
	    (and (mae (car lst) 0) (ushiro (reverse (cadr lst)) (- (if (eq? row-or-col 'row) *cols* *rows*) 1)))
	    )))
    
    (let* ((states (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index))
	   (shiro-list (find-shiro matrix-list))
	   (nakami-list (find-kuro-and-mi-kakutei matrix-list)))
;;      (print ";;; matrix-list=" matrix-list)
;;      (print ";;; shiro-list=" shiro-list)
      (if (ryo-hashi-shiro? row-or-col shiro-list)
	  (begin
;;	    (print ";; ryouhashi ha shiro !")
;;	    (print ";; shiro-list=" shiro-list)
;;	    (print ";; nakami-list=" nakami-list)
	    (bubun-hashi row-or-col index (caar nakami-list) (car states) (matrix->sublist row-or-col index (car nakami-list)))))))

  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
	  (if (not (kakutei? 'row r))
	      (begin
		(kakutei 'row r)
		(kuromasu 'row r)
		(hashi 'row r)
		(kyosho 'row r)
		(todoku 'row r)
		(kakutei-2 'row r)
		(kakutei-3 'row r)
		(kakutei-4 'row r)
		(bubun-kakutei 'row r)
		))
	  (iter-r (+ r 1)))))

  (define (iter-c c)
    (if (= c *cols*)
	'done
	(begin
	  (if (not (kakutei? 'col c))
	      (begin
		(kakutei 'col c)
		(kuromasu 'col c)
		(hashi 'col c)
		(kyosho 'col c)
		(todoku 'col c)
		(kakutei-2 'col c)
		(kakutei-3 'col c)
		(kakutei-4 'col c)
		(bubun-kakutei 'col c)
		))
	  (iter-c (+ c 1)))))

  ;; パズルが出来たか調べる
  (define (dekita?)
    (= (length (filter (lambda (x) (= x -1)) (s8vector->list *matrix*))) 0))
  
  (define (iter phase)
    (if (dekita?)
	'done
	(begin
	  (iter-r 0)
	  (iter-c 0)
;;	  (print ";; ===== solve-2 phase=" phase " =====")
;;	  (print-matrix)
	  (iter (+ phase 1)))))

  (iter 1))

(define (nonograms row-states column-states)
  (init row-states column-states)
  (solve-1)
  (solve-2)
  (print-matrix)
  )

コードが汚い!とにかく汚い!
手続き名がローマ字読みwww

解法のロジックはウィキペディアを参考にしました。
なお、第三段階は未実装です。
列毎の黒マスの数が3個以上の場合に正常に動くかはテストしていませんw

結果

gosh> (time (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3))))
0 1 1 1 0 0 0 0 
1 1 0 1 0 0 0 0 
0 1 1 1 0 0 1 1 
0 0 1 1 0 0 1 1 
0 0 1 1 1 1 1 1 
1 0 1 1 1 1 1 0 
1 1 1 1 1 1 0 0 
0 0 0 0 1 0 0 0 
0 0 0 1 1 0 0 0 
;(time (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) ...
; real   0.000
; user   0.000
; sys    0.000
done

処理時間についてですが、ミリ秒のオーダーでは計れません。
総当たり解法よりも圧倒的に速いです。

L-99 P97

数独を解く問題。Euler Project 問題 96 と同じです。

まず、問題をスクラッチバッファで加工して sudoku_p97.txt を作ります。
ファイルの中身はこんな感じ。未確定の部分は 0 にします。

Grid 01
004800017
670900000
508030004
300740100
069000780
001069005
100080306
000006091
240001500

コードがテキトーなので、データの末尾にタブやらスペースがあるとバグります。
注意してくださいw


次に数独を解くプログラムです。

(use util.list)

(define nil '())

(define (list->number lis)
  (fold (lambda (a b) (+ a (* b 10))) 0 lis))

(define (digit->integer c)
  (- (char->integer c) (char->integer #\0)))

(define (number->list num)
  (map digit->integer (string->list (number->string num))))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (filter pred items)
  (cond ((null? items) nil)
        ((pred (car items))
         (cons (car items)
               (filter pred (cdr items))))
        (else
         (filter pred (cdr items)))))

(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))

(define (uniq set)
  (define (iter x s)
    (if (null? x)
        s
        (iter (cdr x)
              (if (element-of-set? (car x) s)
                  s
                  (cons (car x) s)))))
  (iter set nil))

;

(define (bins->num bin-lis)
  (define (iter lis k num)
    (if (null? lis)
        num
        (iter (cdr lis) (* k 2) (+ num (* k (car lis))))))
  (iter (reverse bin-lis) 1 0))

(define (num->bins num k)
  (define (iter n)
    (if (= n 0)
      nil
      (append (iter (quotient n 2)) (list (remainder n 2)))))
  (let ((bins (iter num)))
    (append (make-list (- k (length bins)) 0) bins)))
  

(define (overlap-num lis)
  (if (null? (cdr lis))
      #f
      (if (= (car lis) (cadr lis))
          (car lis)
          (overlap-num (cdr lis)))))

(define (find-val num lis)
  (define (iter l i vals)
    (if (null? l)
        vals
        (iter (cdr l) (+ i 1) (if (= (car l) num) (append vals `(,i)) vals))))
  (iter lis 1 nil))

(define (find-vals lis lists)
  (define (iter l i vals)
    (if (null? l)
        vals
        (iter (cdr l) (+ i 1)
              (if (and (memq (car lis) (car l))
                       (memq (cadr lis) (car l)))
                  (append vals `(,i))
                  vals))))
  (iter lists 1 nil))

(define (find-lis lis lists)
  (define (iter l i vals)
    (if (null? l)
        vals
        (iter (cdr l)
              (+ i 1)
              (if (equal? (car l) lis)
                  (append vals `(,i))
                  vals))))
  (iter lists 1 nil))
        
;;

(define (make-grids filename)
  (define ip (open-input-file filename))
  (define (read-line ip)
    (define (iter lis)
      (let ((c (read-char ip)))
        (cond ((eof-object? c) lis)
              ((eq? c #\cr) (read-char ip) lis)
              (else
               (iter (append lis (list (digit->integer c))))))))
    (iter nil))
  (define (read-grids)
    (define (iter lis c)
      (if (= c 0)
          (list lis)
          (let ((line (read-line ip)))
            (if (null? line)
                (begin
                  (close-input-port ip)
                  nil)
                (iter (append lis (list line)) (- c 1))))))
    (read-line ip)
    (iter nil 9))
  (define (iter lis)
    (if (port-closed? ip)
        lis
        (iter (append lis (read-grids)))))
  (iter nil))

(define (grid->hash grid)
  (define ht (make-hash-table 'equal?))
  (define (list->hash lis y)
    (define (iter l x)
      (if (null? l)
          'done
          (begin
            (hash-table-put! ht (list x y) (car l))
            (iter (cdr l) (+ x 1)))))
    (iter lis 1))
  (define (init-hash lis y)
    (if (null? lis)
        ht
        (begin
          (list->hash (car lis) y)
          (init-hash (cdr lis) (+ y 1)))))
  (init-hash grid 1))

(define (gen-keys-mg key)
  (define (get-keys n)
    (cond ((< n 4) '(1 2 3))
          ((< n 7) '(4 5 6))
          (else '(7 8 9))))
  (let ((xs (get-keys (car key)))
        (ys (get-keys (cadr key))))
    (define (iter x lis)
      (if (null? x)
          lis
          (iter (cdr x) (append lis (map (lambda (y) (list (car x) y)) ys)))))
    (iter xs nil)))

(define (gen-keys-row key)
  (define keys (enumerate-interval 1 9))
  (filter (lambda (k) (not (equal? k key)))
          (map (lambda (x) (list x (cadr key))) keys)))

(define (gen-keys-col key)
  (define keys (enumerate-interval 1 9))
  (filter (lambda (k) (not (equal? k key)))
          (map (lambda (y) (list (car key) y)) keys)))

(define (gen-keys-rc key)
  (define keys (enumerate-interval 1 9))
  (append (map (lambda (x) (list x (cadr key))) keys)
          (map (lambda (y) (list (car key) y)) keys)))

(define (append-keys remove-keys keys1 keys2)
  (define (iter rk keys)
    (if (null? rk)
        keys
        (iter (cdr rk) (filter (lambda (k) (not (equal? k (car rk)))) keys))))
  (iter remove-keys (append keys1 keys2)))

;;

(define (improve-vals ht val keys)
  (define (iter k)
    (if (null? k)
        'done
        (let ((v (hash-table-get ht (car k))))
          (if (pair? v)
              (let ((new-v (filter (lambda (x) (not (= x val))) v)))
;;                (print ";IMPROVE_VALS key=" (car k) " old-val=" v " new-val=" new-v)
                (if (null? (cdr new-v))
                    (begin
                      (hash-table-put! ht (car k) (car new-v))
                      (improve-vals ht (car new-v) (append-keys (list (car k)) (gen-keys-mg (car k)) (gen-keys-rc (car k)))))
                    (hash-table-put! ht (car k) new-v))))
          (iter (cdr k)))))
;;  (print "IMPROVE-VALS val=" val " keys=" keys)
  (iter keys))

(define (solve-init ht)
  (define init-val '(1 2 3 4 5 6 7 8 9))
  (define (init-proc key val)
    (if (= val 0)
        (hash-table-put! ht key init-val)
        val))
  (define (init-imp-proc key val)
    (if (not (pair? val))
        (improve-vals ht val (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key)))
        val))
  (hash-table-map ht init-proc)
  (hash-table-map ht init-imp-proc)
  ht)

(define (check ht val keys)
  (define (iter k)
    (if (null? k)
        #t
        (let ((v (hash-table-get ht (car k))))
          (if (pair? v)
              (if (not (null? (filter (lambda (x) (= val x)) v)))
                  #f
                  (iter (cdr k)))
              (iter (cdr k))))))
  (iter keys))


(define (refine-val ht gen-keys-proc key val)
  (define (iter v)
    (if (null? v)
        #f
        (let ((result (check ht (car v) (gen-keys-proc key))))
          (if result
              (begin
                ;;(print ";PUT! key=" key " val=" (car v))
                (hash-table-put! ht key (car v))
                (car v))
              (iter (cdr v))))))
  ;;(print ";REFINE-VAL key=" key " val=" val)
  (iter val))

(define (refine-val-mg ht key val)
  (refine-val ht gen-keys-mg key val))

(define (refine-val-rc ht key val)
  (refine-val ht gen-keys-rc key val))

(define (refine-val-row ht key val)
  (refine-val ht gen-keys-row key val))

(define (refine-val-col ht key val)
  (refine-val ht gen-keys-col key val))

(define (solve-proc-primary ht)
  (define (proc key val)
    (if (list? val)
        (let ((v1 (refine-val-mg ht key val))
              (v2 (refine-val-row ht key val))
              (v3 (refine-val-col ht key val)))
          ;;(print ";debug key=" key " val=" val " v1=" v1 " v2=" v2 " v3=" v3)
          (and v1 (improve-vals ht v1 (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key))))
          (and v2 (improve-vals ht v2 (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key))))
          (and v3 (improve-vals ht v3 (append-keys (list key) (gen-keys-mg key) (gen-keys-rc key))))
          )))
  (hash-table-map ht proc)
  ht)

(define (solve-proc-simple-chain ht)
  (define (find-sc ht mg-keys)
    (define (sc keys)
      (define (one? lis) (null? (cdr lis)))
      (let ((x (uniq (map car keys)))
            (y (uniq (map cadr keys))))
        (cond ((null? keys) '(0 0))
              ((one? x) (list (car x) 0))
              ((one? y) (list 0 (car y)))
              (else '(0 0)))))
  
    (define (key-iter num keys results)
      (if (null? keys)
          results
          (let ((val (hash-table-get ht (car keys))))
            (if (pair? val)
                (let ((v (filter (lambda (v) (= v num)) val)))
                  (key-iter num
                            (cdr keys)
                            (if (null? v)
                                results
                                (cons (car keys) results))))
                (key-iter num (cdr keys) results)))))

    (define (num-iter nums)
      (if (null? nums)
          'done
          (let ((key (sc (key-iter (car nums) mg-keys nil))))
            (if (not (null? key))
                (let ((val (car nums)))
                  ;;(print "val=" val " key=" key)
                  (and (not (= 0 (cadr key))) (improve-vals ht val (append-keys mg-keys (gen-keys-row key) nil)))
                  (and (not (= 0 (car key))) (improve-vals ht val (append-keys mg-keys (gen-keys-col key) nil)))
                  (num-iter (cdr nums)))))))
    
    (num-iter (enumerate-interval 1 9)))

  (define (iter keys)
    (if (null? keys)
        ht
        (begin
          (find-sc ht (gen-keys-mg (car keys)))
          (iter (cdr keys)))))
  (iter '((1 1) (4 1) (7 1) (1 4) (4 4) (7 4) (1 7) (4 7) (7 7))))

    (define (get-keys-col org idx)
      (list (car org) (+ (cadr org) (- idx 1))))
    (define (get-keys-row org idx)
      (list (+ (car org) (- idx 1)) (cadr org)))
    (define (get-keys-mg org idx)
      (let ((r (quotient (- idx 1) 3))
            (c (remainder (- idx 1) 3)))
        (list (+ (car org) r) (+ (cadr org) c))))

    (define (make-pair-num r c)
      (cond ((= r 0) nil)
            ((= c 1) (cons (list r c) (make-pair-num (- r 1) 9)))
            ((= r c) (make-pair-num r (- c 1)))
            (else (cons (list r c) (make-pair-num r (- c 1))))))

  (define (find-naked-num vals)
    (define (iter pn vals nks)
      (if (null? pn)
          nks
          (let ((n1 (find-lis (car pn) vals)))
            (let ((n2 (find-vals (car pn) vals)))
              (if  (and (not (null? n1)) (= 2 (length n1)))
                   (iter (cdr pn) vals (cons (car pn) nks))
                   (if (and (not (null? n2)) (= 2 (length n2)))
                       (iter (cdr pn) vals (cons (car pn) nks))
                       (iter (cdr pn) vals nks)))))))
    (iter (make-pair-num 9 9)
          (map (lambda (v) (if (pair? v) v (list v))) vals)
          nil))

  (define (find-naked ht org keys get-keys-proc)
    (let ((vals (map (lambda (k) (hash-table-get ht k)) keys)))
      (find-naked-num vals)
      (let ((n (filter (lambda (k) (and (pair? k) (null? (cddr k)))) vals)))
;;        (print ";;n=" n)
        (if (null? n)
            #f
            (let ((d (overlap-num (sort (map list->number n)))))
              (if d
                  (if (null? (cddr (find-lis (number->list d) vals)))
                      (cons (car n) (map (lambda (idx) (get-keys-proc org idx)) (find-lis (car n) vals)))
                      #f)
                  #f))))))

  (define (find-naked-row ht org keys)
    (find-naked ht org keys get-keys-row))

  (define (find-naked-col ht org keys)
    (find-naked ht org keys get-keys-col))

  (define (find-naked-mg ht org keys)
    (find-naked ht org keys get-keys-mg))

(define (solve-proc-naked ht)
  (define (iter keys gen-keys-proc find-naked-proc)
    (if (null? keys)
        ht
        (let ((gk (gen-keys-proc (car keys))))
          (let ((nk (find-naked-proc ht (car keys) gk)))
            (if nk
                (let ((vals (car nk)))
                  (improve-vals ht (car vals) (append-keys (cdr nk) gk nil))
                  (improve-vals ht (cadr vals) (append-keys (cdr nk) gk nil))))
            (iter (cdr keys) gen-keys-proc find-naked-proc)))))
;;  (iter '((1 1) (4 1) (7 1) (1 4) (4 4) (7 4) (1 7) (4 7) (7 7)) gen-keys-mg find-naked-mg)
;;  (iter (cons '(1 1) (gen-keys-col '(1 1))) (lambda (k) (cons k (gen-keys-row k))) find-naked-row)
;;  (iter (cons '(1 1) (gen-keys-row '(1 1))) (lambda (k) (cons k (gen-keys-col k))) find-naked-col)
  (iter (cons '(1 1) (gen-keys-col '(1 1))) (lambda (k) (cons k (gen-keys-row k))) find-naked-row)
  )

(define (solve-proc-xy-wing ht)
  (define (xy-wing lis)
    (let ((w (filter (lambda (l) (= 2 (apply + l))) lis)))
      (cond ((null? w) #f)
            ((null? (cdr w)) #f)
            (else
             (let ((bins (map bins->num w)))
               (let ((sb (sort bins)))
                 (let ((usb (sort (uniq sb))))
                   (if (= (abs (- (length sb) (length usb))) 1)
                       (num->bins (overlap-num sb) 9)
                       #f
                       ))))))))
  (define (xy-wing-imp-vals ht n r c)
    (let ((k1 (list (car c) (car r)))
          (k2 (list (cadr c) (cadr r))))
      (let ((rk (list k1 k2 (list (car k2) (cadr k1)) (list (car k1) (cadr k2)))))
        ;;(print "n=" n " r=" r " c=" c " k1=" k1 " k2=" k2 " rk=" rk)
        (improve-vals ht n (append-keys rk (gen-keys-row k1) (gen-keys-col k1)))
        (improve-vals ht n (append-keys rk (gen-keys-row k2) (gen-keys-col k2)))
        )))
  (define (find-xy-wing ht num keys)
    (define (iter vals results)
      (if (null? vals)
          results
          (if (pair? (car vals))
              (if (null? (filter (lambda (n) (= n num)) (car vals)))
                  (iter (cdr vals) (append results '(0)))
                  (iter (cdr vals) (append results '(1))))
              (iter (cdr vals) (append results '(0))))))
    (let ((vals (map (lambda (k) (hash-table-get ht k)) keys)))
      ;;(print "num=" num " keys=" keys " vals=" vals)
      (iter vals nil)))
  (define (r-iter n nums results)
    (if (null? nums)
        results
        (let ((rk (list 1 (car nums))))
          (r-iter n
                  (cdr nums)
                  (append results
                          (list (find-xy-wing ht n (cons rk (gen-keys-row rk)))))))))
  (define (c-iter n nums results)
    (if (null? nums)
        results
        (let ((ck (list (car nums) 1)))
          (c-iter n
                  (cdr nums)
                  (append results
                          (list (find-xy-wing ht n (cons ck (gen-keys-col ck)))))))))
  (define (iter nums)
    (if (null? nums)
        ht
        (begin
          (let ((r (r-iter (car nums) (enumerate-interval 1 9) nil)))
            (let ((rw (xy-wing r)))
              (and rw (xy-wing-imp-vals ht (car nums) (find-lis rw r) (find-val 1 rw)))))
          (let ((c (c-iter (car nums) (enumerate-interval 1 9) nil)))
            (let ((cw (xy-wing c)))
              (and cw (xy-wing-imp-vals ht (car nums) (find-val 1 cw) (find-lis cw c)))))
          (iter (cdr nums)))))
  (iter (enumerate-interval 1 9)))
  
  
#;(define (prov ht)
  (define (iter2 ht key v)
    (if (null? v)
        ht
        (let ((htwk (alist->hash-table (hash-table->alist ht) 'equal?)))
          (hash-table-put! htwk key (car v))
          (solve-proc-primary htwk)
          (if (check-uniq-nums? htwk)
              htwk
              (iter2 ht key (cdr v))))))
  
  (define (iter ht alis)
    (if (null? alis)
        ht
        (let ((key (car (car alis)))
              (val (cdr (car alis))))
          (iter (if (pair? val)
                    (iter2 ht key val)
                    ht)
                (cdr alis)))))

  (iter ht (hash-table->alist ht)))

(define (solve-main ht alis)
;;  (solve-proc ht)
  (if (solve-end? ht)
      ht
      (if (equal? (hash-table->alist ht) alis)
          ht
          (let ((old-alis (hash-table->alist ht)))
            (solve-proc-primary ht)
            (solve-proc-simple-chain ht)
            (solve-proc-xy-wing ht)
            ;;(solve-proc-naked ht)
            (solve-main ht old-alis)))))

(define (transpose grid)
  (define (iter lis new-lis)
    (if (null? (car lis))
        new-lis
        (iter (map cdr lis) (append new-lis (list (map car lis))))))
  (iter grid nil))

(define (check-grid grid)
  (map (lambda (l) (equal? l '(1 2 3 4 5 6 7 8 9))) (map sort grid)))

(define (check-grid-all grid)
  (equal? (list #t)
       (uniq (append (check-grid grid) (check-grid (transpose grid))))))

(define (check-uniq-nums? ht)
  (let ((grid (hash->grid ht)))
    (let ((lis (map (lambda (lis) (filter (lambda(x) (not (pair? x))) lis)) (append grid (transpose grid)))))
      (equal? (map sort lis) (map (lambda (l) (sort (uniq l))) lis)))))

(define (solve-end? ht)
  (let ((alis (hash-table->alist ht))
        (grid (hash->grid ht)))
    (and (null? (filter pair? (map cdr alis)))
         (equal? (list #t) (uniq (append (check-grid grid) (check-grid (transpose grid))))))))

(define (hash->grid ht)
  (let ((nums (enumerate-interval 1 9)))
    (map (lambda (y)
           (map (lambda (x) (hash-table-get ht `(,x ,y)))
                nums))
         nums)))

(define (get-num ht)
  (+ (* 100 (hash-table-get ht '(1 1)))
     (* 10 (hash-table-get ht '(2 1)))
     (hash-table-get ht '(3 1))))

(define (problem-096)
  (define (iter sum grids)
    (if (null? grids)
        sum
        (let ((ans (solve (grid->hash (car grids)))))
          (print (hash->grid ans))
          (iter (+ sum (get-num ans)) (cdr grids)))))
  (iter 0 (make-grids "./sudoku.txt")))

(define (problem-096-test grid-no)
  (define grids (make-grids "./sudoku_p97.txt"))
  (define ht (grid->hash (list-ref grids (- grid-no 1))))
  (define ans (solve-proc-naked (solve-main (solve-init ht) nil)))
  (print (hash->grid ans))
  ans)

;;

;; test
;;(define h1 (problem-096-test 50))
;;(define h2 (solve-main h1 nil))
;;(define h3 (solve-proc-naked h2))
;;(hash->grid h3)
;;(define vals (map (lambda (k) (hash-table-get h3 k)) (cons '(2 1) (gen-keys-col '(2 1)))))
;;(define v (map (lambda (v) (if (pair? v) v (list v))) vals))

;;(map (lambda (x) (list x (solve-end? (solve-main (problem-096-test x) nil)))) (enumerate-interval 1 50))

コメントアウトされたデバッグ用のコードがあちこちにありますが、面倒なのでそのままです。
プログラムを書くには数独の解き方を猛勉強しなければならず、その結果プログラムが出来た時にはもはやプログラムは要らなくなってしまいますw

結果

gosh> (problem-096-test 1)
((9 3 4 8 2 5 6 1 7) (6 7 2 9 1 4 8 5 3) (5 1 8 6 3 7 9 2 4) (3 2 5 7 4 8 1 6 9) (4 6 9 1 5 3 7 8 2) (7 8 1 2 6 9 4 3 5) (1 9 7 5 8 2 3 4 6) (8 5 3 4 7 6 2 9 1) (2 4 6 3 9 1 5 7 8))
#<hash-table equal? 0x600356cd0>

ハッシュテーブルを返しますが気にしてはいけません。
出力結果を整形したもの。

((9 3 4 8 2 5 6 1 7)
 (6 7 2 9 1 4 8 5 3)
 (5 1 8 6 3 7 9 2 4)
 (3 2 5 7 4 8 1 6 9)
 (4 6 9 1 5 3 7 8 2)
 (7 8 1 2 6 9 4 3 5)
 (1 9 7 5 8 2 3 4 6)
 (8 5 3 4 7 6 2 9 1)
 (2 4 6 3 9 1 5 7 8))

このように解けました。

L-99 P90

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)

と表示します。

L-99 P98 その後

人間が解くみたいにプログラムで解くの面倒くっさいーーーーーwwwww

 

「nonograms」でググってもほとんど何も出てきませんが、

「お絵かきロジック」でググると色々と出てきます。

 

Lisp で配列処理するのは面倒くっさくて、

やる気が萎え萎えで捗らないなーw

 

L-99 P98

問題 P98 は言葉で説明するのが難しいので、問題(英語)を読んでください。
https://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html

なお、P90 の 8クイーン問題は、SICP の問 2.42 *1 で、P97 の数独問題は Euler Project の問 96 *2でやったのでパスです。週末の暇な時に気が向いたらコードを掲載するかも知れません。

閑話休題。コードはこんな感じになります。

(define (state lst)
  (define (iter l c result)
    (if (null? l)
	(if (> c 0)
	    (append result `(,c))
	    result)
	(iter (cdr l)
	      (if (= (car l) 1) (+ c 1) 0)
	      (if (and (> c 0) (= (car l) 0))
		  (append result `(,c))
		  result))))
  (iter lst 0 nil))

(define (answer? column-states r1 r2 r3 r4 r5 r6 r7 r8 r9)
  (let* ((rows `(,r1 ,r2 ,r3 ,r4 ,r5 ,r6 ,r7 ,r8 ,r9))
	 (columns1 (map (lambda (x) (list-ref x 0)) rows))
	 (columns2 (map (lambda (x) (list-ref x 1)) rows))
	 (columns3 (map (lambda (x) (list-ref x 2)) rows))
	 (columns4 (map (lambda (x) (list-ref x 3)) rows))
	 (columns5 (map (lambda (x) (list-ref x 4)) rows))
	 (columns6 (map (lambda (x) (list-ref x 5)) rows))
	 (columns7 (map (lambda (x) (list-ref x 6)) rows))
	 (columns8 (map (lambda (x) (list-ref x 7)) rows)))
     (and
      (equal? (state columns1) (list-ref column-states 0))
      (equal? (state columns2) (list-ref column-states 1))
      (equal? (state columns3) (list-ref column-states 2))
      (equal? (state columns4) (list-ref column-states 3))
      (equal? (state columns5) (list-ref column-states 4))
      (equal? (state columns6) (list-ref column-states 5))
      (equal? (state columns7) (list-ref column-states 6))
      (equal? (state columns8) (list-ref column-states 7))
      )))

(define (nonograms row-states column-states)
  (let* ((rows (repeated-permutations '(1 0) 8))
         (row1 (filter (lambda(x) (equal? (state x) (list-ref row-states 0))) rows))
	 (row2 (filter (lambda(x) (equal? (state x) (list-ref row-states 1))) rows))
	 (row3 (filter (lambda(x) (equal? (state x) (list-ref row-states 2))) rows))
	 (row4 (filter (lambda(x) (equal? (state x) (list-ref row-states 3))) rows))
	 (row5 (filter (lambda(x) (equal? (state x) (list-ref row-states 4))) rows))
	 (row6 (filter (lambda(x) (equal? (state x) (list-ref row-states 5))) rows))
	 (row7 (filter (lambda(x) (equal? (state x) (list-ref row-states 6))) rows))
	 (row8 (filter (lambda(x) (equal? (state x) (list-ref row-states 7))) rows))
	 (row9 (filter (lambda(x) (equal? (state x) (list-ref row-states 8))) rows)))
    (call/cc (lambda (c)
	       (map (lambda (r1)
		      (map (lambda (r2)
			     (map (lambda (r3)
				    (map (lambda (r4)
					   (map (lambda (r5)
						  (map (lambda (r6)
							 (map (lambda (r7)
								(map (lambda (r8)
								       (map (lambda (r9)
									      (and (answer? column-states r1 r2 r3 r4 r5 r6 r7 r8 r9)
										   (c `(,r1 ,r2 ,r3 ,r4 ,r5 ,r6 ,r7 ,r8 ,r9)))
									      ) row9)
								       ) row8)
								) row7)
							 ) row6)
						  ) row5)
					   ) row4)
				    ) row3)
			     ) row2)
		      ) row1)
	       ))))

総当たり力技解法ならば、そんなに難しいコードではありません。
map の入れ子は気にしたら負けです。
解答は1個らしいので、見つかったら call/cc を使ってブレークします。

結果

gosh> (time (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3))))
;(time (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) ...
; real  17.862
; user  18.970
; sys    0.281
((0 1 1 1 0 0 0 0) (1 1 0 1 0 0 0 0) (0 1 1 1 0 0 1 1) (0 0 1 1 0 0 1 1) (0 0 1 1 1 1 1 1) (1 0 1 1 1 1 1 0) (1 1 1 1 1 1 0 0) (0 0 0 0 1 0 0 0) (0 0 0 1 1 0 0 0))

この程度(9 x 8 マス) の問題なら総当たりでもそれなりの時間で解けます。
少し見やすくします。

gosh> (begin (map print (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3)))) 'done)
(0 1 1 1 0 0 0 0)
(1 1 0 1 0 0 0 0)
(0 1 1 1 0 0 1 1)
(0 0 1 1 0 0 1 1)
(0 0 1 1 1 1 1 1)
(1 0 1 1 1 1 1 0)
(1 1 1 1 1 1 0 0)
(0 0 0 0 1 0 0 0)
(0 0 0 1 1 0 0 0)
done


人間らしく解くコードも考えてみる事にします。
計算時間は総当たり方式より速くなるでしょうか?

L-99 P93

年度始めすぐは、なにかと暇なので勉強が捗っちゃうねーw

2 3 5 7 11 から等式を作って正しい計算結果になる式をリストアップしなさい。
例として、2-3+5+7 = 11 とか 2 = (3*5+7)/11 があるよ。(あと 10 個ある。)

という問題。

まずは汎用手続き

(define nil '())

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (accumulate op initial seq)
  (if (null? seq)
      initial
      (op (car seq)
	  (accumulate op initial (cdr seq)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (remove item seq)
  (filter (lambda (x) (not (eq? x item))) seq))

(define (permutations s c)
  (if (or (= c 0) (null? s))
      (list nil)
      (flatmap (lambda (x)
		 (map (lambda (p) (cons x p))
		      (permutations (remove x s) (- c 1))))
	       s)))

(define (repeated-permutations s n)
  (if (= n 0)
      (list nil)
      (flatmap (lambda (x)
		 (map (lambda (p) (cons x p)) (repeated-permutations s (- n 1))))
	       s)))

(define (uniq lis)
  (define ht (make-hash-table 'equal?))
  (define (iter l)
    (if (null? l)
	(hash-table-keys ht)
	(let ((key (hash-table-get ht (car l) nil)))
	  (and (null? key) (hash-table-put! ht (car l) (car l)))
	  (iter (cdr l)))))
  (iter lis))

次にスタックまわりの手続き

(define *stack* nil)
(define level-ratio 100)

(define (last-pushed)
  (if (empty?)
      nil
      (car *stack*)))

(define (after-popped)
  (if (empty?)
      nil
      (cdr *stack*)))

(define (init-stack)
  (set! *stack* nil))

(define (empty?)
  (null? *stack*))

(define (push x)
  (set! *stack* (cons x *stack*)))

(define (pop)
  (if (empty?)
      nil
      (let ((result (last-pushed)))
	(set! *stack* (after-popped))
	result)))

(define (pop-all level)
  (define (iter ops)
    (if (or (empty?) (< (priority (last-pushed)) (* level level-ratio)))
	ops
	(iter (append ops (cons (operator (pop)) nil)))))
  (iter nil))

;;

(define (priority p)
  (if (null? p)
      0
      (cdr p)))

(define (operator p)
  (car p))

(define (operator? x)
  (or (eq? x '+) (eq? x '-) (eq? x '*) (eq? x '/)))

(define (make-priority op level)
  (let ((priority
	 (cond ((eq? op '*) 20)
	       ((eq? op '/) 20)
	       ((eq? op '+) 10)
	       ((eq? op '-) 10)
	       (else 0))))
    (cons op (+ priority (* level level-ratio)))))

(define (exchange-operator op level)
  (define (iter ops)
    (if (or (empty?) (<= (priority (last-pushed)) (priority (make-priority op level))))
	ops
	(iter (append ops (cons (operator (pop)) nil)))))
  (iter nil))

メインの問題を解くプログラム。

(define (exp->rpn exp)
  (define (iter e r level)
    (if (null? e)
	(append r (pop-all level))
	(if (list? (car e))
	    (iter (cdr e) (iter (car e ) r (+ level 1)) level)
	    (cond ((operator? (car e))
		   (let ((ops (exchange-operator (car e) level)))
		     (push (make-priority (car e) level))
		     (iter (cdr e) (append r ops) level)))
		  (else (iter (cdr e) (append r (list (car e))) level))))))
  (init-stack)
  (iter exp nil 0))

(define (eval-rpn rpn)
  (define (iter r)
    (if (null? r)
	(pop)
	(let ((e (car r)))
	  (cond ((eq? e '+)
		 (let ((addend (pop)))
		   (push (+ (pop) addend))))
		((eq? e '-)
		 (let ((subtrahend (pop)))
		   (push (- (pop) subtrahend))))
		((eq? e '*)
		 (let ((multiplier (pop)))
		   (push (* (pop) multiplier))))
		((eq? e '/)
		 (let ((divisor (pop)))
		   (if (= divisor 0)
		       (error "attempt to calculate a division by zero")
		       (push (/ (pop) divisor)))))
		(else (push e)))
	  (iter (cdr r)))))
  (init-stack)
  (guard (e ((<error> e) -999))
	 (iter rpn)))

(define (build-exp o d)
  (if (null? o)
      nil
      (cons (car o) (cons (car d) (build-exp (cdr o) (cdr d))))))

(define (build-exps ops dgt)
  (map cdr (map (lambda (o) (build-exp (cons '_ o) dgt)) ops)))

(define operators (repeated-permutations (list '+ '- '* '/ '=) 4))

(define digits '(2 3 5 7 11))

(define (ins-parens exp)
  (let ((len (length exp)))
    (cond ((= len 7)
	   (let ((a (list-ref exp 0))
		 (op1 (list-ref exp 1))
		 (b (list-ref exp 2))
		 (op2 (list-ref exp 3))
		 (c (list-ref exp 4))
		 (op3 (list-ref exp 5))
		 (d (list-ref exp 6)))
	     `(
	       (((,a ,op1 ,b) ,op2 ,c) ,op3 ,d)
	       ((,a ,op1 (,b ,op2 ,c)) ,op3 ,d)
	       (,a ,op1 ((,b ,op2 ,c) ,op3 ,d))
	       (,a ,op1 (,b ,op2 (,c ,op3 ,d)))
	       ((,a ,op1 ,b) ,op2 (,c ,op3 ,d))
	       )))
	  ((= len 5)
	   (let ((a (list-ref exp 0))
		 (op1 (list-ref exp 1))
		 (b (list-ref exp 2))
		 (op2 (list-ref exp 3))
		 (c (list-ref exp 4)))
	     `(
	       ((,a ,op1 ,b) ,op2 ,c)
	       (,a ,op1 (,b ,op2 ,c))
		)))
	  (else
	   exp))))

(define (holds-equation? equation)
  (let ((left  (eval-rpn (exp->rpn (car equation))))
	(right (eval-rpn (exp->rpn (cadr equation)))))
    (= left right)))

(define (tenkai equations)
  (define (iter e result)
    (if (null? e)
	result
	(iter (cdr e) (append result (list (list (car e) (cadr equations)))))))
  (iter (car equations) nil))

(define (modosu equations)
  (let* ((left (car equations))
	 (right (cadr equations))
	 (l-min (car (exp->rpn left)))
	 (r-min (car (exp->rpn right))))
    (if (< l-min r-min)
	(list left '= right)
	(list right '= left))))
  
(define (split-equal lst)
  (define (iter l left)
    (if (eq? (car l) '=)
	(list left (cdr l))
	(iter (cdr l) (append left (cons (car l) nil)))))
  (iter lst nil))

(define (count-equal lst)
  (length (filter (lambda (x) (eq? x '=)) lst)))

(define (arithmetic-puzzle)
  (map modosu
       (filter holds-equation?
	       (flatmap (lambda (e) (tenkai (sort (map ins-parens (split-equal e)))))
			(filter (lambda (exp) (= 1 (count-equal exp))) (build-exps operators digits))))))

最後のほうは考えるのが面倒くさくなってローマ字表記みたいな手続き名になっていますが、
良い子のプログラマー諸君はマネしてはいけません。

arithmetic-puzzle 手続きを見るとわかる通り、

オペレータ(演算子)と数字から計算式の組み合わせを作り、
イコールが一つだけの式を絞り込み、
さらにイコールで左辺と右辺を分解し、
カッコの組み合わせを左辺と右辺の式それぞれに適用し、
その結果から新しい式を展開して作り出し、
左辺と右辺をの計算式をそれぞれ計算してイコールになるものを絞り込み、
分解した式を整形して元に戻す

ということをやっていますw


データは次から次へと流れる滝のように処理されます。
このように処理を行う事を「カスケード」と言います。

結果

gosh> (arithmetic-puzzle)
(((((2 - 3) + 5) + 7) = (11)) (((2 - 3) + (5 + 7)) = (11)) (((2 - (3 - 5)) + 7) = (11)) ((2 - (3 - (5 + 7))) = (11)) ((2 - ((3 - 5) - 7)) = (11)) ((2 * (3 - 5)) = (7 - 11)) ((2) = ((3 - (5 + 7)) + 11)) ((2) = (3 - ((5 + 7) - 11))) ((2) = (3 - (5 + (7 - 11)))) ((2) = (((3 - 5) - 7) + 11)) ((2) = ((3 - 5) - (7 - 11))) ((2) = (((3 * 5) + 7) / 11)))

Lisp な人は出力結果はリストです。きれいに出力しようとかあまり気にしません。
でも、もう少し気にしてみた。

gosh> (begin (map print (arithmetic-puzzle)) 'done)
((((2 - 3) + 5) + 7) = (11))
(((2 - 3) + (5 + 7)) = (11))
(((2 - (3 - 5)) + 7) = (11))
((2 - (3 - (5 + 7))) = (11))
((2 - ((3 - 5) - 7)) = (11))
((2 * (3 - 5)) = (7 - 11))
((2) = ((3 - (5 + 7)) + 11))
((2) = (3 - ((5 + 7) - 11)))
((2) = (3 - (5 + (7 - 11))))
((2) = (((3 - 5) - 7) + 11))
((2) = ((3 - 5) - (7 - 11)))
((2) = (((3 * 5) + 7) / 11))
done

いらないカッコもあったりしますが気にしてはいけません。

ちなみに答えの数ですが、

gosh> (length (arithmetic-puzzle))
12

12 個あります。適当に検算しましたが問題なさそうです。