Chapter 2 - Building Abstractions With Data [36/97]

; From the text
(define (gcd a b)
  (if [= b 0]
      a
      (gcd b (remainder a b))))

(define (make-rat n d)
  (if (< d 0)
      (make-rat (- n) (- d))
      (cons n d)))

(define (make-point x y) (cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))

(define (make-segment start end) (cons start end))

(define (start-segment s) (car s))
(define (end-segment s) (cdr s))

(define (midpoint-segment s)
  (make-point (/ (+ (x-point (start-segment s)) (x-point (end-segment s))) 2)
              (/ (+ (y-point (start-segment s)) (y-point (end-segment s))) 2)))

(define (print-point p)
  (newline)
  (display "(")
  (display (x-point p))
  (display ", ")
  (display (y-point p))
  (display ")"))

(define (rect w h) ; two corners
  (cons w h))

(define (width r) (car r))
(define (height r) (cdr r))

(define (area r)
  (* (width r) (height r)))

(define (perimeter r)
  (+ (* 2 (width r)) (* 2 (height r))))

(define (make-point x y) (cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))

(define (rect p1 p2))
(define (bottom-left r) (car r))
(define (top-right r) (cdr r))

(define (width r)
  (- (x-point (top-right r)) (x-point (bottom-left r))))

(define (height r)
  (- (y-point (top-right r)) (y-point (bottom-left r))))

; Same definitions
(define (area r)
  (* (width r) (height r)))

(define (perimeter r)
  (+ (* 2 (width r)) (* 2 (height r))))

; From the text
(define (cons x y)
  (lambda (m) (m x y)))

(define (car z)
  (z (lambda (p q) p)))

; Solution
(define (cdr z)
  (z (lambda (p q) q)))

(define (cons a b) (* (expt 2 a) (expt 3 b)))
; TODO

(define zero (lambda (g) (lambda (y) y)))

(define one
  (lambda (f)
    (lambda (x)
      (f (((lambda (g) (lambda (y) y)) f) x)))))

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

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

(define (sub-interval x y)
  (make-interval (- (lower-bound x) (lower-bound y))
                 (- (upper-bound x) (upper-bound y))))

(/ (- (+ (upper-bound a) (upper-bound b))
      (+ (lower-bound a) (lower-bound b)))
   2)

(+ (/ (- (upper-bound a) (lower-bound a))
      2)
   (/ (- (upper-bound b) (lower-bound b))
      2))

(+ (width a) (width b))

(define (make-center-percent center percent) (cons center percent))

(define (center x) (car x))
(define (percent x) (cdr x))

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

(define (reverse items)
  (define (reverse-iter items reversed)
    (if (null? items)
        reversed
        (reverse-iter (cdr items) (cons (car items) reversed))))
  (reverse-iter items '()))

; From the text
(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 (first-denomination coin-values)
  (car coin-values))

(define (except-first-denomination coin-values)
  (cdr coin-values))

(define (same-parity z0 . z)
  (define (same-parity-iter z)
    (cond [(null? z) z]
          [(= (modulo z0 2) (modulo (car z) 2)) (cons (car z) (same-parity-iter (cdr z)))]
          [else (same-parity-iter (cdr z))]))
  (cons z0 (same-parity-iter z)))

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

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

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

; From the text
(define (square-list items)
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons (square (car things))
                    answer))))
  (iter items nil))

; Tests
(square-list (list 1 2 3 4 5))

(square-list '(1 2 3))
(iter '(1 2 3) nil)
(iter (cdr '(1 2 3)) (cons (square (car '(1 2 3))) nil)) -> (iter '(2 3) (cons (square 1) nil)) -> (iter '(2 3) '(1))
(iter (cdr '(2 3)) (cons (square (car '(2 3))) '(1))) -> (iter '(3) (cons (square 2) '(1))) -> (iter '(3) '(4 1))
(iter (cdr '(3)) (cons (square (car '(3))) '(4 1))) -> (iter nil (cons (square 3) '(4 1))) -> (iter nil '(9 4 1))
'(9 4 1)

(define (for-each procedure items)
  (if (null? items)
      nil
      (begin (procedure (car items)) (for-each procedure (cdr items)))))

(list 1 (list 2 (list 3 4)))

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

(car (cdr (car (cdr (cdr a)))))
(car (car b))
(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr c))))))))))))

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

(append x y)
(cons x y)
(list x y)

