3章「データで決まるプログラムの構造」- 珠玉のプログラミング（Programming Pearls）

珠玉のプログラミングの3章。
日付周りのコードを書いたことがなかったので勉強になった。

3.7.1

税率と境界値を配列に格納すればコンパクトに。

3.7.2

問題が曖昧な気がする。コード参照。

3.7.3

コード参照。

3.7.4

アルゴリズムは以下のサイトを参考にした。大変勉強になった。
http://www.st.rim.or.jp/~phinloda/cqa/cqa15.html

3.7.5

コード参照。

3.7.6

似たようなものを何回も書いたことがあるので省略。

3.7.7

正しいスペルを示す辞書は先頭数文字がおなじものを固めたもの。
韻は分からない。

3.7.8

コード参照。ビット省略。

3.scm

;; Programming Pearls Chapter 2
(import (rnrs)
        (except (mosh) format)
        (srfi :48)
        (match)
        (only (srfi :1) car+cdr)
        (only (srfi :13) string-suffix?)
        (mosh test)
        (mosh file))

;; 3.7.2
(define a
  (match-lambda*
    [(1 a1 cv) a1]
    [(n a1 cv)
     (define (c-ref i) (vector-ref cv (- i 1)))
     (define k (- (vector-length cv) 1))
     (let loop ([i 1]
                [ret 0])
       (cond
        [(= 0 (- n i)) (+ ret (c-ref (+ k 1)))]
        [else
         (loop (+ i 1) (+ ret (* (c-ref i) (a (- n i) a1 cv))))]))]))

 (test-eqv 2 (a 1 2 '#(1 2 3 4)))
 (test-eqv 6 (a 2 2 '#(1 2 3 4)))
 (test-eqv 14 (a 3 2 '#(1 2 3 4)))

;; 3.7.3
(define ch* '#(#f #f #f #f #f #f #f #f #f #f #f
                  #(#t #f #f #f
                    #t #f #f #f
                    #t #f #f #f
                    #t #t #t #t) #f #f #f #f #f #f #f #f #f #f #f #f #f))

(define (draw ch)
  (newline)
  (let ([ch-data (vector-ref ch* (- (char->integer ch) (char->integer #\A)))])
    (let y-loop ([y 0])
      (cond
       [(= y 4) '()]
       [else
      (let x-loop ([x 0])
        (cond
         [(= x 4)
          (newline)
          (y-loop (+ y 1))]
         [else
          (display
           (if (vector-ref ch-data (+ x (* y 4)))
               #\*
               #\space))
          (x-loop (+ x 1))]))]))))

(draw #\L)

;; 3.7.4
(define (ymd->d y m d)
  (define days '#(31 #f 31 30 31 30 31 31 30 31 30 31))
  (let loop ([i 0]
             [ret 0])
    (cond
     [(= (- m 1) i)
      (+ d ret)]
     [(vector-ref days i)
      (loop (+ i 1) (+ ret (vector-ref days i)))]
     [else
      (loop (+ i 1) (+ ret 28
                       (if (zero? (mod y 400))
                           1
                           (if (zero? (mod y 100))
                               0
                               (if (zero? (mod y 4))
                                   1
                                   0))))))]))

(define (date-sub y1 m1 d1 y2 m2 d2)
  (let loop ([y y2]
             [ret 0])
    (cond
     [(= y y1)
      (+ ret (ymd->d y1 m1 d1))]
     [(= y y2)
      (loop (+ y 1) (+ ret (- (ymd->d y 12 31) (ymd->d y m2 d2))))]
     [else
      (loop (+ y 1) (+ ret (ymd->d y 12 31)))])))

(test-eq 731 (date-sub 2010 1 1 2008 1 1))

(define (ymd->day-of-week y m d)
  (define month-plus '#(0 0 3 2 5 0 3 5 1 4 6 2 4))
  (let ([y (if (< m 3) (- y 1) y)])
    (mod (+ y (div y 4) (- (div y 100)) (div y 400) (vector-ref month-plus m) d) 7)))

(define (day-of-week->string day)
  (vector-ref '#("日" "月" "火" "水" "木" "金" "土") day))

(test-equal "金" (day-of-week->string (ymd->day-of-week 2009 8 21)))

(define (calender y m)
  (define days* '#(31 #f 31 30 31 30 31 31 30 31 30 31))
  (define days
    (cond
     [(vector-ref days* (- m 1))
      (vector-ref days* (- m 1))]
     [else
      (+ 28
         (if (zero? (mod y 400))
             1
             (if (zero? (mod y 100))
                 0
                 (if (zero? (mod y 4))
                     1
                     0))))]))
  (do ([i 0 (+ i 1)])
      ((= i 7) (newline))
    (display (day-of-week->string i))
    (display #\space))
  (do ([i 0 (+ i 1)])
      ((= (ymd->day-of-week y m 1) i))
    (display "   "))
  (do ([i 1 (+ i 1)])
      ((> i days) (newline))
    (format #t "~2F " i)
    (when (= 6 (ymd->day-of-week y m i))
        (newline))))

(calender 2009 8)

;; 3.7.5
(define (separate-word word)
  (define rules '(("etic" . "et-ic") ("alistic" . "al-is-tic") ("stic" . "s-tic") ("ptic" . "p-tic") ("lytic" . "-lyt-ic")
                  ("otic" . "ot-ic") ("antic" . "an-tic") ("ntic" . "n-tic") ("ctic" . "c-tic") ("atic" . "at-ic") ("hnic" . "h-nic")
                  ("nic" . "n-ic") ("mic" . "m-ic") ("llic" . "l-lic") ("hlic" . "h-lic") ("lic" . "l-ic") ("hic" . "h-ic") ("fic" . "f-ic")
                  ("dic" . "d-ic") ("hic" . "-hic") ("aic" . "a-ic") ("mac" . "-mac") ("iac" . "i-ac")))
  (define (match text)
    (find (lambda (rule)
            (string-suffix? (car rule) text))
            rules))
  (let-values (([suffix rule] (car+cdr (match word))))
    (string-append (substring word 0 (- (string-length word) (string-length suffix) ))
                   rule)))

(test-equal "eth-nic" (separate-word "ethnic"))
(test-equal "clin-ic" (separate-word "clinic"))

;; 6 省略


;; 3.7.8
(define (show-number n)
  (define numbers '#((#t #f #t #t #t #t #t)   ;; 0
                     (#f #f #f #f #t #f #t)   ;; 1
                     (#t #t #t #f #t #t #f)   ;; 2
                     (#t #t #t #f #t #f #t)   ;; 3
                     (#f #t #f #t #t #f #t)   ;; 4
                     (#t #t #t #t #f #f #t)   ;; 5
                     (#t #t #t #t #f #t #t)   ;; 6
                     (#f #f #t #f #t #f #t)   ;; 7
                     (#t #t #t #t #t #t #t)   ;; 8
                     (#f #t #t #t #t #f #t))) ;; 9
  (define (show n0 n1 n2 n3 n4 n5 n6)
    (when n2
      (display " ======\n"))
    (do ([i 0 (+ i 1)])
        ((= i 4))
      (display (if n3 "=" " "))
      (display "      ")
      (display (if n4 "=" " "))
      (newline))
    (when n1
      (display " ======\n"))
    (do ([i 0 (+ i 1)])
        ((= i 4))
      (display (if n5 "=" " "))
      (display "      ")
      (display (if n6 "=" " "))
      (newline))
    (when n0
      (display " ======\n")))
  (let* ([num-str (number->string n)]
         [digit (string-length num-str)])
    (do ([i 0 (+ i 1)])
        ((= i digit))
      (apply show (vector-ref numbers (- (char->integer (string-ref num-str i)) (char->integer #\0)))))))

(begin
(newline)
(show-number 9876))

(test-results)

珠玉のプログラミング—本質を見抜いたアルゴリズムとデータ構造

posted with amazlet at 09.07.11

ジョン ベントリー
ピアソンエデュケーション
売り上げランキング: 5607

Amazon.co.jp で詳細を見る