SICP 2.3.4 例: Huffman 符号化木

GET A JOB

SHA NA NA NA NA NA NA NA NA

GET A JOB

SHA NA NA NA NA NA NA NA NA

WAH YJP YJP YJP YJP YJP YJP YJP YJP YJP

SHA BOOM

'(1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 0 1 1)

; Huffman 木の表現
(define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))

(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))

(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))

(define (symbols tree)
  (if (leaf? tree)
    (list (symbol-leaf tree))
    (caddr tree)))

(define (weight tree)
  (if (leaf? tree)
    (weight-leaf tree)
    (cadddr tree)))

; 復号化手続き
(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
      ()
      (let ((next-branch
              (choose-branch (car bits) current-branch)))
        (if (leaf? next-branch)
          (cons (symbol-leaf next-branch)
                (decode-1 (cdr bits) tree))
          (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- CHOOSE-BRANCH" bit))))

; 重み付き要素の集合
(define (adjoin-set x set)
  (cond ((null? set) (list x))
        ((< (weight x) (weight (car set))) (cons x set))
        (else (cons (car set)
                     (adjoin-set x (cdr set))))))

(define (make-leaf-set pairs)
  (if (null? pairs)
    ()
    (let ((pair (car pairs)))
      (adjoin-set (make-leaf (car pair)   ; 記号
                             (cadr pair)) ; 頻度
                  (make-leaf-set (cdr pairs))))))

; ex-2.67
(define sample-tree
  (make-code-tree (make-leaf 'A 4)
                  (make-code-tree
                    (make-leaf 'B 2)
                    (make-code-tree (make-leaf 'D 1)
                                    (make-leaf 'C 1)))))

(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))

; (print (decode sample-message sample-tree))
; (A D A B B C A)

; ex-2.68
; message: (A D A B B C A)
; tree: sample-tree
;  ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)
; return: (0 1 1 0 0 1 0 1 0 1 1 1 0)
(define (encode message tree)
  (if (null? message)
    ()
    (append (encode-symbol (car message) tree)
            (encode (cdr message) tree))))


(define (encode-symbol symbol tree)
  ; (print tree)
  ; (print symbol)
  (cond ((leaf? tree) ())
        ((memq symbol (symbols (left-branch tree)))
         (cons 0 (encode-symbol symbol (left-branch tree))))
        ((memq symbol (symbols (right-branch tree)))
          (cons 1 (encode-symbol symbol (right-branch tree))))
        (else (error "not symbol in symbols" symbol))))

; (print (encode '(A D A B B C A) sample-tree))
; (0 1 1 0 0 1 0 1 0 1 1 1 0)
; (print (equal? sample-message (encode (decode sample-message sample-tree) sample-tree)))
; #t

; ex-2.69
; '((A 4) (B 2) (C 1) (D 1))
; '((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)

; (make-leaf-set '((A 4) (B 2) (C 1) (D 1)))
; ((leaf D 1) (leaf C 1) (leaf B 2) (leaf A 4))

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

; ((leaf D 1) (leaf C 1) (leaf B 2) (leaf A 4))
(define (successive-merge leafs)
  (print leafs)
  (cond ((null? leafs) ())
        ((null? (cdr leafs)) (car leafs))
        (else (successive-merge
                (adjoin-set (make-code-tree (car leafs) (cadr leafs))
                            (cddr leafs))))))
; (print (generate-huffman-tree '((A 4) (B 2) (C 1) (D 1))))
; ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)

; ex-2.70
(define song-tree (generate-huffman-tree '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YJP 9) (JOB 2) (WAH 1))))
(define song '(
               GET A JOB
               SHA NA NA NA NA NA NA NA NA
               GET A JOB
               SHA NA NA NA NA NA NA NA NA
               WAH YJP YJP YJP YJP YJP YJP YJP YJP YJP
               SHA BOOM))
; (print (encode song song-tree))
; (1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 0 1 1)
; (print (length (encode song song-tree)))
; 84bit

SICP 2.3.3 例: 集合の表現

やってます

#|
; 要素xが集合setの構成要素か?
(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))

; setにxを追加する
(define (adjoin-set x set)
  (if (element-of-set? x set)
    set
    (cons x set)))

; ２つの集合の積集合, 両方の集合に現れる要素だけを含む集合
(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) '())
        ((element-of-set? (car set1) set2)
         (cons (car set1)
               (intersection-set (cdr set1) set2)))
        (else (intersection-set (cdr set1) (cdr set2)))))

; ex-2.59
; 和集合, どちらかの集合に現れる要素を含んでいる集合
(define (union-set set1 set2)
  (if (null? set1)
    set2
    (union-set (cdr set1) (adjoin-set (car set1) set2))))
|#

; ex-2.60
; 重複可の集合

; そのまま
#|
(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))
(define (adjoin-set x set)
  (cons x set))
|#

(define (union-set set1 set2)
  (append set1 set2))

; そのまま
#|
(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) '())
        ((element-of-set? (car set1) set2)
         (cons (car set1)
               (intersection-set (cdr set1) set2)))
        (else (intersection-set (cdr set1) (cdr set2)))))
|#

; 順序づけられたリストとしての集合
(define (element-of-set? x set)
  (cond ((null? set) false)
        ((= x (car set)) true)
        ((< x (car set)) false)
        (else (element-of-set? x (cdr set)))))

(define (intersection-set set1 set2)
  (if (or (null? set1) (null? set2))
    '()
    ((let ((x1 (car set1)) (x2 (car set2)))
       (cond ((= x1 x2)
              (cons x1
                    (intersection-set (cdr set1)
                                      (cdr set2))))
             ((< x1 x2)
              (intersection-set (cdr set1) set2))
             ((< x2 x1)
              (intersection-set set1 (cdr set2))))))))

; ex-2.61
(define (adjoin-set x set)
  (cond ((null? set) (list x))
        ((= x (car set)) set)
        ((< x (car set)) (append (list x) set))
        (else (append (list (car set)) (adjoin-set x (cdr set))))))

; ex-2.62
; (union-set '(1 2) '(1 2 4 6 8 10))
; (1 2 4 6 8 10)
#|
(define (union-set set1 set2)
  (if (null? set1)
    set2
    (union-set (cdr set1) (adjoin-set (car set1) set2))))
|#
(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((null? set2) set1)
        (else
          (let ((x1 (car set1))
                (x2 (car set2)))
            (cond ((= x1 x2)
                   (cons x1 (union-set (cdr set1) (cdr set2))))
                  ((< x1 x2)
                   (cons x1 (union-set (cdr set1) set2)))
                  ((> x1 x2)
                   (cons x2 (union-set set1 (cdr set2)))))))))

; 二進木としての集合

(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))

(define (make-tree entry left right)
  (list entry left right))

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((= x (entry set)) true)
        ((< x (entry set))
         (element-of-set? x (left-branch set)))
        ((> x (entry set))
         (element-of-set? x (right-branch set)))))

(define (adjoin-set x set)
  (cond ((null? set) (make-tree x '() '()))
        ((= x (entry set)) set)
        ((< x (entry set))
         (make-tree (entry set)
                    (adjoin-set x (left-branch set))
                    (right-branch set)))
        ((> x (entry set))
         (make-tree (entry set)
                    (left-branch set)
                    (adjoin-set x (right-branch set))))))

; ex-2.63
; a. 結果は同じ
; b. 1は再帰, 2は反復. 2の方が軽い.
;    けどprintしたらほぼ変わらなそう.
(define tree (make-tree
               7
               (make-tree 3 (make-tree 1 () ()) (make-tree 5 () ()))
               (make-tree 9 () (make-tree 11 () ()))))

(define (tree->list-1 tree)
  ; (print tree)
  (if (null? tree)
    ()
    (append (tree->list-1 (left-branch tree))
            (cons (entry tree)
                  (tree->list-1 (right-branch tree))))))

; (print (tree->list-1 tree))

(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
    ; (print tree)
    (if (null? tree)
      result-list
      (copy-to-list (left-branch tree)
                    (cons (entry tree)
                          (copy-to-list (right-branch tree)
                                        result-list)))))
  (copy-to-list tree ()))

; (print (tree->list-2 tree))

; ex-2.64
(define (list->tree elements)
  (car (partial-tree elements (length elements))))

(define (partial-tree elts n)
  ; (print elts)
  (if (= n 0)
    (cons '() elts)
    (let ((left-size (quotient (- n 1) 2)))
      (let ((left-result (partial-tree elts left-size)))
        (let ((left-tree (car left-result))
              (non-left-elts (cdr left-result))
              (right-size (- n (+ left-size 1))))
          (let ((this-entry (car non-left-elts))
                (right-result (partial-tree (cdr non-left-elts) right-size)))
            (let ((right-tree (car right-result))
                  (remaining-elts (cdr right-result)))
              (newline)
              (cons (make-tree this-entry left-tree right-tree)
                    remaining-elts))))))))

; (print (list->tree '(1 3 5 7 9 11)))
; (print "************************************")
; (print (list->tree '(1 3 5 7 9)))
; (5
;    (1 () (3 () ()))
;    (9 (7 () ()) (11 () ())))

; a.
;   5
; 1   9
;  3 7 11

; b. O(n)

; ex-2.65
; union-set 和集合
; intersection-set 積集合
(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((null? set2) set1)
        (else
          (let ((x1 (car set1))
                (x2 (car set2)))
            (cond ((= x1 x2)
                   (cons x1 (union-set (cdr set1) (cdr set2))))
                  ((< x1 x2)
                   (cons x1 (union-set (cdr set1) set2)))
                  ((> x1 x2)
                   (cons x2 (union-set set1 (cdr set2)))))))))

(define (union-tree tree1 tree2)
  (list->tree
    (union-set
      (tree->list-1 tree1)
      (tree->list-1 tree2))))

; (print (union-tree (list->tree '(1 2 3 4 5)) (list->tree '(4 5 6 7 8))))

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

(define (intersection-set set1 set2)
  (print set1)
  (print set2)
  (cond ((or (null? set1 ) (null? set2)) ())
        ((element-of-set-old? (car set1) set2)
         (cons (car set1)
               (intersection-set (cdr set1) set2)))
        (else (intersection-set (cdr set1) set2))))

(define (intersection-tree tree1 tree2)
  (list->tree
    (intersection-set
      (tree->list-1 tree1)
      (tree->list-1 tree2))))

; (print (intersection-tree (list->tree '(1 2 3 4 5)) (list->tree '(4 5 6 7 8))))

(define (lookup given-key set-of-records)
  (cond ((null? set-of-records) #f)
        ((equal? given-key (key (car set-of-records)))
         (car set-of-records))
        (else (lookup given-key (cdr set-of-records)))))

; ex-2.66
(define (key record) (car record))
(define (value record) (cadr record))
(define (make-record key value) (list key value))
(define record
  (list->tree (list
                (make-record 1 'hoge)
                (make-record 2 'fuga)
                (make-record 3 'piyo)
                (make-record 4 'piyora))))

(define (lookup-record given-key records)
  (print records)
  (if (null? records)
    #f
    (let ((record (car records)))
      (let ((take-key (key record)))
        (cond ((equal? given-key take-key)
               (value record))
              ((< given-key take-key)
               (lookup-record given-key (left-branch records)))
              ((> given-key take-key)
               (lookup-record given-key (right-branch records))))))))

SICP 2.2.4 例:図形言語

実際に描画出来ないのでパスした問題が何問か。

gauche-glとかを使えばいけそうな気がしたけど、使い方とか調べてまでこれを描画したいか？と言われるとそうでもなかったのでパスする方向で(テヘペロ

SICP2周目とかでやるといいかもしれない。

; wave
;  線画を描く基本的なpainter
; beside
;  ２つのペインタをとり、第一のペインタ画像をフレームの左半分に描き、
;  第２のペインタ画像をフレームの右半分に描く新しい合成ペインタを作る
; below
;  ２つのペインタをとり、
;  第一のペインタ画像を第二のペインタ画像の下に描く新しい合成ペインタを作る
; flip-vert
;  ペインタを一つとり、その上下逆転の画像を描く
; flip-horiz
;  ペインタを一つとり、その左右逆転の画像を描く

(define wave2 (beside wave (flip-vert wave)))
; (define wave4 (below wave2 wave2))

; wave4のパターンを抽象化
#|
(define (flipped-pairs painter)
  (let ((painter2 (beside painter (flip-vert painter))))
    (below painter2 painter2)))
|#

; wave4のパターンを具体化(rogersじゃなくてwaveを渡している=具体的)
(define wave4 (flipped-pairs wave))

; 再帰的演算. ペインタを右の方へ分割,枝分かれさせるものである
#|
(define (right-split painter n)
  (if (= n 0)
    painter
    (let ((smaller (right-split painter (- n 1))))
      (beside painter (below smaller smaller)))))
|#

; 上へも枝分かれさせ、バランスの取れたパターンが作れる
(define (corner-split painter n)
  (if (= n 0)
    painter
    (let ((up (up-split painter (- n 1)))
          (right (right-split painter (- n 1))))
      (let ((top-left (beside up up))
            (bottom-right (below right right))
            (corner (corner-split painter (- n 1))))
        (beside (below painter top-left)
                (below bottom-right corner))))))

; 図2.9(きれいなやつ)
(define (square-limit painter n)
  (let ((quarter (corner-split painter n)))
    (let ((half (beside (flip-horiz quarter) quarter)))
      (below (flip-vert half) half))))

; ex-2.44
#|
(define (up-split painter n)
  (if (= n 0)
    painter
    (let ((smaller (up-split painter (- n 1))))
      (below painter (beside smaller smaller)))))
|#
;;;;;;

; tl, tr, bl, br
; 上左コピー, 上右コピー, 下左コピー, 下右コピー
(define (square-of-four tl tr bl br)
  (lambda (painter)
    (let ((top (beside (tl painter) (tr painter)))
          (bottom (beside (bl painter) (br painter))))
      (below bottom top))))

(define (flipped-pairs painter)
  (let ((combine4 (square-of-four identity flip-vert identity flip-vert)))
    (combine4 painter)))

; rotate180はex-2.50で出てくるらしい
(define (square-limit painter n)
  (let ((combine4 (square-of-four flip-horiz identity rotate180 flip-vert)))
    (combine4 (corner-split painter n))))

; ex-2.45
(define right-split (split beside below))
(define up-split (split below beside))

(define (split copy1 copy2)
  (if (= n 0)
    painter
    (let ((smaller (split painter (- n 1))))
      (copy1 painter (copy2 smaller smaller)))))

;;;;;;;;;

; v=(x,y)
(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
      (origin-frame frame)
      (add-vect (scale-vect (xcor-vect v)
                            (edge1-frame frame))
                (scale-vect (ycor-vect v)
                            (edge2-frame frame))))))

; ((frame-coord-map a-frame) (make-vect 0 0))
; (origin-frame a-frame)
; ↑両者は同じベクタを返す

; ex-2.46
(define (make-vect x y) (cons x y))
(define (xcor-vect v) (car v))
(define (ycor-vect v) (cdr v))

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2)) (+ (ycor-vect v1) (ycor-vect v2))))

(define (sub-vect v1 v2)
  (make-vect (- (xcor-vect v1) (xcor-vect v2)) (- (ycor-vect v1) (ycor-vect v2))))

(define (scale-vect s v)
  (make-vect (* s (xcor-vect v)) (* s (ycor-vect v))))

; ex-2.47
(define (make-frame origin edge1 edge2) (list origin edge1 edge2))
(define (origin-frame frame) (car frame))
(define (edge1-frame frame) (cadr frame))
(define (edge2-frame frame) (caddr frame))

(define (make-frame origin edge1 edge2) (cons origin (cons edge1 edge2)))
(define (origin-frame frame) (car frame))
(define (edge1-frame frame) (cadr frame))
(define (edge2-frame frame) (cddr frame))

; ex-2.48
(define (make-segment origin-to-start origin-to-end)
  (list origin-to-start origin-to-end))

(define (start-segment segment) (car segment))
(define (end-segment segment) (cadr segment))

; ex-2.49
(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
      (lambda (segment)
        (draw-line
          ((frame-coordmap frame) (start-segment segment))
          ((frame-coordmap frame) (end-segment segment))))
      (segment-list))))

; 実際に描画出来ないのでコピペしてふ〜んこうなんだーくらいの感じ
(define draw-frame-outline
  (let ((v0 (make-vect 0.0 0.0))
        (v1 (make-vect 1.0 0.0))
        (v2 (make-vect 1.0 1.0))
        (v3 (make-vect 0.0 1.0)))
    (segments->painter
      (list (make-segment v0 v1)
            (make-segment v1 v2)
            (make-segment v0 v3)
            (make-segment v3 v2)))))

(define draw-frame-cross
  (let ((v0 (make-vect 0 0))
        (v1 (make-vect 1 0))
        (v2 (make-vect 1 1))
        (v3 (make-vect 0 1)))
    (segments->painter
      (list (make-segment v0 v2)
            (make-segment v1 v3)))))

(define draw-frame-diamond
  (let ((v0 (make-vect 0.5 0.0))
        (v1 (make-vect 1.0 0.5))
        (v2 (make-vect 0.5 1.0))
        (v3 (make-vect 0.0 0.5)))
    (segments->painter
      (list (make-segment v0 v1)
            (make-segment v1 v2)
            (make-segment v2 v3)
            (make-segment v3 v0)))))

(define wave
  (segments->painter
    (list (make-segment (make-vect 0.35 0.85) (make-vect 0.40 1.00))
          (make-segment (make-vect 0.65 0.85) (make-vect 0.60 1.00))
          (make-segment (make-vect 0.35 0.85) (make-vect 0.40 0.65))
          (make-segment (make-vect 0.65 0.85) (make-vect 0.60 0.65))
          (make-segment (make-vect 0.60 0.65) (make-vect 0.75 0.65))
          (make-segment (make-vect 0.40 0.65) (make-vect 0.30 0.65))
          (make-segment (make-vect 0.75 0.65) (make-vect 1.00 0.35))
          (make-segment (make-vect 0.60 0.45) (make-vect 1.00 0.15))
          (make-segment (make-vect 0.60 0.45) (make-vect 0.75 0.00))
          (make-segment (make-vect 0.50 0.30) (make-vect 0.60 0.00))
          (make-segment (make-vect 0.30 0.65) (make-vect 0.15 0.60))
          (make-segment (make-vect 0.30 0.60) (make-vect 0.15 0.40))
          (make-segment (make-vect 0.15 0.60) (make-vect 0.00 0.85))
          (make-segment (make-vect 0.15 0.40) (make-vect 0.00 0.65))
          (make-segment (make-vect 0.30 0.60) (make-vect 0.35 0.50))
          (make-segment (make-vect 0.35 0.50) (make-vect 0.25 0.00))
          (make-segment (make-vect 0.50 0.30) (make-vect 0.40 0.00)))))

; ex-2.50
; r180とr270はコピペ.
; 実際に試せないとこの辺はやりにくなー
(define (flip-holiz painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)
                     (make-vect 0.0 0.0)
                     (make-vect 1.0 1.0)))

(define (rotate180 painter)
  (transform-painter painter
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 1.0)
                     (make-vect 1.0 0.0)))

(define (rotate270 painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)
                     (make-vect 0.0 0.0)
                     (make-vect 1.0 1.0)))

; ex-2.51
; below
;  ２つのペインタをとり、
;  第一のペインタ画像を第二のペインタ画像の下に描く新しい合成ペインタを作る
; これもコピペ.実際に(ry
  (define (below painter1 painter2)
    (let ((split-point (make-vect 0.0 0.5)))
      (let ((paint-bottom
              (transform-painter painter1
                                 (make-vect 0.0 0.0)
                                 (make-vect 1.0 0.0)
                                 split-point))
            (paint-top
              (transform-painter painter2
                                 split-point
                                 (make-vect 1.0 0.5)
                                 (make-vect 0.0 1.0))))
        (lambda (frame)
          (paint-bottom frame)
          (paint-top frame)))))

; ex-2.51
; これも実際に出力できないと厳しいかなぁ...
; ここでやりたい事は理解できた筈なのでパス

SICP 問題 2.42 エイトクイーンパズル

ex-2.42 エイトクイーンパズルが終わりました(2.43もエイトクイーンパズルだけど).

全く何も見ないで解くのは無理だなーと思ったので、答えを見て動かしながら手続きどの様に動作するのか？を理解するに留めました。 まぁこういうのは「知っているか、知らないか」「知っているけど、使いこなせない」「知っていてるし、使いこなせる(応用して実務で使える)」だと思うのでまずは「知れた」から良かったかなと。 (もちろん知らないで自力で解ける人はいるし凄い！僕には無理なだけ)

; ex-2.42
; rest-of-queensは最初のk-1列にk-1個のクイーンを置く方法である
; new-rowはk列目にクイーンの置ける行の案である
; - [x] adjoin-positionは盤上の位置の集合の表現を実装し、位置の集合に新しい場所の座標を連結する手続き
; - [x] empty-boardは場所のから集合を表現する
; - [x] safe?は他のクイーンに対してk番目のクイーンが安全な場所か?(他のクイーンは互いに安全である事が保証されているので新しいクイーンだけ調べれば良い)

; 参考 : https://www.serendip.ws/archives/776

; > (queens 4)
; (((2 . 1) (4 . 2) (1 . 3) (3 . 4)) ((3 . 1) (1 . 2) (4 . 3) (2 . 4)))
(define (queens board-size)
  (define (queen-cols k) ; 板の最初のk列にクイーンを置く全ての方法の並びを返す
    (if (= k 0)
      (list empty-board)
      (filter ; (fleter predicate sequence)
        (lambda (positions) (safe? k positions)) ; predicate
        ; (flatmap (lambda (rest-of-queens) (map (lambda (new-row) (adjoin-position new-row 2 rest-of-queens)) '(1 2 3 4))) '(((1 1))))
        ; (((1行目 2列目) (1行目 1列目)) ...)
        ; (((1 2) (1 1)) ((2 2) (1 1)) ((3 2) (1 1)) ((4 2) (1 1)))
        (flatmap ; sequence
          (lambda (rest-of-queens)
            ;                                    1,2,3,4    k        enumerate-intervalなnew-row(1 2 3 4)
            ; (map (lambda (new-row) (cons (list new-row 1) ())) (list 1 2 3 4))
            ; k = 1
            ;   行 列
            ; (((1 1)) ((2 1)) ((3 1)) ((4 1)))
            ; k = 2
            ; (((1 2)) ((2 2)) ((3 2)) ((4 2)))
            (map (lambda (new-row)
                   (adjoin-position new-row k rest-of-queens))
                 (enumerate-interval 1  board-size))); new-row
          (queen-cols (- k 1)))))) ; rest-of-queens, queen-colsの再帰
  (queen-cols board-size)) ; k

(define empty-board ())

; rowはクイーンを置く行の案. 1,2,3,4
; kは引数board-sizeと-1されていく値. 4,3,2,1
; rest-of-queensは()
; (cons (list 1or2or3or4 1) ())
(define (adjoin-position new-row k rest-of-queens)
  (cons (list new-row k) rest-of-queens))

(define (safe? k positions)
  (print "poisitions " positions)
  ;  行 列
  ; ((1 1))
  ; ((2 1))
  ; ((3 3) (1 2) (3 1))
  ;   kth  : (3 3)
  ;   rest : ((1 2) (3 1))
  (let ((kth (car positions)))
    (define (iter rest)
      (print "kth " kth ", rest: " rest)

      ; conflictsするかnullになるまでiterを回す
      ; nullになった = (3行 3列)と(1 2), (3 3)と(3 1)すべて問題なし
      (cond ((null? rest) #t)
            ((conflicts? (car rest) kth) #f)
            (else (iter (cdr rest)))))
    (iter (cdr positions))))

; a (3 3)
; b (1 2)
; なんでこれでconflicts判定できるのかよくわかってない。
; ここはこういうロジックなんだなーくらいで良いかも。
; 2週目やる時はここもちゃんと理解したいな(別ロジックでも良い)。
(define (conflicts? a b)
  (let (
        ;   (abs (-      3       1))   => 2
        (dx (abs (- (car a) (car b))))
        ;   (abs (-       3        2)) => 1
        (dy (abs (- (cadr a) (cadr b)))))
    (cond ((= dx 0) #t)
          ((= dy 0) #t)
          ((= dx dy) #t)
          (else #f))))

; いつもflatmapの挙動を忘れるのでメモ
(flatmap
  (lambda (rest-of-queens)
    (map (lambda (new-row)
           (cons (list new-row 1) rest-of-queens))
         (list 1 2 3 4)))
  (list 1 2 3))
; (((1 1) . 1) ((2 1) . 1) ((3 1) . 1) ((4 1) . 1)
;  ((1 1) . 2) ((2 1) . 2) ((3 1) . 2) ((4 1) . 2)
;  ((1 1) . 3) ((2 1) . 3) ((3 1) . 3) ((4 1) . 3))

結果

gosh$ (queens 4)
poisitions ((1 1))
kth (1 1), rest: ()
poisitions ((2 1))
kth (2 1), rest: ()
poisitions ((3 1))
kth (3 1), rest: ()
poisitions ((4 1))
kth (4 1), rest: ()
poisitions ((1 2) (1 1))
kth (1 2), rest: ((1 1))
poisitions ((2 2) (1 1))
kth (2 2), rest: ((1 1))
poisitions ((3 2) (1 1))
kth (3 2), rest: ((1 1))
kth (3 2), rest: ()
poisitions ((4 2) (1 1))
kth (4 2), rest: ((1 1))
kth (4 2), rest: ()
poisitions ((1 2) (2 1))
kth (1 2), rest: ((2 1))
poisitions ((2 2) (2 1))
kth (2 2), rest: ((2 1))
poisitions ((3 2) (2 1))
kth (3 2), rest: ((2 1))
poisitions ((4 2) (2 1))
kth (4 2), rest: ((2 1))
kth (4 2), rest: ()
poisitions ((1 2) (3 1))
kth (1 2), rest: ((3 1))
kth (1 2), rest: ()
poisitions ((2 2) (3 1))
kth (2 2), rest: ((3 1))
poisitions ((3 2) (3 1))
kth (3 2), rest: ((3 1))
poisitions ((4 2) (3 1))
kth (4 2), rest: ((3 1))
poisitions ((1 2) (4 1))
kth (1 2), rest: ((4 1))
kth (1 2), rest: ()
poisitions ((2 2) (4 1))
kth (2 2), rest: ((4 1))
kth (2 2), rest: ()
poisitions ((3 2) (4 1))
kth (3 2), rest: ((4 1))
poisitions ((4 2) (4 1))
kth (4 2), rest: ((4 1))
poisitions ((1 3) (3 2) (1 1))
kth (1 3), rest: ((3 2) (1 1))
kth (1 3), rest: ((1 1))
poisitions ((2 3) (3 2) (1 1))
kth (2 3), rest: ((3 2) (1 1))
poisitions ((3 3) (3 2) (1 1))
kth (3 3), rest: ((3 2) (1 1))
poisitions ((4 3) (3 2) (1 1))
kth (4 3), rest: ((3 2) (1 1))
poisitions ((1 3) (4 2) (1 1))
kth (1 3), rest: ((4 2) (1 1))
kth (1 3), rest: ((1 1))
poisitions ((2 3) (4 2) (1 1))
kth (2 3), rest: ((4 2) (1 1))
kth (2 3), rest: ((1 1))
kth (2 3), rest: ()
poisitions ((3 3) (4 2) (1 1))
kth (3 3), rest: ((4 2) (1 1))
poisitions ((4 3) (4 2) (1 1))
kth (4 3), rest: ((4 2) (1 1))
poisitions ((1 3) (4 2) (2 1))
kth (1 3), rest: ((4 2) (2 1))
kth (1 3), rest: ((2 1))
kth (1 3), rest: ()
poisitions ((2 3) (4 2) (2 1))
kth (2 3), rest: ((4 2) (2 1))
kth (2 3), rest: ((2 1))
poisitions ((3 3) (4 2) (2 1))
kth (3 3), rest: ((4 2) (2 1))
poisitions ((4 3) (4 2) (2 1))
kth (4 3), rest: ((4 2) (2 1))
poisitions ((1 3) (1 2) (3 1))
kth (1 3), rest: ((1 2) (3 1))
poisitions ((2 3) (1 2) (3 1))
kth (2 3), rest: ((1 2) (3 1))
poisitions ((3 3) (1 2) (3 1))
kth (3 3), rest: ((1 2) (3 1))
kth (3 3), rest: ((3 1))
poisitions ((4 3) (1 2) (3 1))
kth (4 3), rest: ((1 2) (3 1))
kth (4 3), rest: ((3 1))
kth (4 3), rest: ()
poisitions ((1 3) (1 2) (4 1))
kth (1 3), rest: ((1 2) (4 1))
poisitions ((2 3) (1 2) (4 1))
kth (2 3), rest: ((1 2) (4 1))
poisitions ((3 3) (1 2) (4 1))
kth (3 3), rest: ((1 2) (4 1))
kth (3 3), rest: ((4 1))
kth (3 3), rest: ()
poisitions ((4 3) (1 2) (4 1))
kth (4 3), rest: ((1 2) (4 1))
kth (4 3), rest: ((4 1))
poisitions ((1 3) (2 2) (4 1))
kth (1 3), rest: ((2 2) (4 1))
poisitions ((2 3) (2 2) (4 1))
kth (2 3), rest: ((2 2) (4 1))
poisitions ((3 3) (2 2) (4 1))
kth (3 3), rest: ((2 2) (4 1))
poisitions ((4 3) (2 2) (4 1))
kth (4 3), rest: ((2 2) (4 1))
kth (4 3), rest: ((4 1))
poisitions ((1 4) (2 3) (4 2) (1 1))
kth (1 4), rest: ((2 3) (4 2) (1 1))
poisitions ((2 4) (2 3) (4 2) (1 1))
kth (2 4), rest: ((2 3) (4 2) (1 1))
poisitions ((3 4) (2 3) (4 2) (1 1))
kth (3 4), rest: ((2 3) (4 2) (1 1))
poisitions ((4 4) (2 3) (4 2) (1 1))
kth (4 4), rest: ((2 3) (4 2) (1 1))
kth (4 4), rest: ((4 2) (1 1))
poisitions ((1 4) (1 3) (4 2) (2 1))
kth (1 4), rest: ((1 3) (4 2) (2 1))
poisitions ((2 4) (1 3) (4 2) (2 1))
kth (2 4), rest: ((1 3) (4 2) (2 1))
poisitions ((3 4) (1 3) (4 2) (2 1))
kth (3 4), rest: ((1 3) (4 2) (2 1))
kth (3 4), rest: ((4 2) (2 1))
kth (3 4), rest: ((2 1))
kth (3 4), rest: ()
poisitions ((4 4) (1 3) (4 2) (2 1))
kth (4 4), rest: ((1 3) (4 2) (2 1))
kth (4 4), rest: ((4 2) (2 1))
poisitions ((1 4) (4 3) (1 2) (3 1))
kth (1 4), rest: ((4 3) (1 2) (3 1))
kth (1 4), rest: ((1 2) (3 1))
poisitions ((2 4) (4 3) (1 2) (3 1))
kth (2 4), rest: ((4 3) (1 2) (3 1))
kth (2 4), rest: ((1 2) (3 1))
kth (2 4), rest: ((3 1))
kth (2 4), rest: ()
poisitions ((3 4) (4 3) (1 2) (3 1))
kth (3 4), rest: ((4 3) (1 2) (3 1))
poisitions ((4 4) (4 3) (1 2) (3 1))
kth (4 4), rest: ((4 3) (1 2) (3 1))
poisitions ((1 4) (3 3) (1 2) (4 1))
kth (1 4), rest: ((3 3) (1 2) (4 1))
kth (1 4), rest: ((1 2) (4 1))
poisitions ((2 4) (3 3) (1 2) (4 1))
kth (2 4), rest: ((3 3) (1 2) (4 1))
poisitions ((3 4) (3 3) (1 2) (4 1))
kth (3 4), rest: ((3 3) (1 2) (4 1))
poisitions ((4 4) (3 3) (1 2) (4 1))
kth (4 4), rest: ((3 3) (1 2) (4 1))
(((3 4) (1 3) (4 2) (2 1)) ((2 4) (4 3) (1 2) (3 1)))

何度目かのSICP再履修

何回目だろう？SICPやってます。 今回はなんと続いています(笑)

↓今日はここまで進みました。

19日目(p65->p68/p366(18.56%))

`2.2.3 公認インターフェイスとしての並び`を読んでいます。問題2.33をやりました。

次回は問題2.34からです。

無理せず1日1P,1問を目処に.
継続してやり切る事が目標.#iori_sicp #sicp

— 伊織🐾S式🌊SICP再履修 (@kakkokka) October 9, 2022

Twitterには毎日「やった」とツイートしているけど、ブログのほうではまとめとかを...書くかな？ 書かない気がするけど、まぁたまには報告を...

MacでMozart Programming Systemを実行するために

コンピュータプログラミングの概念・技法・モデル（CTMCP / ガウディ本)がまだ途中までしかやっていなかったなぁと思い、１ページからやろうとMacにMozartを入れたら

Aquamacs Not Found

が出た。 あぁ、そういえば最初にこれ買った当時もこれあったわー。。。と思い、まぁ動かすようにしましたよっと。

出版された年が2007年なのでversion1.4.0を選択。 version2なら問題ないのかも？(未検証)

必要なものをDL

http://mozart.github.io/ から remain available to downloadをクリックして1.4.0のdmgをDLする。 クリックしたらaquamacsがないよ〜って言われるのでaquamacsをDLする。 でもまだ起こられる。

scriptを編集する

/Applications/Mozart.app/Contents/Resources/script

これでaquamacsを探したりしているみたいだが、aquamacsのPATHが間違っている（Aquamacsが多分変わって、それに対応していないと思われる). 上記ファイルの10行目と61行目を以下のように修正

...
if [ ! -e "/Applications/Aquamacs.app" ]; then
...
exec /Applications/Aquamacs.app/Contents/MacOS/Aquamacs --eval '(setq load-path (cons "'$OZHOME'/share/elisp" load-path))' -l oz.elc -f run-oz $2 &

これでMozartを実行出来ます:)

Common LispのTestingFrameworkを2つほど触ってみる

昨日に引き続きCLネタです。

引っ越しの準備で大江戸Ruby会議に行けなくて寂しいので、家で一人でLISPの妖精さんとお話して*1戯れて寂しさを紛らわせています。

で、CLでも当たり前の如くテスト書きたいよねーってことで http://quickdocs.org/ でライブラリを調べて、取り敢えず2つ試して見ました。

当然のごとくVimで書いています。 emacsでLISPとか今どきないわー（煽 *2

CL-TEST-MORE

perlのtest-moreに影響を受けているとのこと。 perlわからんので似てる〜とか言えない。 僕的にはあまり馴染みのない感じでしたけどとてもわかり易かったです。

;;; CL-TEST-MORE
(ql:quickload :cl-test-more)
(in-package :cl-test-more)

(print "ok Function")
(ok (eq 1 1) "description") ; ok
(ok (eq 1 2) "description") ; not ok

(print "is Function")
(is 1 1 "description") ; ok
(is 1 2 "description") ; not ok

(print "isnt Function")
(isnt 1 2 "description") ; ok
(isnt 1 1 "description") ; not ok

(defun fib (n) (if (< n 2) n (+ (fib (- n 2)) (fib (- n 1)))))
(print "TEST Fibonacci Function")
(is (fib 0) 0)
(is (fib 1) 1)
(is (fib 2) 1)
(is (fib 3) 2)
(is (fib 4) 3)
(is (fib 5) 5)
(is (fib 6) 8)

詳しくはこちら

lisp-unit

こっちのほうが僕の好みでした。 個人的に何か開発するときはこっちを使うかな。

;;; LISP-UNIT
(ql:quickload :lisp-unit)
(in-package :lisp-unit)

(define-test fib
   (assert-equal 0 (fib 0))
   (assert-equal 1 (fib 1))
   (assert-equal 1 (fib 2))
   (assert-equal 2 (fib 3))
   (assert-equal 3 (fib 4))
   (assert-equal 5 (fib 5))
   (assert-equal 8 (fib 6)))

(defun fib (n) (if (< n 2) n (+ (fib (- n 2)) (fib (- n 1)))))
(run-tests '(fib))

(define-test my-sqrt
   (dotimes (i 5)
      (assert-equal i (my-sqrt (* i i)))))

(defun my-sqrt (n) (/ n 2)) ; これはテストコケます
(run-tests '(my-sqrt))

(run-tests :all)

詳しくはこちら

*1:ダグラス・ホフスタッターによるとREPL(対話型評価環境)の>や?はLISPの妖精で、REPLを使うことはLISPの妖精との対話である(ダグラス・ホフスタッター頭良すぎてぶっ飛んでる) メタマジック・ゲーム―科学と芸術のジグソーパズル

*2:冗談なのでマサカリ禁止