ZETT

<a href="https://web.archive.org/web/https://core.puter.site/">CORE</a> by <a href="https://web.archive.org/web/https://ytp.me/">Zelah Hutchinson</a> is marked <a href="https://creativecommons.org/publicdomain/zero/1.0/">CC0 1.0</a><img src="https://mirrors.creativecommons.org/presskit/icons/cc.svg" alt="" style="max-width: 1em;max-height:1em;margin-left: .2em;"><img src="https://mirrors.creativecommons.org/presskit/icons/zero.svg" alt="" style="max-width: 1em;max-height:1em;margin-left: .2em;">

;; -------------------------------
;; Minimal-Scheme Huffman Encoding
;; -------------------------------

;; foldl (simple definition in case your Scheme doesn't have it)
(define (foldl f acc xs)
  (if (null? xs)
      acc
      (foldl f (f (car xs) acc) (cdr xs))))

;; remove (predicate-based)
(define (remove pred xs)
  (cond
    ((null? xs) '())
    ((pred (car xs)) (remove pred (cdr xs)))
    (else (cons (car xs) (remove pred (cdr xs))))))

;; Count frequencies of characters in a list
(define (freq-table xs)
  (define (inc tbl ch)
    (let ((p (assoc ch tbl)))
      (if p
          (cons (cons ch (+ 1 (cdr p)))
                (remove (lambda (x) (eq? (car x) ch)) tbl))
          (cons (cons ch 1) tbl))))
  (foldl (lambda (ch tbl) (inc tbl ch)) '() xs))

;; Priority queue insert (sorted by weight)
(define (pq-insert node q)
  (cond
    ((null? q)
     (list node))
    ((< (car node) (caar q))
     (cons node q))
    (else
     (cons (car q) (pq-insert node (cdr q))))))

;; Build initial queue from frequency table
(define (make-pq freq)
  (foldl (lambda (p q)
           (pq-insert (list (cdr p) (car p)) q))
         '()
         freq))

;; Build Huffman tree
(define (build-tree pq)
  (if (= (length pq) 1)
      (car pq)
      (let* ((a (car pq))
             (b (cadr pq))
             (rest (cddr pq))
             (wa (car a))
             (wb (car b))
             (node (list (+ wa wb) a b)))
        (build-tree (pq-insert node rest)))))

;; Generate code table from tree
(define (make-codes tree)
  (define (walk node prefix)
    (cond
      ;; leaf: (weight char)
      ((and (pair? node)
            (not (pair? (cadr node))))
       (list (cons (cadr node) prefix)))
      (else
       (append (walk (cadr node) (string-append prefix "0"))
               (walk (caddr node) (string-append prefix "1"))))))
  (walk tree ""))

;; Encode a list of chars using code table
(define (encode xs codes)
  (apply string-append
         (map (lambda (ch) (cdr (assoc ch codes))) xs)))

;; Top-level convenience function
(define (huffman-encode str)
  (let* ((chars (string->list str))
         (freq  (freq-table chars))
         (pq    (make-pq freq))
         (tree  (build-tree pq))
         (codes (make-codes tree)))
    (list
     (cons 'codes codes)
     (cons 'encoded (encode chars codes)))))

;; Example:
 (huffman-encode "hello world")

;; ============================================================
;;   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 '() 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)))

;; ============================================================
;;   FULL CPS HUFFMAN ENCODER — PRODUCTION C2L, ALL TAIL CALLS
;;   COMPILE TO SCHEME HERE: c2l.puter.site
;;   WORK IS ONGOING
;;   THIS IS PUBLIC DOMAIN SOFTWARE BY ZELAH HUTCHINSON
;;   I RELEASE THIS SOFTWARE UNDER THE TERMS OF THE UNLICENSE
;; ============================================================

;; REVERSE IN CPS
define... [reverse xs k


;; LOOP
define.. [loop xs acc k
or...

;; CONTINUE
[and null?. xs k. acc

;; ACCUMULATE
and.. pair?. xs
loop... [cdr xs
 [cons car. xs acc
 k

;; ERROR
[error '[NOT LIST


;; BEGIN
[loop xs (list) k

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

;; FOLDL IN CPS
define.. [foldl f acc xs k
or...

;; CONTINUE
[and null?. xs k. acc

;; PAIR
and.. pair?. xs
f... car. xs
 acc
 lambda.. [new-acc
  [foldl f new-acc cdr. xs k

;; ERROR
[error '[NOT LIST

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

// trampoline : (thunk -> thunk | value) -> value
// Runs a chain of thunks iteratively so recursion doesn't grow the JS call stack.
// - Start with a "thunk" (a function with no args)
// - While the result is still a function, keep calling it
// - When a non-function value is produced, return it
const trampoline = (thunk) => {
  let t = thunk;
  while (typeof t === "function") t = t(); // keep "bouncing"
  return t; // final value
};

// foldl : (f, acc, xs, k) -> ...
//
// Fold an array xs from left to right in a continuation-passing style (CPS) and
// use trampoline to stay stack-safe.
//
// Type-ish comments:
// - f : (x, acc, k2) => ...
//   where k2 : (newAcc) => ... is a continuation that tells foldl what to do next
//   IMPORTANT: f is expected to call k2(newAcc) rather than directly returning newAcc.
// - k : (finalAcc) => ... is the final continuation invoked at the end.
//
// Returns: a call that eventually triggers k(finalAcc).
const foldl = (f, acc, xs, k) => {
  // step(i, accNow) describes "the rest of the fold" starting at index i
  // and current accumulator accNow.
  //
  // It returns either:
  // - a thunk (function) that when called computes the next step, or
  // - in the base case, a thunk that calls k(accNow).
  const step = (i, accNow) => {
    // Base case: we've processed every element in xs.
    if (i >= xs.length) return () => k(accNow);

    // Process the next element.
    const x = xs[i];

    // We don't call f(x, accNow, ...) immediately on the call stack.
    // Instead, we return a thunk so trampoline can manage the iteration safely.
    return () =>
      // Call f in CPS form:
      // f decides how to compute/update the accumulator, and then calls k2(newAcc).
      f(x, accNow, (newAcc) => {
        // After f computes newAcc, continue folding from i+1.
        // step(i + 1, newAcc) returns a thunk, which trampoline will eventually run.
        return step(i + 1, newAcc);
      });
  };

  // Start the fold at index 0 with the initial accumulator acc.
  // step(0, acc) returns the initial thunk; trampoline runs it to completion.
  return trampoline(() => step(0, acc));
};