Discrete Maths, ProblemSet#3

These are my solutions to 3rd problem set of discrete mathematics course taught at Arsdigita university by Shai Simonson. Other posts relating to this are here.

The code for various problems is here...

;P-2c
(define nil '())
;this is a LIFO stack(peg for TOH) in which you can put
;numbers(number represents disk)
;bigger number represents a disk with bigger size
;Each peg/stack has a name also
(define (make-disk-stack stack-name)
  (let ((disks nil))
    (define (put-disk n)
      (if (and (not (null? disks)) (> n (car disks)))
          (error "ERROR: trying to put bigger disk 
            over smaller disk. new-disk: " n  
            " on stack:" stack-name disks)
          (set! disks (cons n disks))))
    (define (remove-disk)
      (if (null? disks)
          (error "Error: No disk is available." stack-name)
          (let ((tmp (car disks)))
            (set! disks (cdr disks))
            tmp)))
    (define (size)
      (length disks))
    (define (print)
      (display disks)
      (newline))
    (define (name)
      stack-name)
    (define (dispatch msg . args)
      (cond
       ((eq? msg 'put-disk) (put-disk (car args)))
       ((eq? msg 'remove-disk) (remove-disk))
       ((eq? msg 'size) (size))
       ((eq? msg 'print) (print))
       ((eq? msg 'name) (name))
       (else (error "Error: msg not recognized." stack-name))))
    dispatch))
(define (put-disk n stack)
  (stack 'put-disk n))
(define (remove-disk stack)
  (stack 'remove-disk))
(define (size stack)
  (stack 'size))
(define (print stack)
  (stack 'print))
(define (name stack)
  (stack 'name))

;create stack containing n disks
(define (fill-stack stack n)
  (if (= n 0) stack
      (begin (put-disk n stack)
             (fill-stack stack (- n 1)))))

;=====================================
;just to check that my approach is correct, I'm doing
;the standard TOH algo here
(define (Standard-TOH from to using n)
  (if (= n 1)
      (begin
        (display (string-append "moving disk from " (name from) 
                                " to " (name to)))
        (newline)
        (put-disk (remove-disk from) to))
      (begin
        (Standard-TOH from using to (- n 1))
        (put-disk (remove-disk from) to)
        (Standard-TOH using to from (- n 1)))))

;lets do for 7 disks
(define to (make-disk-stack "TO"))
(define from (fill-stack (make-disk-stack "FROM") 7))
(Standard-TOH from to (make-disk-stack "USING") 7)
(print to) ;should print (1 2 3 4 5 6 7)
(print from) ;should print ()


;==================================

;Sloppy Joe's algorithm       
(define (TOH from to using1 using2 n)
  (if (= n 1)
      (begin
        (display (string-append 
                  "moving disk from " (name from) " to " (name to)))
        (newline)
        (put-disk (remove-disk from) to))
      (begin
        (TOH from using1 to using2 (/ n 2))
        (TOH from to using1 using2 (/ n 2))
        (TOH using1 to from using2 (/ n 2)))))

(TOH (fill-stack (make-disk-stack "FROM") 4) 
     (make-disk-stack "TO") 
     (make-disk-stack "USING1") (make-disk-stack "USING2") 4)
;ERROR: trying to put bigger disk over 
;smaller disk. new-disk:  3 " stack:" (1 2)
(TOH (fill-stack (make-disk-stack "FROM") 8) 
     (make-disk-stack "TO") 
     (make-disk-stack "USING1") (make-disk-stack "USING2") 8)
;ERROR: trying to put bigger disk over 
;smaller disk. new-disk:  3 " stack:" (1 2)

;Fruity Freddie algorithm       
(define (TOH from to using1 using2 n)
  (if (= n 1)
      (begin
        (display (string-append 
                  "moving disk from " (name from) " to " (name to)))
        (newline)
        (put-disk (remove-disk from) to))
      (begin
        (TOH from using1 to using2 (/ n 2))
        (TOH from to using2 using1 (/ n 2))
        (TOH using1 to from using2 (/ n 2)))))

(TOH (fill-stack (make-disk-stack "FROM") 4) 
     (make-disk-stack "TO") 
     (make-disk-stack "USING1") (make-disk-stack "USING2") 4)
; Finishes successfully
(TOH (fill-stack (make-disk-stack "FROM") 8) 
     (make-disk-stack "TO") 
     (make-disk-stack "USING1") (make-disk-stack "USING2") 8)
;ERROR: trying to put bigger disk over 
;smaller disk. new-disk:  7 " stack:" (1 2 3 4)


;3 a,b
;steps
;if n = 1 then move 1 disk from From to To
;else
;Move n/2 disks to Using1 from From, using To and Using2
;Move remaining n/2 disks from From to To using Using2 only with
;standard TOH algorithm
;Move n/2 disks from Using1 to To using From and Using2
(define (TOH from to using1 using2 n)
  (if (= n 1)
      (begin
        (display (string-append 
                  "moving disk from " (name from) " to " (name to)))
        (newline)
        (put-disk (remove-disk from) to))
      (begin
        (TOH from using1 to using2 (quotient n 2))
        (Standard-TOH from to using2 (- n (quotient n 2)))
        (TOH using1 to from using2 (quotient n 2)))))


;lets do for 16 disks
(define to (make-disk-stack "TO"))
(define from (fill-stack (make-disk-stack "FROM") 15))
(TOH from to (make-disk-stack "USING1") (make-disk-stack "USING2") 15)
(print to) ;should print (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
(print from) ;should print ()


;11a
;Algorithm
;num = (d1 d2 ...dn)
;result = (g1 g2 ...gn)
;start with dn, if dn-1 = 1 then gn=1-dn or gn=dn
;go all the way till d1, d0 is assumed to be 0
;so g1 = d1
(define (bin->gray num)
  (define (iter n a)
    (if (null? (cdr n))
        (cons (car n) a)
        (if (= (cadr n) 1)
            (iter (cdr n) (cons (- 1 (car n)) a))
            (iter (cdr n) (cons (car n) a)))))
  (iter (reverse num) nil))

;11b
(define (gray->bin num)
  (define (iter n a)
    (if (null? n) a
        (if
         (= (modulo (reduce + 0 (cdr n)) 2) 1)
         (iter (cdr n) (cons (- 1 (car n)) a))
         (iter (cdr n) (cons (car n) a)))))
  (iter (reverse num) nil))

Here are my solutions...