Structure and Interpretation of Computer Programs

Class length: 13 weeks. Start anytime.

Creator: kday

Status: Established

Do every third problem in section 2.2 of SICP, starting with 2.17. Total of 11 problems.

This is a long chapter...

Homework Submissions (2 total):

mizery_guts (Self-grade: Outstanding)
Submitted 4 months ago

;; Exercise 2.29

If we change the representation of mobiles so that the constructor is:

(define (make-mobile left right)(cons left right))

then we only need to change the selector left-branch:

(define (right-branch mobile)(cdr mobile))

;; Exercise 2.32

(1 2 3) ==> (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

The base case is the set containing the empty set. This is described when the if-statement is true.

(subsets nil) ==> (())

For a set containing one element, the base case isn't true, so use the alternative case:

(append (subsets nil) (map f(x) (subsets nil)))

We know (subsets nil) is the set containing the empty set. So we are appending the set containing the empty set and the set containing the element 3. This set containing the element 3 is represented as a list containing the element 3, (3), which is the car of the list (3) cons'd with the empty set:

(cons (car (3)) (())) ==> (3)

Looking at the incomplete line we have for the alternate case, we guess that the procedure f(x) is

(lambda (x) (cons (car s) x))

;; Exercise 2.38

(fold-right / 1 (list 1 2 3)) ; value 3/2

(fold-left / 1 (list 1 2 3)) ; value 1/6

(fold-right list '() (list 1 2 3)) ; Value (1 (2 (3 ())))

(fold-left list '() (list 1 2 3)) ; Value (((() 1) 2) 3)

For fold-left and fold-right to produce the same values the operator must be commutative. That is, (op A B) = (op B A).

;; Exercise 2-17

(define (last-pair items)
  (define (iter items result)
    (if (null? items)
	result
	(iter (cdr items) items)))
  (iter items items))

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

;; Exercise 2-20

(define (same-parity f . n)
  (define parity? (if (even? f) even? odd?))
  (define (try-it n)
    (if (null? n)
	n
	(if (parity? (car n))
	    (cons (car n) (try-it (cdr n)))
	    (try-it (cdr n)))))
  (cons f (try-it n)))


(same-parity 1 2 3 4 5 6 7)


;; Exercise 2.23

(for-each (lambda (x) (newline) (display x))
	  (list 57 321 88))

(define (for-each proc items)
  (cond ((not (null? items))
	 (proc (car items))
	 (for-each proc (cdr items)))))


;; Exercise 2.26

(define x (list 1 2 3))
(define y (list 4 5 6))

(append x y) ; (1 2 3 4 5 6)
(cons x y) ; ((1 2 3) 4 5 6)
(list x y) ; ((l 2 3) (4 5 6))


;; Exercise 2.29

(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)(cadr mobile))

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

(define (branch-structure branch)(cadr branch))

(define (weight-mobile m)
  (if (not (pair? m))
      m
      (+ (weight-mobile (branch-structure (left-branch m)))
	 (weight-mobile (branch-structure (right-branch m))))))

(define (balanced-mobile? m)
  (if (not (pair? m))
      true
      (let ((left-m  (branch-structure (left-branch m))))
	    (right-m (branch-structure (right-branch m))))
	(and (= (* (branch-length (left-branch m)) (weight-mobile left-m))
		(* (branch-length (right-branch m)) (weight-mobile right-m)))
	     (balanced-mobile? left-m)
	     (balanced-mobile? right-m)))))

(define b1 (make-branch 1 7/2))
(define b2 (make-branch 1 7/2))
(define b3 (make-branch 2 3))
(define b4 (make-branch 3 2))
(define b5 (make-branch 5 (make-mobile b1 b2)))
(define b6 (make-branch 7 (make-mobile b3 b4)))
(define m (make-mobile b5 b6))

(weight-mobile m)
(balanced-mobile? m)

;; Exercise 2.35

(define (count-leaves t)
  (accumulate +
	      0
	      (map (lambda (x) 1)
		   (enumerate-tree t))))


;; Exercise 2.41

(define (unique-pairs n)
  (flatmap (lambda (i)
	     (map (lambda (j) (list i j)) (enumerate-interval 1 (- i 1))))
	   (enumerate-interval 1 n)))

(define (unique-triples n)
  (flatmap (lambda (i)
	     (map (lambda (p) (cons i p)) (unique-pairs (- i 1))))
	   (enumerate-interval 1 n)))

(define (unique-triples-less-than-or-equal-to-n-that-sum-to-s n s)
  (filter (lambda (triple) (triple-equals-s? s triple))
	  (unique-triples n)))

(define (triple-equals-s? s triple)
  (= s (+ (car triple) (cadr triple) (caddr triple))))

(unique-triples-less-than-or-equal-to-n-that-sum-to-s 6 12)

;; Exercise 2.44

(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
	(below painter (beside smaller smaller)))))


