[SICP] ch-2习题堆

2.4

用函数的参数作为pair的representation

;2.4
;m是一个双参函数，cons是一个以m为参数的函数
( define ( cons x y )
         ( lambda ( m ) ( m x y ) ))
;给m赋值为返回p的函数
( define ( car z ) 
         ( z ( lambda ( p q ) p ) ))
( define ( cdr z )
         ( z ( lambda ( p q ) q ) ))

! 2.6

Church numerals

;2.6
;church numerals DEF
( define zero ( lambda ( f ) ( lambda ( x ) x ) ) )

( define ( add-1 n )
         ( lambda ( f )( lambda ( x ) ( f ( ( n f ) x ) ))))

;从0开始，每多一个f就+1
( define ( church-to-int ch )
         ( ( ch ( lambda ( n ) ( + n 1 ) ) ) 0 ) )

( define one ( lambda ( f ) ( lambda ( x ) ( f x ) ) ) )

( define two ( lambda ( f ) ( lambda ( x ) ( f ( f x ) ) ) ) )

;a,b: function of zero, one, two...
;b以x为参数经过b次apply f
;a以x经过b次apply后的结果为参数(( b f ) x )，在此基础上再apply f a次
( define ( add a b )
         ( lambda ( f )
                  ( lambda ( x ) ( ( a f ) ( ( b f ) x ) ) ) ) )

;调用
( define ( square x )
         ( * x x ))

; f = square x = 2 
( ( two square ) 2 )

2.1.4 Interval Arithmetic

( define ( add-interval x y )
         ( make-interval ( + ( lower-bound x ) ( lower-bound y ) )
                         ( + ( upper-bound x ) ( upper-bound y ) ) ) )

(define ( make-interval a b) ( cons a b))

(define (upper-bound interval) (max (car interval) (cdr interval))) 
(define (lower-bound interval) (min (car interval) (cdr interval))) 

( define ( div-interval x y )
         ;y区间包含0
         ( if ( >= 0 ( * ( lower-bound y ) ( upper-bound y ) ) )
              ( error "Division error ( interval spans 0 )" y )
              ( mul-interval x 
                             ( make-interval ( / 1. ( upper-bound y ) )
                                             ( / 1/ ( lower-bound y ) )))) )  

( define ( mul-interval x y )

         ( define ( endpoint-sign i )
                         ; + +
                  ( cond ( ( and ( >= ( lower-bound i ) 0 ) ( >= ( upper-bound i ) 0 ) ) 1 )
                         ; - -
                         ( ( and ( < ( lower-bound i ) 0 ) ( < ( upper-bound i ) 0 ) ) -1)
                         ; - +
                         ( else 0 )))

         ( let ( ( es-x ( endpoint-sign x ) )
                 ( es-y ( endpoint-sign y ) )
                 ( x-up ( upper-bound x ) )
                 ( x-lo ( lower-bound x ) )
                 ( y-up ( upper-bound y ) )
                 ( y-lo ( lower-bound y ) ) ) 

              (if (and (= es-x 0) (= es-y 0)) 
          ; Take care of the exceptional condition where we have to test 
          (make-interval (min (* x-lo y-up) (* x-up y-lo)) 
                         (max (* x-lo y-lo) (* x-up y-up))) 

          ; Otherwise, select which value goes in which "slot". I'm not sure 
          ; whether there is an intuitive way to explain *why* these 
          ; selections work. 
          (let ((a1 (if (and (<= es-y 0) (<= (- es-y es-x) 0)) x-up x-lo)) (a2 (if (and (<= es-x 0) (<= (- es-x es-y) 0)) y-up y-lo)) (b1 (if (and (<= es-y 0) (<= (+ es-y es-x) 0)) x-lo x-up)) (b2 (if (and (<= es-x 0) (<= (+ es-x es-y) 0)) y-lo y-up))) 
            (make-interval (* a1 a2) (* b1 b2))))))  

( define ( make-interval-center-percentage c pct )
         ( let ( ( width ( * c ( / pct 100.0 ) ) ) )
               ( make-interval ( - c width ) ( + c width ) )))

( define ( percentage-tolerance i )          
         ( let ( ( center ( / ( + ( upper-bound i ) ( lower-bound i ) ) 2.0 ) )
                 ( width  ( / ( - ( upper-bound i ) ( lower-bound i ) ) 2.0 ) ) )
               ( * ( / width center ) 100 )))

List Operations

;2.17
; procedure last-pair
( define ( last-pair items )
         ( if ( null? ( cdr items ) )
              ( car items ) 
              ( last-pair ( cdr items ) ) ) )

