;;
;; compartment.scm — Compartmentalized Learning System
;;
;; Load after corpus-learning.scm in CogServer:
;; (load "compartment.scm")
;; (compartment-init!)
;; (compartment-run 100)
;;
;; Architecture:
;; 5 compartments (one per Gutenberg book), each with isolated state.
;; Coordinator runs round-robin batches, periodically merges all stats,
;; then runs full pipeline (MI → sections → connectors → clustering → grammar).
;; Polysemy detected via MI-neighborhood divergence (exp9c).
;;
;; Validated by experiments:
;; exp6: swap-globals isolation (zero leaks)
;; exp7: merge ≡ monolithic (bit-for-bit identical)
;; exp8: freeze/thaw 2.9x faster than scratch
;; exp9c: MI-neighborhood divergence (2.1% polysemy rate)
;; exp10: round-robin first, surprise-weighted after >1000 sent/comp
;;
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-13))
(use-modules (ice-9 regex))
;; Load experiment utilities for merge
(let ((exp3-file (string-append *mvp-dir* "/experiments/exp3-merge-stats.scm")))
(when (file-exists? exp3-file)
(load exp3-file)))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 1: COMPARTMENT DATA STRUCTURE
;; ═══════════════════════════════════════════════════════════════════
(define (make-compartment id name book-file)
"Create a compartment with isolated state for one book.
ID: integer index. NAME: short string. BOOK-FILE: path to corpus."
(list
;; Identity
(cons 'id id)
(cons 'name name)
(cons 'book-file book-file)
(cons 'sentences '()) ; loaded sentences (list of strings)
;; Per-compartment state (swapped in/out of globals)
(cons 'mi-cache (make-hash-table))
(cons 'left-marg (make-hash-table))
(cons 'right-marg (make-hash-table))
(cons 'total-n 0)
(cons 'word-classes (make-hash-table))
(cons 'word-to-class (make-hash-table))
(cons 'sections (make-hash-table))
(cons 'section-counts (make-hash-table))
(cons 'connector-index (make-hash-table))
(cons 'dirty-pairs (make-hash-table))
(cons 'dirty-count 0)
(cons 'word-surprise (make-hash-table)) ; word → surprise (EMA)
(cons 'baseline-mi 0.0) ; mean MI for this compartment
;; Lifecycle
(cons 'state 'learning) ; learning | frozen | thawed
(cons 'sentences-processed 0)
(cons 'sentence-cursor 0) ; next sentence index to process
(cons 'mean-surprise 10.0)
(cons 'top-pair-score 1.0)
(cons 'entropy-history '())
(cons 'merge-rounds-zero 0)
(cons 'class-count 0)
(cons 'next-class-id 0)
(cons 'last-merge-at 0) ; sentence count at last merge
;; Chapter tracking (populated by comp-init-chapters!)
(cons 'chapters '()) ; list of chapter names
(cons 'chapter-words (make-hash-table)) ; chapter-name → hash-set of words
(cons 'chapter-lines (make-hash-table)))) ; chapter-name → (start . end)
(define (comp-ref comp key)
"Get value from compartment alist."
(let ((pair (assq key comp)))
(if pair (cdr pair)
(error (format #f "comp-ref: unknown key ~a" key)))))
(define (comp-set! comp key value)
"Set value in compartment alist (mutates the pair in place)."
(let ((pair (assq key comp)))
(if pair (set-cdr! pair value)
(error (format #f "comp-set!: unknown key ~a" key)))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 2: GLOBAL SWAP PROTOCOL
;; ═══════════════════════════════════════════════════════════════════
;;
;; 11 globals swapped per compartment. Proven zero-leak by exp6.
;; "Parking" holds the original globals while a compartment is active.
(define *comp-parking* #f) ; saved globals while compartment is swapped in
(define (comp-swap-in! comp)
"Save current globals to parking, install compartment's tables."
(set! *comp-parking*
(list *mi-cache* *left-marginals* *right-marginals* *total-pair-count*
*word-classes* *word-to-class* *sections* *section-counts*
*cl-connector-index* *cl-dirty-pairs* *cl-dirty-count*
*next-class-id*))
;; Install compartment state
(set! *mi-cache* (comp-ref comp 'mi-cache))
(set! *left-marginals* (comp-ref comp 'left-marg))
(set! *right-marginals* (comp-ref comp 'right-marg))
(set! *total-pair-count* (comp-ref comp 'total-n))
(set! *word-classes* (comp-ref comp 'word-classes))
(set! *word-to-class* (comp-ref comp 'word-to-class))
(set! *sections* (comp-ref comp 'sections))
(set! *section-counts* (comp-ref comp 'section-counts))
(set! *cl-connector-index* (comp-ref comp 'connector-index))
(set! *cl-dirty-pairs* (comp-ref comp 'dirty-pairs))
(set! *cl-dirty-count* (comp-ref comp 'dirty-count))
(set! *next-class-id* (comp-ref comp 'next-class-id)))
(define (comp-swap-out! comp)
"Save globals back into compartment, restore from parking."
;; Save back to compartment
(comp-set! comp 'mi-cache *mi-cache*)
(comp-set! comp 'left-marg *left-marginals*)
(comp-set! comp 'right-marg *right-marginals*)
(comp-set! comp 'total-n *total-pair-count*)
(comp-set! comp 'word-classes *word-classes*)
(comp-set! comp 'word-to-class *word-to-class*)
(comp-set! comp 'sections *sections*)
(comp-set! comp 'section-counts *section-counts*)
(comp-set! comp 'connector-index *cl-connector-index*)
(comp-set! comp 'dirty-pairs *cl-dirty-pairs*)
(comp-set! comp 'dirty-count *cl-dirty-count*)
(comp-set! comp 'next-class-id *next-class-id*)
(comp-set! comp 'class-count (hash-count (const #t) *word-classes*))
;; Restore parking
(set! *mi-cache* (list-ref *comp-parking* 0))
(set! *left-marginals* (list-ref *comp-parking* 1))
(set! *right-marginals* (list-ref *comp-parking* 2))
(set! *total-pair-count* (list-ref *comp-parking* 3))
(set! *word-classes* (list-ref *comp-parking* 4))
(set! *word-to-class* (list-ref *comp-parking* 5))
(set! *sections* (list-ref *comp-parking* 6))
(set! *section-counts* (list-ref *comp-parking* 7))
(set! *cl-connector-index* (list-ref *comp-parking* 8))
(set! *cl-dirty-pairs* (list-ref *comp-parking* 9))
(set! *cl-dirty-count* (list-ref *comp-parking* 10))
(set! *next-class-id* (list-ref *comp-parking* 11))
(set! *comp-parking* #f))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 3: LEARNING PIPELINE
;; ═══════════════════════════════════════════════════════════════════
(define (comp-count-and-compute! words)
"Count word pairs in sliding window. Stores pair counts in *cl-dirty-pairs*
(key → count) and updates marginals. No CogServer Edge atoms."
(let ((n (length words))
(window 6))
(do ((i 0 (+ i 1))) ((>= i n))
(do ((j (+ i 1) (+ j 1))) ((or (>= j n) (> (- j i) window)))
(let* ((w1 (list-ref words i))
(w2 (list-ref words j))
(key (cons w1 w2)))
;; Track in dirty set
(hash-set! *cl-dirty-pairs* key
(+ (hash-ref *cl-dirty-pairs* key 0) 1))
(set! *cl-dirty-count* (+ *cl-dirty-count* 1))
;; Update marginals
(hash-set! *left-marginals* w1
(+ (hash-ref *left-marginals* w1 0) 1))
(hash-set! *right-marginals* w2
(+ (hash-ref *right-marginals* w2 0) 1))
(set! *total-pair-count* (+ *total-pair-count* 1)))))))
(define (comp-batch-mi!)
"Compute MI for all tracked pairs from sufficient statistics.
dirty-pairs stores (w1 . w2) → count. This IS the pair-counts hash."
(let ((n (exact->inexact *total-pair-count*)))
(when (> n 0)
(hash-clear! *mi-cache*)
(hash-for-each
(lambda (key count)
(let* ((w1 (car key))
(w2 (cdr key))
(left-m (hash-ref *left-marginals* w1 1))
(right-m (hash-ref *right-marginals* w2 1)))
(when (and (> count 0) (> left-m 0) (> right-m 0))
(let* ((p-pair (/ count n))
(p-left (/ left-m n))
(p-right (/ right-m n))
(mi (/ (log (/ p-pair (* p-left p-right))) (log 2))))
(hash-set! *mi-cache* key mi)
;; Symmetric entry for lookups
(hash-set! *mi-cache* (cons w2 w1) mi)))))
*cl-dirty-pairs*))))
(define (comp-extract-sections! words)
"Extract sections from PMFG parse. Uses swapped-in *mi-cache* for parsing."
(let ((edges (cpu-pmfg-parse words)))
(cl-l0-extract-sections! words edges)
edges))
(define (comp-learn-batch! comp n-sentences)
"Process a batch of sentences in one compartment.
Returns number of sentences actually processed."
(let* ((sents (comp-ref comp 'sentences))
(cursor (comp-ref comp 'sentence-cursor))
(total (length sents))
(actual (min n-sentences (- total cursor)))
(surprise-sum 0.0)
(surprise-count 0))
(when (> actual 0)
;; Swap in compartment state
(comp-swap-in! comp)
;; Restore convergence globals from compartment metadata
(set! *cl-top-pair-score* (comp-ref comp 'top-pair-score))
(set! *cl-entropy-history* (comp-ref comp 'entropy-history))
(set! *cl-merge-rounds-zero* (comp-ref comp 'merge-rounds-zero))
;; Process sentences
(do ((i 0 (+ i 1))) ((>= i actual))
(let* ((sent (list-ref sents (+ cursor i)))
(words (filter (lambda (w) (> (string-length w) 0))
(string-split sent #\space))))
(when (> (length words) 2)
;; Tag words with chapter
(comp-tag-sentence-chapter! comp (+ cursor i) words)
;; Count pairs (stores counts in dirty-pairs)
(comp-count-and-compute! words)
;; Track surprise for allocation
(let ((edges (cpu-pmfg-parse words)))
(let ((surprise (cl-compute-surprise edges)))
(set! surprise-sum (+ surprise-sum surprise))
(set! surprise-count (+ surprise-count 1)))
;; Per-word surprise: baseline - avg_MI(edges touching word)
(let ((n-words (length words))
(baseline (comp-ref comp 'baseline-mi))
(ws-table (comp-ref comp 'word-surprise)))
(do ((k 0 (+ k 1))) ((>= k n-words))
(let* ((w (list-ref words k))
(my-edges (filter (lambda (e)
(or (= (car e) k) (= (cadr e) k)))
edges))
(word-sur
(if (null? my-edges)
10.0 ; isolated = max surprise
(let ((avg (/ (apply + (map caddr my-edges))
(length my-edges))))
(max 0.0 (- baseline avg)))))
(old (hash-ref ws-table w #f)))
(hash-set! ws-table w
(if old
(+ (* 0.1 word-sur) (* 0.9 old))
word-sur)))))
;; Extract sections
(cl-l0-extract-sections! words edges)))))
;; Batch MI recompute
(comp-batch-mi!)
;; Update compartment baseline MI (mean of all MI values)
(let ((mi-sum 0.0) (mi-cnt 0))
(hash-for-each
(lambda (key val)
(when (and (pair? key) (number? val) (> val 0))
(set! mi-sum (+ mi-sum val))
(set! mi-cnt (+ mi-cnt 1))))
*mi-cache*)
(when (> mi-cnt 0)
(comp-set! comp 'baseline-mi (/ mi-sum mi-cnt))))
;; Build connector index for clustering
(let ((freq-words (comp-high-freq-words 30)))
(when (> (length freq-words) 5)
(cl-build-connector-index! freq-words)
;; One clustering round
(cl-l0-cluster!)))
;; Update metadata
(comp-set! comp 'sentence-cursor (+ cursor actual))
(comp-set! comp 'sentences-processed
(+ (comp-ref comp 'sentences-processed) actual))
(when (> surprise-count 0)
(comp-set! comp 'mean-surprise (/ surprise-sum surprise-count)))
(comp-set! comp 'top-pair-score *cl-top-pair-score*)
(comp-set! comp 'entropy-history *cl-entropy-history*)
(comp-set! comp 'merge-rounds-zero *cl-merge-rounds-zero*)
;; Check convergence
(when (and (> (comp-ref comp 'sentences-processed) 200)
(cl-structure-exhausted?))
(comp-set! comp 'state 'frozen)
(format #t " [~a FROZEN at ~a sentences, ~a classes]~%"
(comp-ref comp 'name)
(comp-ref comp 'sentences-processed)
(hash-count (const #t) *word-classes*)))
;; Swap out
(comp-swap-out! comp))
actual))
(define (comp-high-freq-words min-count)
"Get words with left-marginal count >= min-count (compartment-local)."
(let ((words '()))
(hash-for-each
(lambda (word count)
(when (>= count min-count)
(set! words (cons (cons word count) words))))
*left-marginals*)
(map car (sort words (lambda (a b) (> (cdr a) (cdr b)))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 4: COORDINATOR
;; ═══════════════════════════════════════════════════════════════════
(define *compartments* '())
(define *merged-state* #f)
(define *comp-active* #f) ; flag: suppress corpus-export during compartment training
(define *comp-batch-size* 50)
(define *comp-merge-interval* 500) ; merge every N sentences per compartment
(define *comp-surprise-threshold* 1000) ; surprise-weighted after this many sent/comp
(define *comp-polysemy-results* '())
(define *comp-book-configs*
;; (name . book-index) — maps to *cl-corpus-files* and *cl-book-names*
(list
(cons "alice" 0)
(cons "pride" 1)
(cons "sherlock" 2)
(cons "expectations" 3)
(cons "moby" 4)))
(define (compartment-init!)
"Initialize 5 compartments from the Gutenberg books."
(format #t "~%═══ COMPARTMENT INIT ═══~%")
;; Ensure corpus is loaded
(cl-load-all-corpus!)
;; Create compartments
(set! *compartments*
(map (lambda (config)
(let* ((name (car config))
(book-idx (cdr config))
(book-file (list-ref *cl-corpus-files* book-idx))
(comp (make-compartment book-idx name book-file))
;; Extract this book's sentences
(book-sents (filter-map
(lambda (entry)
(if (= (car entry) book-idx)
(cdr entry)
#f))
*cl-all-sentences*)))
(comp-set! comp 'sentences book-sents)
;; Detect chapters
(comp-init-chapters! comp)
(format #t " ~a: ~a sentences, ~a chapters~%"
name (length book-sents)
(length (comp-ref comp 'chapters)))
comp))
*comp-book-configs*))
(set! *merged-state* #f)
(set! *comp-polysemy-results* '())
(format #t "~%Initialized ~a compartments. Use (compartment-run N) to learn.~%~%"
(length *compartments*)))
(define (comp-pick-next-round-robin round-idx)
"Pick next compartment via round-robin. Skips frozen."
(let ((active (filter (lambda (c)
(not (eq? (comp-ref c 'state) 'frozen)))
*compartments*)))
(if (null? active)
#f
(list-ref active (modulo round-idx (length active))))))
(define (comp-pick-next-surprise)
"Pick compartment with highest mean surprise. Skips frozen."
(let ((active (filter (lambda (c)
(not (eq? (comp-ref c 'state) 'frozen)))
*compartments*)))
(if (null? active)
#f
(car (sort active (lambda (a b)
(> (comp-ref a 'mean-surprise)
(comp-ref b 'mean-surprise))))))))
(define (comp-all-above-threshold?)
"Check if all active compartments have > threshold sentences."
(let ((active (filter (lambda (c)
(not (eq? (comp-ref c 'state) 'frozen)))
*compartments*)))
(every (lambda (c)
(> (comp-ref c 'sentences-processed) *comp-surprise-threshold*))
active)))
(define (comp-needs-merge?)
"Check if any compartment has processed enough new sentences to trigger merge."
(any (lambda (c)
(> (- (comp-ref c 'sentences-processed) (comp-ref c 'last-merge-at))
*comp-merge-interval*))
*compartments*))
(define (compartment-run n)
"Run N batches across compartments.
Each batch = *comp-batch-size* sentences to one compartment."
(format #t "~%═══ COMPARTMENT RUN (~a batches × ~a sentences) ═══~%"
n *comp-batch-size*)
(set! *comp-active* #t) ; suppress corpus-export during training
(let ((t0 (get-internal-real-time))
(total-processed 0)
(use-surprise #f))
(do ((round 0 (+ round 1))) ((>= round n))
;; Check allocation strategy
(set! use-surprise (comp-all-above-threshold?))
;; Pick compartment
(let ((comp (if use-surprise
(comp-pick-next-surprise)
(comp-pick-next-round-robin round))))
(when comp
(let ((actual (comp-learn-batch! comp *comp-batch-size*)))
(set! total-processed (+ total-processed actual))
(when (zero? (modulo (+ round 1) 5))
(format #t " [round ~a] ~a: +~a sent (total ~a, surprise ~,2f, ~a classes, ~a)~%"
(+ round 1) (comp-ref comp 'name)
actual (comp-ref comp 'sentences-processed)
(comp-ref comp 'mean-surprise)
(comp-ref comp 'class-count)
(comp-ref comp 'state))))))
;; Export multi-atomspace viz after each full cycle
(when (zero? (modulo (+ round 1) (length *compartments*)))
(compartment-export)
;; Check if merge needed
(when (comp-needs-merge?)
(format #t "~% --- Merge triggered at round ~a ---~%" (+ round 1))
(compartment-merge!))))
(set! *comp-active* #f)
(compartment-export) ; final export
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t "~%Done: ~a sentences in ~,1f ms (~a)~%"
total-processed elapsed-ms
(if use-surprise "surprise-weighted" "round-robin"))
(compartment-status))))
(define (compartment-run-all)
"Run until all compartments are frozen."
(format #t "~%═══ COMPARTMENT RUN-ALL ═══~%")
(let loop ((round 0))
(let ((active (filter (lambda (c)
(not (eq? (comp-ref c 'state) 'frozen)))
*compartments*)))
(if (null? active)
(begin
(format #t "~%All ~a compartments frozen after ~a rounds.~%"
(length *compartments*) round)
(compartment-merge!)
(compartment-status))
(begin
(compartment-run 5)
(loop (+ round 5)))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 5: MERGE PROTOCOL
;; ═══════════════════════════════════════════════════════════════════
(define (comp-hash-copy ht)
"Shallow copy of hash table."
(let ((new (make-hash-table)))
(hash-for-each (lambda (k v) (hash-set! new k v)) ht)
new))
;; Word senses: word → list of sense objects
;; Each sense: ((id . N) (compartments . (name ...)) (partners . ((word . mi) ...)) (classId . N))
(define *word-senses* (make-hash-table))
(define *next-sense-id* 0)
(define (compartment-merge!)
"Merge compartments preserving per-compartment semantics as word senses.
Words with similar MI neighborhoods across compartments → 1 sense.
Words with divergent neighborhoods → multiple senses (one per cluster)."
(format #t "~% [MERGE] Merging ~a compartments (sense-preserving)...~%" (length *compartments*))
(let ((t0 (get-internal-real-time)))
;; ── Step 1: Build MI neighborhoods per compartment ──
(let* ((mi-hoods (comp-build-mi-neighborhoods))
(names (map car mi-hoods))
(hoods (map cdr mi-hoods))
(n-comps (length hoods))
;; Track which words appear in which compartments
(word-presence (make-hash-table))
;; Merged marginals (still additive — needed for base stats)
(merged-left (make-hash-table))
(merged-right (make-hash-table))
(merged-n 0))
;; Build word presence map: word → list of compartment indices
(do ((i 0 (+ i 1))) ((>= i n-comps))
(hash-for-each
(lambda (word _)
(hash-set! word-presence word
(cons i (hash-ref word-presence word '()))))
(list-ref hoods i)))
;; Merge marginals (additive — for base frequency stats)
(for-each
(lambda (comp)
(hash-for-each
(lambda (w cnt) (hash-set! merged-left w (+ cnt (hash-ref merged-left w 0))))
(comp-ref comp 'left-marg))
(hash-for-each
(lambda (w cnt) (hash-set! merged-right w (+ cnt (hash-ref merged-right w 0))))
(comp-ref comp 'right-marg))
(set! merged-n (+ merged-n (comp-ref comp 'total-n))))
*compartments*)
;; ── Step 2: Compute word senses from neighborhood comparison ──
(set! *word-senses* (make-hash-table))
(set! *next-sense-id* 0)
(let ((total-senses 0)
(multi-sense-words 0)
(single-sense-words 0))
(hash-for-each
(lambda (word comp-ids)
(let ((comp-ids-sorted (sort comp-ids <)))
(cond
;; Single compartment → single sense, take its neighborhood directly
((= (length comp-ids-sorted) 1)
(let* ((ci (car comp-ids-sorted))
(vec (hash-ref (list-ref hoods ci) word #f))
(partners (if vec
(hash-map->list cons vec)
'()))
(sid *next-sense-id*))
(set! *next-sense-id* (+ *next-sense-id* 1))
(hash-set! *word-senses* word
(list (list (cons 'id sid)
(cons 'compartments (list (list-ref names ci)))
(cons 'partners partners))))
(set! total-senses (+ total-senses 1))
(set! single-sense-words (+ single-sense-words 1))))
;; Multiple compartments → cluster neighborhoods by cosine
(else
(let* ((vecs (filter-map
(lambda (ci)
(let ((v (hash-ref (list-ref hoods ci) word #f)))
(and v (> (hash-count (const #t) v) 1)
(cons ci v))))
comp-ids-sorted))
(nv (length vecs)))
(if (< nv 2)
;; Not enough data — single sense from all compartments
(let ((all-partners (make-hash-table))
(all-comps '())
(sid *next-sense-id*))
(set! *next-sense-id* (+ *next-sense-id* 1))
(for-each
(lambda (ci)
(set! all-comps (cons (list-ref names ci) all-comps))
(let ((v (hash-ref (list-ref hoods ci) word #f)))
(when v
(hash-for-each
(lambda (p mi)
(hash-set! all-partners p
(max mi (hash-ref all-partners p 0.0))))
v))))
comp-ids-sorted)
(hash-set! *word-senses* word
(list (list (cons 'id sid)
(cons 'compartments all-comps)
(cons 'partners (hash-map->list cons all-partners)))))
(set! total-senses (+ total-senses 1))
(set! single-sense-words (+ single-sense-words 1)))
;; ── Agglomerative clustering of neighborhood vectors ──
;; Start: each compartment is its own cluster
;; Merge clusters with cosine > 0.3 (similar neighborhoods)
(let* ((clusters (map (lambda (cv) (list cv)) vecs)) ; each cluster = list of (ci . vec)
(merged-clusters
(let merge-loop ((cls clusters))
(if (< (length cls) 2)
cls
;; Find best pair
(let ((best-i 0) (best-j 1) (best-cos -1.0))
(do ((i 0 (+ i 1))) ((>= i (length cls)))
(do ((j (+ i 1) (+ j 1))) ((>= j (length cls)))
;; Avg cosine between all pairs in clusters i,j
(let* ((ci-items (list-ref cls i))
(cj-items (list-ref cls j))
(sum 0.0) (cnt 0))
(for-each
(lambda (a)
(for-each
(lambda (b)
(set! sum (+ sum (comp-mi-cosine (cdr a) (cdr b))))
(set! cnt (+ cnt 1)))
cj-items))
ci-items)
(let ((avg (if (> cnt 0) (/ sum cnt) 0.0)))
(when (> avg best-cos)
(set! best-i i)
(set! best-j j)
(set! best-cos avg))))))
;; Merge if similar enough
(if (> best-cos 0.3)
(let* ((new-cluster (append (list-ref cls best-i)
(list-ref cls best-j)))
(rest (let build ((k 0) (acc '()))
(if (>= k (length cls))
(reverse acc)
(if (or (= k best-i) (= k best-j))
(build (+ k 1) acc)
(build (+ k 1) (cons (list-ref cls k) acc)))))))
(merge-loop (cons new-cluster rest)))
cls))))))
;; Create one sense per cluster
(let ((senses '()))
(for-each
(lambda (cluster)
(let ((sense-partners (make-hash-table))
(sense-comps '())
(sid *next-sense-id*))
(set! *next-sense-id* (+ *next-sense-id* 1))
;; Merge neighborhoods within this sense (max MI)
(for-each
(lambda (cv)
(set! sense-comps
(cons (list-ref names (car cv)) sense-comps))
(hash-for-each
(lambda (p mi)
(hash-set! sense-partners p
(max mi (hash-ref sense-partners p 0.0))))
(cdr cv)))
cluster)
(set! senses
(cons (list (cons 'id sid)
(cons 'compartments sense-comps)
(cons 'partners (hash-map->list cons sense-partners)))
senses))))
merged-clusters)
(hash-set! *word-senses* word senses)
(set! total-senses (+ total-senses (length senses)))
(if (> (length senses) 1)
(set! multi-sense-words (+ multi-sense-words 1))
(set! single-sense-words (+ single-sense-words 1)))))))))))
word-presence)
(format #t " Senses: ~a total (~a words with 1 sense, ~a with multiple)~%"
total-senses single-sense-words multi-sense-words)
;; ── Step 3: Build merged MI cache from senses ──
;; For single-sense words: use the sense's partners directly
;; For multi-sense words: each sense contributes its own MI edges
(let ((merged-mi (make-hash-table)))
(hash-for-each
(lambda (word senses)
(if (= (length senses) 1)
;; Single sense: partners go directly into merged MI
(for-each
(lambda (partner-entry)
(let* ((partner (car partner-entry))
(mi (cdr partner-entry))
(key (if (string<? word partner) (cons word partner) (cons partner word))))
(hash-set! merged-mi key (max mi (hash-ref merged-mi key 0.0)))
(hash-set! merged-mi (cons (cdr key) (car key))
(max mi (hash-ref merged-mi (cons (cdr key) (car key)) 0.0)))))
(assoc-ref (car senses) 'partners))
;; Multi-sense: each sense contributes independently
(for-each
(lambda (sense)
(for-each
(lambda (partner-entry)
(let* ((partner (car partner-entry))
(mi (cdr partner-entry))
(key (if (string<? word partner) (cons word partner) (cons partner word))))
(hash-set! merged-mi key (max mi (hash-ref merged-mi key 0.0)))
(hash-set! merged-mi (cons (cdr key) (car key))
(max mi (hash-ref merged-mi (cons (cdr key) (car key)) 0.0)))))
(assoc-ref sense 'partners)))
senses)))
*word-senses*)
(format #t " Merged MI: ~a pairs~%"
(let ((cnt 0))
(hash-for-each
(lambda (k v)
(when (and (pair? k) (string<? (car k) (cdr k)))
(set! cnt (+ cnt 1))))
merged-mi)
cnt))
;; ── Step 4: Install merged state and run pipeline ──
(let ((saved-parking *comp-parking*))
(set! *comp-parking*
(list *mi-cache* *left-marginals* *right-marginals* *total-pair-count*
*word-classes* *word-to-class* *sections* *section-counts*
*cl-connector-index* *cl-dirty-pairs* *cl-dirty-count*
*next-class-id*))
(set! *mi-cache* merged-mi)
(set! *left-marginals* merged-left)
(set! *right-marginals* merged-right)
(set! *total-pair-count* merged-n)
(set! *word-classes* (make-hash-table))
(set! *word-to-class* (make-hash-table))
(set! *sections* (make-hash-table))
(set! *section-counts* (make-hash-table))
(set! *cl-connector-index* (make-hash-table))
(set! *cl-dirty-pairs* (make-hash-table))
(set! *cl-dirty-count* 0)
;; Parse sentences to build sections
(let ((sample-sentences (comp-sample-merged-sentences 500)))
(for-each
(lambda (sent)
(let* ((words (filter (lambda (w) (> (string-length w) 0))
(string-split sent #\space)))
(edges (cpu-pmfg-parse words)))
(cl-l0-extract-sections! words edges)))
sample-sentences))
;; Cluster
(let ((freq-words (comp-high-freq-words 30)))
(when (> (length freq-words) 5)
(cl-build-connector-index! freq-words)
(let cluster-loop ((round 0))
(when (< round 10)
(cl-l0-cluster!)
(unless (cl-structure-exhausted?)
(cluster-loop (+ round 1)))))))
;; Assign class IDs back to senses
(hash-for-each
(lambda (word senses)
(let ((new-senses
(map
(lambda (sense)
(let ((partners (assoc-ref sense 'partners)))
;; A sense's class = class of its highest-MI partner (heuristic)
(let ((best-class -1))
(for-each
(lambda (pe)
(let ((cls (hash-ref *word-to-class* (car pe) #f)))
(when cls (set! best-class cls))))
(sort partners (lambda (a b) (> (cdr a) (cdr b)))))
;; Also check the word itself
(let ((self-cls (hash-ref *word-to-class* word #f)))
(when self-cls (set! best-class self-cls)))
;; Return sense with classId appended
(append sense (list (cons 'classId best-class))))))
senses)))
(hash-set! *word-senses* word new-senses)))
*word-senses*)
;; Grammar
(when (> (hash-count (const #t) *word-classes*) 0)
(cl-build-class-mi-cache!)
(cl-export-grammar!))
;; Store merged state
(set! *merged-state*
(list
(cons 'mi-cache merged-mi)
(cons 'left-marg merged-left)
(cons 'right-marg merged-right)
(cons 'total-n merged-n)
(cons 'word-classes (comp-hash-copy *word-classes*))
(cons 'word-to-class (comp-hash-copy *word-to-class*))
(cons 'sections (comp-hash-copy *sections*))
(cons 'section-counts (comp-hash-copy *section-counts*))
(cons 'class-count (hash-count (const #t) *word-classes*))
(cons 'mi-count (hash-count (const #t) merged-mi))
(cons 'sense-count *next-sense-id*)
(cons 'multi-sense-count
(let ((cnt 0))
(hash-for-each
(lambda (w s) (when (> (length s) 1) (set! cnt (+ cnt 1))))
*word-senses*)
cnt))))
;; Detect polysemy (now redundant with senses, but kept for compatibility)
(compartment-detect-polysemy!)
;; Restore globals
(set! *mi-cache* (list-ref *comp-parking* 0))
(set! *left-marginals* (list-ref *comp-parking* 1))
(set! *right-marginals* (list-ref *comp-parking* 2))
(set! *total-pair-count* (list-ref *comp-parking* 3))
(set! *word-classes* (list-ref *comp-parking* 4))
(set! *word-to-class* (list-ref *comp-parking* 5))
(set! *sections* (list-ref *comp-parking* 6))
(set! *section-counts* (list-ref *comp-parking* 7))
(set! *cl-connector-index* (list-ref *comp-parking* 8))
(set! *cl-dirty-pairs* (list-ref *comp-parking* 9))
(set! *cl-dirty-count* (list-ref *comp-parking* 10))
(set! *next-class-id* (list-ref *comp-parking* 11))
(set! *comp-parking* saved-parking))))
;; Mark merge point
(for-each
(lambda (comp)
(comp-set! comp 'last-merge-at (comp-ref comp 'sentences-processed)))
*compartments*)
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t " [MERGE] Done in ~,1f ms. ~a senses (~a multi-sense words), ~a MI pairs, ~a classes~%"
elapsed-ms
*next-sense-id*
(if *merged-state* (assoc-ref *merged-state* 'multi-sense-count) 0)
(if *merged-state* (assoc-ref *merged-state* 'mi-count) 0)
(if *merged-state* (assoc-ref *merged-state* 'class-count) 0))))))
(define (comp-sample-merged-sentences n)
"Sample N sentences evenly from all compartments for section building."
(let* ((per-comp (max 1 (quotient n (length *compartments*))))
(samples '()))
(for-each
(lambda (comp)
(let* ((sents (comp-ref comp 'sentences))
(total (length sents))
(take-n (min per-comp total)))
;; Take evenly spaced sentences
(when (> take-n 0)
(let ((step (max 1 (quotient total take-n))))
(do ((i 0 (+ i step))) ((or (>= i total) (>= (length samples) n)))
(set! samples (cons (list-ref sents i) samples)))))))
*compartments*)
(take samples (min n (length samples)))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 6: POLYSEMY DETECTION
;; ═══════════════════════════════════════════════════════════════════
;;
;; MI-neighborhood divergence (exp9c): For each shared word, compare its
;; MI partner vectors across compartments. Low cosine = polysemy.
(define (comp-mi-cosine vec-a vec-b)
"Cosine between two MI neighborhood vectors (hash: partner → MI)."
(let ((dot 0.0) (norm-a-sq 0.0) (norm-b-sq 0.0))
(hash-for-each
(lambda (partner mi-a)
(set! norm-a-sq (+ norm-a-sq (* mi-a mi-a)))
(let ((mi-b (hash-ref vec-b partner #f)))
(when mi-b (set! dot (+ dot (* mi-a mi-b))))))
vec-a)
(hash-for-each
(lambda (partner mi-b)
(set! norm-b-sq (+ norm-b-sq (* mi-b mi-b))))
vec-b)
(let ((denom (* (sqrt norm-a-sq) (sqrt norm-b-sq))))
(if (< denom 1e-10) 0.0 (/ dot denom)))))
(define (comp-build-mi-neighborhoods)
"Build MI neighborhood vectors per compartment from their mi-caches.
Returns list of (name . neighborhood-hash) where neighborhood-hash
maps word → (hash: partner → MI)."
(map
(lambda (comp)
(let ((mi (comp-ref comp 'mi-cache))
(hoods (make-hash-table)))
(hash-for-each
(lambda (key mi-val)
(when (and (pair? key) (number? mi-val) (> mi-val 0))
(let ((w1 (car key))
(w2 (cdr key)))
;; Add w2 to w1's neighborhood
(let ((vec (hash-ref hoods w1 #f)))
(unless vec
(set! vec (make-hash-table))
(hash-set! hoods w1 vec))
(hash-set! vec w2 mi-val))
;; Add w1 to w2's neighborhood
(let ((vec (hash-ref hoods w2 #f)))
(unless vec
(set! vec (make-hash-table))
(hash-set! hoods w2 vec))
(hash-set! vec w1 mi-val)))))
mi)
(cons (comp-ref comp 'name) hoods)))
*compartments*))
(define (compartment-detect-polysemy!)
"Detect polysemy via MI-neighborhood divergence across compartments."
(let* ((mi-hoods (comp-build-mi-neighborhoods))
(names (map car mi-hoods))
(hoods (map cdr mi-hoods))
(n-comps (length hoods))
;; Find shared words (in 2+ compartment neighborhoods)
(word-presence (make-hash-table))
(polysemy '())
(stable '()))
;; Build word presence map
(do ((i 0 (+ i 1))) ((>= i n-comps))
(hash-for-each
(lambda (word _)
(hash-set! word-presence word
(cons i (hash-ref word-presence word '()))))
(list-ref hoods i)))
;; Compare MI neighborhoods for shared words
(hash-for-each
(lambda (word comp-ids)
(when (>= (length comp-ids) 2)
(let ((min-cos 1.0)
(pairs '()))
;; All pairwise comparisons
(let outer ((rest comp-ids))
(when (>= (length rest) 2)
(let inner ((others (cdr rest)))
(when (not (null? others))
(let* ((ci-a (car rest))
(ci-b (car others))
(vec-a (hash-ref (list-ref hoods ci-a) word #f))
(vec-b (hash-ref (list-ref hoods ci-b) word #f)))
(when (and vec-a vec-b
(> (hash-count (const #t) vec-a) 2)
(> (hash-count (const #t) vec-b) 2))
(let ((cos (comp-mi-cosine vec-a vec-b)))
(when (< cos min-cos) (set! min-cos cos))
(set! pairs (cons (list (list-ref names ci-a)
(list-ref names ci-b) cos)
pairs)))))
(inner (cdr others))))
(outer (cdr rest))))
(unless (null? pairs)
(if (< min-cos 0.3)
(set! polysemy (cons (list word min-cos pairs) polysemy))
(when (> min-cos 0.7)
(set! stable (cons (list word min-cos) stable))))))))
word-presence)
;; Sort and store results
(set! polysemy (sort polysemy (lambda (a b) (< (cadr a) (cadr b)))))
(set! stable (sort stable (lambda (a b) (> (cadr a) (cadr b)))))
(set! *comp-polysemy-results* polysemy)
;; Report
(let ((shared-count 0))
(hash-for-each
(lambda (w ids) (when (>= (length ids) 2) (set! shared-count (+ shared-count 1))))
word-presence)
(format #t " [POLYSEMY] ~a shared words, ~a polysemy candidates, ~a stable~%"
shared-count (length polysemy) (length stable))
(when (> (length polysemy) 0)
(format #t " Polysemy candidates:~%")
(for-each
(lambda (p)
(format #t " ~a (min-cosine=~,3f)~%" (car p) (cadr p)))
(take polysemy (min 10 (length polysemy))))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 7: VIZ & STATUS
;; ═══════════════════════════════════════════════════════════════════
(define (compartment-status)
"Pretty-print status of all compartments."
(format #t "~%═══ COMPARTMENT STATUS ═══~%")
(format #t " ~12a ~8a ~6a ~8a ~8a ~8a~%"
"Name" "State" "Sent" "Classes" "Surprise" "Cursor")
(format #t " ~a~%" (make-string 60 #\─))
(for-each
(lambda (comp)
(format #t " ~12a ~8a ~6a ~8a ~8,2f ~6a/~a~%"
(comp-ref comp 'name)
(comp-ref comp 'state)
(comp-ref comp 'sentences-processed)
(comp-ref comp 'class-count)
(comp-ref comp 'mean-surprise)
(comp-ref comp 'sentence-cursor)
(length (comp-ref comp 'sentences))))
*compartments*)
;; Merged state
(if *merged-state*
(format #t "~% Merged: ~a MI pairs, ~a classes~%"
(assoc-ref *merged-state* 'mi-count)
(assoc-ref *merged-state* 'class-count))
(format #t "~% Merged: (not yet merged)~%"))
;; Polysemy
(format #t " Polysemy candidates: ~a~%"
(length *comp-polysemy-results*))
(format #t "═══════════════════════════════~%~%"))
(define (compartment-polysemy)
"Show polysemy detection results."
(format #t "~%═══ POLYSEMY REPORT ═══~%")
(if (null? *comp-polysemy-results*)
(format #t " No polysemy candidates found. Run (compartment-merge!) first.~%")
(for-each
(lambda (p)
(format #t "~% ~a (min-cosine=~,3f):~%" (car p) (cadr p))
(for-each
(lambda (pair)
(format #t " ~a vs ~a: ~,3f~%"
(list-ref pair 0) (list-ref pair 1) (list-ref pair 2)))
(caddr p)))
*comp-polysemy-results*))
(format #t "═══════════════════════════════~%~%"))
;; ── JSON helpers ──
(define (json-escape-string s)
"Escape string for JSON output."
(let ((out (open-output-string)))
(string-for-each
(lambda (c)
(cond
((char=? c #\") (display "\\\"" out))
((char=? c #\\) (display "\\\\" out))
((char=? c #\newline) (display "\\n" out))
((char=? c #\tab) (display "\\t" out))
(else (display c out))))
s)
(get-output-string out)))
;; ── Per-atomspace data collection ──
(define (comp-collect-atomspace-data comp max-pairs max-words)
"Collect top words and MI pairs from one compartment's state.
Returns (words-alist . pairs-list) where words-alist is ((word . info) ...)
and pairs-list is ((w1 w2 mi) ...)."
(let* ((mi (comp-ref comp 'mi-cache))
(left-m (comp-ref comp 'left-marg))
(word-cls (comp-ref comp 'word-classes))
(w-to-c (comp-ref comp 'word-to-class))
(all-pairs '())
(word-degree (make-hash-table))
(word-total-mi (make-hash-table)))
;; Collect MI pairs
(hash-for-each
(lambda (key mi-val)
(when (and (pair? key) (number? mi-val) (> mi-val 1.0))
(let ((w1 (car key)) (w2 (cdr key)))
(when (and (string<? w1 w2)
(not (cl-sentinel? w1)) (not (cl-sentinel? w2))
(> (string-length w1) 1) (> (string-length w2) 1))
(set! all-pairs (cons (list w1 w2 mi-val) all-pairs))
(hash-set! word-degree w1 (+ 1 (hash-ref word-degree w1 0)))
(hash-set! word-degree w2 (+ 1 (hash-ref word-degree w2 0)))
(hash-set! word-total-mi w1 (+ mi-val (hash-ref word-total-mi w1 0.0)))
(hash-set! word-total-mi w2 (+ mi-val (hash-ref word-total-mi w2 0.0)))))))
mi)
;; Sort pairs by MI descending, take top N
(let* ((sorted (sort all-pairs (lambda (a b) (> (caddr a) (caddr b)))))
(top-pairs (if (> (length sorted) max-pairs)
(list-head sorted max-pairs)
sorted)))
;; Build word set from pairs (only words with degree >= 2)
(let ((word-set (make-hash-table)))
(for-each
(lambda (p)
(hash-set! word-set (car p) #t)
(hash-set! word-set (cadr p) #t))
top-pairs)
(let* ((all-words (hash-map->list (lambda (k v) k) word-set))
(connected (filter (lambda (w) (>= (hash-ref word-degree w 0) 2)) all-words))
(export-words (if (> (length connected) max-words)
(list-head
(sort connected
(lambda (a b) (> (hash-ref word-degree a 0)
(hash-ref word-degree b 0))))
max-words)
connected))
(export-set (make-hash-table)))
(for-each (lambda (w) (hash-set! export-set w #t)) export-words)
;; Filter pairs to export set
(let ((export-pairs (filter
(lambda (p)
(and (hash-ref export-set (car p) #f)
(hash-ref export-set (cadr p) #f)))
top-pairs)))
;; Build words alist
(let ((words-alist
(map (lambda (w)
(cons w (list
(cons 'degree (hash-ref word-degree w 0))
(cons 'totalMI (hash-ref word-total-mi w 0.0))
(cons 'classId (hash-ref w-to-c w -1))
(cons 'count (hash-ref left-m w 0)))))
export-words)))
(cons words-alist export-pairs))))))))
;; ── Common knowledge computation ──
(define (comp-compute-common-knowledge)
"Find words that appear with consistent MI neighborhoods across 3+ atomspaces.
Returns (common-words . common-pairs) where common-words is a list of words
and common-pairs is ((w1 w2 avg-mi) ...)."
(let* ((mi-hoods (comp-build-mi-neighborhoods))
(n-comps (length mi-hoods))
(word-presence (make-hash-table)) ; word → list of compartment indices
(common-words '())
(common-pairs '()))
;; Build word presence map
(do ((i 0 (+ i 1))) ((>= i n-comps))
(let ((hoods (cdr (list-ref mi-hoods i))))
(hash-for-each
(lambda (word _)
(hash-set! word-presence word
(cons i (hash-ref word-presence word '()))))
hoods)))
;; Find common words: present in 3+ compartments with min cosine > 0.5
(hash-for-each
(lambda (word comp-ids)
(when (>= (length comp-ids) (min 3 n-comps))
;; Compute pairwise MI-neighborhood cosine
(let ((min-cos 1.0)
(all-ok #t))
(let outer ((rest comp-ids))
(when (and all-ok (>= (length rest) 2))
(let inner ((others (cdr rest)))
(when (and all-ok (not (null? others)))
(let* ((ci-a (car rest))
(ci-b (car others))
(hoods-a (cdr (list-ref mi-hoods ci-a)))
(hoods-b (cdr (list-ref mi-hoods ci-b)))
(vec-a (hash-ref hoods-a word #f))
(vec-b (hash-ref hoods-b word #f)))
(if (and vec-a vec-b
(> (hash-count (const #t) vec-a) 2)
(> (hash-count (const #t) vec-b) 2))
(let ((cos (comp-mi-cosine vec-a vec-b)))
(when (< cos min-cos) (set! min-cos cos))
(when (< cos 0.5) (set! all-ok #f)))
(set! all-ok #f)))
(inner (cdr others))))
(outer (cdr rest))))
(when (and all-ok (> min-cos 0.5))
(set! common-words (cons word common-words))))))
word-presence)
;; Find common pairs: both words are common, MI consistent across atomspaces
(let ((common-set (make-hash-table)))
(for-each (lambda (w) (hash-set! common-set w #t)) common-words)
;; Average MI across compartments for common word pairs
(let ((pair-mi-sums (make-hash-table))
(pair-mi-counts (make-hash-table)))
(for-each
(lambda (comp)
(let ((mi (comp-ref comp 'mi-cache)))
(hash-for-each
(lambda (key mi-val)
(when (and (pair? key) (number? mi-val) (> mi-val 0))
(let ((w1 (car key)) (w2 (cdr key)))
(when (and (string<? w1 w2)
(hash-ref common-set w1 #f)
(hash-ref common-set w2 #f))
(hash-set! pair-mi-sums key
(+ mi-val (hash-ref pair-mi-sums key 0.0)))
(hash-set! pair-mi-counts key
(+ 1 (hash-ref pair-mi-counts key 0)))))))
mi)))
*compartments*)
;; Only keep pairs seen in 2+ compartments
(hash-for-each
(lambda (key sum)
(let ((cnt (hash-ref pair-mi-counts key 0)))
(when (>= cnt 2)
(set! common-pairs
(cons (list (car key) (cdr key) (/ sum cnt))
common-pairs)))))
pair-mi-sums)))
(format #t " [COMMON] ~a common words, ~a common pairs~%"
(length common-words) (length common-pairs))
(cons common-words common-pairs)))
;; ── Alignment cosines between compartments ──
(define (comp-compute-alignment-cosines)
"Compute pairwise class alignment cosines between compartments.
Returns list of (name-a name-b cosine)."
(let ((results '())
(n (length *compartments*)))
(do ((i 0 (+ i 1))) ((>= i n))
(do ((j (+ i 1) (+ j 1))) ((>= j n))
(let* ((comp-a (list-ref *compartments* i))
(comp-b (list-ref *compartments* j))
(mi-a (comp-ref comp-a 'mi-cache))
(mi-b (comp-ref comp-b 'mi-cache))
;; Compute cosine over shared MI pairs
(dot 0.0) (norm-a 0.0) (norm-b 0.0))
(hash-for-each
(lambda (key mi-val-a)
(when (and (pair? key) (number? mi-val-a))
(let ((mi-val-b (hash-ref mi-b key #f)))
(when (and mi-val-b (number? mi-val-b))
(set! dot (+ dot (* mi-val-a mi-val-b)))
(set! norm-a (+ norm-a (* mi-val-a mi-val-a)))
(set! norm-b (+ norm-b (* mi-val-b mi-val-b)))))))
mi-a)
(let ((denom (* (sqrt norm-a) (sqrt norm-b))))
(set! results
(cons (list (comp-ref comp-a 'name)
(comp-ref comp-b 'name)
(if (< denom 1e-10) 0.0 (/ dot denom)))
results))))))
results))
;; ── Main export ──
(define (compartment-export)
"Export multi-atomspace viz JSON with per-compartment data, common knowledge,
alignment cosines, and polysemy annotations."
(unless *merged-state*
(format #t "Merging first...~%")
(compartment-merge!))
(let ((filename (string-append *mvp-dir* "/viz/data.json"))
(max-pairs-per-as 1000)
(max-words-per-as 500)
(t0 (get-internal-real-time)))
(format #t "~%═══ COMPARTMENT EXPORT ═══~%")
;; Step 1: Collect per-atomspace data
(format #t " Collecting per-atomspace data...~%")
(let ((as-data
(map (lambda (comp)
(let ((result (comp-collect-atomspace-data comp
max-pairs-per-as max-words-per-as)))
(format #t " ~a: ~a words, ~a pairs~%"
(comp-ref comp 'name)
(length (car result))
(length (cdr result)))
(cons (comp-ref comp 'name) result)))
*compartments*)))
;; Step 2: Common knowledge
(format #t " Computing common knowledge...~%")
(let ((common (comp-compute-common-knowledge)))
(let ((common-words (car common))
(common-pairs (cdr common)))
;; Step 3: Alignment cosines
(format #t " Computing alignment cosines...~%")
(let ((alignments (comp-compute-alignment-cosines)))
;; Step 4: Write JSON
(format #t " Writing ~a...~%" filename)
(call-with-output-file filename
(lambda (port)
(format port "{~%")
;; ── atomspaces section ──
(format port " \"atomspaces\": {~%")
(format port " \"meta\": {\"backend\": \"hash-tables\", \"treeComputed\": true},~%")
;; nodes
(format port " \"nodes\": {~%")
;; Common/root node
(let ((child-names (map (lambda (c) (comp-ref c 'name)) *compartments*)))
(format port " \"common\": {\"depth\": 0, \"parent\": null, \"children\": [")
(let ((first #t))
(for-each (lambda (name)
(unless first (format port ", "))
(format port "~s" name)
(set! first #f))
child-names))
(format port "], \"isIntersection\": true, \"wordCount\": ~a, \"pairCount\": ~a, \"note\": \"words all atomspaces agree on\"}"
(length common-words) (length common-pairs)))
;; Leaf atomspace nodes
(for-each
(lambda (comp)
(let* ((name (comp-ref comp 'name))
(as-entry (assoc name as-data string=?))
(word-count (if as-entry (length (cadr as-entry)) 0))
(pair-count (if as-entry (length (cddr as-entry)) 0)))
(format port ",~% ~s: {\"depth\": 1, \"parent\": \"common\", \"children\": [], \"state\": ~s, \"sentences\": ~a, \"classes\": ~a, \"surprise\": ~,2f, \"wordCount\": ~a, \"pairCount\": ~a"
name
(symbol->string (comp-ref comp 'state))
(comp-ref comp 'sentences-processed)
(comp-ref comp 'class-count)
(comp-ref comp 'mean-surprise)
word-count
pair-count)
;; Chapters list
(let ((chapters (comp-ref comp 'chapters)))
(when (> (length chapters) 0)
(format port ", \"chapters\": [")
(let ((cf #t))
(for-each (lambda (ch)
(unless cf (format port ", "))
(format port "~s" (json-escape-string ch))
(set! cf #f))
chapters))
(format port "]")))
(format port "}")))
*compartments*)
(format port "~% },~%")
;; edges (tree edges root→leaf with alignment cosines)
(format port " \"edges\": [~%")
(let ((first #t))
(for-each
(lambda (comp)
(let* ((name (comp-ref comp 'name))
;; Find avg alignment of this leaf to all others
(relevant (filter (lambda (a)
(or (string=? (car a) name)
(string=? (cadr a) name)))
alignments))
(avg-cos (if (null? relevant) 0.5
(/ (apply + (map caddr relevant))
(length relevant)))))
(unless first (format port ",~%"))
(format port " {\"from\": \"common\", \"to\": ~s, \"alignmentCosine\": ~,4f}"
name (exact->inexact avg-cos))
(set! first #f)))
*compartments*))
(format port "~% ]~%")
(format port " },~%")
;; ── words section (with sense data from merge) ──
(format port " \"words\": {~%")
(let ((word-atomspaces (make-hash-table))
(word-info (make-hash-table))
(polysemy-set (make-hash-table)))
;; Mark polysemy words
(for-each
(lambda (p) (hash-set! polysemy-set (car p) #t))
*comp-polysemy-results*)
;; Collect from each atomspace
(for-each
(lambda (as-entry)
(let ((as-name (car as-entry))
(words-alist (cadr as-entry)))
(for-each
(lambda (wa)
(let ((word (car wa))
(info (cdr wa)))
(hash-set! word-atomspaces word
(cons as-name (hash-ref word-atomspaces word '())))
(let ((existing (hash-ref word-info word #f)))
(if existing
(let ((exist-cls (assoc-ref existing 'classId))
(new-cls (assoc-ref info 'classId)))
(hash-set! word-info word
(list
(cons 'degree (max (assoc-ref info 'degree)
(assoc-ref existing 'degree)))
(cons 'totalMI (+ (assoc-ref info 'totalMI)
(assoc-ref existing 'totalMI)))
;; Keep real classId over -1
(cons 'classId (if (and exist-cls (>= exist-cls 0))
exist-cls
(or new-cls -1)))
(cons 'count (+ (assoc-ref info 'count)
(assoc-ref existing 'count))))))
(hash-set! word-info word info)))))
words-alist)))
as-data)
;; Add common words
(for-each
(lambda (w)
(hash-set! word-atomspaces w
(cons "common" (hash-ref word-atomspaces w '()))))
common-words)
(let ((merged-w2c (if *merged-state*
(assoc-ref *merged-state* 'word-to-class)
(make-hash-table))))
(let ((first #t)
(word-list (hash-map->list cons word-info)))
(let ((sorted-words (sort word-list
(lambda (a b)
(> (assoc-ref (cdr a) 'totalMI)
(assoc-ref (cdr b) 'totalMI))))))
(for-each
(lambda (entry)
(let* ((word (car entry))
(info (cdr entry))
(as-list (hash-ref word-atomspaces word '()))
(is-polysemy (hash-ref polysemy-set word #f))
(merged-class (hash-ref merged-w2c word #f))
(senses (hash-ref *word-senses* word '()))
;; Surprise: max per-word surprise across compartments
;; Each compartment tracks word→surprise via EMA
(word-surp
(let loop ((comps *compartments*) (best -1.0))
(if (null? comps)
(if (> best 0.0) best 5.0) ; fallback if no data
(let* ((c (car comps))
(ws-table (comp-ref c 'word-surprise))
(ws (and ws-table (hash-ref ws-table word #f))))
(loop (cdr comps)
(if (and ws (number? ws) (> ws best))
ws best))))))
;; Cluster: use classId from per-compartment data
(word-cluster (assoc-ref info 'classId)))
(unless first (format port ",~%"))
(format port " ~s: {\"surprise\": ~,3f, \"cluster\": ~a, \"degree\": ~a, \"totalMI\": ~,3f"
word
(exact->inexact (max 0.0 word-surp))
(if (and word-cluster (>= word-cluster 0)) word-cluster -1)
(assoc-ref info 'degree)
(exact->inexact (assoc-ref info 'totalMI)))
(when merged-class
(format port ", \"classId\": ~a" merged-class))
;; Atomspaces
(format port ", \"atomspaces\": [")
(let ((af #t))
(for-each (lambda (as)
(unless af (format port ", "))
(format port "~s" as)
(set! af #f))
(delete-duplicates as-list string=?)))
(format port "]")
(when is-polysemy
(format port ", \"polysemy\": true"))
;; Per-word chapter membership
(let ((word-chs '()))
(for-each
(lambda (comp)
(let* ((cname (comp-ref comp 'name))
(cw (comp-ref comp 'chapter-words))
(chapters (comp-ref comp 'chapters))
(word-in '()))
(for-each
(lambda (ch)
(let ((ws (hash-ref cw ch #f)))
(when (and ws (hash-ref ws word #f))
(set! word-in (cons ch word-in)))))
chapters)
(when (> (length word-in) 0)
(set! word-chs
(cons (cons cname (reverse word-in))
word-chs)))))
*compartments*)
(when (> (length word-chs) 0)
(format port ", \"chapters\": {")
(let ((chf #t))
(for-each
(lambda (entry)
(unless chf (format port ", "))
(format port "~s: [" (car entry))
(let ((inner-f #t))
(for-each
(lambda (ch)
(unless inner-f (format port ", "))
(format port "~s" (json-escape-string ch))
(set! inner-f #f))
(cdr entry)))
(format port "]")
(set! chf #f))
word-chs))
(format port "}")))
;; ── Senses (the key new data) ──
(when (> (length senses) 0)
(format port ", \"senses\": [")
(let ((sf #t))
(for-each
(lambda (sense)
(unless sf (format port ", "))
(format port "{\"id\": ~a" (assoc-ref sense 'id))
;; Compartments for this sense
(format port ", \"in\": [")
(let ((cf #t))
(for-each
(lambda (c)
(unless cf (format port ", "))
(format port "~s" c)
(set! cf #f))
(assoc-ref sense 'compartments)))
(format port "]")
;; Top partners (max 8)
(let* ((partners (assoc-ref sense 'partners))
(top (if (> (length partners) 8)
(list-head
(sort partners (lambda (a b) (> (cdr a) (cdr b))))
8)
(sort partners (lambda (a b) (> (cdr a) (cdr b)))))))
(format port ", \"partners\": [")
(let ((pf #t))
(for-each
(lambda (pe)
(unless pf (format port ", "))
(format port "[~s, ~,2f]" (car pe) (exact->inexact (cdr pe)))
(set! pf #f))
top))
(format port "]"))
;; Class ID for this sense
(let ((cls (assoc-ref sense 'classId)))
(when (and cls (> cls -1))
(format port ", \"classId\": ~a" cls)))
(format port "}")
(set! sf #f))
senses))
(format port "]"))
(format port "}")
(set! first #f)))
sorted-words)))))
(format port "~% },~%")
;; ── pairs section (with atomspace source) ──
(format port " \"pairs\": [~%")
(let ((first #t)
(pair-count 0)
(max-total-pairs 5000))
;; Common pairs first
(for-each
(lambda (p)
(when (< pair-count max-total-pairs)
(unless first (format port ",~%"))
(format port " [~s, ~s, ~,3f, ~s]"
(car p) (cadr p) (exact->inexact (caddr p)) "common")
(set! first #f)
(set! pair-count (+ pair-count 1))))
(sort common-pairs (lambda (a b) (> (caddr a) (caddr b)))))
;; Per-atomspace pairs
(for-each
(lambda (as-entry)
(let ((as-name (car as-entry))
(pairs (cddr as-entry)))
(for-each
(lambda (p)
(when (< pair-count max-total-pairs)
(unless first (format port ",~%"))
(format port " [~s, ~s, ~,3f, ~s]"
(car p) (cadr p) (exact->inexact (caddr p)) as-name)
(set! first #f)
(set! pair-count (+ pair-count 1))))
pairs)))
as-data))
(format port "~% ],~%")
;; ── classes section (from merged state) ──
(format port " \"classes\": {~%")
(when *merged-state*
(let ((merged-classes (assoc-ref *merged-state* 'word-classes))
(first #t))
(when merged-classes
(hash-for-each
(lambda (cid members)
(unless first (format port ",~%"))
(format port " \"~a\": [" cid)
(let ((mf #t))
(for-each
(lambda (w)
(unless mf (format port ", "))
(format port "~s" w)
(set! mf #f))
members))
(format port "]")
(set! first #f))
merged-classes))))
(format port "~% },~%")
;; ── stats section ──
(format port " \"stats\": {~%")
(let ((total-sent (apply + (map (lambda (c) (comp-ref c 'sentences-processed))
*compartments*)))
(total-classes (if *merged-state*
(assoc-ref *merged-state* 'class-count) 0))
(total-mi (if *merged-state*
(assoc-ref *merged-state* 'mi-count) 0)))
(format port " \"totalSentences\": ~a,~%" total-sent)
(format port " \"totalClusters\": ~a,~%" (length *compartments*))
(format port " \"wordClasses\": ~a,~%" total-classes)
(format port " \"miCacheSize\": ~a,~%" total-mi)
(format port " \"polysemyCandidates\": ~a~%" (length *comp-polysemy-results*)))
(format port " },~%")
;; ── hierarchy (empty for now — Phase 2) ──
(format port " \"hierarchy\": []~%")
(format port "}~%")))
;; Report
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t " Exported to ~a in ~,0f ms~%" filename elapsed-ms)
(format #t " ~a atomspace nodes, ~a alignment edges~%"
(+ 1 (length *compartments*))
(length alignments))
(format #t " ~a common words, ~a common pairs~%"
(length common-words) (length common-pairs))
(format #t " ~a polysemy candidates~%"
(length *comp-polysemy-results*))
(format #t "═══════════════════════════════~%~%"))))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 7b: CHAPTER DETECTION
;; ═══════════════════════════════════════════════════════════════════
;;
;; Parse chapter markers from Gutenberg texts and track per-word chapter
;; membership during learning. Used by viz for chapter-based layouts.
(define (comp-detect-chapters filepath)
"Parse chapter markers from a Gutenberg text file.
Returns list of (chapter-name . start-line-number).
Handles formats: CHAPTER I., Chapter I., CHAPTER 1. Title., I. TITLE"
(if (not (file-exists? filepath))
(begin
(format #t " [CHAPTERS] File not found: ~a~%" filepath)
'())
(let ((lines '())
(in-body #f)
(past-footer #f)
(chapters '())
(line-num 0))
;; Read all lines
(call-with-input-file filepath
(lambda (port)
(let loop ()
(let ((line (read-line port)))
(unless (eof-object? line)
(set! lines (cons (cons (length lines) line) lines))
(loop))))))
(set! lines (reverse lines))
;; Scan for chapters, skipping Gutenberg header/footer
(for-each
(lambda (entry)
(let ((lno (car entry))
(line (string-trim-both (cdr entry))))
;; Detect start of body (after "*** START OF")
(when (string-contains line "*** START OF")
(set! in-body #t))
;; Detect end of body (after "*** END OF")
(when (string-contains line "*** END OF")
(set! past-footer #t))
(when (and in-body (not past-footer) (> (string-length line) 3))
(cond
;; Pattern 1: "CHAPTER I." or "CHAPTER XII. Title" (Alice, Pride)
((string-match "^CHAPTER ([IVXLC]+)\\.(.*)$" line)
=> (lambda (m)
(let* ((num (match:substring m 1))
(rest (string-trim-both (match:substring m 2)))
(name (if (> (string-length rest) 0)
(format #f "Chapter ~a. ~a" num rest)
(format #f "Chapter ~a" num))))
(set! chapters (cons (cons name lno) chapters)))))
;; Pattern 2: "Chapter I." or "Chapter XXXIX." (Expectations)
((string-match "^Chapter ([IVXLC]+)\\.(.*)$" line)
=> (lambda (m)
(let* ((num (match:substring m 1))
(rest (string-trim-both (match:substring m 2)))
(name (if (> (string-length rest) 0)
(format #f "Chapter ~a. ~a" num rest)
(format #f "Chapter ~a" num))))
(set! chapters (cons (cons name lno) chapters)))))
;; Pattern 3: "CHAPTER 1. Title." (Moby Dick — arabic numerals)
((string-match "^CHAPTER ([0-9]+)\\.(.*)$" line)
=> (lambda (m)
(let* ((num (match:substring m 1))
(rest (string-trim-both (match:substring m 2)))
(name (if (> (string-length rest) 0)
(format #f "Chapter ~a. ~a" num rest)
(format #f "Chapter ~a" num))))
(set! chapters (cons (cons name lno) chapters)))))
;; Pattern 4: "I. A SCANDAL IN BOHEMIA" (Sherlock — roman + title)
((string-match "^([IVXLC]+)\\. ([A-Z][A-Z ]+)$" line)
=> (lambda (m)
(let* ((num (match:substring m 1))
(title (match:substring m 2))
(name (format #f "~a. ~a" num title)))
;; Only accept if roman numeral is short (avoid false matches)
(when (<= (string-length num) 5)
(set! chapters (cons (cons name lno) chapters))))))))))
lines)
(let ((result (reverse chapters)))
(format #t " [CHAPTERS] ~a: ~a chapters detected~%"
(let ((parts (string-split filepath #\/)))
(if (null? parts) filepath (last parts)))
(length result))
result))))
;; Per-compartment chapter tracking
;; Each compartment gets a 'chapters field (list of chapter names) and
;; a 'chapter-words field (hash: chapter-name → hash-set of words).
;; The 'chapter-lines field maps chapter-name → (start-line . end-line).
(define (comp-init-chapters! comp)
"Detect chapters for a compartment and set up tracking tables."
(let* ((book-file (comp-ref comp 'book-file))
(chapters (comp-detect-chapters book-file))
(chapter-words (make-hash-table))
(chapter-lines (make-hash-table)))
;; Build chapter-lines map with start/end boundaries
(let loop ((chs chapters) (prev-name #f))
(when (not (null? chs))
(let ((name (caar chs))
(start (cdar chs)))
(when prev-name
;; Previous chapter ends where this one starts
(let ((prev-entry (hash-ref chapter-lines prev-name)))
(when prev-entry
(hash-set! chapter-lines prev-name
(cons (car prev-entry) start)))))
(hash-set! chapter-lines name (cons start 999999))
(hash-set! chapter-words name (make-hash-table))
(loop (cdr chs) name))))
;; Store in compartment
(comp-set! comp 'chapters (map car chapters))
(comp-set! comp 'chapter-words chapter-words)
(comp-set! comp 'chapter-lines chapter-lines)))
(define (comp-tag-sentence-chapter! comp sentence-idx words)
"Tag words in a sentence with their chapter based on sentence position.
Uses approximate mapping: sentence-idx → line-number (1 sent ≈ 2 lines)."
(let* ((chapter-lines (comp-ref comp 'chapter-lines))
(chapter-words (comp-ref comp 'chapter-words))
(chapters (comp-ref comp 'chapters))
;; Approximate: sentence cursor maps roughly to line number
;; Each sentence is ~2 lines on average in Gutenberg texts
(approx-line (* sentence-idx 2)))
;; Find which chapter this sentence falls in (last chapter whose start <= approx-line)
(let loop ((chs chapters) (current-chapter #f))
(if (null? chs)
;; Done scanning — tag words with the last matching chapter
(when current-chapter
(let ((ws (hash-ref chapter-words current-chapter #f)))
(when ws
(for-each (lambda (w) (hash-set! ws w #t)) words))))
;; Check if this chapter's start line <= approx-line
(let* ((ch-name (car chs))
(range (hash-ref chapter-lines ch-name #f)))
(if (and range (<= (car range) approx-line))
(loop (cdr chs) ch-name) ; this chapter started before our line
(begin
;; This chapter starts after our line — tag with previous
(when current-chapter
(let ((ws (hash-ref chapter-words current-chapter #f)))
(when ws
(for-each (lambda (w) (hash-set! ws w #t)) words)))))))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 8: USER COMMANDS
;; ═══════════════════════════════════════════════════════════════════
(define (compartment-freeze! name)
"Manually freeze a compartment."
(let ((comp (find (lambda (c) (string=? (comp-ref c 'name) name))
*compartments*)))
(if comp
(begin
(comp-set! comp 'state 'frozen)
(format #t "Compartment ~a frozen.~%" name))
(format #t "Unknown compartment: ~a~%" name))))
(define (compartment-thaw! name)
"Thaw a frozen compartment for continued learning."
(let ((comp (find (lambda (c) (string=? (comp-ref c 'name) name))
*compartments*)))
(if comp
(begin
(comp-set! comp 'state 'thawed)
(comp-set! comp 'merge-rounds-zero 0)
(comp-set! comp 'entropy-history '())
(format #t "Compartment ~a thawed.~%" name))
(format #t "Unknown compartment: ~a~%" name))))
(define (compartment-get name)
"Get a compartment by name."
(find (lambda (c) (string=? (comp-ref c 'name) name))
*compartments*))
;; ── Telnet-safe aliases (CogServer shell escapes ! characters) ──
(define (compartment-init) (compartment-init!))
(define (compartment-merge) (compartment-merge!))
(define (compartment-freeze name) (compartment-freeze! name))
(define (compartment-thaw name) (compartment-thaw! name))
(format #t "~%compartment.scm loaded. Commands:~%")
(format #t " (compartment-init) ;; Initialize 5 compartments~%")
(format #t " (compartment-run N) ;; Run N batches (50 sent each)~%")
(format #t " (compartment-run-all) ;; Run until all frozen~%")
(format #t " (compartment-merge) ;; Force merge now~%")
(format #t " (compartment-status) ;; Status overview~%")
(format #t " (compartment-polysemy) ;; Show polysemy candidates~%")
(format #t " (compartment-export) ;; Export viz JSON~%")
(format #t " (compartment-freeze name) ;; Freeze compartment~%")
(format #t " (compartment-thaw name) ;; Thaw compartment~%~%")