;; Exercise 2.47

(define (make-frame origin edge1 edge2) (list origin edge1 edge2))

(define (origin-frame frame)(car frame))

(define (edge1-frame frame)(cadr frame))

(define (edge2-frame frame) (caddr frame))

(define (make-frame origin edge1 edge2) (cons origin (cons edge1 edge2)))

(define (origin-frame frame)(car frame))

(define (edge1-frame frame)(cadr frame))

(define (edge2-frame frame)(cddr frame))


;; Exercise 2.50

(define (flip-horiz painter)
  (transform-painter painter
		     (make-vect 1.0 0.0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.0)))

(define (rotate180 painter)
  (transform-painter painter
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 1.0)
                     (make-vect 1.0 0.0)))

(define (rotate270 painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)
                     (make-vect 0.0 0.0)
                     (make-vect 1.0 1.0)))

Permalink

Comments:

mizery_guts
4 months ago

Exercise 2.43, is not on the assignment list, but if someone has attempted it I would like to see some solutions. I am unconvinced of my own answer. And experimenting with how long the procedure takes suggests I'm out by a factor of 1/2.

My argument for 2.43 goes as follows :-

Louis' innermost loop is calling the internal procedure, queen-cols, a total of n times, where n is the board size. (Once for each new row in our new column.) The number of operations is -

n * queens-cols (where n is the board-size)

The procedure queens-cols is recursive, and when queens-cols recurses into the simpler problem it is again called n times. (Once for each row in our simpler "k - 1" problem.)

n * (n * queens-cols)

This will cascade out 'till we reach our base case, multiplying out a total of n - 1 times.

n * n * .. n * empty-board

This means, queens-cols, our internal procedure is called n raised to the power n - 1.

In our good version, we call queens-cols in the outer loop, so the total number of calls to queens-cols is linear

queens-cols + queens-cols + ... + base-case

Our internal procedure is called just n - 1 times.

If T is the time taken for the good version, I guessed that Louis version will take n raised to the power n - 1 times longer. I tested this guess using the procedures queens and queens2, where queens2 is Louis' broken version, and queens is the original procedure, and from my tests , if T is the time taken for the good version, then Louis version takes n raised to the power (n - 1)/2 times longer.

This is a factor of 1/2 out from my guess.

(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 (adjoin-position new-row k rest-of-queens)
  (cons new-row rest-of-queens))

(define empty-board '())

(define (safe? k positions)
  (if (= k 1)
      true
      (let ((new-row (car positions)))
	(define (try-it c rest)
	  (let ((r (car rest)))
	    (if (or (= new-row r) ; same row
		    (= (abs (- k c)) (abs (- new-row r)))) ; same diagonal
		false
		(if (= c 1)
		    true
		    (try-it (- c 1) (cdr rest))))))
	(try-it (- k 1) (cdr positions)))))
   
(queens 4)  ; ((3 1 4 2) (2 4 1 3))

bhrgunatha (Self-grade: Pretty good)
Submitted 2 months ago

As usual I did all the exercises, according to my ability, because it makes following the text much easier. It makes for a much longer homework post though, so, sorry for that.

There is a problem with the SICP language in the latest version of DrScheme, now that it is DrRacket.

It isn't possible to use the paint or paint-hires procedures with painters created by segment->painter. I think it may be due to list creating an immutable list by default.

#lang planet neil/sicp

;; Ex 2.17
;;
(define (last-pair xs)
  (cond ((null? xs) (error "last-pair expects a non-empty list"))
        ((null? (cdr xs)) xs)
        (else (last-pair (cdr xs)))))

(define (last-pair-b xs)
  (cond ((null? xs) (error "last-pair expects a non-empty list"))
        (else (cons (list-ref xs (- (length xs) 1))
                    nil))))


;; Ex 2.18
;;
(define (reverse-ls xs)
  (define (reverse-loop items result)
    (cond ((null? items) result)
          (else (reverse-loop (cdr items) (cons (car items) result)))))
  (reverse-loop xs nil))

;; Ex 2.19
;;
(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 200 100 50 20 10 5 2 1))   

(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 first-denomination car)
(define except-first-denomination cdr) 
(define no-more? null?)

;; Ex 2.20
;;
(define (same-parity head . tail)
  
  (define (parity-filter same-parity? others)
    (cond ((null? others) nil)
          ((same-parity? (car others)) (cons (car others)
                                             (parity-filter same-parity? (cdr others))))
          (else (parity-filter same-parity? (cdr others)))))
  
  (cons head (parity-filter (if (even? head) 
                                even?
                                odd?)
                            tail)))

