;;
;; exp10-attention.scm — Surprise-Based Attention Allocation
;;
;; Hypothesis: Allocating more sentences to high-surprise compartments
;; produces faster overall convergence than round-robin allocation.
;;
;; Method: Create 3 compartments, run 600 sentences with two strategies:
;; (A) round-robin and (B) surprise-weighted. Compare final quality.
;;
(define *exp10-results* '())
;; ─────────────────────────────────────────────────────────────────────
;; MINI SURPRISE COMPUTATION
;; ─────────────────────────────────────────────────────────────────────
(define (exp10-compute-surprise mi-cache sentences book-idx)
"Compute mean surprise for a set of sentences using the given MI cache.
Surprise = 10 - avg_MI(parse_edges) for each sentence."
(if (null? sentences) 10.0
(let ((surprises '())
(saved-mi *mi-cache*))
(set! *mi-cache* mi-cache)
(for-each
(lambda (entry)
(let* ((sentence (cdr entry))
(words (filter (lambda (w) (> (string-length w) 0))
(string-split sentence #\space)))
(edges (cpu-pmfg-parse words)))
(if (null? edges) (set! surprises (cons 10.0 surprises))
(let* ((mi-values (map car edges))
(avg-mi (/ (apply + mi-values) (max 1 (length mi-values)))))
(set! surprises (cons (max 0.0 (- 10.0 avg-mi)) surprises))))))
sentences)
(set! *mi-cache* saved-mi)
(if (null? surprises) 10.0
(/ (apply + surprises) (length surprises))))))
;; ─────────────────────────────────────────────────────────────────────
;; COMPARTMENT STATE FOR ATTENTION EXPERIMENT
;; ─────────────────────────────────────────────────────────────────────
(define (exp10-make-comp id name all-sentences)
"Create attention experiment compartment with sentence pool."
(list
(cons 'id id)
(cons 'name name)
(cons 'all-sentences all-sentences)
(cons 'pair-counts (make-hash-table))
(cons 'left-marg (make-hash-table))
(cons 'right-marg (make-hash-table))
(cons 'total-n 0)
(cons 'mi-cache (make-hash-table))
(cons 'connector-index (make-hash-table))
(cons 'word-classes (make-hash-table))
(cons 'word-to-class (make-hash-table))
(cons 'sentences-fed 0)
(cons 'mean-surprise 10.0)
(cons 'n-classes 0)))
(define (exp10-ref comp key)
(let ((p (assq key comp))) (if p (cdr p) (error "bad key" key))))
(define (exp10-set! comp key val)
(let ((p (assq key comp))) (if p (set-cdr! p val) (error "bad key" key))))
(define (exp10-feed-batch! comp batch-size)
"Feed batch-size sentences to compartment, update stats + MI + sections + cluster.
Returns number of sentences actually fed."
(let* ((id (exp10-ref comp 'id))
(all-sents (exp10-ref comp 'all-sentences))
(already-fed (exp10-ref comp 'sentences-fed))
(remaining (- (length all-sents) already-fed))
(n-feed (min batch-size remaining))
(window 6))
(when (> n-feed 0)
(let* ((batch (take (drop all-sents already-fed) n-feed))
;; Count new pairs
(stats (exp3-process-book id batch window))
(new-pairs (list-ref stats 0))
(new-left (list-ref stats 1))
(new-right (list-ref stats 2))
(new-n (list-ref stats 3))
(pair-counts (exp10-ref comp 'pair-counts))
(left-marg (exp10-ref comp 'left-marg))
(right-marg (exp10-ref comp 'right-marg)))
;; Merge into compartment
(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)
(exp10-set! comp 'total-n (+ (exp10-ref comp 'total-n) new-n))
;; Recompute MI
(let ((mi (exp3-compute-mi-from-stats pair-counts left-marg right-marg
(exp10-ref comp 'total-n))))
(exp10-set! comp 'mi-cache mi)
;; Build sections + update connector index
(let ((saved-mi *mi-cache*))
(set! *mi-cache* mi)
(let* ((sec-data (exp4-build-sections-from-book id 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))
(index (exp10-ref comp 'connector-index)))
(set! *mi-cache* saved-mi)
;; Merge connector index
(hash-for-each
(lambda (w vec)
(let ((existing (hash-ref index w #f)))
(if existing
(hash-for-each
(lambda (conn cnt)
(hash-set! existing conn (+ (hash-ref existing conn 0) cnt)))
vec)
(hash-set! index w vec))))
new-index)
;; One clustering attempt
(let* ((all-words (let ((wl '()))
(hash-for-each (lambda (w _) (set! wl (cons w wl))) index)
wl))
(w2c (exp10-ref comp 'word-to-class))
(unclassified (filter (lambda (w) (not (hash-ref w2c w #f))) all-words))
(search-words (take unclassified (min 100 (length unclassified))))
(best-pair #f)
(best-score 0.0))
(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 index w1 w2)))
(when (> sim best-score)
(set! best-score sim)
(set! best-pair (list w1 w2))))))
(when (and best-pair (> best-score 0.15))
(let ((group (exp4-find-in-group index
(list-ref best-pair 0)
(list-ref best-pair 1)
unclassified
0.10 0.7 0.10 8))
(wc (exp10-ref comp 'word-classes)))
(when (>= (length group) 2)
(let ((class-id (hash-count (const #t) wc)))
(hash-set! wc class-id group)
(for-each (lambda (w) (hash-set! w2c w class-id)) group)))))
(exp10-set! comp 'n-classes
(hash-count (const #t) (exp10-ref comp 'word-classes)))))))
;; Update surprise (sample 20 recent sentences for speed)
(let* ((sample-sents (take batch (min 20 (length batch))))
(surprise (exp10-compute-surprise (exp10-ref comp 'mi-cache)
sample-sents id)))
(exp10-set! comp 'mean-surprise surprise))
(exp10-set! comp 'sentences-fed (+ already-fed n-feed))))
n-feed))
;; ─────────────────────────────────────────────────────────────────────
;; STRATEGIES
;; ─────────────────────────────────────────────────────────────────────
(define (exp10-run-strategy comps strategy-name allocator total-batches batch-size)
"Run an allocation strategy. allocator: (comps round) -> comp to feed.
Returns list of per-round metrics."
(format #t "~% Running ~a strategy (~a batches of ~a)...~%"
strategy-name total-batches batch-size)
(let ((metrics '()))
(do ((round 0 (+ round 1))) ((>= round total-batches))
(let* ((target-comp (allocator comps round))
(name (exp10-ref target-comp 'name))
(fed (exp10-feed-batch! target-comp batch-size)))
;; Collect per-round metrics
(let ((round-metrics
(map (lambda (c)
(list (exp10-ref c 'name)
(exp10-ref c 'mean-surprise)
(exp10-ref c 'n-classes)
(exp10-ref c 'sentences-fed)))
comps)))
(set! metrics (cons (cons round round-metrics) metrics)))))
(reverse metrics)))
(define (run-exp10)
"Run Experiment 10: Surprise-Based Attention Allocation."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 10: Surprise-Based Attention Allocation~%")
(format #t "══════════════════════════════════════════════════~%~%")
(cl-load-all-corpus!)
(let* ((book-indices (list 0 1 4)) ; alice, pride, moby
(bootstrap-n 200)
(additional-n 200) ; per book (600 total)
(batch-size 50)
(total-batches (/ (* additional-n (length book-indices)) batch-size)) ;; 12 batches
(t0 (get-internal-real-time)))
(format #t "Books: ~a~%"
(string-join (map (lambda (i) (vector-ref *cl-book-names* i)) book-indices) ", "))
(format #t "Bootstrap: ~a sentences each, Additional: ~a per book~%"
bootstrap-n additional-n)
(format #t "Total additional: ~a sentences in ~a batches of ~a~%~%"
(* additional-n (length book-indices)) total-batches batch-size)
;; ── Create and bootstrap compartments for BOTH strategies ──
(define (make-strategy-comps)
(map (lambda (book-idx)
(let* ((bname (vector-ref *cl-book-names* book-idx))
(book-sents (filter (lambda (e) (= (car e) book-idx))
*cl-all-sentences*))
(bootstrap-sents (take book-sents (min bootstrap-n (length book-sents))))
;; Remaining sentences for additional feeding
(remaining (drop book-sents (min bootstrap-n (length book-sents))))
(additional (take remaining (min additional-n (length remaining))))
(comp (exp10-make-comp book-idx bname additional)))
;; Bootstrap with initial sentences
(let* ((window 6)
(stats (exp3-process-book book-idx bootstrap-sents window)))
(hash-for-each
(lambda (k v) (hash-set! (exp10-ref comp 'pair-counts) k v))
(list-ref stats 0))
(hash-for-each
(lambda (k v) (hash-set! (exp10-ref comp 'left-marg) k v))
(list-ref stats 1))
(hash-for-each
(lambda (k v) (hash-set! (exp10-ref comp 'right-marg) k v))
(list-ref stats 2))
(exp10-set! comp 'total-n (list-ref stats 3))
(let ((mi (exp3-compute-mi-from-stats
(list-ref stats 0) (list-ref stats 1)
(list-ref stats 2) (list-ref stats 3))))
(exp10-set! comp 'mi-cache mi))
;; Initial surprise
(let ((surprise (exp10-compute-surprise
(exp10-ref comp 'mi-cache)
(take bootstrap-sents (min 20 (length bootstrap-sents)))
book-idx)))
(exp10-set! comp 'mean-surprise surprise)))
comp))
book-indices))
;; ── Strategy A: Round-Robin ──
(format #t "═══ Strategy A: Round-Robin ═══~%")
(let* ((comps-a (make-strategy-comps))
(t-a (get-internal-real-time))
(rr-allocator (lambda (comps round)
(list-ref comps (modulo round (length comps)))))
(metrics-a (exp10-run-strategy comps-a "round-robin" rr-allocator
total-batches batch-size))
(time-a (/ (- (get-internal-real-time) t-a) 1000000.0)))
;; ── Strategy B: Surprise-Weighted ──
(format #t "~%═══ Strategy B: Surprise-Weighted ═══~%")
(let* ((comps-b (make-strategy-comps))
(t-b (get-internal-real-time))
(surprise-allocator
(lambda (comps round)
;; Pick compartment with highest surprise
(let ((best-comp (car comps))
(best-surprise (exp10-ref (car comps) 'mean-surprise)))
(for-each
(lambda (c)
(let ((s (exp10-ref c 'mean-surprise)))
(when (> s best-surprise)
(set! best-comp c)
(set! best-surprise s))))
(cdr comps))
best-comp)))
(metrics-b (exp10-run-strategy comps-b "surprise-weighted"
surprise-allocator
total-batches batch-size))
(time-b (/ (- (get-internal-real-time) t-b) 1000000.0)))
;; ── Comparison ──
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " COMPARISON~%")
(format #t "══════════════════════════════════════════════════~%~%")
;; Final state per compartment
(format #t " Strategy A (Round-Robin):~%")
(let ((total-surprise-a 0.0) (total-classes-a 0))
(for-each
(lambda (c)
(let ((s (exp10-ref c 'mean-surprise))
(n (exp10-ref c 'n-classes))
(fed (exp10-ref c 'sentences-fed)))
(set! total-surprise-a (+ total-surprise-a s))
(set! total-classes-a (+ total-classes-a n))
(format #t " ~a: surprise=~,2f, classes=~a, sentences=~a~%"
(exp10-ref c 'name) s n fed)))
comps-a)
(format #t "~% Strategy B (Surprise-Weighted):~%")
(let ((total-surprise-b 0.0) (total-classes-b 0))
(for-each
(lambda (c)
(let ((s (exp10-ref c 'mean-surprise))
(n (exp10-ref c 'n-classes))
(fed (exp10-ref c 'sentences-fed)))
(set! total-surprise-b (+ total-surprise-b s))
(set! total-classes-b (+ total-classes-b n))
(format #t " ~a: surprise=~,2f, classes=~a, sentences=~a~%"
(exp10-ref c 'name) s n fed)))
comps-b)
;; Attention distribution in strategy B
(format #t "~% Attention distribution (Strategy B):~%")
(for-each
(lambda (c)
(format #t " ~a got ~a sentences (~,1f%)~%"
(exp10-ref c 'name)
(exp10-ref c 'sentences-fed)
(if (> (* additional-n (length book-indices)) 0)
(* 100.0 (/ (exp10-ref c 'sentences-fed)
(* additional-n (length book-indices)) 1.0))
0.0)))
comps-b)
;; Summary
(let* ((mean-surprise-a (/ total-surprise-a (length comps-a)))
(mean-surprise-b (/ total-surprise-b (length comps-b)))
(surprise-improvement (if (> mean-surprise-a 0)
(- 1.0 (/ mean-surprise-b mean-surprise-a))
0.0))
(passed (and (< mean-surprise-b mean-surprise-a)
(>= total-classes-b total-classes-a))))
(format #t "~%── SUMMARY ──~%")
(format #t " Mean surprise A: ~,3f~%" mean-surprise-a)
(format #t " Mean surprise B: ~,3f~%" mean-surprise-b)
(format #t " Surprise reduction: ~,1f%~%" (* 100.0 surprise-improvement))
(format #t " Total classes A: ~a~%" total-classes-a)
(format #t " Total classes B: ~a~%" total-classes-b)
(format #t " Time A: ~,1f ms, Time B: ~,1f ms~%" time-a time-b)
(format #t "~%VERDICT: ~a~%"
(cond
((and (< mean-surprise-b mean-surprise-a)
(>= total-classes-b total-classes-a))
"Surprise-weighted produces lower surprise AND equal-or-better classes (CONFIRMED)")
((< mean-surprise-b mean-surprise-a)
"Lower surprise but fewer classes (PARTIALLY CONFIRMED)")
((>= total-classes-b total-classes-a)
"More classes but higher surprise (PARTIALLY CONFIRMED)")
(else
"Round-robin performs equally or better (REJECTED)")))
;; Store results
(set! *exp10-results*
(list mean-surprise-a mean-surprise-b
total-classes-a total-classes-b
surprise-improvement
time-a time-b passed))
;; Write results
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp10-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 10: Surprise-Based Attention Allocation~%")
(format port "# Date: ~a~%" (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
(format port "# Books: alice, pride, moby~%")
(format port "# Bootstrap: ~a, Additional: ~a per book~%" bootstrap-n additional-n)
(format port "#~%")
(format port "mean_surprise_roundrobin: ~,4f~%" mean-surprise-a)
(format port "mean_surprise_weighted: ~,4f~%" mean-surprise-b)
(format port "surprise_improvement: ~,4f~%" surprise-improvement)
(format port "total_classes_roundrobin: ~a~%" total-classes-a)
(format port "total_classes_weighted: ~a~%" total-classes-b)
(format port "time_roundrobin_ms: ~,2f~%" time-a)
(format port "time_weighted_ms: ~,2f~%" time-b)
(format port "verdict: ~a~%" (if passed "CONFIRMED" "REJECTED"))
(format port "#~%# Per-compartment final state (round-robin):~%")
(for-each
(lambda (c)
(format port "rr_~a: surprise=~,3f classes=~a fed=~a~%"
(exp10-ref c 'name) (exp10-ref c 'mean-surprise)
(exp10-ref c 'n-classes) (exp10-ref c 'sentences-fed)))
comps-a)
(format port "#~%# Per-compartment final state (surprise-weighted):~%")
(for-each
(lambda (c)
(format port "sw_~a: surprise=~,3f classes=~a fed=~a~%"
(exp10-ref c 'name) (exp10-ref c 'mean-surprise)
(exp10-ref c 'n-classes) (exp10-ref c 'sentences-fed)))
comps-b)))
(format #t "~%Results written to ~a~%" out-file))))))))))