;;
;; exp9b-word-polysemy.scm — Word-Level Polysemy Detection
;;
;; Hypothesis: Comparing a word's own connector profile between
;; compartments reveals polysemy more reliably than comparing
;; the classes it belongs to (exp9's approach).
;;
;; Method: For each word appearing in multiple compartments'
;; connector indices, compute cosine between its connector vectors.
;; Low cosine = different grammatical behavior = polysemy.
;;
(define *exp9b-results* '())
(define (exp9b-word-cosine index-a index-b word)
"Cosine between a word's connector vectors in two different indices."
(let ((vec-a (hash-ref index-a word #f))
(vec-b (hash-ref index-b word #f)))
(if (or (not vec-a) (not vec-b))
#f ; word not in both indices
(let ((dot 0.0) (norm-a-sq 0.0) (norm-b-sq 0.0))
(hash-for-each
(lambda (conn ca)
(set! norm-a-sq (+ norm-a-sq (* ca ca)))
(let ((cb (hash-ref vec-b conn #f)))
(when cb (set! dot (+ dot (* ca cb))))))
vec-a)
(hash-for-each
(lambda (conn cb)
(set! norm-b-sq (+ norm-b-sq (* cb cb))))
vec-b)
(let ((denom (* (sqrt norm-a-sq) (sqrt norm-b-sq))))
(if (< denom 1e-10) 0.0 (/ dot denom)))))))
(define (exp9b-word-connectors index word)
"Get a word's top connectors as a readable string."
(let ((vec (hash-ref index word #f)))
(if (not vec) "(none)"
(let ((pairs '()))
(hash-for-each (lambda (c n) (set! pairs (cons (cons c n) 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 6 (length sorted))))
" "))))))
(define (run-exp9b)
"Run Experiment 9b: Word-Level Polysemy Detection."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 9b: Word-Level Polysemy Detection~%")
(format #t "══════════════════════════════════════════════════~%~%")
;; Need exp7 compartment data
(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))
(for-each
(lambda (r)
(format #t " ~a: ~a classes, ~a words in connector index~%"
(car r) (length (cadr r))
(hash-count (const #t) (list-ref (cdr r) 1))))
comp-data)
;; Step 1: Find words present in multiple compartments' connector indices
(format #t "~%Step 1: Finding shared words across connector indices...~%")
(let* ((indices (map (lambda (r) (list-ref (cdr r) 1)) comp-data))
(names (map car comp-data))
(word-presence (make-hash-table))) ; word → list of (comp-idx . index)
;; Map each word to which compartments it appears in
(do ((i 0 (+ i 1))) ((>= i (length indices)))
(hash-for-each
(lambda (word _)
(let ((existing (hash-ref word-presence word '())))
(hash-set! word-presence word (cons i existing))))
(list-ref indices i)))
;; Filter to words in 2+ compartments
(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 word-level cosine across all compartment pairs
(format #t "Step 2: Computing word-level connector-cosine...~%")
(let ((polysemy-candidates '())
(stable-words '())
(all-scores '()))
;; For each shared word, compute cosine between each pair of compartments
(for-each
(lambda (entry)
(let* ((word (car entry))
(comp-ids (cdr entry))
(pair-cosines '()))
;; Compute pairwise cosines
(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))
(cos (exp9b-word-cosine
(list-ref indices ci-a)
(list-ref indices ci-b)
word)))
(when cos
(set! pair-cosines
(cons (list (list-ref names ci-a)
(list-ref names ci-b)
cos)
pair-cosines))))
(inner (cdr others))))
(outer (cdr rest))))
;; Classify: min cosine across all pairs
(unless (null? pair-cosines)
(let ((min-cos (apply min (map caddr pair-cosines)))
(max-cos (apply max (map caddr pair-cosines)))
(mean-cos (/ (apply + (map caddr pair-cosines))
(length pair-cosines))))
(set! all-scores (cons (list word min-cos mean-cos max-cos
pair-cosines)
all-scores))
(if (< min-cos 0.3)
(set! polysemy-candidates
(cons (list word min-cos mean-cos pair-cosines)
polysemy-candidates))
(when (> min-cos 0.7)
(set! stable-words
(cons (list word min-cos mean-cos pair-cosines)
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 (min cosine < 0.3): ~a~%"
(length polysemy-candidates))
(format #t " Stable words (min cosine > 0.7): ~a~%"
(length stable-words))
;; Show polysemy candidates with connector details
(format #t "~%── Polysemy Candidates ──~%")
(if (null? polysemy-candidates)
(format #t " (none found)~%")
(for-each
(lambda (p)
(let ((word (list-ref p 0))
(min-cos (list-ref p 1))
(pairs (list-ref p 3)))
(format #t "~% ~a (min-cosine=~,3f):~%" word min-cos)
(for-each
(lambda (pc)
(format #t " ~a vs ~a: cosine=~,3f~%"
(list-ref pc 0) (list-ref pc 1) (list-ref pc 2)))
pairs)
;; Show what connectors differ
(for-each
(lambda (ci)
(format #t " ~a connectors: ~a~%"
(list-ref names ci)
(exp9b-word-connectors (list-ref indices ci) word)))
(let ((seen (make-hash-table)))
(let ((ids '()))
(for-each
(lambda (pc)
(let ((ci-a (let find ((i 0))
(if (string=? (list-ref names i) (list-ref pc 0)) i
(find (+ i 1)))))
(ci-b (let find ((i 0))
(if (string=? (list-ref names i) (list-ref pc 1)) i
(find (+ i 1))))))
(unless (hash-ref seen ci-a #f)
(hash-set! seen ci-a #t)
(set! ids (cons ci-a ids)))
(unless (hash-ref seen ci-b #f)
(hash-set! seen ci-b #t)
(set! ids (cons ci-b ids)))))
pairs)
(reverse ids))))))
(take polysemy-candidates (min 20 (length polysemy-candidates)))))
;; Show stable words
(format #t "~%── Stable Words (same role everywhere) ──~%")
(for-each
(lambda (s)
(format #t " ~15a min-cosine=~,3f~%" (list-ref s 0) (list-ref s 1)))
(take stable-words (min 15 (length stable-words))))
;; Distribution histogram
(format #t "~%── Cosine Distribution ──~%")
(let ((bins (make-vector 10 0)))
(for-each
(lambda (s)
(let ((bin (min 9 (inexact->exact (floor (* (cadr s) 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)) #\#))))
;; Compare to exp5 and exp9
(format #t "~%── Comparison ──~%")
(format #t " exp5 (jaccard): ~a polysemy candidates~%"
(if (null? *exp5-results*) "not run"
(number->string (list-ref *exp5-results* 1))))
(format #t " exp9 (class-cosine): ~a polysemy candidates~%"
(if (null? *exp9-results*) "not run"
(number->string (list-ref *exp9-results* 1))))
(format #t " exp9b (word-cosine): ~a polysemy candidates~%"
(length polysemy-candidates))
(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)
"Word-level cosine 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 at word level (REJECTED)")))
;; Store results
(set! *exp9b-results*
(list (length all-scores) (length polysemy-candidates)
(length stable-words)
polysemy-candidates stable-words passed))
;; Write results
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp9b-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 9b: Word-Level Polysemy Detection~%")
(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 (min cosine < 0.3):~%")
(for-each
(lambda (p)
(format port "polysemy: ~a min_cos=~,3f mean_cos=~,3f~%"
(list-ref p 0) (list-ref p 1) (list-ref p 2)))
polysemy-candidates)
(format port "#~%# Stable words (min cosine > 0.7):~%")
(for-each
(lambda (s)
(format port "stable: ~a min_cos=~,3f~%"
(list-ref s 0) (list-ref s 1)))
stable-words)
(format port "#~%# Full distribution (word min_cos mean_cos max_cos):~%")
(for-each
(lambda (s)
(format port "word: ~a ~,3f ~,3f ~,3f~%"
(list-ref s 0) (list-ref s 1)
(list-ref s 2) (list-ref s 3)))
all-scores)))
(format #t "~%Results written to ~a~%" out-file))))))))