;; Leere Bäume

(define empty-tree-type (make-type 'empty-tree))

(define make-empty-tree
  (let ((construct (typed-value-maker empty-tree-type)))
    (lambda ()
      (construct 'dont-care))))

(define empty-tree (make-empty-tree))

(define empty-tree? (typed-value-predicate empty-tree-type))

;; Knoten

(define node-type (make-type 'node))

(define make-node
  (let ((construct (typed-value-maker node-type)))
    (lambda (label left-branch right-branch)
      (construct (cons label
		       (cons left-branch
			     right-branch))))))

(define node? (typed-value-predicate node-type))

(define node-data (typed-value-selector node-type))

(define node-label
  (lambda (node)
    (car (node-data node))))

(define node-left-branch
  (lambda (node)
    (car (cdr (node-data node)))))

(define node-right-branch
  (lambda (node)
    (cdr (cdr (node-data node)))))

(define tree?
  (lambda (value)
    (or (empty-tree? value)
        (node? value))))

;; Suchbäume

(define search-tree-type (make-type 'search-tree))

(define make-search-tree
  (let ((construct (typed-value-maker search-tree-type)))
    (lambda (= < tree)
      (construct (cons (cons = <) tree)))))

(define make-empty-search-tree
  (lambda (= <)
    (make-search-tree = < empty-tree)))

(define search-tree? (typed-value-predicate search-tree-type))

(define search-tree-data (typed-value-selector search-tree-type))

(define search-tree-<
  (lambda (search-tree)
    (cdr (car (search-tree-data search-tree)))))

(define search-tree-=
  (lambda (search-tree)
    (car (car (search-tree-data search-tree)))))

(define search-tree-tree
  (lambda (search-tree)
    (cdr (search-tree-data search-tree))))

(define search-tree-member?
  (lambda (element search-tree)
    (let ((= (search-tree-= search-tree))
	  (< (search-tree-< search-tree)))
      (letrec
	  ((member?
	    (lambda (tree)
	      (cond
	       ((empty-tree? tree)
		#f)
	       ((= (node-label tree) element)
		#t)
	       ((< element (node-label tree))
		(member? (node-left-branch tree)))
	       (else
		(member? (node-right-branch tree)))))))
	(member? (search-tree-tree search-tree))))))

(define search-tree-insert
  (lambda (element search-tree)
    (let ((= (search-tree-= search-tree))
	  (< (search-tree-< search-tree)))
      (letrec
	  ((insert
	    (lambda (tree)
	      (cond
	       ((empty-tree? tree)
		(make-node element empty-tree empty-tree))
	       ((= element (node-label tree))
		tree)
	       ((< element (node-label tree))
		(make-node (node-label tree)
			   (insert (node-left-branch tree))
			   (node-right-branch tree)))
	       (else
		(make-node (node-label tree)
			   (node-left-branch tree)
			   (insert (node-right-branch tree))))))))
	(make-search-tree
	 = <
	 (insert (search-tree-tree search-tree)))))))

;; Huffman-Bäume

(define huffman-leaf-type (make-type 'huffman-leaf))

(define make-huffman-leaf
  (let ((construct (typed-value-maker huffman-leaf-type)))
    (lambda (symbol weight)
      (construct (cons symbol weight)))))

(define huffman-leaf? (typed-value-predicate huffman-leaf-type))

(define huffman-leaf-data (typed-value-selector huffman-leaf-type))

(define huffman-leaf-symbol
  (lambda (leaf)
    (car (huffman-leaf-data leaf))))

(define huffman-leaf-weight
  (lambda (leaf)
    (cdr (huffman-leaf-data leaf))))

(define huffman-node-type (make-type 'huffman-node))

(define make-huffman-node
  (let ((construct (typed-value-maker huffman-node-type)))
    (lambda (left-branch right-branch)
      (let ((label (cons (append (huffman-symbols left-branch)
				 (huffman-symbols right-branch))
			 (+ (huffman-weight left-branch)
			    (huffman-weight right-branch)))))
	(construct (cons label (cons left-branch right-branch)))))))

(define huffman-node? (typed-value-predicate huffman-node-type))

(define huffman-node-data (typed-value-selector huffman-node-type))

(define huffman-node-label
  (lambda (huffman-node)
    (car (huffman-node-data huffman-node))))

(define huffman-node-left-branch
  (lambda (huffman-node)
    (car (cdr (huffman-node-data huffman-node)))))

(define huffman-node-right-branch
  (lambda (huffman-node)
    (cdr (cdr (huffman-node-data huffman-node)))))

(define huffman-node-symbols
  (lambda (node)
    (car (huffman-node-label node))))

(define huffman-node-weight
  (lambda (node)
    (cdr (huffman-node-label node))))

(define huffman-symbols
  (lambda (tree)
    (if (huffman-leaf?  tree)
	(list (huffman-leaf-symbol tree))
	(huffman-node-symbols tree))))

(define huffman-weight
  (lambda (tree)
    (if (huffman-leaf? tree)
	(huffman-leaf-weight tree)
	(huffman-node-weight tree))))

(define huffman-decode
  (lambda (bits tree)
    (letrec
	((decode-1
	  (lambda (bits current-branch)
	    (if (null? bits)
		'()
		(let ((next-branch
		       (choose-branch (car bits) current-branch)))
		  (if (huffman-leaf? next-branch)
		      (cons (huffman-leaf-symbol next-branch)
			    (decode-1 (cdr bits) tree))
		      (decode-1 (cdr bits) next-branch)))))))
      (decode-1 bits tree))))

(define choose-branch
  (lambda (bit branch)
    (cond
     ((= bit 0) (huffman-node-left-branch  branch))
     ((= bit 1) (huffman-node-right-branch branch))
     (else (error "bad bit")))))

(define huffman-encode
  (lambda (message tree)
    (fold-right (lambda (symbol rest)
		  (append (huffman-encode-symbol symbol tree)
			  rest))
		'()
		message)))

(define huffman-encode-symbol
  (lambda (symbol tree)
    (if (huffman-leaf? tree)
	(if (equal? (huffman-leaf-symbol tree) symbol)
	    '()
	    #f)
	(let ((maybe-encoding
	       (huffman-encode-symbol symbol
				      (huffman-node-left-branch tree))))
	  (if maybe-encoding
	      (cons 0 maybe-encoding)
	      (let ((maybe-encoding
		     (huffman-encode-symbol symbol
					    (huffman-node-right-branch tree))))
		(if maybe-encoding
		    (cons 1 maybe-encoding)
		    #f)))))))