Scheme 函数式编程：工具箱

老刘1号

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

列表映射

(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)
复制代码