SICP読書女子会 2.2.3 (#21,22,23,24)

2.2.3 集積

SICP/2.2.3.scm at master · cocodrips/SICP

(display "*********2.2.3**********")
(newline)

;; 標準インタフェース
;; 奇数の葉の二乗の合計を計算
(define (sum-odd-squares tree)
    (cond 
        ((null? tree) 0)
        ((not (pair? tree))　(if (odd? tree) (square tree) 0))
    (else 
        (+ (sum-odd-squares (car tree))
    (sum-odd-squares (cdr tree))))))

;;by @hioさん
; p.40, 1.2.2 木の再帰
(define (fib n)
    (define (iter a b count)
        (if
            (= count 0)
            b
            (iter (+ a b) a (- count 1))))
    (iter 1 0 n))

;; フィボナッチ数のうち、偶数のものをかえすリストを構築する
(define (even-fibs n)
    (define (next k)
        (if (> k n)
            ()
            (let ((f (fib k)))
                (if 
                    (even? f)
                    (cons f (next (+ k 1)))
                    (next (+ k 1))))))
(next 0))
(display (even-fibs 10))
(newline)
;(0 2 8 34)

;; Filter
(define (filter predicate sequence)
    (cond 
        ((null? sequence) ())
        ((predicate (car sequence)) 
            (cons (car sequence)
            (filter predicate (cdr sequence))))
    (else (filter predicate (cdr sequence)))))

(display (filter odd? (list 1 2 3 4 5)))
(newline)

;; 集積　accumulate
(define (accumulate op initial sequence)
    (if 
        (null? sequence)
        initial
        (op (car sequence) (accumulate op initial (cdr sequence)))))

(display (accumulate + 0 (list 1 2 3 4 5)))(newline)
;15
(display (accumulate * 1 (list 1 2 3 4 5)))(newline)
;120
(display (accumulate cons () (list 1 2 3 4 5)))(newline)

;(1 2 3 4 5)

よくわからなくなるのでメモ：

accumulate

(accumulate f(array[i], 今までのaccumulate結果) 初期値 array) 
-> 初期値にmergeされてく

map

(map f(array[i]) array)
-> 配列が返る

2.33

(display "======Ex.2.33======")
(newline)
;練習問題 2.33: 基本的なリスト操作のいくつかを集積として定義
;したものを以下に示す。欠けている式を埋めて、完成させよ。

(define (map p sequence)
    (accumulate (lambda (x y) (cons (p x) y)) () sequence))

(define (double x)
   (* 2 x))
(display (map double (list 1 2 3 4 5))) 
(newline)
;(2 4 6 8 10)

(define (append seq1 seq2)
    (accumulate cons seq1 seq2))
(display (append (list 1 2 3) (list 4 5 8))) 
(newline)
;(4 5 8 1 2 3)
(define (length sequence)
    (accumulate (lambda (_ x) (+ x 1)) 0 sequence))
(display (length (list 1 2 3)) )
(newline)
;3

2.34

(display "======Ex.2.34======")
(newline)

(define (horner-eval x coefficient-sequence)
    (accumulate
        (lambda (this-coeff higher-terms) (+ (* higher-terms x) this-coeff))
        0
        coefficient-sequence))

(display (horner-eval 2 (list 1 3 0 5 0 1)))
;; 79

Ex 2.35

(display "======Ex.2.35======")
(newline)

(define (count-leaves t)
    (accumulate + 0 (map (lambda (x) 1) (enumerate-tree t))))

(define tree (cons (list 1 2) (list 3 4)))
(display (count-leaves tree))
(newline)
; 4

(define tree (cons (list 1 2) (list 3 4 5)))
(display (count-leaves tree))
(newline)
;5

@hioさんの実装｜再帰的に足してく


(define (count-leaves t)
    (accumulate
        +
        0
        (map
            (lambda (x)
                (if
                    (pair? x)
                    (count-leaves x)
                    1))
            t)))

Ex 2.36

(display "======Ex.2.36======")
(newline)

(define (accumulate-n op init seqs)
(if (null? (car seqs))
    nil
    (cons (accumulate op init (map car seqs)) (accumulate-n op init (map cdr seqs)))))


(define s (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12)))
(display (accumulate-n + 0 s))

