Scheme 函数式编程：工具箱

老刘1号

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

列表映射

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

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

(sum-of-squares 3 4)COPY

25COPY

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

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

(2 3 4 5 6)COPY

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

(sum-of-cubes 1 2 3)COPY

36COPY

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

(sum-of-cubes 1 2 3)COPY

36COPY

常量过程

(define (values? . ignored)
  #t)COPY

(values? 1)COPY

#tCOPY

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

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

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

"Why?"COPY

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

"Why?"COPY

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

"Why?"COPY

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

"Why?"COPY

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

(len (list 3 2 3 4 7))COPY

5COPY

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

5COPY

过程节选

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

(invoke + 1 2 3)COPY

6COPY

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

(power-of-two 10)COPY

1024.0COPY

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

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

(equal-to? 2)COPY

#<procedure>COPY

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

#fCOPY

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

#tCOPY

耦合器

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

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

(pipe + power-of-two)COPY

#<procedure>COPY

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

256.0COPY

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

256.0COPY

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

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

(transfer-unit 861 19)COPY

(860 20)COPY

(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)))COPY

((dispatch + *) 3 4)COPY

(7 12)COPY

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

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

9COPY

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

#tCOPY

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

#fCOPY

适配器

(define (>initial initial . ignored)
  initial)COPY

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

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

1COPY

(>initial 0 #t '())COPY

0COPY

(transfer-unit 861 19)COPY

(860 20)COPY

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

860COPY

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

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

(20)COPY

(define (identity something) something)COPY

(identity 2333)COPY

2333COPY

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

(>exch 1 2)COPY

(2 1)COPY

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

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

(expt 3 5)COPY

243.0COPY

((converse expt) 3 5)COPY

125.0COPY

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

(~initial (sect2 * 3))COPY

#<procedure>COPY

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

(9 4 5 6)COPY

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

(~next (sect2 * 3))COPY

#<procedure>COPY

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

(3 12 5 6)COPY

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

(~each (sect2 * 3))COPY

#<procedure>COPY

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

(9 12 15 18)COPY

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

(sum-of-squares 3 4 5 6)COPY

86COPY

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

递归管理器

(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)COPY

((dispatch identity sub1) 3)COPY

(3 2)COPY

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

(factorial 5)COPY

120COPY

(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)COPY

(define (wrap . args) args)COPY

(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))))))COPY

(factorial2 3 5)COPY

(6 120)COPY

(factorial2 7 2)COPY

(5040 2)COPY

(factorial2 0 0)COPY

(1 1)COPY

(factorial2 1 0)COPY

(1 1)COPY

(null? '())COPY

#tCOPY

(sum (list 3 4))COPY

7COPY

(length (list 3 4))COPY

2COPY

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

(arithmetic-mean 3 5)COPY

4COPY

(arithmetic-mean 1 2 3)COPY

2COPY

(arithmetic-mean 1 10 100)COPY

37COPY

(arithmetic-mean 1 2 1.5)COPY

1.5COPY

(constant 1)COPY

#<procedure>COPY

((constant 1))COPY

1COPY

((constant 1) 'others)COPY

1COPY

(length (list))COPY

0COPY

(define halve (sect2 div 2))COPY

(halve 20)COPY

10COPY

(halve 5)COPY

2COPY

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

(power-of-two? 2048)COPY

#tCOPY

(power-of-two? 4860)COPY

#fCOPY

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

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

(power-of-two? 2048)COPY

#tCOPY

(power-of-two? 4860)COPY

#fCOPY

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

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

(greatest-odd-divisor 24)COPY

(3)COPY

(define double (sect1 * 2))COPY

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

((32 5))COPY

(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)))COPY

(ceiling-of-log-two 23)COPY

5COPY

(ceiling-of-log-two 32)COPY

5COPY

(ceiling-of-log-two 8)COPY

3COPY

(ceiling-of-log-two 34)COPY

6COPY

(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))COPY

(ceiling-of-log-two 34)COPY

6COPY

辗转相除法

modCOPY

#<procedure>COPY

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

(divisible-by? 60 2)COPY

#tCOPY

(divisible-by? 60 7)COPY

#fCOPY

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

(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))))COPY

(greatest-common-divisor 20 12)COPY

(4)COPY

((dispatch >next mod) 3 4)COPY

(4 3)COPY

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

(20 12)COPY

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

((8 4))COPY

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

(greater-and-lesser 3 4)COPY

(4 3)COPY

(greater-and-lesser 4 3)COPY

(4 3)COPY

(greater-and-lesser 0 0)COPY

(0 0)COPY

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

(greatest-common-divisor 12 20)COPY

4COPY

(greatest-common-divisor 120 270)COPY

30COPY

(greatest-common-divisor 270 120)COPY

30COPY

高阶布尔过程

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

((^not zero?) 3)COPY

#tCOPY

((^not zero?) 0)COPY

#fCOPY

((^not zero?) 0)COPY

#fCOPY

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

((^et number? even?) 3)COPY

#fCOPY

((^et zero? even?) 4)COPY

#fCOPY

((^et zero? even?) 0)COPY

#tCOPY

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

((^vel zero? odd?) 0)COPY

#tCOPY

((^vel zero? odd?) 1)COPY

#tCOPY

((^vel zero? odd?) 2)COPY

#fCOPY

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

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

(disparity 588 920)COPY

332COPY

(disparity 920 588)COPY

332COPY

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

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

(3)COPY

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

(2)COPY