sicp-ex-2.29

  
 ;; Binary mobile. 
  
 ;; Given: 
 (define (make-mobile left right) 
   (list left right)) 
 (define (make-branch length structure) 
   (list length structure)) 
  
  
 ;; ---------------------- 
  
 ;; a.  "Primary accessors" ... accessors that know the underlying data 
 ;; structures.  All operations should be defined in terms of these. 
  
 (define (left-branch mobile) 
   (car mobile)) 
 (define (right-branch mobile) 
   (car (cdr mobile))) 
  
 (define (branch-length branch) 
   (car branch)) 
 (define (branch-structure branch) 
   (car (cdr branch))) 
  
 (define (structure-is-mobile? structure) 
   (pair? structure)) 
  
 ;; (Re-run everything from here on after the redefinition in part d.) 
 ;; Tests: 
 (left-branch (make-mobile 2 3)) 
 (right-branch (make-mobile 2 3)) 
 (branch-length (make-branch 4 5)) 
 (branch-structure (make-branch 4 5)) 
  
  
 ;; ---------------------- 
  
 ;; b.  Total mobile weight.  The total weight of a mobile is the sum 
 ;; of the weight of its branches.  The weight of a branch is the 
 ;; weight if the structure is an atom, or the weight of its mobile. 
  
  
 ;; We'll need the branch weight in part c, so pulling it out for 
 ;; re-use. 
 (define (branch-weight branch) 
   (let ((s (branch-structure branch))) 
     (if (structure-is-mobile? s) 
         (total-weight s) 
         s))) 
  
 (define (total-weight mobile) 
   (+ (branch-weight (left-branch mobile)) 
      (branch-weight (right-branch mobile)))) 
  
  
 ;; A test mobile: 
 ;; Level 
 ;; ----- 
 ;; 3                   4  |    8                                      
 ;;              +---------+--------+ 2                        
 ;; 2         3  |  9                                        
 ;;        +-----+----+ 1                                    
 ;; 1    1 | 2                                       
 ;;    +---+---+                             
 ;;    2       1                             
  
 (define level-1-mobile (make-mobile (make-branch 2 1) 
                                     (make-branch 1 2))) 
 (define level-2-mobile (make-mobile (make-branch 3 level-1-mobile) 
                                     (make-branch 9 1))) 
 (define level-3-mobile (make-mobile (make-branch 4 level-2-mobile) 
                                     (make-branch 8 2))) 
  
 (total-weight level-1-mobile) 
 (total-weight level-2-mobile) 
 (total-weight level-3-mobile) 
  
  
 ;; ---------------------- 
  
 ;; c.  Balancing. 
  
 ;; Pulling component functions out of balanced so I can test them out. 
  
 ;; A branch is balanced if its mobile is balanced, or if it's just a 
 ;; simple weight. 
 (define (branch-balanced? branch) 
   (let ((s (branch-structure branch))) 
     (if (structure-is-mobile? s) 
         (balanced? s) 
         true))) 
  
 ;; Test: 
 (branch-balanced? (make-branch 2 3)) 
  
 ;; Can't test branch holding mobile yet, balanced? not created.  We ''could'' stub out the function to always return true or false and ensure that it's getting called (a Test Driven Development technique), but I won't bother here. 
  
 (define (branch-torque branch) 
   (* (branch-weight branch) 
      (branch-length branch))) 
  
 ;; Test: 
 (branch-torque (make-branch 2 3)) 
  
  
 ;; Mobile is balanced if the torques of the branches are equal and any 
 ;; mobiles on branches are also balanced. 
 (define (balanced? mobile) 
  
   (let ((left (left-branch mobile)) 
         (right (right-branch mobile))) 
     (and (= (branch-torque left) 
             (branch-torque right)) 
          (branch-balanced? left) 
          (branch-balanced? right)))) 
  
 ;; Usage: 
 (balanced? (make-mobile (make-branch 2 3) 
                         (make-branch 3 2))) 
  
 ;; Usage: 
 (balanced? level-1-mobile) 
 (balanced? level-2-mobile) 
 (balanced? level-3-mobile) 
  
 (balanced? (make-mobile (make-branch 10 1000) 
                         (make-branch 1 level-3-mobile))) 
  
  
 ;; ---------------------- 
  
 ;; d.  Changing representation forces change to any accessors with 
 ;; knowledge of structure. 
  
 (define (make-mobile left right) 
   (cons left right)) 
 (define (make-branch length structure) 
   (cons length structure)) 
  
 (define (left-branch mobile) 
   (car mobile)) 
 (define (right-branch mobile) 
   (cdr mobile)) 
  
 (define (branch-length branch) 
   (car branch)) 
 (define (branch-structure branch) 
   (cdr branch)) 
  
 (define (structure-is-mobile? structure) 
   (pair? structure)) 
  

 ; balanced? predicate 
  
 (define (balanced? m) 
   (define (total-weight m) 
     (define (branch-weight b) 
       (let ((s (branch-structure b))) 
         (if (mobile? s) 
           (total-weight s) 
           s))) 
     (let* ((l (left-branch m)) 
            (r (right-branch m)) 
            (lw (branch-weight l)) 
            (rw (branch-weight r))) 
       (if (or (< lw 0) (< rw 0)) 
         -1 
         (let ((lt (* (branch-length l) lw)) 
               (rt (* (branch-length r) rw))) 
           (if (= lt rt) 
             (+ lw rw) 
             -1))))) 
   (> (total-weight m) -1)) 