Ex 2.37

(display "======Ex.2.37======")
(newline)

;(define (map proc items)
;    (if (null? items)
;    nil
;    (cons (proc (car items)) (map proc (cdr items)))))
(define (dot-product v w)
    (accumulate + 0 (_map * v w)))

(define m1 (list (list 1 2 3 4) (list 4 5 6 7)))
(define v1 (list 1 2))
(define v2 (list 10 20))


(display (dot-product v1 v2)) 
(newline)
;50

(define (matrix-*-vector m v)
    (_map (lambda (m_i) (dot-product m_i v)) m)) ;; By @hioさん

(display (matrix-*-vector m1 v2))
(newline)
;(50 140)


(define (transpose mat)
    (accumulate-n cons nil mat))
(display (transpose m1))
(newline)
;((1 4) (2 5) (3 6) (4 7))


;(define (matrix-*-matrix m n)
;(let ((cols (transpose n)))
;(map ⟨??⟩ m)))
;cols???

Ex 2.38

(display "======Ex.2.38======")
(newline)

;練習問題 2.38: accumulate 手続きは、列の最初の要素と、右の
;すべての要素を組み合わせた結果とを組み合わせるため、foldright
;としても知られている。fold-left というものもあり、これ
;は fold-right に似ているが、要素の組み合わせを逆方向に行うと
;いう点が違う。
(define (accumulate op initial sequence)
    (if (null? sequence)
        initial
        (op (car sequence) (accumulate op initial (cdr sequence)))))

(define fold-right accumulate)

(define (fold-left op initial sequence)
    (define (iter result rest)
        (if (null? rest)
            result
        (iter (op result (car rest))
            (cdr rest))))
(iter initial sequence))

(display (fold-right / 1 (list 1 2 3)))     (newline) 
; (/ 1 (/ 2 (/ 3 1)))
; 2 / 3
(display (fold-left / 1 (list 1 2 3)))      (newline)
; (/ (/ (/ 1 2) 2 ) 3)

(display (fold-right list nil (list 1 2 3)))(newline)
;(1 (2 (3 ())))
(display (fold-left list nil (list 1 2 3))) (newline)
;(((() 1) 2) 3)

;; 可換な演算ならright/fold-leftで結果がおなじになる

Ex 2.39

(display "======Ex.2.39======")
(newline)
;練習問題 2.39: 以下の reverse(練習問題 2.18) 手続きの定義を、練
;習問題 2.38の fold-right と fold-left によって完成させよ。
(define (reverse sequence)
    (fold-right (lambda (x y) (append (list x) y)) (list) sequence))

(define l (list 1 3 5))
(display (reverse l))
(newline)
;(5 3 1)

(define (reverse sequence)
    (fold-left (lambda (x y) (cons y x)) nil sequence))
(display (reverse l))
(newline)
;(5 3 1)

マップのネスト

;; マップのネスト
(define (enumerate-interval low high)
    (if 
        (> low high)
        nil
    (cons low (enumerate-interval (+ low 1) high))))
(display (enumerate-interval 2 7))
(newline)


(define n 3)
(display (accumulate
    append nil (map (lambda (i)
        (map (lambda (j) (list i j))
            (enumerate-interval 1 (- i 1))))
        (enumerate-interval 1 n))))
(newline)
;((3 1) (3 2) (2 1))
(load "../1.2/smallest-divisor.scm")
(define (prime-sum? pair)
    (prime? (+ (car pair) (cadr pair))))

(define (flatmap proc seq)
    (accumulate append nil (map proc seq)))
;; [proc(seq[0]), proc(seq[1]) .....] みたいなのが出来る？
    