;; Ex 2.21
;;
(define (square x) (* x x))

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

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

;; Ex 2.22
;;pair?
(define (square-list-louis items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things) 
              (cons (square (car things))
                    answer))))
  (iter items nil))

; The result is built iteratively by appending 
; the square of each item onto the front of the current result list
; but the argument is processed from the beginning in order.
; The result is therefore reversed
(define (square-list-louis-oh-dear items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons answer
                    (square (car things))))))
  (iter items nil))

; This also fails because at each stage a new pair is made from a list and a non-null atom
; - which doesn't produce a valid list structure   


(define (for-each proc items)
  (cond ((null? items) #t)
        (else (proc (car items))
              (for-each proc (cdr items)))))

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

; (list 1 (list 2 (list 3 4)))
; (1 (2 (3 4)))
;
;  --------
; | 1 |   |
;  --------
;       |
;       v
;      -------
;     | 2 |   |
;      -------
;          |
;          v
;         -------      ---------
;        | 3     |-->| 4 | nil |
;         -------      ---------
;
;       1
;      /
;     2
;    / \
;   3   4

;; Ex 2.25
;;
(define a '(1 3 (5 7) 9))
(define b '((7)))
(define c '(1 (2 (3 (4 (5 (6 7))))) ))

(define a7 (car (cdr (car (cdr (cdr a))))))
(define b7 (car (car b)))
(define c7 (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr c)))))))))))))

;; Ex 2.26
;;
(define x (list 1 2 3))
(define y (list 4 5 6))
; (append x y) 
; -> (1 2 3 4 5 6)
; (cons x y)
; -> ((1 2 3) 4 5 6)
; (list x y)
; -> ((1 2 3) (4 5 6))

;; Ex 2.27
;;
(define (deep-reverse xs)
  
  (define (reverse-iter items result)
    (if (null? items) 
        result
        (let ((head (car items)))
          (reverse-iter (cdr items) 
                        (cons (if (pair? head)
                                  (deep-reverse head)
                                  head)
                              result)))))
  (reverse-iter xs nil))

(define (deep-reverse-b tree)
  (if (pair? tree) 
      (reverse (map deep-reverse-b tree))
      tree))

;(define dx (list (list 1 2) (list 3 4)))
;(display dx)
;((1 2) (3 4))
;(display (deep-reverse dx))
;((4 3) (2 1))
;(display (deep-reverse-b dx))
;((4 3) (2 1))

;; Ex 2.28
;;
(define (fringe tree)
  (cond ((null? tree) nil)
        ((pair? tree) (append (fringe (car tree))
                              (fringe (cdr tree))))
        (else (list tree))))

;(display (fringe dx))
;(1 2 3 4)

;; Ex 2.29 a
;;
(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)))

;; Ex 2.29 b
;;
; Is a branch-structure a mobile?
(define (mobile? s) (pair? s))
; ... or a weight?
(define (weight? s) 
  (and (not (mobile? s))
       (number? s)))

(define (mobile-weight mobile)
  (+ (branch-weight (left-branch  mobile)) 
     (branch-weight (right-branch mobile))))

(define (branch-weight branch)
  (let ((structure (branch-structure branch)))
    (if (mobile? structure) 
        (mobile-weight branch)
        structure)))

;; Ex 2.29 c
;;
(define (mobile-balanced? mobile)
  
  (define (branch-torque branch)
    (* (branch-length branch) (branch-weight branch)))
  
  (define (branch-balanced? branch)
    (let ((structure (branch-structure branch)))
      (or (weight? structure)  
          (mobile-balanced? structure))))
  
  (let ((left  (left-branch  mobile))
        (right (right-branch mobile)))
    (and (branch-balanced? left)
         (branch-balanced? right)
         (= (branch-torque (left-branch  mobile))
            (branch-torque (right-branch mobile))))))


(define balanced-r-branch (make-branch 4 100))
(define unbalanced-r-branch (make-branch 4 10))
(define balanced-l-branch (make-branch 8 50))

(define 2-balanced (make-mobile balanced-l-branch balanced-r-branch))
(define 2-unbalanced (make-mobile balanced-l-branch unbalanced-r-branch))


;; Ex 2.29 d
;;
(define (make-mobile-b left right)
  (cons left right))
(define (make-branch-b length structure)
  (cons length structure))

; Using these new constructors and replacing just 2 selectors we can use
; all of the programs unmodified.
; -> new mobile selector
(define (right-branch-b m) (cdr m))

; -> new branch selector
(define (branch-structure-b b) (cdr b))


