;
; lib/counting.scm
;
; Shared infrastructure for corpus-based experiments.
; Provides: tokenization, co-occurrence counting, PMI computation,
; agglomerative clustering by PMI-profile similarity, medoid naming,
; frame evidence computation.
;
; All experiments should use these functions instead of reimplementing
; the counting/clustering pipeline. This ensures that every value in
; every experiment is COMPUTED from data, not hardcoded.
;
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-69)) ; hash tables
(use-modules (ice-9 format))
;; ═══════════════════════════════════════════════════════════════════
;; TOKENIZATION
;; ═══════════════════════════════════════════════════════════════════
;; Tokenize a sentence into words, filtering short function words
(define (tokenize sent)
(filter (lambda (w) (> (string-length w) 0))
(string-split sent #\space)))
;; Tokenize keeping only content words (length > 2)
(define (tokenize-content sent)
(filter (lambda (w) (> (string-length w) 2))
(string-split sent #\space)))
;; ═══════════════════════════════════════════════════════════════════
;; CO-OCCURRENCE COUNTING
;; ═══════════════════════════════════════════════════════════════════
;; Canonical key for a word pair (alphabetically ordered)
(define (pair-key w1 w2)
(if (string<? w1 w2)
(string-append w1 "|" w2)
(string-append w2 "|" w1)))
;; Count word co-occurrences and individual word frequencies from corpus.
;; Returns: (word-counts-table . pair-counts-table)
;; Counts all pairs of words that appear in the same sentence.
;; min-length default 2 matches tokenize-content (keeps words > 2 chars).
(define (count-cooccurrences corpus . opts)
(let ((min-length (if (null? opts) 2 (car opts)))
(word-counts (make-hash-table string=?))
(pair-counts (make-hash-table string=?)))
(for-each
(lambda (sent)
(let ((words (filter (lambda (w) (> (string-length w) min-length))
(string-split sent #\space))))
;; Count individual words
(for-each
(lambda (w)
(hash-table-set! word-counts w
(+ 1 (hash-table-ref/default word-counts w 0))))
words)
;; Count co-occurrences (all pairs in sentence)
(for-each
(lambda (w1)
(for-each
(lambda (w2)
(when (not (string=? w1 w2))
(let ((key (pair-key w1 w2)))
(hash-table-set! pair-counts key
(+ 1 (hash-table-ref/default pair-counts key 0))))))
words))
words)))
corpus)
(cons word-counts pair-counts)))
;; ═══════════════════════════════════════════════════════════════════
;; PMI COMPUTATION
;; ═══════════════════════════════════════════════════════════════════
;; Compute the co-occurrence marginal for a word: sum of all pair counts
;; containing that word. This ensures PMI uses a consistent probability space.
(define (pair-marginal word pair-counts)
(let ((total 0))
(hash-table-walk pair-counts
(lambda (key count)
(let ((parts (string-split key #\|)))
(when (or (string=? word (car parts))
(string=? word (cadr parts)))
(set! total (+ total count))))))
total))
;; Compute PMI(w1, w2) given count tables.
;; PMI = log2(P(w1,w2) / (P(w1) * P(w2)))
;; All probabilities computed from the co-occurrence matrix for consistency:
;; P(w1,w2) = c(w1,w2) / T
;; P(w) = marginal(w) / T
;; where T = sum of all pair counts.
;; High positive PMI = strong association.
;; Returns -999 for zero-count pairs.
(define (compute-pmi word-counts pair-counts w1 w2)
(let* ((total-pairs (apply + (hash-table-values pair-counts)))
(joint (hash-table-ref/default pair-counts (pair-key w1 w2) 0))
(m1 (pair-marginal w1 pair-counts))
(m2 (pair-marginal w2 pair-counts)))
(if (or (= joint 0) (= m1 0) (= m2 0) (= total-pairs 0))
-999.0
;; PMI = log2( c(w1,w2) * T / (marginal(w1) * marginal(w2)) )
(/ (log (/ (* joint total-pairs) (* m1 m2))) (log 2)))))
;; Compute PMI vector for a word: PMI with every other word that co-occurs.
;; Returns: alist of (other-word . pmi-value)
(define (pmi-vector word-counts pair-counts target-word)
(let ((result '()))
(hash-table-walk word-counts
(lambda (w count)
(when (not (string=? w target-word))
(let ((pmi (compute-pmi word-counts pair-counts target-word w)))
(when (> pmi -999.0)
(set! result (cons (cons w pmi) result)))))))
(sort result (lambda (a b) (> (cdr a) (cdr b))))))
;; ═══════════════════════════════════════════════════════════════════
;; SIMILARITY BETWEEN PMI VECTORS
;; ═══════════════════════════════════════════════════════════════════
;; Cosine similarity between two PMI vectors (alists).
;; Words not present in one vector are treated as 0.
(define (cosine-similarity vec1 vec2)
(let* ((all-words (delete-duplicates
(append (map car vec1) (map car vec2))
string=?))
(get-val (lambda (vec w)
(let ((entry (assoc w vec string=?)))
(if entry (cdr entry) 0.0))))
(dot (apply + (map (lambda (w)
(* (get-val vec1 w) (get-val vec2 w)))
all-words)))
(mag1 (sqrt (apply + (map (lambda (p) (* (cdr p) (cdr p))) vec1))))
(mag2 (sqrt (apply + (map (lambda (p) (* (cdr p) (cdr p))) vec2)))))
(if (or (= mag1 0) (= mag2 0))
0.0
(/ dot (* mag1 mag2)))))
;; ═══════════════════════════════════════════════════════════════════
;; AGGLOMERATIVE CLUSTERING BY PMI-PROFILE SIMILARITY
;; ═══════════════════════════════════════════════════════════════════
;; Cluster words by similarity of their PMI profiles.
;; threshold: minimum cosine similarity to merge (0.0 to 1.0)
;; Returns: list of clusters, each cluster is a list of words.
(define (cluster-by-pmi-similarity word-counts pair-counts threshold)
;; Get all content words (appear more than once)
(let* ((all-words (filter
(lambda (w) (> (hash-table-ref/default word-counts w 0) 1))
(hash-table-keys word-counts)))
;; Compute PMI vectors for each word
(vectors (make-hash-table string=?)))
;; Build PMI vectors
(for-each
(lambda (w)
(hash-table-set! vectors w
(pmi-vector word-counts pair-counts w)))
all-words)
;; Start with each word as its own cluster
(let ((clusters (map list all-words)))
;; Compute similarity between two clusters (average-link)
(define (cluster-similarity c1 c2)
(if (or (null? c1) (null? c2))
0.0
(let* ((pairs (append-map
(lambda (w1)
(map (lambda (w2)
(cosine-similarity
(hash-table-ref/default vectors w1 '())
(hash-table-ref/default vectors w2 '())))
c2))
c1))
(n (length pairs)))
(if (= n 0) 0.0
(/ (apply + pairs) n)))))
;; Find the most similar pair of clusters
(define (find-best-merge clusters)
(let ((best-sim -1.0)
(best-i 0)
(best-j 1)
(n (length clusters)))
(do ((i 0 (+ i 1)))
((>= i n))
(do ((j (+ i 1) (+ j 1)))
((>= j n))
(let ((sim (cluster-similarity
(list-ref clusters i)
(list-ref clusters j))))
(when (> sim best-sim)
(set! best-sim sim)
(set! best-i i)
(set! best-j j)))))
(values best-i best-j best-sim)))
;; Agglomerative merging loop
(let loop ((current-clusters clusters))
(if (<= (length current-clusters) 1)
current-clusters
(call-with-values
(lambda () (find-best-merge current-clusters))
(lambda (i j sim)
(if (< sim threshold)
current-clusters ;; No more merges above threshold
(let* ((ci (list-ref current-clusters i))
(cj (list-ref current-clusters j))
(merged (append ci cj))
(rest (filter
(lambda (c)
(and (not (equal? c ci))
(not (equal? c cj))))
current-clusters)))
(loop (cons merged rest)))))))))))
;; ═══════════════════════════════════════════════════════════════════
;; MEDOID NAMING
;; ═══════════════════════════════════════════════════════════════════
;; Find the medoid of a cluster: the member with the highest average
;; PMI to all other members. This word IS the cluster's algorithmic name.
;; No human labels needed.
(define (find-medoid cluster word-counts pair-counts)
(if (= (length cluster) 1)
(car cluster)
(let ((best-word "")
(best-avg -999.0))
(for-each
(lambda (w)
(let* ((others (filter (lambda (w2) (not (string=? w w2))) cluster))
(pmis (map (lambda (w2)
(compute-pmi word-counts pair-counts w w2))
others))
(valid-pmis (filter (lambda (p) (> p -999.0)) pmis))
(avg (if (null? valid-pmis) -999.0
(/ (apply + valid-pmis) (length valid-pmis)))))
(when (> avg best-avg)
(set! best-avg avg)
(set! best-word w))))
cluster)
best-word)))
;; Name all clusters by their medoids.
;; Returns: alist of (medoid-name . cluster-members)
(define (name-clusters-by-medoid clusters word-counts pair-counts)
(map (lambda (cluster)
(cons (find-medoid cluster word-counts pair-counts) cluster))
clusters))
;; ═══════════════════════════════════════════════════════════════════
;; FRAME EVIDENCE COMPUTATION
;; ═══════════════════════════════════════════════════════════════════
;; For a given sentence, compute how much evidence each cluster has.
;; Evidence = sum of PMI between context words and each cluster's members.
;; Returns: alist of (cluster-medoid . total-evidence)
(define (compute-frame-evidence sentence named-clusters word-counts pair-counts)
(let* ((words (tokenize-content sentence))
(results '()))
(for-each
(lambda (named-cluster)
(let* ((medoid (car named-cluster))
(members (cdr named-cluster))
(evidence 0.0))
;; For each context word, sum PMI with cluster members
(for-each
(lambda (context-word)
(for-each
(lambda (member)
(when (not (string=? context-word member))
(let ((pmi (compute-pmi word-counts pair-counts
context-word member)))
(when (> pmi -999.0)
(set! evidence (+ evidence pmi))))))
members))
words)
(set! results (cons (cons medoid evidence) results))))
named-clusters)
(sort results (lambda (a b) (> (cdr a) (cdr b))))))
;; ═══════════════════════════════════════════════════════════════════
;; DISAMBIGUATION
;; ═══════════════════════════════════════════════════════════════════
;; Disambiguate a target word in a sentence by finding which cluster
;; the context best supports.
;; Returns: (best-cluster-medoid . evidence-score)
(define (disambiguate sentence target-word named-clusters word-counts pair-counts)
(let* (;; Only consider clusters that contain the target word
(relevant-clusters
(filter (lambda (nc)
(member target-word (cdr nc) string=?))
named-clusters))
;; If target word isn't in multiple clusters, check all
(clusters-to-check
(if (< (length relevant-clusters) 2)
named-clusters
relevant-clusters))
(evidence (compute-frame-evidence sentence clusters-to-check
word-counts pair-counts)))
(if (null? evidence)
(cons "UNKNOWN" 0.0)
(car evidence))))
;; ═══════════════════════════════════════════════════════════════════
;; VAGUENESS METRIC
;; ═══════════════════════════════════════════════════════════════════
;; Compute vagueness for a disambiguation result.
;; Measures the relative gap between top-2 evidence scores.
;; Vagueness = 1 - |best - second| / (|best| + |second|)
;; Works correctly with both positive and negative evidence.
;; 0.0 = maximally clear (large gap between best and second).
;; 1.0 = maximally vague (top clusters tied).
;; If no evidence or only one cluster, returns 1.0 (maximally vague).
(define (compute-vagueness evidence-scores)
(if (< (length evidence-scores) 2)
1.0 ;; Can't disambiguate with < 2 clusters
(let* ((best (cdr (car evidence-scores)))
(second (cdr (cadr evidence-scores)))
(margin (abs (- best second)))
(scale (+ (abs best) (abs second))))
(if (= scale 0.0)
1.0 ;; Both zero = no evidence
(- 1.0 (/ margin scale))))))
;; ═══════════════════════════════════════════════════════════════════
;; ANOMALY DETECTION
;; ═══════════════════════════════════════════════════════════════════
;; Compute average pairwise PMI between all content words in a sentence.
;; High positive = normal (words commonly co-occur in corpus).
;; Low/negative = anomalous (unusual word combinations).
;; Returns: (average-pmi . pair-count)
(define (sentence-coherence sentence word-counts pair-counts)
(let* ((words (tokenize-content sentence))
(total-pmi 0.0)
(pair-count 0)
(unknown-pairs 0))
(for-each
(lambda (w1)
(for-each
(lambda (w2)
(when (string<? w1 w2) ;; Each pair once
(let ((pmi (compute-pmi word-counts pair-counts w1 w2)))
(if (> pmi -999.0)
(begin
(set! total-pmi (+ total-pmi pmi))
(set! pair-count (+ pair-count 1)))
(set! unknown-pairs (+ unknown-pairs 1))))))
words))
words)
(let ((total-possible (+ pair-count unknown-pairs)))
(if (= total-possible 0)
(cons 0.0 0)
;; Unknown pairs count as negative evidence (words never seen together)
;; Penalize by -2.0 per unknown pair (moderate penalty)
(cons (/ (- total-pmi (* 2.0 unknown-pairs)) total-possible)
total-possible)))))
;; Classify a sentence as EXPECTED or SURPRISING based on word coherence.
;; threshold: minimum average PMI for EXPECTED (default 0.0).
;; Returns: (label . average-pmi)
(define (detect-anomaly sentence word-counts pair-counts . opts)
(let* ((threshold (if (null? opts) 0.0 (car opts)))
(coherence (sentence-coherence sentence word-counts pair-counts))
(avg-pmi (car coherence)))
(cons (if (>= avg-pmi threshold) "EXPECTED" "SURPRISING")
avg-pmi)))
;; ═══════════════════════════════════════════════════════════════════
;; UTILITY: Display cluster contents
;; ═══════════════════════════════════════════════════════════════════
(define (display-clusters named-clusters)
(for-each
(lambda (nc)
(let ((medoid (car nc))
(members (cdr nc)))
(format #t " [~a]: ~a\n"
medoid
(string-join (take members (min 8 (length members))) ", "))
(when (> (length members) 8)
(format #t " ... (~a total)\n" (length members)))))
named-clusters))
(define (display-evidence evidence-scores)
(for-each
(lambda (e)
(format #t " [~a]: ~,2f\n" (car e) (cdr e)))
evidence-scores))
;; Convert SRFI-69 hash table to alist (Guile's hash-map->list
;; doesn't work with SRFI-69 tables).
(define (hash-table->alist ht)
(hash-table-walk ht
(lambda (k v) #f)) ;; ensure it's walkable
(let ((result '()))
(hash-table-walk ht
(lambda (k v) (set! result (cons (cons k v) result))))
result))