;;
;; exp9e-connector-entropy.scm — Connector Entropy Comparison
;;
;; Hypothesis: Words with very different connector entropy across
;; compartments are using different grammatical patterns = polysemy.
;; A word with low entropy in one compartment (specialized use) but
;; high entropy in another (diverse use) signals different roles.
;;
;; Method: For each word, compute Shannon entropy of its connector
;; distribution in each compartment. Compare entropies + use
;; Jensen-Shannon divergence between distributions.
;;
(define *exp9e-results* '())
(define (exp9e-connector-entropy vec)
"Compute Shannon entropy of a connector distribution.
H = -sum(p * log2(p)) where p = count/total."
(let ((total 0.0))
(hash-for-each (lambda (_ cnt) (set! total (+ total cnt))) vec)
(if (< total 1e-10) 0.0
(let ((h 0.0))
(hash-for-each
(lambda (_ cnt)
(let ((p (/ cnt total)))
(when (> p 0)
(set! h (- h (* p (/ (log p) (log 2))))))))
vec)
h))))
(define (exp9e-js-divergence vec-a vec-b)
"Jensen-Shannon divergence between two connector distributions.
JSD = (KL(P||M) + KL(Q||M)) / 2 where M = (P+Q)/2.
Returns value in [0, 1] (using log base 2)."
(let ((total-a 0.0) (total-b 0.0))
(hash-for-each (lambda (_ c) (set! total-a (+ total-a c))) vec-a)
(hash-for-each (lambda (_ c) (set! total-b (+ total-b c))) vec-b)
(if (or (< total-a 1e-10) (< total-b 1e-10)) 1.0
;; Build probability distributions and midpoint
(let ((all-conns (make-hash-table))
(jsd 0.0))
;; Collect all connectors
(hash-for-each (lambda (c _) (hash-set! all-conns c #t)) vec-a)
(hash-for-each (lambda (c _) (hash-set! all-conns c #t)) vec-b)
;; Compute JSD
(hash-for-each
(lambda (conn _)
(let* ((pa (/ (hash-ref vec-a conn 0) total-a))
(pb (/ (hash-ref vec-b conn 0) total-b))
(m (/ (+ pa pb) 2.0)))
(when (> m 0)
(when (> pa 0)
(set! jsd (+ jsd (* 0.5 pa (/ (log (/ pa m)) (log 2))))))
(when (> pb 0)
(set! jsd (+ jsd (* 0.5 pb (/ (log (/ pb m)) (log 2)))))))))
all-conns)
jsd))))
(define (exp9e-top-connectors vec n)
"Get top-N connectors as readable string."
(let ((pairs '()))
(hash-for-each (lambda (c cnt) (set! pairs (cons (cons c cnt) pairs))) vec)
(let ((sorted (sort pairs (lambda (a b) (> (cdr a) (cdr b))))))
(string-join
(map (lambda (p) (format #f "~a:~a" (car p) (cdr p)))
(take sorted (min n (length sorted))))
" "))))
(define (run-exp9e)
"Run Experiment 9e: Connector Entropy Comparison."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 9e: Connector Entropy Comparison~%")
(format #t "══════════════════════════════════════════════════~%~%")
(when (null? *exp7-compartments*)
(format #t "Exp7 data not cached — running exp7 first...~%~%")
(run-exp7))
(let* ((comp-data *exp7-compartments*)
(t0 (get-internal-real-time)))
(format #t "Using ~a compartments from exp7~%" (length comp-data))
(let* ((indices (map (lambda (r) (list-ref (cdr r) 1)) comp-data))
(names (map car comp-data)))
;; Step 1: Find shared words
(format #t "~%Step 1: Finding shared words across connector indices...~%")
(let ((word-presence (make-hash-table)))
(do ((i 0 (+ i 1))) ((>= i (length indices)))
(hash-for-each
(lambda (word _)
(hash-set! word-presence word
(cons i (hash-ref word-presence word '()))))
(list-ref indices i)))
(let ((shared-words '()))
(hash-for-each
(lambda (word comps)
(when (>= (length comps) 2)
(set! shared-words (cons (cons word comps) shared-words))))
word-presence)
(format #t " Words in 2+ compartments: ~a~%~%" (length shared-words))
;; Step 2: Compute entropy + JSD for each shared word
(format #t "Step 2: Computing entropy and JSD per word...~%")
(let ((polysemy-candidates '())
(stable-words '())
(all-scores '()))
(for-each
(lambda (entry)
(let* ((word (car entry))
(comp-ids (cdr entry))
;; Compute entropy in each compartment
(entropies
(map (lambda (ci)
(let ((vec (hash-ref (list-ref indices ci) word #f)))
(list (list-ref names ci)
(if vec (exp9e-connector-entropy vec) 0.0)
(if vec (hash-count (const #t) vec) 0))))
comp-ids))
;; Compute pairwise JSD
(jsd-scores '()))
(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 indices ci-a) word #f))
(vec-b (hash-ref (list-ref indices ci-b) word #f)))
(when (and vec-a vec-b)
(let ((jsd (exp9e-js-divergence vec-a vec-b)))
(set! jsd-scores
(cons (list (list-ref names ci-a)
(list-ref names ci-b) jsd)
jsd-scores)))))
(inner (cdr others))))
(outer (cdr rest))))
(unless (null? jsd-scores)
(let* ((entropy-vals (map cadr entropies))
(max-entropy (apply max entropy-vals))
(min-entropy (apply min entropy-vals))
(entropy-diff (- max-entropy min-entropy))
(max-jsd (apply max (map caddr jsd-scores)))
(mean-jsd (/ (apply + (map caddr jsd-scores))
(length jsd-scores)))
;; Combined score: JSD is primary, entropy-diff secondary
(score (+ (* 0.7 max-jsd) (* 0.3 (min 1.0 (/ entropy-diff 3.0))))))
(set! all-scores
(cons (list word score max-jsd entropy-diff mean-jsd
entropies jsd-scores)
all-scores))
(if (> max-jsd 0.3)
(set! polysemy-candidates
(cons (list word score max-jsd entropy-diff
entropies jsd-scores)
polysemy-candidates))
(when (< max-jsd 0.05)
(set! stable-words
(cons (list word score max-jsd entropy-diff
entropies jsd-scores)
stable-words))))))))
shared-words)
;; Sort
(set! polysemy-candidates
(sort polysemy-candidates (lambda (a b) (> (cadr a) (cadr b)))))
(set! stable-words
(sort stable-words (lambda (a b) (< (cadr a) (cadr b)))))
(set! all-scores
(sort all-scores (lambda (a b) (> (cadr a) (cadr b)))))
;; Report
(format #t "~%── RESULTS ──~%")
(format #t " Shared words analyzed: ~a~%" (length all-scores))
(format #t " Polysemy candidates (max JSD > 0.3): ~a~%"
(length polysemy-candidates))
(format #t " Stable words (max JSD < 0.05): ~a~%"
(length stable-words))
;; Show candidates
(format #t "~%── Polysemy Candidates ──~%")
(if (null? polysemy-candidates)
(format #t " (none found)~%")
(for-each
(lambda (p)
(let ((word (list-ref p 0))
(score (list-ref p 1))
(max-jsd (list-ref p 2))
(entropy-diff (list-ref p 3))
(entropies (list-ref p 4))
(jsd-scores (list-ref p 5)))
(format #t "~% ~a (score=~,3f max-JSD=~,3f entropy-diff=~,2f):~%"
word score max-jsd entropy-diff)
;; Show entropy per compartment
(for-each
(lambda (e)
(format #t " ~a: H=~,2f bits (~a connectors)~%"
(list-ref e 0) (list-ref e 1) (list-ref e 2)))
entropies)
;; Show JSD
(for-each
(lambda (j)
(format #t " ~a vs ~a: JSD=~,3f~%"
(list-ref j 0) (list-ref j 1) (list-ref j 2)))
jsd-scores)
;; Show top connectors per compartment
(for-each
(lambda (ci)
(let ((vec (hash-ref (list-ref indices ci) word #f)))
(when vec
(format #t " ~a connectors: ~a~%"
(list-ref names ci)
(exp9e-top-connectors vec 5)))))
(let ((seen '()))
(for-each
(lambda (e)
(let ((ci (let find ((i 0))
(if (string=? (list-ref names i) (list-ref e 0)) i
(find (+ i 1))))))
(unless (memv ci seen)
(set! seen (cons ci seen)))))
entropies)
(reverse seen)))))
(take polysemy-candidates (min 15 (length polysemy-candidates)))))
;; Stable words
(format #t "~%── Stable Words (same entropy everywhere) ──~%")
(for-each
(lambda (s)
(format #t " ~15a max-JSD=~,3f entropy-diff=~,2f~%"
(list-ref s 0) (list-ref s 2) (list-ref s 3)))
(take stable-words (min 10 (length stable-words))))
;; JSD Distribution
(format #t "~%── JSD Distribution ──~%")
(let ((bins (make-vector 10 0)))
(for-each
(lambda (s)
(let ((bin (min 9 (inexact->exact (floor (* (list-ref s 2) 10))))))
(vector-set! bins bin (+ (vector-ref bins bin) 1))))
all-scores)
(do ((i 0 (+ i 1))) ((>= i 10))
(format #t " ~,1f-~,1f: ~a ~a~%"
(* i 0.1) (* (+ i 1) 0.1)
(vector-ref bins i)
(make-string (min 50 (vector-ref bins i)) #\#))))
(let* ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0))
(passed (>= (length polysemy-candidates) 3)))
(format #t "~% Total time: ~,1f ms~%" elapsed-ms)
(format #t "~%VERDICT: ~a~%"
(cond
((>= (length polysemy-candidates) 6)
"Entropy/JSD reveals rich polysemy (CONFIRMED)")
((>= (length polysemy-candidates) 3)
"Polysemy detected, moderate signal (CONFIRMED)")
((> (length polysemy-candidates) 0)
"Some polysemy found but below threshold (PARTIALLY CONFIRMED)")
(else
"No polysemy detected via entropy (REJECTED)")))
(set! *exp9e-results*
(list (length all-scores) (length polysemy-candidates)
(length stable-words)
polysemy-candidates stable-words passed))
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp9e-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 9e: Connector Entropy Comparison~%")
(format port "# Date: ~a~%" (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
(format port "#~%")
(format port "shared_words: ~a~%" (length all-scores))
(format port "polysemy_candidates: ~a~%" (length polysemy-candidates))
(format port "stable_words: ~a~%" (length stable-words))
(format port "time_ms: ~,2f~%" elapsed-ms)
(format port "verdict: ~a~%" (if passed "CONFIRMED" "REJECTED"))
(format port "#~%# Polysemy candidates (max JSD > 0.3):~%")
(for-each
(lambda (p)
(format port "polysemy: ~a score=~,3f jsd=~,3f entropy_diff=~,2f~%"
(list-ref p 0) (list-ref p 1)
(list-ref p 2) (list-ref p 3)))
polysemy-candidates)
(format port "#~%# Stable words (max JSD < 0.05):~%")
(for-each
(lambda (s)
(format port "stable: ~a jsd=~,3f~%"
(list-ref s 0) (list-ref s 2)))
stable-words)
(format port "#~%# All scores (word score max_jsd entropy_diff mean_jsd):~%")
(for-each
(lambda (s)
(format port "word: ~a ~,3f ~,3f ~,2f ~,3f~%"
(list-ref s 0) (list-ref s 1)
(list-ref s 2) (list-ref s 3) (list-ref s 4)))
all-scores)))
(format #t "~%Results written to ~a~%" out-file)))))))))