;;
;; exp4-domain-clustering.scm — Domain-Specific Clustering
;;
;; Hypothesis: Clustering within a domain produces different (and potentially
;; more precise) word classes than global clustering.
;;
;; Method: Run clustering on the largest book's pairs alone, compare to
;; global clustering. Use connector-cosine as quality metric.
;;
(define *exp4-results* '())
(define (exp4-build-sections-from-book book-idx sentences)
"Build section inventory from one book's sentences.
Returns (sections section-counts) where:
sections: hash word -> list of disjuncts
section-counts: hash (word . disjunct) -> count"
(let ((sections (make-hash-table))
(section-counts (make-hash-table))
(window 6))
(for-each
(lambda (entry)
(let* ((sentence (cdr entry))
(words (filter (lambda (w) (> (string-length w) 0))
(string-split sentence #\space)))
(n (length words))
(word-vec (list->vector words)))
;; Get MI-based parse edges for this sentence
(let ((edges (cpu-pmfg-parse words)))
;; Extract sections from parse
(do ((i 0 (+ i 1))) ((>= i n))
(let ((word (vector-ref word-vec i))
(left-conns '())
(right-conns '()))
(for-each
(lambda (edge)
(let ((p1 (car edge))
(p2 (cadr edge)))
(cond
((= p1 i)
(set! right-conns
(cons (string-append (vector-ref word-vec p2) "+")
right-conns)))
((= p2 i)
(set! left-conns
(cons (string-append (vector-ref word-vec p1) "-")
left-conns))))))
edges)
(let ((connectors (append (reverse left-conns) right-conns)))
(unless (null? connectors)
(let* ((disjunct (string-join connectors " "))
(key (cons word disjunct)))
;; Add to sections
(let ((existing (hash-ref sections word '())))
(unless (member disjunct existing)
(hash-set! sections word (cons disjunct existing))))
;; Count
(hash-set! section-counts key
(+ (hash-ref section-counts key 0) 1))))))))))
sentences)
(list sections section-counts)))
(define (exp4-build-connector-index sections section-counts word-list)
"Build connector index from domain-specific sections.
Returns hash: word -> hash(connector -> count)."
(let ((index (make-hash-table)))
(for-each
(lambda (w)
(let ((disjs (hash-ref sections w '()))
(vec (make-hash-table)))
(for-each
(lambda (d)
(let ((count (hash-ref section-counts (cons w d) 0)))
(when (> count 0)
(let ((connectors (filter (lambda (c) (> (string-length c) 0))
(string-split d #\space))))
(for-each
(lambda (conn)
(hash-set! vec conn (+ (hash-ref vec conn 0) count)))
connectors)))))
disjs)
(when (> (hash-count (const #t) vec) 0)
(hash-set! index w vec))))
word-list)
index))
(define (exp4-cosine-from-index index w1 w2)
"Compute cosine similarity between two words using given connector index."
(let ((v1 (hash-ref index w1 #f))
(v2 (hash-ref index w2 #f)))
(if (or (not v1) (not v2))
0.0
(let ((dot 0.0) (norm1-sq 0.0) (norm2-sq 0.0))
(hash-for-each
(lambda (conn c1)
(set! norm1-sq (+ norm1-sq (* c1 c1)))
(let ((c2 (hash-ref v2 conn #f)))
(when c2 (set! dot (+ dot (* c1 c2))))))
v1)
(hash-for-each
(lambda (conn c2)
(set! norm2-sq (+ norm2-sq (* c2 c2))))
v2)
(let ((denom (* (sqrt norm1-sq) (sqrt norm2-sq))))
(if (< denom 1e-10) 0.0 (/ dot denom)))))))
(define (exp4-find-in-group index w1 w2 candidates epsilon tightness lower-bound max-size)
"Expand seed pair into natural group using domain-specific connector index."
(let ((benchmark (exp4-cosine-from-index index w1 w2))
(ingroup (list w1 w2)))
(let ((minscore (- benchmark epsilon)))
(let loop ((cands candidates))
(cond
((null? cands) ingroup)
((>= (length ingroup) max-size) ingroup)
(else
(let ((candidate (car cands)))
(if (or (equal? candidate w1) (equal? candidate w2)
(member candidate ingroup))
(loop (cdr cands))
(let* ((insz (length ingroup))
(tight (if (= insz 2) 2
(inexact->exact (round (* tightness insz)))))
(maxfail (- insz tight))
(failcnt 0)
(rejected #f))
(let member-loop ((members ingroup))
(when (and (not (null? members)) (not rejected))
(let ((score (exp4-cosine-from-index index candidate (car members))))
(cond
((< score lower-bound) (set! rejected #t))
((< score minscore)
(set! failcnt (+ failcnt 1))
(when (> failcnt maxfail) (set! rejected #t))))
(member-loop (cdr members)))))
(unless rejected
(set! ingroup (append ingroup (list candidate))))
(loop (cdr cands)))))))))))
(define (exp4-cluster-domain index word-list max-groups)
"Run clustering on domain-specific connector index.
Returns list of groups (each group is a list of words)."
(let ((classes '())
(classified (make-hash-table))
(n-words (length word-list)))
;; Find top pairs by cosine
(let ((pair-scores '()))
(do ((i 0 (+ i 1))) ((>= i (min 200 n-words)))
(do ((j (+ i 1) (+ j 1))) ((>= j (min 200 n-words)))
(let* ((w1 (list-ref word-list i))
(w2 (list-ref word-list j))
(sim (exp4-cosine-from-index index w1 w2)))
(when (> sim 0.15)
(set! pair-scores (cons (list w1 w2 sim) pair-scores))))))
;; Sort by cosine descending
(let ((sorted (sort pair-scores (lambda (a b) (> (list-ref a 2) (list-ref b 2))))))
;; Greedily form groups from top pairs
(let loop ((remaining sorted) (groups-found 0))
(when (and (not (null? remaining)) (< groups-found max-groups))
(let* ((top (car remaining))
(w1 (list-ref top 0))
(w2 (list-ref top 1)))
(if (or (hash-ref classified w1 #f) (hash-ref classified w2 #f))
(loop (cdr remaining) groups-found)
(let ((group (exp4-find-in-group index w1 w2 word-list
0.10 0.7 0.10 8)))
(when (>= (length group) 2)
(for-each (lambda (w) (hash-set! classified w #t)) group)
(set! classes (cons group classes)))
(loop (cdr remaining) (+ groups-found 1)))))))
(reverse classes)))))
(define (exp4-intra-class-similarity index class)
"Compute mean pairwise cosine within a class."
(if (< (length class) 2) 0.0
(let ((sum 0.0) (n 0))
(let outer ((rest class))
(when (not (null? rest))
(let inner ((others (cdr rest)))
(when (not (null? others))
(set! sum (+ sum (exp4-cosine-from-index index (car rest) (car others))))
(set! n (+ n 1))
(inner (cdr others))))
(outer (cdr rest))))
(if (> n 0) (/ sum n) 0.0))))
(define (run-exp4)
"Run Experiment 4: Domain-Specific Clustering."
(format #t "~%══════════════════════════════════════════════════~%")
(format #t " EXPERIMENT 4: Domain-Specific Clustering~%")
(format #t "══════════════════════════════════════════════════~%~%")
;; Load corpus
(cl-load-all-corpus!)
;; Find the largest book
(let* ((book-counts (map (lambda (idx)
(cons idx (length (filter (lambda (e) (= (car e) idx))
*cl-all-sentences*))))
(iota 5)))
(largest (car (sort book-counts (lambda (a b) (> (cdr a) (cdr b))))))
(book-idx (car largest))
(book-name (vector-ref *cl-book-names* book-idx))
(book-sentences (filter (lambda (e) (= (car e) book-idx)) *cl-all-sentences*)))
(format #t "Largest book: ~a (~a) with ~a sentences~%~%"
book-name book-idx (length book-sentences))
;; Step 1: Build domain-specific sections (this takes a while — parsing)
(format #t "Step 1: Building domain-specific sections...~%")
(let* ((t0 (get-internal-real-time))
;; Only process first 2000 sentences to keep runtime reasonable
(sample-sentences (take book-sentences (min 2000 (length book-sentences))))
(sec-data (exp4-build-sections-from-book book-idx sample-sentences))
(domain-sections (list-ref sec-data 0))
(domain-sec-counts (list-ref sec-data 1))
(sec-time-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t " ~a words with sections, ~a section entries in ~,1f ms~%"
(hash-count (const #t) domain-sections)
(hash-count (const #t) domain-sec-counts)
sec-time-ms)
;; Step 2: Build domain connector index
(format #t "~%Step 2: Building domain connector index...~%")
(let* ((domain-words (let ((wl '()))
(hash-for-each (lambda (w _) (set! wl (cons w wl)))
domain-sections)
wl))
(domain-index (exp4-build-connector-index domain-sections domain-sec-counts
domain-words)))
(format #t " ~a words in domain connector index~%" (hash-count (const #t) domain-index))
;; Step 3: Run domain clustering
(format #t "~%Step 3: Running domain-specific clustering...~%")
(let* ((t1 (get-internal-real-time))
(domain-classes (exp4-cluster-domain domain-index domain-words 20))
(domain-time-ms (/ (- (get-internal-real-time) t1) 1000000.0)))
(format #t " Found ~a domain classes in ~,1f ms~%" (length domain-classes) domain-time-ms)
;; Step 4: Get global classes for comparison
(format #t "~%Step 4: Comparing to global classes...~%")
(let ((global-classes '()))
(hash-for-each
(lambda (class-id members)
(when (>= (length members) 2)
(set! global-classes (cons members global-classes))))
*word-classes*)
(format #t " Global classes: ~a~%" (length global-classes))
;; Display domain classes with quality metrics
(format #t "~%── Domain Classes ──~%")
(let ((domain-sims '()))
(for-each
(lambda (class)
(let ((sim (exp4-intra-class-similarity domain-index class)))
(set! domain-sims (cons sim domain-sims))
(format #t " [~,3f] ~a~%" sim
(string-join class ", "))))
domain-classes)
;; Display global classes (only those with words in this domain)
(format #t "~%── Global Classes (with domain words) ──~%")
(let ((global-sims '())
(domain-word-set (make-hash-table)))
(for-each (lambda (w) (hash-set! domain-word-set w #t)) domain-words)
(for-each
(lambda (class)
(let ((in-domain (filter (lambda (w) (hash-ref domain-word-set w #f)) class)))
(when (>= (length in-domain) 2)
;; Use global connector index for fair comparison
(let ((global-sim (exp4-intra-class-similarity *cl-connector-index* class))
(domain-sim (exp4-intra-class-similarity domain-index in-domain)))
(set! global-sims (cons global-sim global-sims))
(format #t " [g=~,3f d=~,3f] ~a~%" global-sim domain-sim
(string-join class ", "))))))
global-classes)
;; Compare class inventories
(format #t "~%── Comparison ──~%")
(let ((avg-domain-sim (if (null? domain-sims) 0.0
(/ (apply + domain-sims) (length domain-sims))))
(avg-global-sim (if (null? global-sims) 0.0
(/ (apply + global-sims) (length global-sims)))))
(format #t " Domain classes: ~a, avg intra-class cosine: ~,3f~%"
(length domain-classes) avg-domain-sim)
(format #t " Global classes: ~a (with domain words), avg cosine: ~,3f~%"
(length global-sims) avg-global-sim)
;; Word overlap: which words are in domain classes vs global?
(let ((domain-classified (make-hash-table))
(global-classified (make-hash-table)))
(for-each
(lambda (class) (for-each (lambda (w) (hash-set! domain-classified w #t)) class))
domain-classes)
(for-each
(lambda (class) (for-each (lambda (w) (hash-set! global-classified w #t)) class))
global-classes)
;; Find words that are grouped DIFFERENTLY
(let ((same-group 0) (diff-group 0) (only-domain 0) (only-global 0))
(hash-for-each
(lambda (w _)
(if (hash-ref global-classified w #f)
;; In both — check if same group
(let* ((d-class (find (lambda (c) (member w c)) domain-classes))
(g-class (find (lambda (c) (member w c)) global-classes)))
(if (and d-class g-class
(> (length (lset-intersection equal? d-class g-class)) 1))
(set! same-group (+ same-group 1))
(set! diff-group (+ diff-group 1))))
(set! only-domain (+ only-domain 1))))
domain-classified)
(hash-for-each
(lambda (w _)
(unless (hash-ref domain-classified w #f)
(set! only-global (+ only-global 1))))
global-classified)
(format #t "~% Words in same group: ~a~%" same-group)
(format #t " Words in different groups: ~a~%" diff-group)
(format #t " Only in domain classes: ~a~%" only-domain)
(format #t " Only in global classes: ~a~%" only-global)
(format #t "~%VERDICT: Domain clustering ~a~%"
(cond
((and (> (length domain-classes) 0)
(> avg-domain-sim avg-global-sim))
"produces TIGHTER classes (CONFIRMED)")
((and (> (length domain-classes) 0)
(> diff-group same-group))
"produces DIFFERENT groupings (PARTIALLY CONFIRMED)")
((> (length domain-classes) 0)
"produces SIMILAR classes to global (MIXED)")
(else "found NO classes — insufficient data (INCONCLUSIVE)")))
;; Record results
(set! *exp4-results*
(list book-name (length domain-classes) (length global-classes)
avg-domain-sim avg-global-sim
same-group diff-group only-domain only-global))
;; Write results
(let ((out-file (string-append *mvp-dir* "/experiments/results/exp4-results.txt")))
(call-with-output-file out-file
(lambda (port)
(format port "# Experiment 4: Domain-Specific Clustering~%")
(format port "# Date: ~a~%" (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
(format port "# Book: ~a (~a sentences, ~a sampled)~%"
book-name (length book-sentences) (length sample-sentences))
(format port "#~%")
(format port "domain_classes: ~a~%" (length domain-classes))
(format port "global_classes: ~a~%" (length global-classes))
(format port "avg_domain_cosine: ~,4f~%" avg-domain-sim)
(format port "avg_global_cosine: ~,4f~%" avg-global-sim)
(format port "words_same_group: ~a~%" same-group)
(format port "words_diff_group: ~a~%" diff-group)
(format port "words_only_domain: ~a~%" only-domain)
(format port "words_only_global: ~a~%" only-global)
(format port "#~%# Domain classes:~%")
(for-each
(lambda (class)
(format port "domain_class: ~a~%" (string-join class ",")))
domain-classes)
(format port "#~%# Global classes:~%")
(for-each
(lambda (class)
(format port "global_class: ~a~%" (string-join class ",")))
global-classes)))
(format #t "~%Results written to ~a~%" out-file)))))))))))))