;; This code runs in the "Pretty Big" language,
;; which is under "PLT" 

; write-numlist : list-of-num output-port -> void
;   Effect: write l to p
(define (write-numlist l p)
  (cond
    [(empty? l) (write-char #\. p)]
    [else (begin
            (write-num (first l) p)
            (write-char #\space p)
            (write-list (rest l) p))]))

; write-num : num output-port -> void
;   Effect: write n to p
(define (write-num n p)
  (cond
    [(< n 10) (write-digit n p)]
    [else (begin
            (write-num (quotient n 10) p)
            (write-digit (remainder n 10) p))]))

; write-digit : num(0-9) output-port -> void
;   Effect: write n to p
(define (write-digit n p)
  (cond
    ((= n 0) (write-char #\0 p))
    ((= n 1) (write-char #\1 p))
    ((= n 2) (write-char #\2 p))
    ((= n 3) (write-char #\3 p))
    ((= n 4) (write-char #\4 p))
    ((= n 5) (write-char #\5 p))
    ((= n 6) (write-char #\6 p))
    ((= n 7) (write-char #\7 p))
    ((= n 8) (write-char #\8 p))
    ((= n 9) (write-char #\9 p))))


; read-numlist : input-port -> list-of-num
(define (read-numlist p)
  (local ((define c (read-char p)))
    (cond
      ((char=? #\. c) empty)
      ((char-digit? c) (cons (read-number p (digit-val c))
                             (read-numlist p))))))

; read-number : input-port num -> num
(define (read-number p n)
  (local ((define c (read-char p)))
    (cond
      ((char=? #\space c) n)
      ((char-digit? c)
       (read-number p (+ (* n 10) (digit-val c)))))))

; char-digit? : char -> bool
(define (char-digit? c)
  (or (char=? c #\0) (char=? c #\1) (char=? c #\2)
      (char=? c #\3) (char=? c #\4) (char=? c #\5)
      (char=? c #\6) (char=? c #\7) (char=? c #\8)
      (char=? c #\9)))

; digit-val : char -> num
(define (digit-val c)
  (cond
    ((char=? c #\0) 0)
    ((char=? c #\1) 1)
    ((char=? c #\2) 2)
    ((char=? c #\3) 3)
    ((char=? c #\4) 4)
    ((char=? c #\5) 5)
    ((char=? c #\6) 6)
    ((char=? c #\7) 7)
    ((char=? c #\8) 8)
    ((char=? c #\9) 9)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; A family-tree is either
;  - empty
;  - (make-child family-tree family-tree sym)
(define-struct child (father mother name))

(define MY-FAMILY (make-child empty empty 'Matthew))

; ----------------------------------------

; add-mother! : sym sym -> void
(define (add-mother! c-name m-name)
  (set! MY-FAMILY (add-mother MY-FAMILY c-name m-name)))

; add-father! : sym sym -> void
(define (add-father! c-name f-name)
  (set! MY-FAMILY (add-father MY-FAMILY c-name f-name)))

; ----------------------------------------

; add-mother : family-tree sym sym -> family-tree
(define (add-mother ft cn mn)
  (add-parent ft cn
              (lambda (f m n)
                (make-child f
                            (make-child empty empty mn)
                            n))))

; add-father : family-tree sym sym -> family-tree
(define (add-father ft cn fn)
  (add-parent ft cn
              (lambda (f m n)
                (make-child (make-child empty empty fn)
                            m
                            n))))

; add-parent : family-tree sym
;            (family-tree family-tree sym -> family-tree)
;            -> family-tree
(define (add-parent ft cn add)
  (cond
    ((empty? ft) empty)
    (else
     (cond
       ((symbol=? cn (child-name ft))
        (add (child-father ft)
             (child-mother ft)
             cn))
       (else
        (make-child (add-parent (child-father ft) cn add)
                    (add-parent (child-mother ft) cn add)
                    (child-name ft)))))))

; ----------------------------------------

; find-relative : sym -> family-tree-or-false
(define (find-relative c-name)
  (find-person MY-FAMILY c-name))

; find-person : family-tree sym -> family-tree-or-false
(define (find-person ft cn)
  (cond
    ((empty? ft) false)
    (else (cond
            ((symbol=? cn (child-name ft)) ft)
            (else
             (or (find-person (child-father ft) cn)
                 (find-person (child-mother ft) cn)))))))

; ----------------------------------------

;; family-tree->sexp : family-tree -> sexp
(define (family-tree->sexp ft)
  (cond
    [(empty? ft) '()]
    [else (list (family-tree->sexp (child-father ft))
                (family-tree->sexp (child-mother ft))
                (child-name ft))]))

(family-tree->sexp empty) "should be" '()
(family-tree->sexp (make-child empty empty 'Matthew))
"should be" '(() () Matthew)
(family-tree->sexp 
 (make-child (make-child empty empty 'Raymond) empty 'Matthew))
"should be" '((() () Raymond) () Matthew)

;; write-family-tree : family-tree output-port -> void
(define (write-family-tree ft p)
  (write (family-tree->sexp ft) p))

; (define o (open-output-port "my tree"))
; (write-family-tree MY-FAMILY o)
; (close-output-port o)

;; sexp->family-tree : sexp -> family-tree
(define (sexp->family-tree sexp)
  (cond
    [(empty? sexp) empty]
    [else (make-child
           (sexp->family-tree (first sexp))
           (sexp->family-tree (second sexp))
           (third sexp))]))

(sexp->family-tree '()) "should be" empty
(sexp->family-tree '(() () Matthew))
"should be" (make-child empty empty 'Matthew)

;; read-family-tree : input-port -> family-tree
(define (read-family-tree i)
  (sexp->family-tree (read i)))

;(define i (open-input-port "my tree"))
;(set! MY-FAMILY (read-family-tree i))
;(close-input-port i)