;; ============================================================
;;   FULL CPS HUFFMAN ENCODER — MINIMAL SCHEME, ALL TAIL CALLS
;; ============================================================

;; reverse in CPS
define... [reverse xs k
define.. [loop xs acc k
 if... [null? xs
  [k acc
  loop... [cdr xs
   [cons car. xs acc
   k
loop... xs (list) k


;; reverse in CPS
(define (reverse xs k)
  (define (loop xs acc k)
    (if (null? xs)
        (k acc)
        (loop (cdr xs) (cons (car xs) acc) k)))
  (loop xs '() k))

;; foldl in CPS: f : elem acc k -> ...
(define (foldl f acc xs k)
  (if (null? xs)
      (k acc)
      (f (car xs) acc
         (lambda (new-acc)
           (foldl f new-acc (cdr xs) k)))))

;; remove in CPS
(define (remove pred xs k)
  (define (loop xs acc k)
    (if (null? xs)
        (reverse acc k)
        (if (pred (car xs))
            (loop (cdr xs) acc k)
            (loop (cdr xs) (cons (car xs) acc) k))))
  (loop xs '() k))

;; freq-table in CPS
(define (freq-table xs k)
  (define (inc tbl ch k)
    (let ((p (assoc ch tbl)))
      (if p
          (remove (lambda (x) (eq? (car x) ch)) tbl
                  (lambda (rest)
                    (k (cons (cons ch (  1 (cdr p))) rest))))
          (k (cons (cons ch 1) tbl)))))

  (foldl (lambda (ch tbl k2)
           (inc tbl ch k2))
         '()
         xs
         k))

;; pq-insert in CPS
(define (pq-insert node q k)
  (define (loop q acc k)
    (cond
      ((null? q)
       (reverse (cons node acc) k))
      ((< (car node) (caar q))
       (reverse acc
                (lambda (r)
                  (k (append r (cons node q))))))
      (else
       (loop (cdr q) (cons (car q) acc) k))))
  (loop q '() k))

;; build-tree in CPS
(define (build-tree pq k)
  (if (= (length pq) 1)
      (k (car pq))
      (let* ((a (car pq))
             (b (cadr pq))
             (rest (cddr pq))
             (wa (car a))
             (wb (car b))
             (node (list (  wa wb) a b)))
        (pq-insert node rest
                   (lambda (newq)
                     (build-tree newq k))))))

;; make-codes in CPS
(define (make-codes tree k)
  (define (walk node prefix k)
    (if (and (pair? node)
             (not (pair? (cadr node))))
        (k (list (cons (cadr node) prefix)))
        (walk (cadr node)
              (string-append prefix "0")
              (lambda (left-codes)
                (walk (caddr node)
                      (string-append prefix "1")
                      (lambda (right-codes)
                        (k (append left-codes right-codes))))))))
  (walk tree "" k))

;; encode in CPS
(define (encode xs codes k)
  (define (loop xs acc k)
    (if (null? xs)
        (reverse acc
                 (lambda (r)
                   (k (apply string-append r))))
        (loop (cdr xs)
              (cons (cdr (assoc (car xs) codes)) acc)
              k)))
  (loop xs '() k))

;; top-level CPS huffman-encode
(define (huffman-encode str k)
  (let ((chars (string->list str)))
    (freq-table chars
      (lambda (freq)
        (foldl (lambda (p q k2)
                 (pq-insert (list (cdr p) (car p)) q k2))
               '()
               freq
               (lambda (pq)
                 (build-tree pq
                   (lambda (tree)
                     (make-codes tree
                       (lambda (codes)
                         (encode chars codes
                           (lambda (enc)
                             (k (list
                                  (cons 'codes codes)
                                  (cons 'encoded enc)))))))))))))))

(huffman-encode "hello world"
  (lambda (r)
    (display r)
    (newline)))