sicp-3-3-1-mutable-list-structure

#lang racket
(require racket/mpair)

;; Racket lists are immutable.  To get mutable lists, we'll need the mpair package.

;;;;;;;;;;
;; 3.12 ;;
;;;;;;;;;;

(define (my-mutable-append x y)
  (if (null? x)
    y
    (mcons (mcar x) (my-mutable-append (mcdr x) y))))

(my-mutable-append (mlist 1 2 3) (mlist 4 5 6))
;; (mcons 1 (mcons 2 (mcons 3 (mcons 4 (mcons 5 (mcons 6 '()))))))

(define (my-last-mpair x) ; x cannot be null
  (if (null? (mcdr x))
    x
    (my-last-mpair (mcdr x))))

(my-last-mpair (mlist 1 2 3))
;; (mcons 3 '())

(define (my-append! x y)
  (set-mcdr! (my-last-mpair x) y)
  x)

(my-append! (mlist 1 2 3) (mlist 4 5 6))
;; (mcons 1 (mcons 2 (mcons 3 (mcons 4 (mcons 5 (mcons 6 '()))))))

(define x (mlist 'a 'b))
(define y (mlist 'c 'd))
(define z (my-mutable-append x y))

z
;; (mcons 'a (mcons 'b (mcons 'c (mcons 'd '()))))

(mcdr x)
;; (mcons 'b '())

(define w (my-append! x y))

w
;; (mcons 'a (mcons 'b (mcons 'c (mcons 'd '()))))

(mcdr x) ; my-append! has mutated x
;; (mcons 'b (mcons 'c (mcons 'd '())))

;;;;;;;;;;
;; 3.13 ;;
;;;;;;;;;;

(define (make-cycle x)
  (set-mcdr! (my-last-mpair x) x)
  x)

(define z2 (make-cycle (mlist 'a 'b 'c)))
z2
;; #0=(mcons 'a (mcons 'b (mcons 'c #0#))) ; #0# references the 'graph tag' #0

#|
This expression:

(my-last-mpair z2)

hangs the repl.
|#

;;;;;;;;;;
;; 3.14 ;;
;;;;;;;;;;

(define (mystery x)
  (define (loop x y)
    (if (null? x)
      y
      (let ([temp (mcdr x)])
        (set-mcdr! x y)
        (loop temp x))))
  (loop x '()))

(define v (mlist 'a 'b 'c 'd))
(define w2 (mystery v))

v ; mystery has mutated v
;; (mcons 'a '())

w2 ; mystery reverses a list
;; (mcons 'd (mcons 'c (mcons 'b (mcons 'a '()))))

;;;;;;;;;;
;; 3.15 ;;
;;;;;;;;;;

(define (set-to-wow! x)
  (set-mcar! (mcar x) 'wow)
  x)

(define x2 (mlist 'a 'b))
(define z3 (mcons x2 x2))
(define z4 (mcons (mlist 'a 'b) (mlist 'a 'b)))

x2
;; (mcons 'a (mcons 'b '()))
z3
;; (mcons (mcons 'a (mcons 'b '())) (mcons 'a (mcons 'b '())))
z4
;; (mcons (mcons 'a (mcons 'b '())) (mcons 'a (mcons 'b '())))

(set-to-wow! z3)
;; (mcons (mcons 'wow (mcons 'b '())) (mcons 'wow (mcons 'b '())))
(set-to-wow! z4)
;; (mcons (mcons 'wow (mcons 'b '())) (mcons 'a (mcons 'b '())))

;;;;;;;;;;
;; 3.16 ;;
;;;;;;;;;;

;; Ben's code is wrong because it assumes that all pointers in x will be distinct,
;; and that is not always the case.

(define (count-mpairs x)
  (if (not (mpair? x))
    0
    (+ (count-mpairs (mcar x))
       (count-mpairs (mcdr x))
       1)))

(count-mpairs (mcons 'a (mcons 'b (mcons 'c '()))))
;; 3

(define y2 (mcons 'a '()))
(count-mpairs (mcons (mcons y2 y2) '()))
;; 4

(define z5 (mcons y2 y2))
(count-mpairs (mcons z5 z5))
;; 7

;; And we could hang the repl by creating a cyclical list like above.

;;;;;;;;;;
;; 3.17 ;;
;;;;;;;;;;

(define (new-count-mpairs x)
  (let ([examined-mpairs '()])
    (define (examined? mp)
      (mmember mp examined-mpairs))
    (define (set-examined! mp)
      (set! examined-mpairs (mcons mp examined-mpairs)))
    (define (examine y)
      (cond
        [(not (mpair? y)) 0]
        [(examined? y) (+ (examine (mcar y)) (examine (mcdr y)))]
        [else (set-examined! y)
              (+ 1 (examine (mcar y)) (examine (mcdr y)))]))
    (examine x)))

(new-count-mpairs (mlist 'a 'b 'c))
;; 3

(new-count-mpairs (mcons (mcons y2 y2) '()))
;; 3

(new-count-mpairs (mcons z5 z5))
;; 3

;;;;;;;;;;
;; 3.18 ;;
;;;;;;;;;;

#|
Here's the idea:

Lists form rooted directed graphs, where cons pairs are interior nodes,
non-pair elements are leaves, and the mcar and mcdr pointers are the edges.
The root is the list itself ie the outer-most cons pair.

Since the digraph is rooted, we can define the level of a node as the minimum
distance to the root.

For example, if x is the list (mcons 'a (mcons 'b (mcons 'c '()))), then x is
the root at level 0, 'a and (mlist 'b 'c) are at level 1, 'b and (mlist 'c) are
at level 2, and 'c and '() are at level 3.

To detect a cycle, we'll look for a node with a child node on a higher level,
ie a pair whose mcar or mcdr is on a higher level.
|#

(define (contains-cycle? x)
  (define level-table (make-hash))
  (define (has-level? node) (member node (hash-keys level-table)))
  (define (assign-level node level) (hash-set! level-table node level))
  (define (level node) (hash-ref level-table node))
  (define (examine node current-level)
    ; Return true if any descendant of node is on a higher level.
    (cond [(not (mpair? node)) #f]
          [(has-level? node)
           (or (< (level node) current-level)
               (examine (mcar node) (add1 current-level))
               (examine (mcdr node) (add1 current-level)))]
          [else
            (assign-level node current-level)
            (or (examine (mcar node) (add1 current-level))
                (examine (mcdr node) (add1 current-level)))]))
  (examine x 0))

(contains-cycle? (mlist 'a 'b 'c))
;; #f

(define y3 (mlist 'a))
(contains-cycle? (mcons y3 y3))
;; #f

(contains-cycle? (make-cycle (mlist 'a 'b 'c)))
;; #t

;;;;;;;;;;
;; 3.19 ;;
;;;;;;;;;;

#|
Detect cycles in lists using a constant space algorithm.

I never would have thought of this.  The answer is Floyd's cycle detection
algorithm, also called the tortoise and the hare.  The algorithm is constant
space because it only tracks two pointers, the tortoise and the hare.

The code below is from The Scheme Programming Language by Dybvig.
|#

(define (race hare tortoise)
  ;; Go down hare and tortoise by taking cdr's but go twice as fast down hare.
  ;; Return true if you never see equal pairs ie the hare wins the race.
  (cond [(mpair? hare)
         (define faster-hare (mcdr hare))
         (if (mpair? faster-hare)
           (and (not (eq? faster-hare tortoise))
                (race (mcdr faster-hare) (mcdr tortoise)))
           (null? faster-hare))]
        [else (null? hare)]))

(define (floyd-cycle? x)
  (not (race x x)))

(floyd-cycle? (mlist 'a 'b 'c))
;; #f

;; Recall that y3 is (mlist 'a).
(floyd-cycle? (mcons y3 y3))
;; #f

(floyd-cycle? (make-cycle (mlist 'a 'b 'c)))
;; #t

;;;;;;;;;;
;; 3.20 ;;
;;;;;;;;;;

(define (my-cons x y)
  (define (set-x! v) (set! x v))
  (define (set-y! v) (set! y v))
  (define (dispatch m)
    (cond [(eq? m 'car) x]
          [(eq? m 'cdr) y]
          [(eq? m 'set-car!) set-x!]
          [(eq? m 'set-cdr!) set-y!]
          [else (error "Undefined operation -- my-cons:" m)]))
  dispatch)
(define (my-car z) (z 'car))
(define (my-cdr z) (z 'cdr))
(define (set-car! z new-value)
  ((z 'set-car!) new-value)
  z)
(define (set-cdr! z new-value)
  ((z 'set-cdr!) new-value)
  z)

;; Describe the environment structures that result from evaluating these
;; expressions:

(define x3 (my-cons 1 2))
(define z6 (my-cons x3 x3))
(set-car! (my-cdr z6) 17)
;; #<procedure:dispatch>
(my-car x3)
;; 17

#|
We're using x3 and z6 for what the book calls x and z to avoid duplicate
definitions from earlier exercises.

(define x3 (my-cons 1 2)) creates a variable x3 in the global environment and
binds it to the result of calling my-cons on 1 and 2.  Calling my-cons on 1 and
2 creates a new binding frame E1 below the global environment where the formal
parameters of my-cons, namely x and y, are bound to the passed values 1 and 2,
and then the body of my-cons is evaluated in E1.  Evaluating the body of
my-cons in E1 creates new functions set-x!, set-y!, and dispatch, whose
enclosing environments are E1.  x3 is then bound to the dispatch function in
E1.

(define z6 (my-cons x3 x3)) creates a variable z6 in the global environment and
binds it to the result of calling my-cons on x3 and x3.  Calling my-cons on x3
and x3 creates a new binding frame E2 below the global environment where the
formal parameters of my-cons, namely x and y, are bound to the passed values x3
and x3, and then the body of my-cons is evaluated in E2.  Evaluating the body
of my-cons in E2 creates new functions set-x!, set-y!, and dispatch, whose
enclosing environments are E2.  z6 is then bound to the dispatch function in
E2.

(set-car! (my-cdr z6) 17) creates a new binding frame E3 below the global
environment where the formal parameters of set-car! are bound to the passed
values.  Namely, z is bound to the result of (my-cdr z6), and new-value is
bound to 17.

(my-cdr z6) creates a new binding frame E4 below the global environment where
the formal parameter of my-cdr, z, is bound to the passed value z6, which is a
pointer to the dispatch function in E2.  Evaluating the body of my-cdr in E4
calls the dispatch function in E2 and applies it to the symbol 'cdr.  Applying
the dispatch function in E2 to 'cdr returns the value of the formal parameter y
in E2 which was bound to x3.  So my-cdr of z6 is x3, which points to the
dispatch function in E1.

So now we evaluate the body of set-car! in E3 where the formal parameters z and
new-value have been bound to x3 and 17.  To do that we first have to evaluate
(z 'set-car!) in E3, but this is just x3, the dispatch function in E1, applied
to 'set-car!, which is the set-x! function in E1.  So now we take the set-x!
function in E1 and apply it to new-value in E3, which is 17.  This changes the
value of the formal parameter x in E1 from 1 to 17, ie we have changed the car
of x3 from 1 to 17, which is what we do observe.
|#