Another form of (balanced? mobile)

  
 (define (balanced? mobile) 
   (define (torque branch) 
 ;find torque on this particular branch 
     (if (is-mobile? (branch-struct branch)) 
         (* (branch-len branch)  
            (total-weight (branch-struct branch))) 
         (* (branch-len branch)  
            (branch-struct branch)))) 
 ;nested AND for each branch pair 
   (and (= (torque (left-branch mobile)) 
           (torque (right-branch mobile))) 
 ;if more branches, repeat balanced? - if a leaf is  
 ;reached, return #t  
        (if (is-mobile? (branch-struct (left-branch mobile))) 
            (balanced? (branch-struct (left-branch mobile))) 
            #t)     
        (if (is-mobile? (branch-struct (right-branch mobile))) 
            (balanced? (branch-struct (right-branch mobile))) 
            #t))) 

My balanced solution.

  
 (define (make-mobile left right) 
   (list left right)) 
  
 (define (make-branch length structure) 
   (list length structure)) 
  
 (define (left-branch mobile) 
   (car mobile)) 
  
 (define (right-branch mobile) 
   (car (cdr mobile))) 
  
 (define (branch-length branch) 
   (car branch)) 
  
 (define (branch-structure branch) 
   (car (cdr branch))) 
  
 (define (left-structure mobile) 
   ((compose branch-structure left-branch) mobile)) 
  
 (define (right-structure mobile) 
   ((compose branch-structure left-branch) mobile)) 
  
 (define mobile? list?) 
  
 (define (struct-eval struct m w) 
   (if (mobile? struct) (m struct) (w struct))) 
    
 (define (branch-weight branch) 
   (define (mobile-structure) (lambda(mobile) (mobile-weight mobile))) 
   (define (weight-structure) (lambda(weight) weight)) 
   (struct-eval (branch-structure branch) (mobile-structure) (weight-structure))) 
                 
 (define (mobile-weight mobile) 
   (+ (branch-weight (left-branch mobile)) 
      (branch-weight (right-branch mobile)))) 
  
 (define (branches-balance? left right) 
   (= (branch-torque left) (branch-torque right))) 
  
 (define (branch-torque branch) 
   (* (branch-length branch) (branch-weight branch))) 
  
 (define (mobile-balanced? mobile) 
   (define (mobile-structure) (lambda(mobile) (mobile-balanced? mobile))) 
   (define (weight-structure) (lambda(weight) #t)) 
    
   (define (try-submobile? struct) 
     (struct-eval struct (mobile-structure) (weight-structure))) 
    
   (and (branches-balance? (left-branch mobile) (right-branch mobile)) 
        ((compose try-submobile? left-structure) mobile)  
        ((compose try-submobile? right-structure) mobile)))