SICP Working Code

Chapter3_3_1.rkt

#lang planet neil/sicp

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))

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

(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

(define (make-cycle x)
  (set-cdr! (last-pair x) x)
  x)

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

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

(define (count-pairs x)
  (if (not (pair? x))
      0
      (+ (count-pairs (car x))
	 (count-pairs (cdr x))
	 1)))

(define w '(a b c))

(define x1 (cons 'a 'b))
(define x2 (cons x1 'c))
(define x (cons x1 x2))

(define y1 (cons 'a 'b))
(define y2 (cons y1 y1))
(define y (cons y2 y2))

(define z (make-cycle '(a b c)))

(define (count-pairs x)
  (define encountered '())
  (define (count-unique-pairs x)
    (if (and (pair? x)
	     (not (memq x encountered)))
	(begin (set! encountered (cons x encountered))
	       (+ (count-unique-pairs (car x))
		  (count-unique-pairs (cdr x))
		  1))
	0))
  (count-unique-pairs x))

(define (has-cycle-e? x)
  (define encountered '())
  (define (check-if-seen x)
    (cond ((not (pair? x)) #f)
	  ((memq x encountered) #t)
	  (else (begin (set! encountered (cons x encountered))
		       (check-if-seen (cdr x))))))
  (check-if-seen x))

(define (has-cycle? x)
  (define (safe-cdr x)
    (if (pair? x)
	(cdr x)
	'()))
  (define (safe-cddr x)
    (safe-cdr (safe-cdr x)))
  (define (advance-pointer t h)
    (cond ((null? h) #f)
	  ((eq? t h) #t)
	  (else (advance-pointer
		 (safe-cdr t)
		 (safe-cddr h)))))
  (advance-pointer x (safe-cdr x)))

(define (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: CONS" m))))
  dispatch)

(define (car z) (z 'car))
(define (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)

Chapter3_3_2.rkt

# lang planet neil/sicp

(define (make-queue) (cons '() '()))

(define (front-ptr queue) (car queue))
(define (rear-ptr queue) (cdr queue))
(define (set-front-ptr! queue item)
  (set-car! queue item))
(define (set-rear-ptr! queue item)
  (set-cdr! queue item))
(define (front-queue queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue" queue)
      (car (front-ptr queue))))

(define (empty-queue? queue)
  (null? (front-ptr queue)))

(define (insert-queue! queue item)
  (let ((new-pair (cons item '())))
    (cond ((empty-queue? queue)
	   (set-front-ptr! queue new-pair)
	   (set-rear-ptr! queue new-pair)
	   queue)
	  (else (set-cdr! (rear-ptr queue)
			  new-pair)
		(set-rear-ptr! queue new-pair)
		queue))))

(define (delete-queue! queue)
  (cond ((empty-queue? queue)
	 (error "DELETE! called with an empty queue" queue))
	(else (set-front-ptr! queue
			      (cdr (front-ptr queue)))
	      queue)))

(define (print-queue queue)
  (newline)
  (display (front-ptr queue)))

(define (make-queue)
  (let ((front-ptr '())
	(rear-ptr '()))
    (define (print-queue)
      (newline)
      (display front-ptr))
    (define (empty-queue?)
      (null? front-ptr))
    (define (front-queue)
      (if (empty-queue?)
	  (error "FRONT called with an empty queue" front-ptr)
	  (car front-ptr)))
    (define (insert-queue! item)
      (let ((new-pair (cons item '())))
	(cond ((empty-queue?)
	       (set! front-ptr new-pair)
	       (set! rear-ptr new-pair))
	      (else
	       (set-cdr! rear-ptr new-pair)
	       (set! rear-ptr new-pair)))))
    (define (delete-queue!)
      (cond ((empty-queue?)
	     (error "DELETE! called with an empty queue" front-ptr))
	    (else
	     (set! front-ptr (cdr front-ptr)))))
    (define (dispatch m)
      (cond ((eq? m 'insert-queue!) insert-queue!)
	    ((eq? m 'delete-queue!) (delete-queue!))
	    ((eq? m 'front-queue) (front-queue))
	    ((eq? m 'empty-queue?) (empty-queue?))
	    ((eq? m 'print-queue) (print-queue))
	    (else (error "Undefined operation: MAKE-QUEUE" m))))
    dispatch))

(define (print-queue queue) (queue 'print-queue))
(define (front-queue queue) (queue 'front-queue))
(define (empty-queue? queue) (queue 'empty-queue?))
(define (insert-queue! queue item)
  ((queue 'insert-queue!) item)
  (print-queue queue))
(define (delete-queue! queue)
  (queue 'delete-queue!)
  (print-queue queue))

(define (make-deque) (cons '() '()))
(define (front-ptr deque) (car deque))
(define (rear-ptr deque) (cdr deque))
(define (set-front-ptr! deque item)
  (set-car! deque item))
(define (set-rear-ptr! deque item)
  (set-cdr! deque item))

(define (make-node value) (cons value (cons '() '())))
(define (get-value node) (car node))
(define (next-ptr node) (cadr node))
(define (prev-ptr node) (cddr node))
(define (set-next-ptr! node next-node)
  (set-car! (cdr node) next-node))
(define (set-prev-ptr! node prev-node)
  (set-cdr! (cdr node) prev-node))

(define (empty-deque? deque)
  (and (null? (front-ptr deque))
       (null? (rear-ptr deque))))

(define (front-deque deque)
  (if (empty-deque? deque)
      (error "FRONT called with an empty deque" deque)
      (get-value (front-ptr deque))))
(define (rear-deque deque)
  (if (empty-deque? deque)
      (error "REAR called with an empty deque" deque)
      (get-value (rear-ptr deque))))

(define (front-insert-deque! deque item)
  (let ((new-node (make-node item)))
    (cond ((empty-deque? deque)
           (set-front-ptr! deque new-node)
           (set-rear-ptr! deque new-node))
          (else (let ((front-node (front-ptr deque)))
                  (set-next-ptr! new-node front-node)
                  (set-prev-ptr! front-node new-node)
                  (set-front-ptr! deque new-node))))))

(define (rear-insert-deque! deque item)
  (let ((new-node (make-node item)))
    (cond ((empty-deque? deque)
           (set-front-ptr! deque new-node)
           (set-rear-ptr! deque new-node))
          (else (let ((rear-node (rear-ptr deque)))
                  (set-prev-ptr! new-node rear-node)
                  (set-next-ptr! rear-node new-node)
                  (set-rear-ptr! deque new-node))))))

(define (front-delete-deque! deque)
  (cond ((empty-deque? deque)
         (error "DELETE! called with an empty deque" deque))
        (else ())
         ))

(define (front-delete-deque! deque)
  (cond ((empty-deque? deque)
         (error "DELETE! called with an empty deque" deque))
        ((eq? (front-ptr deque) (rear-ptr deque))
         (set-front-ptr! deque '())
         (set-rear-ptr! deque '()))
        (else (set-front-ptr! deque (next-ptr (front-ptr deque))))))

(define (rear-delete-deque! deque)
  (cond ((empty-deque? deque)
         (error "DELETE! called with an empty deque" deque))
        ((eq? (front-ptr deque) (rear-ptr deque))
         (set-front-ptr! deque '())
         (set-rear-ptr! deque '()))
        (else (set-rear-ptr! deque (prev-ptr (rear-ptr deque))))))

(define (print-deque deque)
  (define (printable-deque ptr)
    (cond ((null? ptr) '())
          ((eq? ptr (rear-ptr deque))
           (cons (get-value ptr) '()))
          (else (cons (get-value ptr)
                      (printable-deque (next-ptr ptr))))))
  (newline)
  (display (printable-deque (front-ptr deque))))