;;
;; exp7-merge-quality.scm — Multi-Compartment Merge Quality
;;
;; Hypothesis: Three small compartments (each trained independently on
;; 500 sentences) produce, when merged, learning quality comparable to
;; one monolithic run on all 1500 sentences.
;;
;; Method: Full pipeline (count → MI → sections → connectors → cluster)
;; on 3 books independently, merge stats, re-pipeline, compare to monolithic.
;;
(define *exp7-results* '())
;; Cached compartment data for reuse by exp9
(define *exp7-compartments* '())
(define *exp7-merged-index* #f)
(define (exp7-full-pipeline sentences book-idx label n-sample max-groups)
"Run complete pipeline: count → MI → sections → connectors → cluster.
Returns (classes connector-index mi-cache stats mean-cosine)."
(let* ((sample (take sentences (min n-sample (length sentences))))
(window 6)
;; Step 1: Count pairs
(stats (exp3-process-book book-idx sample window))
(pair-counts (list-ref stats 0))
(left-marg (list-ref stats 1))
(right-marg (list-ref stats 2))
(total-n (list-ref stats 3))
;; Step 2: Compute MI
(mi (exp3-compute-mi-from-stats pair-counts left-marg right-marg total-n)))
(format #t " [~a] ~a pairs, N=~a, ~a MI entries~%"
label (hash-count (const #t) pair-counts) total-n
(hash-count (const #t) mi))
;; Step 3: Build sections using local MI for parsing
;; We need to temporarily set *mi-cache* so cpu-pmfg-parse uses our MI
(let ((saved-mi *mi-cache*))
(set! *mi-cache* mi)
(let* ((sec-data (exp4-build-sections-from-book book-idx sample))
(sections (list-ref sec-data 0))
(sec-counts (list-ref sec-data 1))
;; Step 4: Build connector index
(words (let ((wl '()))
(hash-for-each (lambda (w _) (set! wl (cons w wl))) sections)
wl))
(index (exp4-build-connector-index sections sec-counts words)))
(set! *mi-cache* saved-mi)
(format #t " [~a] ~a words with sections, ~a in connector index~%"
label (hash-count (const #t) sections)
(hash-count (const #t) index))
;; Step 5: Cluster
(let* ((classes (exp4-cluster-domain index words max-groups))
;; Compute mean intra-class cosine
(cosines (map (lambda (c) (exp4-intra-class-similarity index c))
classes))
(mean-cos (if (null? cosines) 0.0
(/ (apply + cosines) (length cosines)))))
(format #t " [~a] ~a classes, mean intra-class cosine: ~,3f~%"
label (length classes) mean-cos)
(list classes index mi stats mean-cos))))))
(define (run-exp7)
"Run Experiment 7: Multi-Compartment Merge Quality."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 7: Multi-Compartment Merge Quality~%")
(format #t "══════════════════════════════════════════════════~%~%")
(cl-load-all-corpus!)
(let* ((n-sentences 500)
(max-groups 15)
(book-indices (list 0 1 2)) ; alice, pride, sherlock
(t0 (get-internal-real-time)))
;; Step 1: Run independent compartments
(format #t "Step 1: Running 3 independent compartments (~a sentences each)...~%~%" n-sentences)
(let* ((comp-results
(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*)))
(cons bname
(exp7-full-pipeline book-sents book-idx
(format #f "comp-~a" bname)
n-sentences max-groups))))
book-indices))
;; Extract per-compartment metrics
(comp-class-counts (map (lambda (r) (length (cadr r))) comp-results))
(comp-cosines (map (lambda (r) (list-ref (cdr r) 4)) comp-results)))
(format #t "~% Per-compartment summary:~%")
(for-each
(lambda (r)
(format #t " ~a: ~a classes, mean cosine ~,3f~%"
(car r) (length (cadr r)) (list-ref (cdr r) 4)))
comp-results)
;; Cache for exp9
(set! *exp7-compartments* comp-results)
;; Step 2: Merge stats from all 3 compartments
(format #t "~%Step 2: Merging stats from 3 compartments...~%")
(let* ((all-stats (map (lambda (r) (list-ref (cdr r) 3)) comp-results))
(merged (exp3-merge-stats all-stats))
(merged-pairs (list-ref merged 0))
(merged-left (list-ref merged 1))
(merged-right (list-ref merged 2))
(merged-n (list-ref merged 3))
(merged-mi (exp3-compute-mi-from-stats merged-pairs merged-left
merged-right merged-n)))
(format #t " Merged: ~a pairs, N=~a, ~a MI entries~%"
(hash-count (const #t) merged-pairs) merged-n
(hash-count (const #t) merged-mi))
;; Step 3: Build sections + cluster from merged MI
(format #t "~%Step 3: Pipeline on merged stats...~%")
(let* ((all-sentences '())
(_ (for-each
(lambda (book-idx)
(let* ((book-sents (filter (lambda (e) (= (car e) book-idx))
*cl-all-sentences*))
(sample (take book-sents (min n-sentences (length book-sents)))))
(set! all-sentences (append all-sentences sample))))
book-indices))
;; Use merged MI for parsing
(saved-mi *mi-cache*))
(set! *mi-cache* merged-mi)
(let* ((sec-data (exp4-build-sections-from-book -1 all-sentences))
(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))
(merged-index (exp4-build-connector-index sections sec-counts words))
(merged-classes (exp4-cluster-domain merged-index words max-groups))
(merged-cosines (map (lambda (c) (exp4-intra-class-similarity merged-index c))
merged-classes))
(merged-mean-cos (if (null? merged-cosines) 0.0
(/ (apply + merged-cosines) (length merged-cosines)))))
(set! *mi-cache* saved-mi)
;; Cache for exp9
(set! *exp7-merged-index* merged-index)
(format #t " Merged pipeline: ~a classes, mean cosine ~,3f~%"
(length merged-classes) merged-mean-cos)
;; Step 4: Monolithic run (all 1500 sentences as one)
(format #t "~%Step 4: Monolithic run (~a sentences pooled)...~%"
(length all-sentences))
(let* ((mono-result (exp7-full-pipeline all-sentences -1 "monolithic"
(* n-sentences 3) max-groups))
(mono-classes (list-ref mono-result 0))
(mono-index (list-ref mono-result 1))
(mono-cosines (map (lambda (c) (exp4-intra-class-similarity mono-index c))
mono-classes))
(mono-mean-cos (if (null? mono-cosines) 0.0
(/ (apply + mono-cosines) (length mono-cosines)))))
;; Step 5: Compare merged vs monolithic
(format #t "~%── COMPARISON ──~%")
(format #t " Merged: ~a classes, mean cosine ~,3f~%"
(length merged-classes) merged-mean-cos)
(format #t " Monolithic: ~a classes, mean cosine ~,3f~%"
(length mono-classes) mono-mean-cos)
;; Class member overlap via connector-cosine
(let* ((merged-flat (apply append merged-classes))
(mono-flat (apply append mono-classes))
(overlap (length (filter (lambda (w) (member w mono-flat))
merged-flat)))
(class-ratio (if (> (length mono-classes) 0)
(/ (length merged-classes)
(length mono-classes) 1.0)
0.0))
(cosine-ratio (if (> mono-mean-cos 0.0)
(/ merged-mean-cos mono-mean-cos)
1.0))
(total-time-ms (/ (- (get-internal-real-time) t0) 1000000.0))
(passed (and (> cosine-ratio 0.8)
(< (abs (- class-ratio 1.0)) 0.2))))
(format #t " Class count ratio (merged/mono): ~,2f~%" class-ratio)
(format #t " Cosine quality ratio (merged/mono): ~,2f~%" cosine-ratio)
(format #t " Classified word overlap: ~a words in both~%" overlap)
(format #t " Total time: ~,1f ms~%" total-time-ms)
;; Per-compartment classes for display
(format #t "~%── Merged Classes ──~%")
(for-each
(lambda (class)
(let ((sim (exp4-intra-class-similarity merged-index class)))
(format #t " [~,3f] ~a~%" sim (string-join class ", "))))
merged-classes)
(format #t "~%── Monolithic Classes ──~%")
(for-each
(lambda (class)
(let ((sim (exp4-intra-class-similarity mono-index class)))
(format #t " [~,3f] ~a~%" sim (string-join class ", "))))
mono-classes)
(format #t "~%VERDICT: ~a~%"
(if passed
"Merged quality within 20% of monolithic (CONFIRMED)"
"Merged quality too far from monolithic (REJECTED)"))
;; Store results
(set! *exp7-results*
(list (length merged-classes) (length mono-classes)
merged-mean-cos mono-mean-cos
class-ratio cosine-ratio
overlap passed))
;; Write results
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp7-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 7: Multi-Compartment Merge Quality~%")
(format port "# Date: ~a~%" (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
(format port "# Books: alice, pride, sherlock (~a sentences each)~%" n-sentences)
(format port "#~%")
(format port "merged_classes: ~a~%" (length merged-classes))
(format port "monolithic_classes: ~a~%" (length mono-classes))
(format port "merged_mean_cosine: ~,4f~%" merged-mean-cos)
(format port "monolithic_mean_cosine: ~,4f~%" mono-mean-cos)
(format port "class_ratio: ~,4f~%" class-ratio)
(format port "cosine_ratio: ~,4f~%" cosine-ratio)
(format port "word_overlap: ~a~%" overlap)
(format port "total_time_ms: ~,2f~%" total-time-ms)
(format port "verdict: ~a~%" (if passed "CONFIRMED" "REJECTED"))
(format port "#~%# Per-compartment:~%")
(for-each
(lambda (r)
(format port "comp_~a: ~a classes, cosine ~,4f~%"
(car r) (length (cadr r)) (list-ref (cdr r) 4)))
comp-results)
(format port "#~%# Merged classes:~%")
(for-each
(lambda (c) (format port "merged_class: ~a~%" (string-join c ",")))
merged-classes)
(format port "#~%# Monolithic classes:~%")
(for-each
(lambda (c) (format port "mono_class: ~a~%" (string-join c ",")))
mono-classes)))
(format #t "~%Results written to ~a~%" out-file)))))))))))