(define (make-pair-sum pair)
    (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))

(define (prime-sum-pairs n)
    (map make-pair-sum
        (filter prime-sum? (flatmap
            (lambda (i)
            (map (lambda (j) (list i j))
            (enumerate-interval 1 (- i 1))))
        (enumerate-interval 1 n)))))

(display (prime-sum-pairs 3))
(newline)
;((3 2 5) (2 1 3))

Ex 2.40

(display "======Ex.2.40======")
(newline)
;整数 n に対し、1 ≤ j < i ≤ n となるペア (i, j) の
;列を生成する手続き unique-pairs を定義せよ。unique-pairs を
;使って上の prime-sum-pairs の定義を簡単にせよ。

;; 自分の
(define (unique-pairs n)
    (define (itr base i stack)
        ;(print base ":" i "\n")
        (cond 
            ((>= base n) stack)
            ((> i n) (itr (+ base 1) (+ base 2) stack))
            (else (itr base (+ i 1) (cons (list base i) stack)))))
(itr 1 2 nil))

(display (unique-pairs 4))
(newline)
;((3 4) (2 4) (2 3) (1 4) (1 3) (1 2))

;(define (accumulate op initial sequence)
(define (prime-sum-pairs n)
    (accumulate 
        (lambda (i acc) 
            (if (prime? (+ (car i) (car (cdr i))))
                (cons i acc)
            acc))
        nil
    (unique-pairs n)))

(display (prime-sum-pairs 3))
(newline)
;((2 3) (1 2))

;; hioさんの
;(define (unique-pairs n)
;    (flatmap 
;        (lambda (i) 
;                (map (lambda (j) (list i j)) (enumerate-interval 1 (- i 1))))
;        (enumerate-interval 1 n)
;    )
;)
;(display (unique-pairs 4))
;(newline)
;((4 1) (4 2) (4 3) (3 1) (3 2) (2 1))
;2.41が小さい順にならんでいるというのが条件として満たさないと
;正しい挙動をしない実装をしてしまったため、コメントアウト

Ex 2.41

(display "======Ex.2.41======")
(newline)
;ある整数 n 以下の異なる正の整数が大小順に並ん
;だ三つ組 i, j, k の中で、合計がある整数 s となるものすべてを見
;つける手続きを書け。


(define (first p) (car p))
(define (second p) (car (cdr p)))
(define (unique-tri n s)
    (define (add-pattern p stack)
        (define (itr p i stack)
            ;(print p i stack)
            (cond 
                ((> i n) stack)
                ((>= (second p) i) (itr p (+ i 1) stack))
                ((> (second p) n) stack)
                (else 
                    (if 
                        (= (+ (first p) (second p) i) s)
                        (itr p (+ i 1) (cons (list (first p) (second p) i) stack))
                        stack))
            )
        )
        (itr p 1 stack)
    )


    (accumulate
        add-pattern
        nil
        (unique-pairs n))

)
(display "わたしの:")
(display (unique-tri 5 10))(newline)
;わたしの:((1 4 5))
;全ペア((3 4 5) (2 4 5) (2 3 5) (2 3 4) (1 4 5) (1 3 5) (1 3 4) (1 2 5) (1 2 4) (1 2 3))

(display "hioさんの:")
(define (unique-triples n)
    (flatmap
        (lambda (i)
            (flatmap
                (lambda (j)
                    (map
                        (lambda (k)
                            (list i j k))
                        (enumerate-interval 1 (- j 1))))
                (enumerate-interval 1 (- i 1))))
        (enumerate-interval 1 n)))
(display (unique-triples 5))
(newline)
;hioさんの:((5 4 1) (5 4 2) (5 4 3) (5 3 1) (5 3 2) (5 2 1) (4 3 1) (4 3 2) (4 2 1) (3 2 1))
; なるほど、こういうことなのね；； 納得；；

Ex2.42

8Queen

(display "======Ex.2.42======")
(newline)

(define (make-position row col)
   (cons row col))

(define (position-row position)
   (car position))

(define (position-col position)
   (cdr position))

(define empty-board nil)

(define (queens board-size)
    (define (queen-cols col)
        ;(print col)
        (if (= col 0)
            (list empty-board)
            (filter
                (lambda (positions) (safe? col positions))
                (flatmap
                    (lambda (rest-of-queens)
                        (map 
                            (lambda (new-row) (adjoin-position new-row col rest-of-queens)) ;;kだけbitかけたやつをかえすかんじ？
                            (enumerate-interval 1 board-size) ; [1...k]
                        ))
                    (queen-cols (- col 1))))))
(queen-cols board-size))

(define (safe? col positions) 
    (let ((kth-queen (list-ref positions (- col 1)))
     (other-queens (filter (lambda (q)
                             (not (= col (position-col q))))
                           positions)))
    (define (valid-position? p1 p2)
        ;(print "valid-position:" p1 p2)
        (not (or 
            (= (position-row p1) (position-row p2))
            (= (position-col p1) (position-col p2))
            (= 
                (abs (- (position-row p1) (position-col p1)))
                (abs (- (position-row p2) (position-col p2)))))))

    (define (iter queen-position board)
     (or (null? board)
         (and (valid-position? queen-position (car board))
              (iter queen-position (cdr board)))))
   (iter kth-queen other-queens))
)

(define (adjoin-position row col positions)
    (append (list (make-position row col)) positions))

(display (queens 0))
(newline)

(display (queens 4))
(newline)
;(((4 . 1) (1 . 2) (3 . 3) (2 . 4)) ((4 . 1) (2 . 2) (1 . 3) (3 . 4)) ((3 . 1) (2 . 2) (4 . 3) (1 . 4)) ((2 . 1) (4 . 2) (3 . 3) (1 . 4)))

(display (queens 5))
(newline)
;(((3 . 1) (5 . 2) (2 . 3) (4 . 4) (1 . 5)) ((4 . 1) (2 . 2) (5 . 3) (3 . 4) (1 . 5)) ((5 . 1) (3 . 2) (1 . 3) (4 . 4) (2 . 5)) ((5 . 1) (2 . 2) (4 . 3) (1 . 4) (3 . 5)))

http://www.billthelizard.com/2011/06/sicp-242-243-n-queens-problem.htmlを参考にしつつ・・・。

2.42 やりなおし

Schemeで考えると難しいのでとりあえずまずPythonでかいた

class QueenN():
    def __init__(self):
        pass

    def create(self, n):
        boards = [[-1] * n]
        for row in range(n):
            boards = self.add_row(row, n, boards)

        print n, "Pattern:", len(boards)
        for board in boards:
            for col in board:
                for i in xrange(n):
                    if i == col:
                        print "Q",
                    else: 
                        print "_",
                print 
            print 


    def add_row(self, row, n, boards):
        next_boards = []
        for board in boards:
            for col in range(n):
                array = board[:]
                if self.is_safe(board, row, col):
                    array[row] = col
                    next_boards.append(array)

        return next_boards

    def is_safe(self, board, row, col):
        # cols
        if col in board:
            return False

        # x
        for i in range(row):
            if (i - board[i]) == (row - col):
                return False
            if abs(board[i] + i) == (row + col):
                return False
        return True
        
if __name__ == '__main__':
    queen = QueenN()
    for i in range(3, 9):
        queen.create(i)

上をふまえて書き直し

;; 2016/10/19 #24
(newline)
(print "===Ex 2.42 もういっかい===")
(define (queens board-size)
    (define (queen-cols k)
        (if (= k 0)
            (list empty-board)
            (filter
                (lambda (positions) (safe? k positions))    ;; 渡ってきたboardが正しい配置か
                (flatmap                                    ;; 全列挙して、↑を満たすものだけ残す
                    (lambda (rest-of-queens)
                        (map 
                            (lambda (new-row)
                                (adjoin-position
                                    new-row k rest-of-queens))  ;; 新しい列に[1..8]を追加して、みる
                        (enumerate-interval 1 board-size)   ;; [1..8]
                        )) ;; 
                    (queen-cols (- k 1))))))                ;;はじめは()
(queen-cols board-size))

(define empty-board nil)
(define (safe? row positions)
    ;(print "safe?" positions)
    (and
        (not (same-col? row positions))
        (not (slash? row positions))
    )
)

(define (adjoin-position new-row k rest-of-queens) (append (list new-row) rest-of-queens))

; 同じ列にないか
(define (same-col? row positions)
    (accumulate 
        (lambda (i acc) (or acc (= (list-ref positions (- row 1)) (list-ref positions i))))
        #f 
        (enumerate-interval 0 (- row 2))
    ))

(define (test-same-col?)
    (print "--test (same-col? 3 (list 1 3 3)) #t")
    (print (same-col? 3 (list 1 3 3)))
    (print "--test  (same-col? 3 (list 1 3 5)) #f")
    (print (same-col? 3 (list 1 3 5)))
)
(test-same-col?)

;右斜にないか
(define (slash? row positions)
    ;(print (- row 1) "," (list-ref positions (- row 1)))
    (accumulate 
        (lambda 
            (i acc) 
            ;(print i acc)
            ;(print i " " (list-ref positions i) " "
            ;        " " acc " " (+ (- row 1) (list-ref positions (- row 1))) "=" (+ i (list-ref positions i))
            ;        "," (- (- row 1) (list-ref positions (- row 1))) "=" (- i (list-ref positions i)))
            (or
                acc
                (= 
                        (+ (- row 1) (list-ref positions (- row 1))) ;; <- list-ref使うと遅い 順番にindexごと確認してくほうが早い
                        (+ i (list-ref positions i))
                )
                (= 
                        (- (- row 1) (list-ref positions (- row 1)))
                        (- i (list-ref positions i))
                )
            )
        )
    #f
    (enumerate-interval 0 (- row 2)))
)

(define (test-slash?)
    (print "--test (slash? 3 (list 3 2 1)) #t")
    (print (slash? 3 (list 3 2 1)))
    (print "--test (slash? 3 (list 5 3 1)) #f")
    (print (slash? 3 (list 5 3 1)))
    (print "--test (slash? 2 (list 1 2)) #t")
    (print (slash? 2 (list 1 2)))
    (print "--test (slash? 2 (list 1 3)) #f")
    (print (slash? 2 (list 1 3)))
    (print "--test (slash? 3 (list 2 4 3)) #t")
    (print (slash? 3 (list 2 4 3))) 
)
(test-slash?)

;--test (same-col? 3 (list 1 3 3)) #t
;#t
;--test  (same-col? 3 (list 1 3 5)) #f
;#f
;--test (slash? 3 (list 3 2 1)) #t
;#t
;--test (slash? 3 (list 5 3 1)) #f
;#f
;--test (slash? 2 (list 1 2)) #t
;#t
;--test (slash? 2 (list 1 3)) #f
;#f
;--test (slash? 3 (list 2 4 3)) #t
;#t

(define (test-nqueen?)
    (print "1-queens: " (length (queens 1)))
    (print "4-queens: " (length (queens 4)))
    (print "8-queens: " (length (queens 8)))
)
(test-nqueen?)
;1-queens: 1
;4-queens: 2
;8-queens: 92
(time (length (queens 8)))
(time (length (queens 9)))
;(time (length (queens 8)))
; real   0.777
; user   1.030
; sys    0.020
;(time (length (queens 9)))
; real  14.940
; user  21.090
; sys    0.470
;; 遅い原因はlist-ref?

Ex 2.43

新しく追加された行だけでなく、毎回全てのボードの中身をチェックしてるから。