;; Ex 2.30
;;
(define (scale-tree tree factor)
  (cond ((null? tree) nil)
        ((not (pair? tree)) (* tree factor))
        (else (cons (scale-tree (car tree) factor)
                    (scale-tree (cdr tree) factor)))))

(define (scale-tree-b tree factor)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (scale-tree-b sub-tree factor)
             (* sub-tree factor)))
       tree))

;(display (scale-tree (list 1 (list 2 (list 3 4) 5) (list 6 7))
;            10))
; => (10 (20 (30 40) 50) (60 70))
;(display (scale-tree-b (list 1 (list 2 (list 3 4) 5) (list 6 7))
;            10))
; => (10 (20 (30 40) 50) (60 70))

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


(define (square-tree-b tree)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (square-tree-b sub-tree)
             (square sub-tree)))
       tree))
;(display (square-tree (list 1 (list 2 (list 3 4) 5) (list 6 7))))
; => (1 (4 (9 16) 25) (36 49))
;(display (square-tree-b (list 1 (list 2 (list 3 4) 5) (list 6 7))))
; => (1 (4 (9 16) 25) (36 49))


;; Ex 2.31
;;
(define (leaf? x) (not (pair? x)))

(define (tree-map proc tree)
  (cond ((null? tree) nil)
        ((leaf? tree) (proc tree))
        (else (cons (tree-map proc (car tree))
                    (tree-map proc (cdr tree))))))


(define (tree-map-b proc tree)
  (map (lambda (sub-tree)
         (if (leaf? sub-tree)
             (proc sub-tree) 
             (tree-map-b proc sub-tree)))
       tree))


;; Ex 2.32
;;
(define (subsets s)
  (if (null? s)
      (list nil)
      (let ((rest (subsets (cdr s))))
        (append rest (map (lambda (subset) 
                            (cons (car s) subset)) 
                          rest)))))

;(display (subsets (list 1 2 3)))
; => (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

;; Let L be a list.
; Let H be the first item of list L and T be the remaining items.
; All subsets = LH + LT
; LH = list of all H + LTi - where LTi is a member of LT
; LT = list of all subsets of T

;; Ex 2.33
;;
(define (filter predicate sequence)
  (cond ((null? sequence) nil)
        ((predicate (car sequence))
         (cons (car sequence)
               (filter predicate (cdr sequence))))
        (else (filter predicate (cdr sequence)))))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence) 
          (accumulate op initial (cdr sequence)))))

(define (map-b p sequence)
  (accumulate (lambda (x y) 
                (cons (p x) y)) 
              nil 
              sequence))

(define (append-b seq1 seq2)
  (accumulate cons seq2 seq1))

(define (length-b sequence)
  (accumulate (lambda (a b) 
                (+ b 1)) 
              0 
              sequence))

;; Ex 2.34
;;
(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms) 
                (+ this-coeff (* higher-terms x)))
              0
              coefficient-sequence))


;; Ex 2.35
;;
(define (count-leaves-b t)
  (accumulate +
              0 
              (map (lambda (root)
                     (if (leaf? root)
                         1
                         (count-leaves-b root)))
                   t)))


;; Ex 2.36
;;
(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      nil
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))


;; Ex 2.37
;;
(define (dot-product v w)
  (accumulate + 0 (map * v w)))

(define (matrix-*-vector m v)
  (map (lambda (m-row) 
         (dot-product m-row v)) 
       m))

(define (transpose mat)
  (accumulate-n cons nil mat))

(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (m-vector) 
           (matrix-*-vector cols m-vector)) 
         m)))

;; Ex 2.38
;;
(define fold-right accumulate)

(define (fold-left op initial sequence)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
              (cdr rest))))
  (iter initial sequence))