( last-pair ( list 23 72 149 34 ) )

;2.18
; procedure reverse
( define ( reverse items )
         ( if ( null? ( cdr items ) )
              items
              ( append ( reverse ( cdr items ) ) ( list ( car items ) ) ) ) )

(reverse (list 1 4 9 16 25))

;2.19
; 用list重写countchange
( define ( cc amount coin-values )
         ( cond ( ( = amount 0 ) 1 )
                ( ( or ( < amount 0 ) ( no-more? coin-values ) ) 0 ) 
                ( else 
                   ( + ( cc amount ( except-first-denomination coin-values ) )
                       ( cc ( - amount ( first-denomination coin-values ) ) coin-values )))))

( define ( no-more? coin-values )
         ( null? coin-values ) )

( define ( except-first-denomination deno )
         ( cdr deno ))

( define ( first-denomination deno )
         ( car deno ))

(cc 100 (list 50 25 10 5 1)) 

( define ( same-parity fst . rst )
         ( define ( same-parity-iter src dist remain )
                  ( if ( null? src )
                       dist 
                       ( same-parity-iter ( cdr src )
                                          ( if ( = ( remainder ( car src ) 2 ) remain ) ( append dist ( list ( car src ) ) ) dist )
                                          remain )
                       ))
         ( same-parity-iter rst ( list fst ) ( remainder fst 2 ) ) )

mapping over list

( define ( square-list items )
         ( if ( null? items )
              nil 
              ( cons ( square ( car items ) ) ( square-list ( cdr items ) ) )))

( define ( square-list items )
         ( map square items ))

Trees

( define ( count-leaves x )
         ( cond ( ( null? x ) 0 )
                ( ( not ( pair? x ) ) 1 )
                ( else ( + ( count-leaves ( car x ) )
                           ( count-leaves ( cdr x ) ) ) )))

( define x ( list ( list 1 2 ) ( list 3 4 ) ) )

;2.27
;tree reverse
( define ( deep-reverse x )
         ( if ( pair? x )
              ( append ( deep-reverse ( cdr x ) )
                       ( list ( deep-reverse ( car x ) ) ))
              x ))

( deep-reverse x )

;2.28
;list all leaves
( define ( fringe x )
         ( if ( not ( pair? x ) )
              (list x)
              ( append ( fringe ( car x ) ) ( fringe ( cdr x ) ) )))

( fringe ( list x x ) )

;2.29
;mobile == two branches
( define ( make-mobile left right )
         ( list left right ) )

;branch == length + struct ( weight / mobile )
( define ( make-branch length structure )
         ( list length structure ))

;a
( define (left-branch mb )
         ( car mb ))

( define ( right-branch mb )
         ( car (cdr mb ) ))

( define ( branch-length bc )
         ( car bc ))

( define (branch-structure bc )
         (car ( cdr bc )))

;b
;define total-weight
( define ( branch-weight bc )
         ( if ( pair? ( branch-structure bc ) )
              ( total-weight ( branch-structure bc ) )
              ( branch-structure bc )))

( define ( total-weight mb )
         ( + ( branch-weight ( left-branch mb ) )
             ( branch-weight ( right-branch mb) )))

;c
;define balenced
( define (branch-balanced? bc)
         ( if ( pair? ( branch-structure bc ) )
              ( balanced? ( branch-structure bc ) )
              true ))

( define ( branch-torque bc )
         ( * ( branch-weight bc ) ( branch-length bc ) ))

( define ( balanced? mb )
         ( let ( ( lft ( left-branch mb ) ) 
                 ( rht ( right-branch mb ) ) ) 
         ( and ( =  ( branch-torque lft ) ( branch-torque rht ))
               ( branch-balanced? lft )
               ( branch-balanced? rht ))))

(balanced? (make-mobile (make-branch 5 3) 
                         (make-branch 3 2))) 

mapping over trees

;2.30
; define square-tree
( define ( square-tree tre )
         ( cond (( null? tre ) nil )
            ( ( not ( pair? ( car tre ))) ( cons ( square ( car tre ) ) ( square-tree ( cdr tre ) ) ) )
            ( else ( cons ( square-tree ( car tre ) ) 
                       ( square-tree ( cdr tre ) ) ) )))

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

;square tree using map
( define ( sqr-tree-mp tree )
         ( map ( lambda ( sub-tree )
                        ( if ( pair? sub-tree )
                             ( sqr-tree-mp sub-tree )
                             ( square sub-tree ) ) )
               tree ))

