【原创】Scheme 函数式编程：工具箱

《函数程序设计算法》读书笔记。

列表映射

(define square (lambda (x) (* x x)))

(define (sum-of-squares . nums)
  (apply + (map square nums)))

(sum-of-squares 3 4)

25

(define f (lambda (x) (+ x 1)))

(map f (list 1 2 3 4 5))

(2 3 4 5 6)

(define (sum-of-cubes . nums)
  (apply + (map * nums nums nums)))

(sum-of-cubes 1 2 3)

36

(define (sum-of-cubes . nums)
  (apply + (map (lambda (nums)
                  (* nums nums nums))
                nums)))

(sum-of-cubes 1 2 3)

36

常量过程

(define (values? . ignored)
  #t)

(values? 1)

#t

(define (constant v) (lambda ignored v))

(define hey-kid (constant "Why?"))

(hey-kid "Don't put your gum in the electrical outlet.")

"Why?"

(hey-kid "It's gross, and you'll get a shock.")

"Why?"

(hey-kid "The gum is wet. There's an electrical current.")

"Why?"

(hey-kid "Just don't do it. okay?")

"Why?"

(define len (lambda (ls)
  (apply + (map (constant 1) ls))))

(len (list 3 2 3 4 7))

5

(length (list 3 2 3 4 4)) ; built-in

5

过程节选

(define (invoke procedure . args)
  (apply procedure args))

(invoke + 1 2 3)

6

(define power-of-two
  (lambda (power) (expt 2 power)))

(power-of-two 10)

1024.0

(define (curry procedure)
  (lambda (initial)
    (lambda remaining
      (apply procedure
             (append (list initial) remaining)))))

(define equal-to? (curry equal?))

(equal-to? 2)

#<procedure>

((equal-to? 2) (+ 1 3))

#f

((equal-to? 2) (+ 1 1))

#t

耦合器

(define (compose outer inner)
  (lambda args
    (let ((intermediates (apply inner args)))
      (apply outer (list intermediates)))))

(define (pipe earlier later)
  (lambda args
    (let ((intermediates (apply earlier args)))
      (apply later (list intermediates)))))

(pipe + power-of-two)

#<procedure>

((pipe + power-of-two) 3 5)

256.0

((compose power-of-two +) 3 5)

256.0

(define (cross . procedures)
  (lambda args
    (map invoke procedures args)))

(define add1 ((curry +) 1))
(define sub1 ((curry +) -1))
(define transfer-unit (cross sub1 add1))

(transfer-unit 861 19)

(860 20)

(define (sect1 f x)
  (lambda (y)
    (f x y)))
(define (sect2 f y)
  (lambda (x)
    (f x y)))
(define (dispatch . procedures)
  (lambda args
    (map (sect2 apply args) procedures)))

((dispatch + *) 3 4)

(7 12)

(define (unwrap-apply f) (lambda (args) (apply f args)))

((unwrap-apply +) (list 2 3 4))

9

((pipe (dispatch + *) (unwrap-apply <)) 3 4)

#t

((pipe (dispatch + *) (unwrap-apply <)) 1 2)

#f

适配器

(define (>initial initial . ignored)
  initial)

(define (>next initial next . ignored)
  next)

(>initial 1 2 3) ; > means 'keep'

1

(>initial 0 #t '())

0

(transfer-unit 861 19)

(860 20)

((pipe transfer-unit (unwrap-apply >initial)) 861 19)

860

(define (>all-but-initial initial . others) others)

((pipe transfer-unit (unwrap-apply >all-but-initial)) 861 19)

(20)

(define (identity something) something)

(identity 2333)

2333

(define (>exch initial next . others)
  (append (list next initial) others))

(>exch 1 2)

(2 1)

(define (echo . args) (display args))

(define (converse f) (pipe >exch (unwrap-apply f)))

(expt 3 5)

243.0

((converse expt) 3 5)

125.0

(define (~initial procedure)
  (lambda (initial . others)
    (cons (procedure initial) others)))

(~initial (sect2 * 3))

#<procedure>

((~initial (sect2 * 3)) 3 4 5 6)

(9 4 5 6)

(define (~next procedure)
  (lambda (initial next . others)
    (cons initial (cons (procedure next) others))))

(~next (sect2 * 3))

#<procedure>

((~next (sect2 * 3)) 3 4 5 6)

(3 12 5 6)

(define (~each f)
  (lambda args
    (map f args)))

(~each (sect2 * 3))

#<procedure>

((~each (sect2 * 3)) 3 4 5 6)

(9 12 15 18)

(define sum-of-squares (pipe (~each square) (unwrap-apply +)))

(sum-of-squares 3 4 5 6)

86

(define (compare-by pre comparer)
  (pipe (~each pre) (unwrap-apply comparer)))

递归管理器

(define (recur base? terminal simplify integrate)
  (define (recurrer guide)
    (if (base? guide)
        (terminal guide)
        (let* ((res (simplify guide))
               (current (car res))
               (next (cadr res))
               (recursive-results (recurrer next)))
          (apply integrate (list current recursive-results)))))
  recurrer)

((dispatch identity sub1) 3)

(3 2)

(define factorial (recur zero? (constant 1) (dispatch identity sub1) *))

(factorial 5)

120

(define (build base? terminal derive simplify integrate)
  (define (builder . guides)
    (if (apply base? guides)
        (apply terminal guides)
        (let* ((recursive-results
                (apply (pipe simplify (unwrap-apply builder)) guides)))
          (apply integrate (list (apply derive guides) recursive-results)))))
  builder)

(define (wrap . args) args)

(define factorial2
 (build (lambda (a b)
         (and (<= a 1) (<= b 1)))
       (constant (list 1 1))
       wrap
       (lambda (a b) (list (max (sub1 a) 1) (max (sub1 b) 1)))
       (lambda (x y) (list (* (car x) (car y)) (* (cadr x) (cadr y))))))

(factorial2 3 5)

(6 120)

(factorial2 7 2)

(5040 2)

(factorial2 0 0)

(1 1)

(factorial2 1 0)

(1 1)

(null? '())

#t

(sum (list 3 4))

7

(length (list 3 4))

2

(define (wrap . args) args)
(define arithmetic-mean (pipe (pipe wrap (dispatch sum length)) (unwrap-apply /)))

(arithmetic-mean 3 5)

4

(arithmetic-mean 1 2 3)

2

(arithmetic-mean 1 10 100)

37

(arithmetic-mean 1 2 1.5)

1.5

(constant 1)

#<procedure>

((constant 1))

1

((constant 1) 'others)

1

(length (list))

0

(define halve (sect2 div 2))

(halve 20)

10

(halve 5)

2

(define (power-of-two? candidate)
  (or (= candidate 1)
      (and (even? candidate)
           (power-of-two? (halve candidate)))))

(power-of-two? 2048)

#t

(power-of-two? 4860)

#f

(define (check stop? continue? step)
  (define (checker . args)
    (or (apply stop? args)
        (and (apply continue? args)
             (apply (pipe step checker) args))))
  checker)

(define power-of-two? (check (sect2 = 1) even? halve))

(power-of-two? 2048)

#t

(power-of-two? 4860)

#f

(define (iterate stop? step)
  (define (iterator . args)
    (if (apply stop? args)
        args
        (apply (pipe step iterator) args)))
  iterator)

(define greatest-odd-divisor (iterate odd? halve))

(greatest-odd-divisor 24)

(3)

(define double (sect1 * 2))

(((lambda (bound)
  (iterate (unwrap-apply (pipe >initial (sect2 >= bound)))
           (unwrap-apply (cross double add1)))) 23) '(1 0))

((32 5))

(define (ceiling-of-log-two bound)
  ((pipe (iterate (unwrap-apply (pipe >initial (sect2 >= bound)))
           (unwrap-apply (cross double add1)))
         (unwrap-apply (unwrap-apply >next)))
   '(1 0)))

(ceiling-of-log-two 23)

5

(ceiling-of-log-two 32)

5

(ceiling-of-log-two 8)

3

(ceiling-of-log-two 34)

6

(define (ceiling-of-log-two bound)
  (define (doubler most-recent-double count)
    (if (>= most-recent-double bound)
        count
        (doubler (double most-recent-double) (add1 count))))
  (doubler 1 0))

(ceiling-of-log-two 34)

6

辗转相除法

mod

#<procedure>

(define divisible-by? (pipe mod zero?))

(divisible-by? 60 2)

#t

(divisible-by? 60 7)

#f

(define lesser (lambda (x y) (if (< x y) x y)))

(define (greatest-common-divisor left right) ; brute-force
  (let ((divides-both? (lambda (candidate)
                         (and (divisible-by? left candidate)
                              (divisible-by? right candidate)))))
        ((iterate divides-both? sub1) (lesser left right))))

(greatest-common-divisor 20 12)

(4)

((dispatch >next mod) 3 4)

(4 3)

((lambda (arg) ((dispatch >next mod) (car arg) (cadr arg))) '(12 20))

(20 12)

((iterate (unwrap-apply divisible-by?)
           (unwrap-apply (dispatch >next mod)))
           '(20 12))

((8 4))

(define (greater-and-lesser l r)
  (if (< l r)
      (list r l)
      (list l r)))

(greater-and-lesser 3 4)

(4 3)

(greater-and-lesser 4 3)

(4 3)

(greater-and-lesser 0 0)

(0 0)

(define greatest-common-divisor
  (pipe greater-and-lesser
        (pipe  (iterate (unwrap-apply divisible-by?)
           (unwrap-apply (dispatch >next mod)))
                            (unwrap-apply (unwrap-apply >next)))))

(greatest-common-divisor 12 20)

4

(greatest-common-divisor 120 270)

30

(greatest-common-divisor 270 120)

30

高阶布尔过程

(define (^not condition-met?)
  (pipe condition-met? not))

((^not zero?) 3)

#t

((^not zero?) 0)

#f

((^not zero?) 0)

#f

(define (^et left-condition-met? right-condition-met?)
  (lambda args
    (and (apply left-condition-met? args)
         (apply right-condition-met? args))))

((^et number? even?) 3)

#f

((^et zero? even?) 4)

#f

((^et zero? even?) 0)

#t

(define (^vel left-condition-met? right-condition-met?)
  (lambda args
    (or (apply left-condition-met? args)
        (apply right-condition-met? args))))

((^vel zero? odd?) 0)

#t

((^vel zero? odd?) 1)

#t

((^vel zero? odd?) 2)

#f

(define (^if condition-met? consequent alternate)
  (lambda args
    (if (apply condition-met? args)
        (apply consequent args)
        (apply alternate args))))

(define disparity (^if < (converse -) -))

(disparity 588 920)

332

(disparity 920 588)

332

(define (conditionally-combine combine? combiner)
  (lambda (initial . others)
    (if (combine? initial)
        (list (apply combiner (cons initial others)))
        others)))

((conditionally-combine odd? +) 1 2)

(3)

((conditionally-combine odd? +) 2 2)

(2)