;
;(fold-right / 1 '(1 2 3))
; => 1 1/2
;(fold-left / 1 '(1 2 3))
; => 1/6
;(display (fold-right list nil '(1 2 3)))
; => (1 (2 (3 ())))
;(display (fold-left list nil '(1 2 3)))
; => (((() 1) 2) 3)
;

;; Ex 2.39
;;
(define (reverse-r sequence)
  (fold-right (lambda (x y) (append y (list x))) 
              nil 
              sequence))

(define (reverse-l sequence)
  (fold-left (lambda (x y) (cons y x)) 
             nil 
             sequence))

;; Ex 2.40
;;
; Helper procedures from the book text
(define (prime? n)
  (define (smallest-divisor n)
    (define (find-divisor n test-divisor)
      (define (divides? a b) (= (remainder b a) 0))
      (cond ((> (square test-divisor) n) n)
            ((divides? test-divisor n) test-divisor)
            (else (find-divisor n (+ test-divisor 1)))))
    (find-divisor n 2))
  (= n (smallest-divisor n)))

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

(define (prime-sum? pair)
  (prime? (+ (car pair) (cadr pair))))

(define (make-pair-sum pair)
  (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i)
                  (map (lambda (j) (list i j))
                       (enumerate-interval 1 (- i 1))))
                (enumerate-interval 1 n)))))


(define (unique-pairs n)
  (flatmap (lambda (i) 
             (map (lambda (j) (list i j))
                  (enumerate-interval 1 (- i 1))))
           (enumerate-interval 1 n)))

(define (prime-sum-pairs-us n)
  (map make-pair-sum
       (filter prime-sum?
               (unique-pairs n))))


;; Ex 2.41
;;
(define (unique-triples n)
  (flatmap (lambda (i) 
             (flatmap (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-of-triple triple)
  (fold-right + 0 triple))

(define (make-triple-sum triple)
  (append triple (list (sum-of-triple triple))))

(define (triple-sum-to-n n sum)
  (map make-triple-sum
       (filter (lambda (triple) 
                 (= (sum-of-triple triple) sum))
               (unique-triples n))))


;; Ex 2.42
;;

(define (queens board-size)
  ; some helper procedures
  (define empty-board nil)
  (define (adjoin-position row positions)
    (cons row positions))
  (define (safe? position)
    
    (define (safe-diagonal? columns)
      
      (define (check-diagonal up down remaining-columns)   
        
        (define (attacked? column up down)
          
          (define (on-board? column) 
            (and (> column 0) 
                 (<= column board-size)))
          
          (or (and (on-board? up)   (= column up))
              (and (on-board? down) (= column down))))
        
        (cond ((null? remaining-columns) #t)
              ((attacked? (car remaining-columns) up down) #f)
              (else (check-diagonal (+ up 1) 
                                    (- down 1)
                                    (cdr remaining-columns)))))
      (let ((k (car columns))) 
        (check-diagonal (+ k 1) (- k 1) (cdr columns))))
    
    (define (safe-horizontal? columns)
      (not (member (car columns) (cdr columns))))
    
    (or (= (length position) 1)  ; the first column is always safe
        (and (safe-horizontal? position) 
             (safe-diagonal?   position))))
  
  ; the main 
  (define (queen-cols k)  
    (if (= k 0)
        (list empty-board)
        (filter
         (lambda (positions) (safe? positions))
         (flatmap
          (lambda (rest-of-queens)
            (map (lambda (new-row)
                   (adjoin-position new-row rest-of-queens))
                 (enumerate-interval 1 board-size)))
          (queen-cols (- k 1))))))
  
  (queen-cols board-size))

(define (present-solutions solutions)
  (define (present-solution rows)
    (define (present columns rows)
      (cond ((null? rows) nil)
            (else (cons (list (car columns) (car rows))
                        (present (cdr columns) (cdr rows))))))
    (present '(a b c d e f g h) rows))
  
  (map present-solution solutions))


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

;queen-cols original is called N+1 times (last call is escape clause N=0)
;adjoin position is called N times so run-time is
;N(N+1) : O(N^2)
;
;Loius' queen-cols:
;For each call to queen-cols there are N calls to queen-cols (N-1)
;QN  : N*(QN-1)
;QN-1: N*(QN-2)
;QN-2: N*(QN-3)
;...
;Q3  : N*(Q2)
;Q2  : N*(Q1)
;Q1  : N
;N^N : O(N^N)
;N^(N-2)T
;


;; Supporting procedures from the book text
;; 
(define (right-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (right-split painter (- n 1))))
        (beside painter (below smaller smaller)))))

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
            (right (right-split painter (- n 1))))
        (let ((top-left (beside up up))
              (bottom-right (below right right))
              (corner (corner-split painter (- n 1))))
          (beside (below painter top-left)
                  (below bottom-right corner))))))

(define (square-limit painter n)
  (let ((quarter (corner-split painter n)))
    (let ((half (beside (flip-horiz quarter) quarter)))
      (below (flip-vert half) half))))




;; Ex 2.44
;; 
(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
        (below painter (beside smaller smaller)))))

;; Ex 2.45
;; 
(define (split compose-large compose-small)
  (lambda (splitter painter n)
    (if (= n 0)
        painter
        (let ((smaller (splitter painter (- n 1))))
          (compose-large painter (compose-small smaller smaller))))))

(define right-split-b (split beside below))
(define up-split-b (split below beside))

;; Ex 2.46
;; 
; The sicp language procedures have different names for vector selectors
(define xcor-vect vector-xcor)
(define ycor-vect vector-ycor)

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1)
                (xcor-vect v2))
             (+ (ycor-vect v1)
                (ycor-vect v2))))