;2.31 abstract square to procedure
( define ( tree-map proc tree )
         ( map ( lambda ( sub-tree )
                        ( if ( pair? sub-tree )
                             ( tree-map proc sub-tree ) 
                             ( proc sub-tree ) ) )
               tree ))


(tree-map square
(list 1
(list 2 (list 3 4) 5)
(list 6 7)))

! 2.32

http://community.schemewiki.org/?sicp-ex-2.32

nested map

棋盘的那个一脸懵逼
智商持续下线中

(define x ( list ( list 1 2 3 ) ( list 3 4 5 ) ( list 6 7 8 ) ))

( define ( filter predicate seq )
         ( cond ( ( null? seq ) nil )
                ( ( predicate ( car seq ) )
                  ( cons ( car seq )
                         ( filter predicate ( cdr seq ) )) )
                ( else ( filter predicate ( cdr seq ) ) )) ) 

;( enumerate-interval 2 7 ) == ( 2 3 4 5 6 7 )
( define ( enumerate-interval low high )
         ( if ( > low high )
              nil
              ( cons low ( enumerate-interval ( + low 1 ) high ) ) ))

( define ( accumulate op init seq )
         ( if ( null? seq )
              init
              ( op ( car seq )
                   ( accumulate op init ( cdr seq) ))))

( define ( flatmap proc seq )
         ( accumulate append nil ( map proc seq ) ))

( define ( all-triple n ) 
( flatmap 
  ( lambda ( i )
           ( map ( lambda ( j ) ( map ( lambda ( k ) ( list i j k ) ) ( enumerate-interval 1 ( - j 1 ) ) ) ) 
                 ( enumerate-interval 1 ( - i 1 ) ) ) )
  ( enumerate-interval 1 n ) ) )

( define ( sum-tri n s )
         ( filter 
            ( lambda ( lst ) 
                     ( = ( accumulate + 0 lst ) s ))
            ( flatmap 
                    ( lambda ( i )
                             ( map ( lambda ( j ) ( map ( lambda ( k ) ( list i j k ) ) ( enumerate-interval 1 ( - j 1 ) ) ) ) ( enumerate-interval 1 ( - i 1 ) ) ) )
                    ( enumerate-interval 1 n ) ) ))


;2.42
( define ( queens board-size ) 
         ( define ( queen-cols k )
                  ( if ( = k 0 )
                       ( list empty-board ) 
                       ( filter 
                          ( lambda ( positions ) ( safe? k positions ))
                          ( flatmap ( lambda ( rest-of-queens ) ( map ( lambda ( new-row ) ( adjoin-position new-row k rest-of-queens ) ) ( enumerate-interval 1 board-size ))) ( queen-cols ( - k 1 ) )))))
         ( queen-cols board-size ))

( define empty-board nil )

;in chess: rank == row, file == col
( define ( place-queen rank file )
         ( cons rank file ))

( define ( queen-rank queen )
         ( car queen ))

( define ( queen-file queen )
         ( cdr queen ))

;ADJOIN-POSITION
( define ( adjoin-position rank file board )
         ( cons ( place-queen rank file ) board ))

;找到items里第一个符合pred条件的
( define ( find-first pred items )
         ( cond ( ( null? items ) nil )
                ( ( pred ( car items ) ) ( car items) )
                ( else ( find-first pred ( cdr items ) ) ) ))

( define ( safe? file board )
         ;在棋盘上找到所判断列（file）上的queen
         ( define ( get-queen-by-file file board )
                  ( find-first ( lambda ( queen )
                                        ( = ( queen-file queen ) file ) )
                               board ) )

         ;定义了两个，the-queen和other-queens
         ;the-queen是当前新增的，要判断是否safe的
         ( let* ( ( the-queen
                    ( get-queen-by-file file board ) )

                 ;other-queens 是和q行列不同的
                  ( other-queens
                    ;filter predicate seq 
                    ( filter ( lambda ( q ) ( not ( and ( = ( queen-rank the-queen ) ( queen-rank q ) ) ( = ( queen-file the-queen ) ( queen-file q ) ) ) ) ) board )))

                ;accumulate op init seq
                ;任何other-queens 和q没有相同行（rank）
                ( and ( not ( accumulate ( lambda ( p q ) ;or ( or q ( = ( queen-rank p ) ( queen-rank the-queen ) ) ) ) #f other-queens ) )
                      ( not ( accumulate ( lambda ( p q ) ( or q ( = ( abs ( - ( queen-rank the-queen ) ( queen-rank p ) ) ) ( abs ( - ( queen-file the-queen ) ( queen-file p ) ) ) ) ) ) #f other-queens )))))