;;
;; exp8-freeze-thaw.scm — Freeze/Thaw Efficiency
;;
;; Hypothesis: A frozen (converged) compartment, when thawed with new data,
;; re-converges in significantly less time than training from scratch.
;;
;; Method: Train to convergence, freeze, add new sentences, compare
;; thaw (resume) time vs scratch (from zero) time.
;;
(define *exp8-results* '())
;; ─────────────────────────────────────────────────────────────────────
;; LOCAL CONVERGENCE CHECK
;; Mirrors cl-structure-exhausted? but uses local state, not globals.
;; ─────────────────────────────────────────────────────────────────────
(define (exp8-structure-exhausted? top-pair-score entropy-history merge-rounds-zero)
"Check convergence: noise floor, entropy plateau, or zero-merge rounds."
(or
;; Signal 1: top-pair cosine below noise floor
(< top-pair-score 0.15)
;; Signal 2: entropy plateaued
(and (>= (length entropy-history) 5)
(let* ((recent (take entropy-history 5))
(mean (/ (apply + recent) (length recent)))
(max-delta (apply max (map (lambda (h) (abs (- h mean))) recent))))
(< (/ max-delta (max mean 0.001)) 0.01)))
;; Signal 3: consecutive zero-merge rounds
(>= merge-rounds-zero 3)))
;; ─────────────────────────────────────────────────────────────────────
;; INCREMENTAL TRAINING
;; ─────────────────────────────────────────────────────────────────────
(define (exp8-train-loop sentences book-idx mi-cache pair-counts left-marg right-marg total-n
connector-index word-classes word-to-class
max-rounds batch-size)
"Train on sentences in batches until convergence or max-rounds.
Mutates all hash tables in place.
Returns (rounds time-ms final-classes top-pair-score entropy-history merge-rounds-zero)."
(let ((window 6)
(top-pair-score 1.0)
(entropy-history '())
(merge-rounds-zero 0)
(round 0)
(t0 (get-internal-real-time))
(sent-idx 0)
(n-sents (length sentences)))
(let loop ()
(when (and (< round max-rounds)
(not (exp8-structure-exhausted? top-pair-score entropy-history merge-rounds-zero))
(< sent-idx n-sents))
;; Process a batch of sentences
(let* ((batch-end (min (+ sent-idx batch-size) n-sents))
(batch (take (drop sentences sent-idx) (- batch-end sent-idx)))
;; Count new pairs from batch
(batch-stats (exp3-process-book book-idx batch window))
(new-pairs (list-ref batch-stats 0))
(new-left (list-ref batch-stats 1))
(new-right (list-ref batch-stats 2))
(new-n (list-ref batch-stats 3)))
;; Merge new stats into accumulator
(hash-for-each
(lambda (k v) (hash-set! pair-counts k (+ (hash-ref pair-counts k 0) v)))
new-pairs)
(hash-for-each
(lambda (k v) (hash-set! left-marg k (+ (hash-ref left-marg k 0) v)))
new-left)
(hash-for-each
(lambda (k v) (hash-set! right-marg k (+ (hash-ref right-marg k 0) v)))
new-right)
(set! total-n (+ total-n new-n))
;; Recompute MI
(let ((new-mi (exp3-compute-mi-from-stats pair-counts left-marg right-marg total-n)))
;; Replace MI cache
(hash-clear! mi-cache)
(hash-for-each (lambda (k v) (hash-set! mi-cache k v)) new-mi))
;; Build sections using this MI
(let ((saved-mi *mi-cache*))
(set! *mi-cache* mi-cache)
(let* ((sec-data (exp4-build-sections-from-book book-idx batch))
(sections (list-ref sec-data 0))
(sec-counts (list-ref sec-data 1))
(words (let ((wl '()))
(hash-for-each (lambda (w _) (set! wl (cons w wl))) sections)
wl))
(new-index (exp4-build-connector-index sections sec-counts words)))
(set! *mi-cache* saved-mi)
;; Merge new connectors into existing index
(hash-for-each
(lambda (w vec)
(let ((existing (hash-ref connector-index w #f)))
(if existing
(hash-for-each
(lambda (conn cnt)
(hash-set! existing conn (+ (hash-ref existing conn 0) cnt)))
vec)
(hash-set! connector-index w vec))))
new-index)
;; Run one clustering round
(let* ((all-words (let ((wl '()))
(hash-for-each (lambda (w _) (set! wl (cons w wl)))
connector-index)
wl))
;; Find top pair among unclassified words
(unclassified (filter (lambda (w) (not (hash-ref word-to-class w #f)))
all-words))
(best-pair #f)
(best-score 0.0))
;; Search for best pair (limit search to first 150 words for speed)
(let ((search-words (take unclassified (min 150 (length unclassified)))))
(do ((i 0 (+ i 1))) ((>= i (length search-words)))
(do ((j (+ i 1) (+ j 1))) ((>= j (length search-words)))
(let* ((w1 (list-ref search-words i))
(w2 (list-ref search-words j))
(sim (exp4-cosine-from-index connector-index w1 w2)))
(when (> sim best-score)
(set! best-score sim)
(set! best-pair (list w1 w2)))))))
(set! top-pair-score best-score)
;; Compute entropy for plateau detection
(let* ((n-words (hash-count (const #t) connector-index))
(n-classified (hash-count (const #t) word-to-class))
(entropy (if (> n-words 0) (/ n-classified n-words 1.0) 0.0)))
(set! entropy-history (cons entropy entropy-history))
(when (> (length entropy-history) 10)
(set! entropy-history (take entropy-history 10))))
;; Try to form a group if best pair is above noise floor
(if (and best-pair (> best-score 0.15))
(let ((group (exp4-find-in-group connector-index
(list-ref best-pair 0)
(list-ref best-pair 1)
unclassified
0.10 0.7 0.10 8)))
(if (>= (length group) 2)
(let ((class-id (hash-count (const #t) word-classes)))
(hash-set! word-classes class-id group)
(for-each (lambda (w) (hash-set! word-to-class w class-id))
group)
(set! merge-rounds-zero 0))
(set! merge-rounds-zero (+ merge-rounds-zero 1))))
(set! merge-rounds-zero (+ merge-rounds-zero 1))))))
(set! sent-idx batch-end)
(set! round (+ round 1))
(loop))))
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0))
(n-classes (hash-count (const #t) word-classes)))
(list round elapsed-ms n-classes top-pair-score entropy-history merge-rounds-zero
pair-counts left-marg right-marg total-n mi-cache connector-index
word-classes word-to-class))))
(define (run-exp8)
"Run Experiment 8: Freeze/Thaw Efficiency."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 8: Freeze/Thaw Efficiency~%")
(format #t "══════════════════════════════════════════════════~%~%")
(cl-load-all-corpus!)
(let* ((book-idx 4) ; moby (largest book)
(bname (vector-ref *cl-book-names* book-idx))
(all-book-sents (filter (lambda (e) (= (car e) book-idx)) *cl-all-sentences*))
(initial-n 500)
(additional-n 200)
(total-n-sents (+ initial-n additional-n))
(initial-sents (take all-book-sents (min initial-n (length all-book-sents))))
(all-sents (take all-book-sents (min total-n-sents (length all-book-sents))))
(additional-sents (drop all-sents initial-n))
(batch-size 50)
(max-rounds 30))
(format #t "Book: ~a~%" bname)
(format #t "Initial: ~a sentences, Additional: ~a sentences, Total: ~a~%~%"
(length initial-sents) (length additional-sents) (length all-sents))
;; ── PATH 1: Train to convergence on initial data, then FREEZE/THAW ──
(format #t "── Path 1: Train → Freeze → Thaw ──~%~%")
;; Phase A: Train on initial 500 sentences
(format #t "Phase A: Training on ~a initial sentences...~%" (length initial-sents))
(let* ((result-a (exp8-train-loop initial-sents book-idx
(make-hash-table) (make-hash-table)
(make-hash-table) (make-hash-table) 0
(make-hash-table) (make-hash-table) (make-hash-table)
max-rounds batch-size))
(rounds-a (list-ref result-a 0))
(time-a (list-ref result-a 1))
(classes-a (list-ref result-a 2))
(top-score-a (list-ref result-a 3))
(converged-a (exp8-structure-exhausted?
(list-ref result-a 3) (list-ref result-a 4) (list-ref result-a 5))))
(format #t " Initial training: ~a rounds, ~,1f ms, ~a classes~%"
rounds-a time-a classes-a)
(format #t " Top-pair: ~,3f, Converged: ~a~%~%" top-score-a converged-a)
;; FREEZE: Save state
(format #t "FREEZE: Saving state...~%")
(let ((frozen-pairs (hash-copy (list-ref result-a 6)))
(frozen-left (hash-copy (list-ref result-a 7)))
(frozen-right (hash-copy (list-ref result-a 8)))
(frozen-total-n (list-ref result-a 9))
(frozen-mi (hash-copy (list-ref result-a 10)))
(frozen-index (hash-copy (list-ref result-a 11)))
(frozen-classes (hash-copy (list-ref result-a 12)))
(frozen-w2c (hash-copy (list-ref result-a 13))))
;; Phase B: THAW — resume with additional sentences
(format #t "~%Phase B: THAW — adding ~a new sentences to frozen state...~%"
(length additional-sents))
(let* ((result-thaw (exp8-train-loop additional-sents book-idx
frozen-mi frozen-pairs
frozen-left frozen-right frozen-total-n
frozen-index frozen-classes frozen-w2c
max-rounds batch-size))
(rounds-thaw (list-ref result-thaw 0))
(time-thaw (list-ref result-thaw 1))
(classes-thaw (list-ref result-thaw 2))
(total-time-thaw (+ time-a time-thaw)))
(format #t " Thaw: ~a rounds, ~,1f ms, ~a classes~%"
rounds-thaw time-thaw classes-thaw)
(format #t " Total (train+thaw): ~,1f ms~%~%" total-time-thaw)
;; ── PATH 2: Train from SCRATCH on all sentences ──
(format #t "── Path 2: Train from Scratch ──~%~%")
(format #t "Training on all ~a sentences from zero...~%" (length all-sents))
(let* ((result-scratch (exp8-train-loop all-sents book-idx
(make-hash-table) (make-hash-table)
(make-hash-table) (make-hash-table) 0
(make-hash-table) (make-hash-table) (make-hash-table)
max-rounds batch-size))
(rounds-scratch (list-ref result-scratch 0))
(time-scratch (list-ref result-scratch 1))
(classes-scratch (list-ref result-scratch 2)))
(format #t " Scratch: ~a rounds, ~,1f ms, ~a classes~%~%"
rounds-scratch time-scratch classes-scratch)
;; ── COMPARISON ──
(format #t "── COMPARISON ──~%")
(format #t " Thaw path: ~,1f ms total (~,1f ms initial + ~,1f ms thaw)~%"
total-time-thaw time-a time-thaw)
(format #t " Scratch path: ~,1f ms~%" time-scratch)
(let* ((speedup (if (> time-thaw 0) (/ time-scratch time-thaw) 0.0))
(thaw-fraction (if (> time-scratch 0) (/ time-thaw time-scratch) 1.0))
(passed (< thaw-fraction 0.5)))
(format #t " Thaw time / Scratch time: ~,2f (~,1f% of scratch)~%"
thaw-fraction (* 100.0 thaw-fraction))
(format #t " Speedup for incremental update: ~,1fx~%" speedup)
(format #t " Thaw classes: ~a, Scratch classes: ~a~%"
classes-thaw classes-scratch)
(format #t " Thaw rounds: ~a, Scratch rounds: ~a~%"
rounds-thaw rounds-scratch)
(format #t "~%VERDICT: ~a~%"
(if passed
"Thaw converges in <50% of scratch time (CONFIRMED)"
"Thaw NOT significantly faster than scratch (REJECTED)"))
;; Store results
(set! *exp8-results*
(list time-a time-thaw total-time-thaw time-scratch
thaw-fraction speedup
classes-a classes-thaw classes-scratch
rounds-a rounds-thaw rounds-scratch
passed))
;; Write results
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp8-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 8: Freeze/Thaw Efficiency~%")
(format port "# Date: ~a~%" (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
(format port "# Book: ~a (initial ~a, additional ~a)~%" bname initial-n additional-n)
(format port "#~%")
(format port "initial_train_ms: ~,2f~%" time-a)
(format port "thaw_ms: ~,2f~%" time-thaw)
(format port "total_thaw_ms: ~,2f~%" total-time-thaw)
(format port "scratch_ms: ~,2f~%" time-scratch)
(format port "thaw_fraction: ~,4f~%" thaw-fraction)
(format port "speedup: ~,2f~%" speedup)
(format port "initial_classes: ~a~%" classes-a)
(format port "thaw_classes: ~a~%" classes-thaw)
(format port "scratch_classes: ~a~%" classes-scratch)
(format port "initial_rounds: ~a~%" rounds-a)
(format port "thaw_rounds: ~a~%" rounds-thaw)
(format port "scratch_rounds: ~a~%" rounds-scratch)
(format port "converged_initial: ~a~%" converged-a)
(format port "verdict: ~a~%" (if passed "CONFIRMED" "REJECTED"))))
(format #t "~%Results written to ~a~%" out-file)))))))))