(define (sub-vect v1 v2)
  (make-vect (- (xcor-vect v1)
                (xcor-vect v2))
             (- (ycor-vect v1)
                (ycor-vect v2))))

(define (scale-vect n v)
  (make-vect (* (xcor-vect v) n)
             (* (ycor-vect v) n)))


;; Ex 2.47
;; 
;; version 1 selectors
(define (frame-1-origin frame)
  (car frame))

(define (frame-1-edge-1 frame)
  (car (cdr frame)))

(define (frame-1-edge-2 frame)
  (car (cdr (cdr frame))))

;; version 2 selectors
(define (frame-2-origin frame)
  (car frame))

(define (frame-2-edge-1 frame)
  (car (cdr frame)))

(define (frame-2-edge-2 frame)
  (cdr (cdr frame)))

;; Ex 2.48
;; 
; The sicp language already has make-segment, segment-start and segment-end 
;(define (make-segment v1 v2)
;  (list v1 v2))
;
;(define (start-segment segment)
;  (car segment))
;
;(define (end-segment segment)
;  (car (cdr segment)))


;; Ex 2.49a
;;
(define outline-painter
  (segments->painter (list (make-segment (make-vect 0 0) (make-vect 0 1))
                           (make-segment (make-vect 0 1) (make-vect 1 1))
                           (make-segment (make-vect 1 1) (make-vect 1 0))
                           (make-segment (make-vect 1 0) (make-vect 0 0)))))

;; Ex 2.49b
;;
(define x-painter-segments (list (make-segment (make-vect 0 0) (make-vect 1 1))
                                 (make-segment (make-vect 0 1) (make-vect 1 0))))

(define x-painter (segments->painter x-painter-segments))
;; Ex 2.49c
;;
(define diamond-painter-segments (list (make-segment (make-vect 0 0.5) (make-vect 0.5 1))
                                       (make-segment (make-vect 0.5 1) (make-vect 1 0.5))
                                       (make-segment (make-vect 1 0.5) (make-vect 0.5 0))
                                       (make-segment (make-vect 0.5 0) (make-vect 0 0.5))))
(define diamond-painter (segments->painter diamond-painter-segments))

;; Ex 2.49d
;;
(define wave-painter-segments (list (make-segment (make-vect 0.2 0.0) (make-vect 0.4 0.4))
                                    (make-segment (make-vect 0.4 0.4) (make-vect 0.3 0.5))
                                    (make-segment (make-vect 0.3 0.5) (make-vect 0.1 0.3))
                                    (make-segment (make-vect 0.1 0.3) (make-vect 0.0 0.6))
                                    (make-segment (make-vect 0.0 0.8) (make-vect 0.1 0.5))
                                    (make-segment (make-vect 0.1 0.5) (make-vect 0.3 0.6))
                                    (make-segment (make-vect 0.3 0.6) (make-vect 0.4 0.6))
                                    (make-segment (make-vect 0.4 0.6) (make-vect 0.3 0.8))
                                    (make-segment (make-vect 0.3 0.8) (make-vect 0.4 1.0))
                                    (make-segment (make-vect 0.6 1.0) (make-vect 0.7 0.8))
                                    (make-segment (make-vect 0.7 0.8) (make-vect 0.6 0.6))
                                    (make-segment (make-vect 0.6 0.6) (make-vect 0.8 0.6))
                                    (make-segment (make-vect 0.8 0.6) (make-vect 1.0 0.4))
                                    (make-segment (make-vect 1.0 0.2) (make-vect 0.6 0.4))
                                    (make-segment (make-vect 0.6 0.4) (make-vect 0.8 0.0))
                                    (make-segment (make-vect 0.7 0.0) (make-vect 0.5 0.3))
                                    (make-segment (make-vect 0.5 0.3) (make-vect 0.3 0.0))))
(define wave-painter (segments->painter wave-painter-segments))

;; Ex 2.50
;;
(define (shrink-to-upper-right painter)
  (transform-painter painter
                     (make-vect 0.5 0.5)
                     (make-vect 1.0 0.5)
                     (make-vect 0.5 1.0)))

(define (squash-inwards painter)
  (transform-painter painter
                     (make-vect 0.0 0.0)
                     (make-vect 0.65 0.35)
                     (make-vect 0.35 0.65)))

; again, these are already defined in the sicp language
(define (flip-horiz-b painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)   ; new origin
                     (make-vect 0.0 0.0)   ; new end of edge1
                     (make-vect 1.0 1.0))) ; new end of edge2