(define (deep-reverse items)
  (define (reverse-iter items reversed)
    (if (null? items)
        reversed
        (reverse-iter
         (cdr items)
         (cons (if [list? (car items)]
                   (deep-reverse (car items))
                   (car items))
               reversed))))
  (reverse-iter items '()))

(define (fringe tree)
  (cond [(not (pair? tree)) tree]
        [(not (pair? (car tree))) (cons (car tree) (fringe (cdr tree)))]
        [else (append (fringe (car tree)) (fringe (cdr tree)))]))

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

(define (make-branch length structure)
  (list length structure))

; Part A
(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)))

; Part B

(define (total-weight mobile)
  (define (branch-weight branch)
    (cond [(number? (branch-structure branch)) (branch-structure branch)]
          [else (total-weight (branch-structure branch))]))
  (+ (branch-weight (left-branch mobile))
     (branch-weight (right-branch mobile))))

; Part C
(define (torque branch distance)
  (cond [(null? branch)
         nil]
        [(number? (branch-structure branch))
         (* (branch-structure branch) distance)]
        [else
         (let ([left (left-branch (branch-structure branch))]
               [right (right-branch (branch-structure branch))])
           (- (torque left (- distance (branch-length left)))
              (torque right (+ distance (branch-length right)))))]))

(define (mobile-balanced? mobile)
  (= (torque (left-branch mobile) (- (branch-length (left-branch mobile))))
     (torque (right-branch mobile) (branch-length (right-branch mobile)))))

(define (square-tree tree)
  (map (lambda (sub-tree)
         (if [pair? sub-tree]
             (square-tree sub-tree)
             (square sub-tree)))
       tree))

(define (tree-map procedure tree)
  (map (lambda (sub-tree)
         (if [pair? sub-tree]
             (tree-map procedure sub-tree)
             (procedure sub-tree)))
       tree))

(define (square-tree tree) (tree-map square tree))

(define (subsets s)
  (if (null? s)
      (list nil)
      (let ((rest (subsets (cdr s))))
        (append rest (map )))))

; From the text
(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) '() sequence))

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

(define (length sequence)
  (accumulate (lambda (x y) (+ y 1)) 0 sequence))

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

(define (count-leaves t)
  (accumulate +
              0
              (map (lambda (node)
                     (if (pair? node)
                         (count-leaves node)
                         1))
                   t)))

(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      '()
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))

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

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

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

(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (row)
           (map (lambda (col)
                  (dot-product row col))
                cols))
         m)))

(use-modules (srfi srfi-1))
(displayln-all
 (fold-right / 1 (list 1 2 3))
 (fold / 1 (list 1 2 3))
 (fold-right list '() (list 1 2 3))
 (fold list '() (list 1 2 3))
)

(use-modules (srfi srfi-1))

(define (unique-pairs n)
  (fold append
        '()
        (map (lambda (i)
               (map (lambda (j)
                      (list i j))
                    (iota (- i 1) 1)))
             (iota n 1))))

; can't think of a more clever way than to run fold twice :p
(define (unique-triples n)
  (fold append
        '()
        (fold append
              '()
              (map (lambda (i)
                     (map (lambda (j)
                            (map (lambda (k)
                                   (list i j k))
                                 (iota n 1)))
                          (iota n 1)))
                   (iota n 1)))))

(define (exercise-241 n s) ; too tired to come up with a good name
  (filter (lambda (triple) (= s (+ (car triple) (cadr triple) (caddr triple))))
          (unique-triples n)))

(define (make-vect x y) (list x y))

(define (xcor-vect u) (car u))
(define (ycor-vect u) (cadr u))

(define (add-vect u . vectors)
  (if (null? vectors)
      u
      (apply add-vect (make-vect (+ (xcor-vect u) (xcor-vect (car vectors)))
                                 (+ (ycor-vect u) (ycor-vect (car vectors))))
             (cdr vectors))))

(define (scale-vect u s)
  (make-vect (* s (xcor-vect u)) (* s (ycor-vect u))))

(define (sub-vect u . vectors)
  (if (null? vectors)
      u
      (apply sub-vect (add-vect u (scale-vect (car vectors) -1))
             (cdr vectors))))

(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) (car (cdr frame)))
(define (edge2-frame frame) (cdr (cdr frame)))

(define (make-segment start end)
  (list start end))

(define (start-segment segment) (car segment))
(define (end-segment segment) (cadr segment))

(list 'a 'b 'c)
(list (list 'george))
(cdr '((x1 x2) (y1 y2)))
(cadr '((x1 x2) (y1 y2)))
(pair? (car '(a short list)))
(memq 'red '((red shoes) (blue socks)))
(memq 'red '(red shoes blue socks))