;;
;; exp5-cross-domain.scm — Cross-Domain Structure
;;
;; Hypothesis: Comparing word classes across domain-specific compartments
;; reveals polysemy and shared grammatical roles.
;;
;; Method: Run domain-specific clustering on 2+ books, compare word groupings.
;; Words in different classes across domains = polysemy candidates.
;;
(define *exp5-results* '())
(define (exp5-cluster-book book-idx n-sample max-groups)
"Run full clustering pipeline for one book.
Returns (book-name classes connector-index)."
(let* ((book-name (vector-ref *cl-book-names* book-idx))
(book-sentences (filter (lambda (e) (= (car e) book-idx)) *cl-all-sentences*))
(sample (take book-sentences (min n-sample (length book-sentences)))))
(format #t " Clustering book ~a (~a sentences sampled)...~%" book-name (length sample))
;; Build sections
(let* ((sec-data (exp4-build-sections-from-book book-idx sample))
(sections (list-ref sec-data 0))
(sec-counts (list-ref sec-data 1))
;; 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))
;; Cluster
(classes (exp4-cluster-domain index words max-groups)))
(format #t " -> ~a classes from ~a words~%" (length classes) (length words))
(list book-name classes index))))
(define (exp5-word-to-class-map classes)
"Build word -> class-index hash from class list."
(let ((map (make-hash-table)))
(let loop ((cls classes) (idx 0))
(when (not (null? cls))
(for-each (lambda (w) (hash-set! map w idx)) (car cls))
(loop (cdr cls) (+ idx 1))))
map))
(define (exp5-class-jaccard class-a class-b)
"Jaccard similarity between two classes (sets of words)."
(let ((set-a (make-hash-table))
(intersection 0)
(union 0))
(for-each (lambda (w) (hash-set! set-a w #t)) class-a)
(for-each
(lambda (w)
(if (hash-ref set-a w #f)
(set! intersection (+ intersection 1))
(set! union (+ union 1))))
class-b)
(set! union (+ union (hash-count (const #t) set-a)))
(if (> union 0) (/ intersection union 1.0) 0.0)))
(define (run-exp5)
"Run Experiment 5: Cross-Domain Structure."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 5: Cross-Domain Structure~%")
(format #t "══════════════════════════════════════════════════~%~%")
;; Load corpus
(cl-load-all-corpus!)
;; Check that exp4 functions are available
(unless (defined? 'exp4-build-sections-from-book)
(format #t "ERROR: exp4 must be loaded first (for section building functions).~%")
(format #t "Load run-experiments.scm which loads all experiments.~%")
(error "exp4 not loaded"))
;; Pick the 3 largest books for comparison
(let* ((book-counts (map (lambda (idx)
(cons idx (length (filter (lambda (e) (= (car e) idx))
*cl-all-sentences*))))
(iota 5)))
(sorted-books (sort book-counts (lambda (a b) (> (cdr a) (cdr b)))))
(top-3 (take sorted-books (min 3 (length sorted-books)))))
(format #t "Selected books:~%")
(for-each
(lambda (bc)
(format #t " ~a (~a): ~a sentences~%"
(vector-ref *cl-book-names* (car bc)) (car bc) (cdr bc)))
top-3)
(format #t "~%")
;; Step 1: Cluster each book
(format #t "Step 1: Clustering each book...~%")
(let* ((t0 (get-internal-real-time))
(book-results (map (lambda (bc)
(exp5-cluster-book (car bc) 1500 15))
top-3))
(cluster-time-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t " All books clustered in ~,1f ms~%~%" cluster-time-ms)
;; Step 2: Build word-to-class maps
(let ((maps (map (lambda (br) (exp5-word-to-class-map (list-ref br 1))) book-results))
(names (map (lambda (br) (list-ref br 0)) book-results)))
;; Step 3: Find shared words across books
(format #t "Step 2: Analyzing cross-domain word behavior...~%~%")
;; Collect all classified words per book
(let ((all-classified (map (lambda (m)
(let ((words '()))
(hash-for-each (lambda (w _) (set! words (cons w words))) m)
words))
maps))
(shared-words (make-hash-table))
(polysemy-candidates '())
(shared-role-words '()))
;; Find words that appear in at least 2 books' class systems
(let ((word-book-map (make-hash-table)))
(do ((i 0 (+ i 1))) ((>= i (length maps)))
(hash-for-each
(lambda (w class-id)
(let ((existing (hash-ref word-book-map w '())))
(hash-set! word-book-map w (cons (cons i class-id) existing))))
(list-ref maps i)))
;; Analyze each shared word
(hash-for-each
(lambda (word book-classes)
(when (>= (length book-classes) 2)
(hash-set! shared-words word book-classes)
;; Check if word is in "same" class across books
;; (by checking if classmates overlap)
(let* ((classes-by-book
(map (lambda (bc)
(let* ((book-i (car bc))
(class-id (cdr bc))
(all-classes (list-ref (list-ref book-results book-i) 1)))
(if (< class-id (length all-classes))
(list-ref all-classes class-id)
(list word))))
book-classes))
;; Pairwise Jaccard between this word's classes across books
(jaccards '()))
(let outer ((rest classes-by-book))
(when (>= (length rest) 2)
(let inner ((others (cdr rest)))
(when (not (null? others))
(set! jaccards (cons (exp5-class-jaccard (car rest) (car others))
jaccards))
(inner (cdr others))))
(outer (cdr rest))))
(let ((max-jaccard (if (null? jaccards) 0.0 (apply max jaccards))))
(if (< max-jaccard 0.2)
;; Different classes in different books → polysemy candidate
(set! polysemy-candidates
(cons (list word max-jaccard book-classes) polysemy-candidates))
;; Same/similar class → shared grammatical role
(set! shared-role-words
(cons (list word max-jaccard book-classes) shared-role-words)))))))
word-book-map)
;; Sort by significance
(set! polysemy-candidates
(sort polysemy-candidates (lambda (a b) (< (list-ref a 1) (list-ref b 1)))))
(set! shared-role-words
(sort shared-role-words (lambda (a b) (> (list-ref a 1) (list-ref b 1)))))
;; Report
(format #t "── Shared Words ──~%")
(format #t " Total classified words per book: ~a~%"
(map length all-classified))
(format #t " Words in ≥2 books' classes: ~a~%"
(hash-count (const #t) shared-words))
(format #t " Polysemy candidates (Jaccard < 0.2): ~a~%"
(length polysemy-candidates))
(format #t " Shared-role words (Jaccard ≥ 0.2): ~a~%"
(length shared-role-words))
;; Top polysemy candidates
(format #t "~%── Top Polysemy Candidates ──~%")
(for-each
(lambda (p)
(let ((word (list-ref p 0))
(jaccard (list-ref p 1))
(books (list-ref p 2)))
(format #t " ~15a (J=~,2f) in books: ~a~%"
word jaccard
(string-join
(map (lambda (bc)
(format #f "~a:class~a"
(list-ref names (car bc)) (cdr bc)))
books)
", "))))
(take polysemy-candidates (min 20 (length polysemy-candidates))))
;; Top shared-role words
(format #t "~%── Top Shared-Role Words ──~%")
(for-each
(lambda (p)
(let ((word (list-ref p 0))
(jaccard (list-ref p 1))
(books (list-ref p 2)))
(format #t " ~15a (J=~,2f) in books: ~a~%"
word jaccard
(string-join
(map (lambda (bc)
(format #f "~a:class~a"
(list-ref names (car bc)) (cdr bc)))
books)
", "))))
(take shared-role-words (min 20 (length shared-role-words))))
;; Class alignment matrix
(format #t "~%── Class Alignment (Book 0 vs Book 1) ──~%")
(when (>= (length book-results) 2)
(let ((classes-0 (list-ref (list-ref book-results 0) 1))
(classes-1 (list-ref (list-ref book-results 1) 1)))
(format #t " ~15a" "")
(do ((j 0 (+ j 1))) ((>= j (min 10 (length classes-1))))
(format #t " ~6a" (format #f "B1-~a" j)))
(format #t "~%")
(do ((i 0 (+ i 1))) ((>= i (min 10 (length classes-0))))
(format #t " ~15a" (format #f "B0-~a" i))
(do ((j 0 (+ j 1))) ((>= j (min 10 (length classes-1))))
(format #t " ~6,2f"
(exp5-class-jaccard (list-ref classes-0 i)
(list-ref classes-1 j))))
(format #t "~%"))))
;; Verdict
(format #t "~%VERDICT: ~a~%"
(cond
((> (length polysemy-candidates) 5)
"Cross-domain analysis reveals polysemy — words cluster differently (CONFIRMED)")
((> (length shared-role-words) (length polysemy-candidates))
"Most words maintain role across domains — grammar is domain-independent (PARTIALLY CONFIRMED)")
((= (hash-count (const #t) shared-words) 0)
"No shared classified words — domains too disjoint (INCONCLUSIVE)")
(else "All words cluster identically — no polysemy detected (REJECTED)")))
;; Store results
(set! *exp5-results*
(list (hash-count (const #t) shared-words)
(length polysemy-candidates)
(length shared-role-words)
(take polysemy-candidates (min 10 (length polysemy-candidates)))
(take shared-role-words (min 10 (length shared-role-words)))))
;; Write results
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp5-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 5: Cross-Domain Structure~%")
(format port "# Date: ~a~%" (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
(format port "# Books: ~a~%" (string-join names ", "))
(format port "#~%")
(format port "shared_words: ~a~%" (hash-count (const #t) shared-words))
(format port "polysemy_candidates: ~a~%" (length polysemy-candidates))
(format port "shared_role_words: ~a~%" (length shared-role-words))
(format port "#~%# Polysemy candidates (word jaccard books):~%")
(for-each
(lambda (p)
(format port "polysemy: ~a ~,3f~%"
(list-ref p 0) (list-ref p 1)))
(take polysemy-candidates (min 30 (length polysemy-candidates))))
(format port "#~%# Shared-role words (word jaccard):~%")
(for-each
(lambda (p)
(format port "shared: ~a ~,3f~%"
(list-ref p 0) (list-ref p 1)))
(take shared-role-words (min 30 (length shared-role-words))))))
(format #t "~%Results written to ~a~%" out-file))))))))