(define (rotate180-b painter)
  (transform-painter painter
                     (make-vect 1.0 1.0)   ; new origin
                     (make-vect 0.0 1.0)   ; new end of edge1
                     (make-vect 1.0 0.0))) ; new end of edge2

(define (rotate270-b painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)   ; new origin
                     (make-vect 0.0 0.0)   ; new end of edge1
                     (make-vect 1.0 1.0))) ; new end of edge2

;; Ex 2.51
;;
(define (below-b1 painter1 painter2)
  (let ((split-point (make-vect 0.0 0.5)))
    (let ((paint-down
           (transform-painter painter1
                              (make-vect 0.0 0.0)
                              (make-vect 1.0 0.0)
                              split-point))
          (paint-up
           (transform-painter painter2
                              split-point
                              (make-vect 1.0 0.5)
                              (make-vect 0.0 1.0))))
      (lambda (frame)
        (paint-down frame)
        (paint-up frame)))))

(define (below-b2 painter1 painter2)
  (rotate90 (beside (rotate270 painter1)
                    (rotate270 painter2))))


;; Ex 2.52
;;
(define (split-b2 large small)
  (define (splitter painter n)
    (if (= n 0)
        painter
        (let ((smaller (splitter painter (- n 1))))
          (large painter (small smaller smaller)))))
  splitter)

(define right-split-b2 (split-b2 beside below))
(define up-split-b2 (split-b2 below beside))

(define (corner-split-b2 painter n)
  (if (= n 0)
      painter
      (let ((up (up-split-b2 painter (- n 1)))
            (right (right-split-b2 painter (- n 1))))
        (let ((top-left (beside up up))
              (bottom-right (below right right))
              (corner (corner-split-b2 painter (- n 1))))
          (beside (below painter top-left)
                  (below bottom-right corner))))))

(define (square-limit-b2 painter n)
  (let ((quarter (corner-split-b2 painter n)))
    (let ((half (beside (flip-horiz quarter) quarter)))
      (below (flip-vert half) half))))

(define (square-of-four-b2 tl tr bl br)
  (lambda (painter)
    (let ((top (beside (tl painter) (tr painter)))
          (bottom (beside (bl painter) (br painter))))
      (below bottom top))))

(define (flipped-pairs-b2 painter)
  (let ((combine4 (square-of-four-b2 identity flip-vert
                                  identity flip-vert)))
    (combine4 painter)))

(define (square-limit-b3 painter n)
  (let ((combine4 (square-of-four-b2 flip-horiz identity
                                  rotate180 flip-vert)))
    (combine4 (corner-split-b2 painter n))))

(define smile (list
               (make-segment (make-vect 0.4 0.9) (make-vect 0.45 0.9))
               (make-segment (make-vect 0.6 0.9) (make-vect 0.55 0.9))
               (make-segment (make-vect 0.4 0.8) (make-vect 0.5  0.7))
               (make-segment (make-vect 0.6 0.8) (make-vect 0.5  0.7))))
(define wave-smile-painter (segments->painter 
                            (append wave-painter-segments smile)))

(define (corner-split-b4 painter n)
  (if (= n 0)
      painter
      (let ((up (up-split-b2 painter (- n 1)))
            (right (right-split-b2 painter (- n 1))))
        (let ((top-left up)
              (bottom-right right)
              (corner (corner-split-b2 painter (- n 1))))
          (beside (below painter top-left)
                  (below bottom-right corner))))))

(define (square-limit-b4 painter n)
  (let ((combine4 (square-of-four-b2 flip-vert flip-horiz 
                                  rotate90 rotate270)))
    (combine4 (corner-split-b2 painter n))))

(define (mirror-pairs-b4 painter)
  (let ((combine4 (square-of-four-b2 identity identity
                                  flip-vert  flip-vert)))
    (combine4 painter)))


