the-little-schemer/chapter-08-lambda-the-ultimate.scm

(use-modules (srfi srfi-64))

;; needed for the books code
(define (atom? sth)
  (and (not (pair? sth))
       (not (null? sth))))

;; ====================================
;; Exercises and Solutions of Chapter 8
;; ====================================
(define rember-f
  (λ (test? a lst)
    (cond [(null? lst) '()]
          [(test? a (car lst))
           (rember-f test? a (cdr lst))]
          [else (cons (car lst)
                      (rember-f test?
                                a
                                (cdr lst)))])))

(test-begin "rember-f-test")
(test-group "rember-f-test"
            (test-equal (rember-f eq? 'a '(a b c a d e)) '(b c d e))
            (test-equal (rember-f eq? 'a '(h b c k d e)) '(h b c k d e))
            (test-equal (rember-f eq? 'tuna '(tuna salad is good)) '(salad is good)))
(test-end "rember-f-test")


(define rember-f-2
  (λ (test?)
    (λ (a lst)
      (cond [(null? lst) '()]
            [(test? a (car lst)) ((rember-f-2 test?) a (cdr lst))]
            [else (cons (car lst)
                        ((rember-f-2 test?) a (cdr lst)))]))))

(test-begin "rember-f-2-test")
(test-group "rember-f-2-test"
            (test-equal ((rember-f-2 eq?) 'a '(a b c a d e))
              '(b c d e))
            (test-equal ((rember-f-2 eq?) 'a '(h b c k d e))
              '(h b c k d e))
            (test-equal ((rember-f-2 eq?) 'tuna '(shrimp salad and tuna salad))
              '(shrimp salad and salad)))
(test-end "rember-f-2-test")


(define insertL
  (λ (insertion right lst)
    (cond [(null? lst) '()]
          [(eq? (car lst) right) (cons insertion
                                       (cons right
                                             (insertL insertion right (cdr lst))))]
          [else (cons (car lst)
                      (insertL insertion
                               right
                               (cdr lst)))])))

(test-begin "insertL-test")
(test-group "insertL-test"
            (test-equal (insertL 'ins 'a '(c b a g d e)) '(c b ins a g d e))
            (test-equal (insertL 'ins 'a '(c b g d e)) '(c b g d e)))
(test-end "insertL-test")


(define insertR
  (λ (insertion left lst)
    (cond [(null? lst) '()]
          [(eq? (car lst) left)
           (cons left
                 (cons insertion
                       (insertR insertion left (cdr lst))))]
          [else (cons (car lst)
                      (insertR insertion
                               left
                               (cdr lst)))])))

(test-begin "insertR-test")
(test-group "insertR-test"
            (test-equal (insertR 'ins 'a '(c b a g d e))
              '(c b a ins g d e))
            (test-equal (insertR 'ins 'a '(c b g d e))
              '(c b g d e)))
(test-end "insertR-test")



(define insertL-f
  (λ (test?)
    (λ (insertion right lst)
      (cond [(null? lst) '()]
            [(test? (car lst) right)
             (cons insertion
                   (cons (car lst)
                         ((insertL-f test?)
                          insertion
                          right
                          (cdr lst))))]
            [else
             (cons (car lst)
                   ((insertL-f test?)
                    insertion
                    right
                    (cdr lst)))]))))

(test-begin "insertL-f-test")
(test-group "insertL-f-test"
            (test-equal ((insertL-f eq?) 'ins 'a '(c b a g d e))
              '(c b ins a g d e))
            (test-equal ((insertL-f eq?) 'ins 'a '(c b g d e))
              '(c b g d e))
            (test-equal ((insertL-f (λ (first second)
                                      (not (eq? first second))))
                         'ins
                         'elem-to-find
                         '(c b g d e))
              '(ins c ins b ins g ins d ins e)))
(test-end "insertL-f-test")



(define insertR-f
  (λ (test?)
    (λ (insertion left lst)
      #;(display (simple-format #f "called with: ~a ~a ~a\n" insertion left lst))
      (cond [(null? lst) '()]
            [(test? (car lst) left)
             #;(display (simple-format #f "res: ~a\n"
                                     (cons (car lst)
                                           (cons insertion
                                                 'REST))))
             (cons (car lst)
                   (cons insertion
                         ((insertR-f test?) insertion left (cdr lst))))]
            [else (cons (car lst)
                        ((insertR-f test?) insertion left (cdr lst)))]))))

(test-begin "insertR-f-test")
(test-group "insertR-f-test"
            (test-equal ((insertR-f eq?) 'ins 'a '(c b a g d e))
              '(c b a ins g d e))
            (test-equal ((insertR-f eq?) 'ins 'a '(c b g d e))
              '(c b g d e))
            (test-equal ((insertR-f (λ (first second) (not (eq? first second))))
                         'ins
                         'a
                         '(c b g d e))
              '(c ins b ins g ins d ins e ins)))
(test-end "insertR-f-test")


(define insert-g-attempt
  (λ (test?)
    (λ (insertion elem-to-find lst)
      (cond [(null? lst) '()]
            [(test? (car lst) elem-to-find)
             (cons (car lst)
                   (cons insertion
                         ((insert-g-attempt test?) insertion elem-to-find (cdr lst))))]
            [else (cons insertion
                        (cons (car lst)
                              ((insert-g-attempt test?) insertion elem-to-find (cdr lst))))]))))

(test-begin "insert-g-attempt-test")
(test-group "insert-g-attempt-test"
            (test-equal ((insert-g-attempt eq?) 'ins 'a '(c b a g d e))
              '(ins c ins b a ins ins g ins d ins e))
            (test-equal ((insert-g-attempt eq?) 'ins 'a '(c b g d e))
              '(ins c ins b ins g ins d ins e))
            (test-equal ((insert-g-attempt (λ (first second)
                                      (not (eq? first second))))
                          'ins
                          'a
                          '(c b g d e))
              '(c ins b ins g ins d ins e ins)))
(test-end "insert-g-attempt-test")


(define seqL
  (λ (insertion right lst)
    (cons insertion (cons right lst))))


(test-begin "seqL-test")
(test-group "seqL-test"
            (test-equal (seqL 'a 'b '(c d))
              '(a b c d)))
(test-end "seqL-test")


(define seqR
  (λ (insertion left lst)
    (cons left (cons insertion lst))))


(test-begin "seqR-test")
(test-group "seqR-test"
            (test-equal (seqR 'a 'b '(c d))
              '(b a c d)))
(test-end "seqR-test")


;; Now define insertL and insertR in terms of a modified insert-g, which takes a function as a parameter, which determins how to insert.

(define make-inserter-with-sequencer
  (λ (sequencer)
    (λ (insertion to-find lst)
      (cond [(null? lst) '()]
            [(eq? (car lst) to-find)
             (sequencer insertion
                        to-find
                        ((make-inserter-with-sequencer sequencer)
                         insertion
                         to-find
                         (cdr lst)))]
            [else (cons (car lst)
                        ((make-inserter-with-sequencer sequencer)
                         insertion
                         to-find
                         (cdr lst)))]))))

(test-begin "make-inserter-with-sequencer-test")
(test-group "make-inserter-with-sequencer-test"
            (let ([insertion 'ins]
                  [to-find 'a]
                  [left-inserter (make-inserter-with-sequencer seqL)]
                  [right-inserter (make-inserter-with-sequencer seqR)]
                  [left-inserter-with-lambda
                   (make-inserter-with-sequencer
                    (λ (insertion right lst)
                      (cons insertion (cons right lst))))]
                  [right-inserter-with-lambda
                   (make-inserter-with-sequencer
                    (λ (insertion left lst)
                      (cons left (cons insertion lst))))])
              (test-equal (left-inserter insertion
                                         to-find
                                         '(c d))
                '(c d))
              (test-equal (left-inserter insertion
                                         to-find
                                         '(a c d))
                '(ins a c d))
              (test-equal (left-inserter insertion
                                         to-find
                                         '(a c a d))
                '(ins a c ins a d))
              (test-equal (right-inserter insertion
                                          to-find
                                          '(a c d))
                '(a ins c d))
              (test-equal (right-inserter insertion
                                          to-find
                                          '(a c a d))
                '(a ins c a ins d))
              (test-equal (left-inserter-with-lambda insertion
                                                     to-find
                                                     '(a c d))
                '(ins a c d))
              (test-equal (right-inserter-with-lambda insertion
                                                      to-find
                                                      '(a c d))
                '(a ins c d))
              (test-equal (left-inserter insertion to-find '(c d))
                (right-inserter insertion to-find '(c d)))))
(test-end "make-inserter-with-sequencer-test")


(define substitute
  (make-inserter-with-sequencer
   (λ (insertion to-find lst)
     (cons insertion lst))))

(test-begin "substitute-test")
(test-group "substitute-test"
            (test-equal (substitute 'a 'c '(c d)) '(a d))
            (test-equal (substitute 'sub 'a '(c a a d)) '(c sub sub d)))
(test-end "substitute-test")


(define rember
  (make-inserter-with-sequencer
   (λ (insertion to-find lst) lst)))

(test-begin "rember-test")
(test-group "rember-test"
            (test-equal (rember #f 'c '(c d)) '(d))
            (test-equal (rember #f 'a '(c a a d)) '(c d))
            (test-equal (rember #f 'sausage '(pizza with sausage and bacon)) '(pizza with and bacon)))
(test-end "rember-test")

;; =======================
;; after ninth commandment
;; =======================
;; Write something similar for the `value` function.
;; Here is the value function from chapter 6.
;; It relies on previously defined functions.
(define value
  (λ (nexp)
    (cond [(atom? nexp) nexp]
          [(eq? (operator nexp) '+)
           (plus (value (1st-sub-expr nexp))
                 (value (2nd-sub-expr nexp)))]
          [(eq? (operator nexp) '*)
           (mult (value (1st-sub-expr nexp))
                 (value (2nd-sub-expr nexp)))]
          [else
           (pow (value (1st-sub-expr nexp))
                (value (2nd-sub-expr nexp)))])))

(define (1st-sub-expr aexp)
  (cadr aexp))
(define (2nd-sub-expr aexp)
  (caddr aexp))
(define (operator aexp)
  (car aexp))

(define (plus num1 num2)
  (define (iter res to-add)
    (cond [(or (< res 0) (< to-add 0))
           (throw 'failed-contract "number is negative - we only deal with positive numbers")]
          [(zero? to-add) res]
          [else (iter (addo1 res) (subo1 to-add))]))
  (iter num1 num2))

(define (mult summand times-to-add)
  (define (iter res times-to-add)
    (cond [(or (< res 0) (< times-to-add 0))
           (throw 'failed-contract "number is negative - we only deal with positive numbers")]
          [(zero? times-to-add) res]
          [else (iter (plus res summand)
                      (subo1 times-to-add))]))
  (iter 0 times-to-add))

(define (pow base exponent)
  (cond
   [(zero? exponent) 1]
   [(zero? base) 0]
   [else (mult base
               (pow base (subo1 exponent)))]))

(define (subo1 num)
  (cond [(< num 1)
         (throw 'failed-contract "number is negative - we only deal with positive numbers")]
        [else (- num 1)]))

(define (addo1 num)
  (cond [(< num 0)
         (throw 'failed-contract "number is negative - we only deal with positive numbers")]
        [else (+ num 1)]))


;; Now we define the abstraction to get the repeating code outside of value.
(define atom-to-function
  (λ (a)
    (cond [(eq? a '+) plus]
          [(eq? a '*) mult]
          [else pow])))
;; Rewrite `value` using `atom-to-function` so that it has only 2 cond branches.
(define value-2
  (λ (nexp)
    (cond [(atom? nexp) nexp]
          [else
           ((atom-to-function (operator nexp))
            (value-2 (1st-sub-expr nexp))
            (value-2 (2nd-sub-expr nexp)))])))

;; Rewrite multirember to take the test? function as an argument.
(define (multirember a lat)
  (cond [(null? lat) '()]
        [(eq? a (car lat)) (multirember a (cdr lat))]
        [else (cons (car lat)
                    (rember a (cdr lat)))]))

(define multirember-f
  (λ (test?)
    (λ (a lat)
      (cond [(null? lat) '()]
            [(test? a (car lat))
             ((multirember-f test?) a (cdr lat))]
            [else
             (cons (car lat)
                   ((multirember-f test?) a (cdr lat)))]))))


(define multirember&co
  (λ (a lat col)
    (cond
     [(null? lat)
      (col '() '())]
     [(eq? (car lat) a)
      (multirember&co a
                      (cdr lat)
                      ;; construct a lambda which takes the final 2 arguments
                      ;; delaying evaluation by using a lambda
                      (λ (newlat seen)
                        ;; call previous lambda (named col)
                        ;; Why name it "newlat"?
                        ;; Because it is the list,
                        ;; that would be without the a, which is removed.
                        (col newlat
                             ;; but append the car of lat to the "seen"
                             ;; equal elements
                             (cons (car lat) seen))))]
     [else
      (multirember&co a
                      (cdr lat)
                      (λ (newlat seen)
                        ;; the other way around,
                        ;; consing to the other elements
                        (col (cons (car lat) newlat)
                             seen)))])))

(define a-friend
  (λ (x y)
    (null? y)))


;; The book gives the following repetition of code for easier reading.
(define (multiinsertL elem right lat)
  (cond [(null? lat) '()]
        [(eq? right (car lat))
         (cons elem
               (cons (car lat)
                     (multiinsertL elem
                                   right
                                   (cdr lat))))]
        [else
         (cons (car lat)
               (multiinsertL elem right (cdr lat)))]))

(define (multiinsertR elem left lat)
  (cond [(null? lat) '()]
        [(eq? left (car lat))
         (cons left
               (cons elem
                     (multiinsertR elem
                                   left
                                   (cdr lat))))]
        [else
         (cons (car lat)
               (multiinsertR elem left (cdr lat)))]))

(define (multiinsertLR elem left right lat)
  (cond [(null? lat) '()]
        [(eq? (car lat) right)
         (cons elem
               (cons right
                     (multiinsertLR elem
                                    left
                                    right
                                    (cdr lat))))]
        [(eq? (car lat) left)
         (cons left
               (cons elem
                     (multiinsertLR elem
                                    left
                                    right
                                    (cdr lat))))]
        [else
         (cons (car lat)
               (multiinsertLR elem
                              left
                              right
                              (cdr lat)))]))

;; Write multiinsertLR&co.

;; The final result depends on the given continuation col, for it will
;; be called in the newly made lambdas, that are passed on as new
;; continuations. It will be called as a very last step, when the list
;; is empty. In other cases it merely be "wrapped" in new
;; lambdas. Those new lambdas or new continuation will finally be
;; evaluated when the base case of multiinsertLR&co happens and the
;; then wrapped continuation is called.
(define (multiinsertLR&co inserted left right lat col)
  (cond [(null? lat)
         ;; empty list will be consed to whatever col builds.
         ;; zeros will be added to the counts col already accumulated.
         (col '() 0 0)]
        [(eq? (car lat) right)
         ;; recur
         (multiinsertLR&co inserted
                           left
                           right
                           ;; search rest of list
                           (cdr lat)
                           ;; build new continuation to wrap previous continuation
                           (λ (newlat left-count right-count)
                             ;; call to the previous col, which will
                             ;; be evaluated later, when this lambda
                             ;; is evaluated
                             (col
                              ;; build the new list - do what you would
                              ;; normally do in multiinsertLR for the
                              ;; list of atoms.

                              ;; newlat will be given later, by outer
                              ;; wrapping lambdas and finally by the
                              ;; call to col, which will be the empty
                              ;; list to make a proper list.
                              (cons inserted (cons right newlat))
                              ;; not a left but a right insertedent was found, so left-count stays the same.
                              left-count
                              ;; a right element was found, so right-count is increased by one.
                              (+ right-count 1))))]
        [(eq? (car lat) left)
         ;; recur
         (multiinsertLR&co inserted
                           left
                           right
                           ;; search rest of list
                           (cdr lat)
                           ;; build new continuation to wrap previous continuation
                           (λ (newlat left-count right-count)
                             ;; call to the previous col, which will
                             ;; be evaluated later, when this lambda
                             ;; is evaluated
                             (col
                              ;; build the new list - do what you would
                              ;; normally do in multiinsertLR for the
                              ;; list of atoms.

                              ;; newlat will be given later, by outer
                              ;; wrapping lambdas and finally by the
                              ;; call to col, which will be the empty
                              ;; list to make a proper list.
                              (cons left (cons inserted newlat))
                              ;; a left element was found, so left-count is increased by one.
                              (+ left-count 1)
                              ;; not a right but a left element was found, so right-count stays the same.
                              right-count)))]
        [else
         ;; recur
         (multiinsertLR&co inserted
                           left
                           right
                           ;; search the rest of the list
                           (cdr lat)
                           ;; build new continuation to wrap previous continuation
                           (λ (newlat left-count right-count)
                             ;; call to the previous col, which will
                             ;; be evaluated later, when this lambda
                             ;; is evaluated
                             (col
                              ;; build the new list - do what you would
                              ;; normally do in multiinsertLR for the
                              ;; list of atoms.

                              ;; newlat will be given later, by outer
                              ;; wrapping lambdas and finally by the
                              ;; call to col, which will be the empty
                              ;; list to make a proper list.

                              ;; neither left nor right has been
                              ;; found, so we do not insert anything.
                              (cons (car lat) newlat)
                              ;; a left element was found, so left-count is increased by one.
                              left-count
                              ;; not a right but a left element was found, so right-count stays the same.
                              right-count)))]))

;; TASK: Write evens-only*.
(define even?
  (lambda (num)
    (= (remainder num 2)
       0)))

(define evens-only*
  (lambda (lst)
    (cond [(null? lst) '()]
          [(atom? (car lst))
           (cond [(even? (car lst))
                  (cons (car lst) (evens-only* (cdr lst)))]
                 [else (evens-only* (cdr lst))])]
          [else
           (cons (evens-only* (car lst))
                 (evens-only* (cdr lst)))])))

(test-begin "evens-only-asterisk-test")
(test-group "evens-only-asterisk-test"
            (test-equal
              '(2 4)
              (evens-only* '(1 2 3 4)))
            (test-equal
              '((2) 4)
              (evens-only* '(1 (2 3) 4))))
(test-end "evens-only-asterisk-test")

;; TASK: Write evens-only*&co.
(define evens-only*&co
  (lambda (lst col)
    (cond [(null? lst)
           ;; Finish the list with the empty list and use the neutral elements of multiplication
           ;; (one) and addition (zero).
           (col '() 1 0)]
          [(atom? (car lst))
           (cond [(even? (car lst))
                  ;; In case of an even number we need to multiply it with the product of factors
                  ;; yet to be visited.
                  (evens-only*&co (cdr lst)
                                  (lambda (new-lst factor addend)
                                    (col (cons (car lst) new-lst)
                                         (* (car lst) factor)
                                         addend)))]
                 [else
                  ;; In case of an odd number, we need to add it to the sum of odd numbers in the
                  ;; continuation.
                  (evens-only*&co (cdr lst)
                                  (lambda (new-lst factor addend)
                                    (col new-lst
                                         factor
                                         (+ (car lst) addend))))])]
          [else
           ;; In case car is a list, it is more complicated. The idea is to first calculate the
           ;; result for the car and at the same time build up the continuation for the cdr of the
           ;; list. The continuation however, needs to to apply evens-only*&co to the cdr at some
           ;; point. This is why we call it and only then give an updated continuation to it as an
           ;; argument.
           (evens-only*&co (car lst)
                           ;; Build the continuation for the application to cdr of the list.  The
                           ;; signature must still match though!
                           (lambda (new-lst-from-car factor-from-car addend-from-car)
                             ;; Apply evens-only*&co also to the cdr of the list.
                             (evens-only*&co (cdr lst)
                                             ;; Give it the updated continuation.
                                             (lambda (new-lst-from-cdr factor-from-cdr addend-from-cdr)
                                               ;; The original list consisted of a list in car and a
                                               ;; list in cdr. This means the new list needs to have
                                               ;; the same nesting structure. We cons the new list
                                               ;; produced from the call of evens-only*&co for the
                                               ;; car to the new list produced from the call to
                                               ;; evens-only*&co for the cdr.
                                               ;; Here we rely on the evens-only*&co call for cdr
                                               ;; again giving us the appropriate arguments and take
                                               ;; the other used values from the outer scope, which
                                               ;; is a continuation for the call of evens-only*&co
                                               ;; for the car of the list.
                                               (col (cons new-lst-from-car new-lst-from-cdr)
                                                    ;; Also we need to multiply the factor from the
                                                    ;; car and the factor from cdr.
                                                    (* factor-from-car factor-from-cdr)
                                                    ;; And the addends of car and cdr.X
                                                    (+ addend-from-car addend-from-cdr))))))])))

;; NOTE:

;; This function is an example for building a continuation, which handles the cdr (or tail or right
;; or left part) to do tail call elimination when traversing a tree. Instead of "forking" into two
;; recursive calls, only the call for the car (or head or left or right part) is made and the call
;; for the cdr is put into the newly built continuation instead of being at the "same level".

(test-begin "evens-only-asterisk-and-co")
(test-group "evens-only-asterisk-and-co"
            (test-equal
              '((2 4) 8 4)
              (evens-only*&co '(1 2 3 4)
                              (lambda (new-lst prod sum)
                                (list new-lst prod sum)))))
(test-end "evens-only-asterisk-and-co")