(define j-body-1
  (list
   (make-segment (make-vect 0.4 0.0)   (make-vect 0.0 0.1))
   (make-segment (make-vect 0.0 0.1)   (make-vect 0.4 0.3))
   (make-segment (make-vect 0.4 0.3)   (make-vect 0.0 0.7))
   (make-segment (make-vect 0.0 0.7)   (make-vect 0.0 0.9))
   (make-segment (make-vect 0.0 0.9)   (make-vect 0.05 0.75))
   (make-segment (make-vect 0.05 0.75) (make-vect 0.1 0.8))
   (make-segment (make-vect 0.1 0.8)   (make-vect 0.2 0.6))
   (make-segment (make-vect 0.2 0.6)   (make-vect 0.35 0.5))
   (make-segment (make-vect 0.35 0.5)  (make-vect 0.25 0.7))
   (make-segment (make-vect 0.25 0.7)  (make-vect 0.4 1.0))
   (make-segment (make-vect 0.4 1.0)   (make-vect 0.55 0.7))
   (make-segment (make-vect 0.55 0.7)  (make-vect 0.45 0.55))
   (make-segment (make-vect 0.45 0.55) (make-vect 0.85 0.9))
   (make-segment (make-vect 0.85 0.9)  (make-vect 0.85 0.95))
   (make-segment (make-vect 0.85 0.95) (make-vect 0.9 1.0))
   (make-segment (make-vect 0.9 1.0)   (make-vect 0.9 0.9))
   (make-segment (make-vect 0.9 0.9)   (make-vect 0.8 0.7))
   (make-segment (make-vect 0.8 0.7)   (make-vect 0.6 0.55))
   (make-segment (make-vect 0.5 0.5)   (make-vect 0.6 0.55))
   (make-segment (make-vect 0.5 0.5)   (make-vect 0.95 0.05))
   (make-segment (make-vect 0.8 0.05)  (make-vect 0.95 0.05))
   (make-segment (make-vect 0.8 0.05)  (make-vect 0.6 0.3))
   (make-segment (make-vect 0.4 0.0)  (make-vect 0.6 0.3))))

(define j-face-1 
  (list
   (make-segment (make-vect 0.35 0.65) (make-vect 0.5 0.7))
   (make-segment (make-vect 0.3 0.8) (make-vect 0.35 0.8))
   (make-segment (make-vect 0.4 0.8) (make-vect 0.45 0.8))))

(define j-painter-1 (segments->painter (append j-body-1 j-face-1)))

(define k-boat-shape
  (list
   (make-segment (make-vect 0.2 0.3) (make-vect 0.1 0.5))
   (make-segment (make-vect 0.2 0.5) (make-vect 0.1 0.5))
   (make-segment (make-vect 0.2 0.5) (make-vect 0.2 0.6))
   (make-segment (make-vect 0.4 0.6) (make-vect 0.2 0.6))
   (make-segment (make-vect 0.4 0.6) (make-vect 0.4 0.8))
   (make-segment (make-vect 0.5 0.8) (make-vect 0.4 0.8))
   (make-segment (make-vect 0.5 0.8) (make-vect 0.5 0.6))
   (make-segment (make-vect 0.7 0.6) (make-vect 0.5 0.6))
   (make-segment (make-vect 0.7 0.6) (make-vect 0.7 0.5))
   (make-segment (make-vect 0.9 0.5) (make-vect 0.7 0.5))
   (make-segment (make-vect 0.9 0.5) (make-vect 0.7 0.3))
   (make-segment (make-vect 0.2 0.3) (make-vect 0.7 0.3))))

(define k-boat-windows
  (list
   (make-segment (make-vect 0.3 0.4) (make-vect 0.3 0.5))
   (make-segment (make-vect 0.4 0.5) (make-vect 0.3 0.5))
   (make-segment (make-vect 0.4 0.5) (make-vect 0.4 0.4))
   (make-segment (make-vect 0.3 0.4) (make-vect 0.4 0.4))
   (make-segment (make-vect 0.5 0.4) (make-vect 0.5 0.5))
   (make-segment (make-vect 0.6 0.5) (make-vect 0.5 0.5))
   (make-segment (make-vect 0.6 0.5) (make-vect 0.6 0.4))
   (make-segment (make-vect 0.5 0.4) (make-vect 0.6 0.4))))

(define k-boat-smoke
  (list
   (make-segment (make-vect 0.45 0.85) (make-vect 0.5 0.9))
   (make-segment (make-vect 0.45 0.9) (make-vect 0.5 0.95))
   (make-segment (make-vect 0.45 0.95) (make-vect 0.5 1.0))))

(define k-boat-painter 
  (segments->painter 
   (append k-boat-shape
           k-boat-windows
           k-boat-smoke)))

(define ai
  (list
   (make-segment (make-vect 0.3 0.7) (make-vect 0.6 0.75))
   (make-segment (make-vect 0.4 0.75) (make-vect 0.4 0.65))
   (make-segment (make-vect 0.5 0.775) (make-vect 0.5 0.675))
   (make-segment (make-vect 0.35 0.6) (make-vect 0.6 0.3))
   (make-segment (make-vect 0.65 0.3) (make-vect 0.6 0.3))
   (make-segment (make-vect 0.55 0.6) (make-vect 0.5 0.5))
   (make-segment (make-vect 0.4 0.4) (make-vect 0.5 0.5))
   (make-segment (make-vect 0.4 0.4) (make-vect 0.2 0.3))))

(define ai-painter (segments->painter ai))

Permalink

Comments:

kday
2 months ago

Wow, nice job doing all of the problems! That's a lot of work.