;
; cluster-demo.scm -- Demonstrate word clustering by grammatical similarity
;
; This shows how words get grouped by similar grammatical behavior,
; without any labels or pre-defined categories.
;
(use-modules (opencog) (opencog exec))
(use-modules (srfi srfi-1))
(display "═══════════════════════════════════════════════════════════════\n")
(display " CLUSTERING: Discovering Word Categories \n")
(display "═══════════════════════════════════════════════════════════════\n\n")
; We'll simulate what the full system does, but simplified for demonstration.
; The real system uses shape-vectors and cross-sections; we'll use bond patterns.
; Sample data: words and what bond types they participate in
; This is what we extracted from parsing - each word has a "grammatical fingerprint"
(define word-bonds (make-hash-table))
; From our Turing article parsing - words and their grammatical contexts
; Format: (word . ((left-bond-types) (right-bond-types)))
; NOUNS - things that take determiners, are subjects/objects
(hash-set! word-bonds "Turing" '((G A) (Ss Os Mp)))
(hash-set! word-bonds "machine" '((Ds AN A) (Ss Os Mp)))
(hash-set! word-bonds "computer" '((Ds AN A) (Ss Os Mp)))
(hash-set! word-bonds "science" '((Ds AN A) (Os Mp)))
(hash-set! word-bonds "war" '((Ds AN A) (Ss Os Mp)))
(hash-set! word-bonds "mathematics" '((Ds) (Os Mp)))
(hash-set! word-bonds "Bletchley" '((G) (Mp)))
(hash-set! word-bonds "Park" '((G A) (Os Mp)))
(hash-set! word-bonds "University" '((G A) (Os Mp)))
(hash-set! word-bonds "Cambridge" '((G) (Os Mp)))
; VERBS - things that take subjects, objects
(hash-set! word-bonds "was" '((Ss) (Pv Os)))
(hash-set! word-bonds "invented" '((Ss) (Os)))
(hash-set! word-bonds "worked" '((Ss) (MVp)))
(hash-set! word-bonds "became" '((Ss) (Os)))
(hash-set! word-bonds "developed" '((Ss) (Os)))
(hash-set! word-bonds "studied" '((Ss) (Os)))
; DETERMINERS - things that attach to nouns on the right
(hash-set! word-bonds "the" '(() (Ds)))
(hash-set! word-bonds "a" '(() (Ds)))
(hash-set! word-bonds "his" '(() (Ds G)))
(hash-set! word-bonds "this" '(() (Ds)))
; PREPOSITIONS - connect nouns to other things
(hash-set! word-bonds "of" '((Mp MVp) (Js)))
(hash-set! word-bonds "in" '((Mp MVp) (Js)))
(hash-set! word-bonds "at" '((Mp MVp) (Js)))
(hash-set! word-bonds "to" '((MVp) (Js TO)))
(hash-set! word-bonds "for" '((Mp MVp) (Js)))
; ADJECTIVES - modify nouns
(hash-set! word-bonds "famous" '(() (A)))
(hash-set! word-bonds "British" '(() (A)))
(hash-set! word-bonds "early" '(() (A)))
(hash-set! word-bonds "mathematical" '(() (A)))
; Function to compute similarity between two words based on shared bonds
(define (bond-similarity w1 w2)
(let* ((b1 (hash-ref word-bonds w1 '(() ())))
(b2 (hash-ref word-bonds w2 '(() ())))
(left1 (car b1))
(right1 (cadr b1))
(left2 (car b2))
(right2 (cadr b2))
; Count shared bond types
(shared-left (length (lset-intersection eq? left1 left2)))
(shared-right (length (lset-intersection eq? right1 right2)))
; Total bonds for normalization
(total1 (+ (length left1) (length right1)))
(total2 (+ (length left2) (length right2))))
(if (and (> total1 0) (> total2 0))
(/ (* 2.0 (+ shared-left shared-right))
(+ total1 total2))
0.0)))
; Get all words
(define all-words (hash-map->list (lambda (k v) k) word-bonds))
; Compute all pairwise similarities
(display "STEP 1: Computing grammatical similarities between all word pairs\n")
(display "───────────────────────────────────────────────────────────────\n\n")
(define similarities '())
(for-each
(lambda (w1)
(for-each
(lambda (w2)
(when (string<? w1 w2) ; Only compute once per pair
(let ((sim (bond-similarity w1 w2)))
(when (> sim 0.3) ; Only keep significant similarities
(set! similarities (cons (list w1 w2 sim) similarities))))))
all-words))
all-words)
; Sort by similarity
(define sorted-sims
(sort similarities (lambda (a b) (> (caddr a) (caddr b)))))
(display "Top word pairs by grammatical similarity:\n\n")
(for-each
(lambda (entry)
(format #t " ~15a ≈ ~15a │ similarity: ~,2f\n"
(car entry) (cadr entry) (caddr entry)))
(take sorted-sims (min 20 (length sorted-sims))))
; Now do simple agglomerative clustering
(display "\n\nSTEP 2: Agglomerative Clustering\n")
(display "───────────────────────────────────────────────────────────────\n\n")
(display "Merge most similar pairs into clusters:\n\n")
(define clusters (make-hash-table))
(define cluster-id 0)
; Find which cluster a word belongs to (or create singleton)
(define (get-cluster word)
(or (hash-ref clusters word)
(begin
(set! cluster-id (+ cluster-id 1))
(hash-set! clusters word cluster-id)
cluster-id)))
; Merge two words into same cluster
(define (merge-words w1 w2)
(let ((c1 (get-cluster w1))
(c2 (get-cluster w2)))
(when (not (= c1 c2))
; Move all words in c2 to c1
(hash-for-each
(lambda (word cid)
(when (= cid c2)
(hash-set! clusters word c1)))
clusters)
#t)))
; Perform clustering on top similar pairs
(for-each
(lambda (entry)
(let ((w1 (car entry))
(w2 (cadr entry))
(sim (caddr entry)))
(when (> sim 0.5) ; High threshold for merging
(when (merge-words w1 w2)
(format #t " Merge: ~15a + ~15a (sim=~,2f)\n" w1 w2 sim)))))
sorted-sims)
; Display final clusters
(display "\n\nSTEP 3: Discovered Categories (no labels - just structure!)\n")
(display "───────────────────────────────────────────────────────────────\n\n")
; Group words by cluster
(define cluster-members (make-hash-table))
(hash-for-each
(lambda (word cid)
(let ((current (hash-ref cluster-members cid '())))
(hash-set! cluster-members cid (cons word current))))
clusters)
; Print clusters with more than one member
(define cluster-list (hash-map->list cons cluster-members))
(define multi-clusters
(filter (lambda (c) (> (length (cdr c)) 1)) cluster-list))
(for-each
(lambda (cluster)
(let ((members (cdr cluster)))
(format #t " CLUSTER ~a: ~a\n" (car cluster) members)))
(sort multi-clusters (lambda (a b) (> (length (cdr a)) (length (cdr b))))))
; Show singleton words (didn't cluster)
(display "\n Singletons (unique grammatical behavior):\n")
(define singletons
(filter (lambda (c) (= (length (cdr c)) 1)) cluster-list))
(format #t " ~a\n" (map cadr singletons))
; ═══════════════════════════════════════════════════════════════
; STEP 4: Name Clusters by Medoid (algorithmic naming)
; ═══════════════════════════════════════════════════════════════
(display "\n\nSTEP 4: Name Clusters by MEDOID (no human labels)\n")
(display "───────────────────────────────────────────────────────────────\n\n")
(display "The medoid is the member with highest average similarity to\n")
(display "all other cluster members. It serves as the algorithmic name.\n\n")
; Find medoid of a cluster using bond-similarity
(define (cluster-medoid members)
(let ((best-word "")
(best-avg -1.0))
(for-each
(lambda (w)
(let* ((others (filter (lambda (w2) (not (string=? w w2))) members))
(sims (map (lambda (w2) (bond-similarity w w2)) others))
(avg (if (null? sims) 0.0 (/ (apply + sims) (length sims)))))
(when (> avg best-avg)
(set! best-avg avg)
(set! best-word w))))
members)
best-word))
(for-each
(lambda (cluster)
(let* ((members (cdr cluster))
(medoid (cluster-medoid members)))
(format #t " [~a]-cluster: ~a\n" medoid members)
(format #t " (medoid '~a' = most typical member)\n\n" medoid)))
(sort multi-clusters (lambda (a b) (> (length (cdr a)) (length (cdr b))))))
; Interpretation
(display "═══════════════════════════════════════════════════════════════\n")
(display " INTERPRETATION \n")
(display "═══════════════════════════════════════════════════════════════\n\n")
(display "The system discovered categories WITHOUT being told.\n\n")
(display "Each cluster groups words with similar grammatical behavior:\n")
(display " - Words that take determiners and are subjects/objects\n")
(display " - Words that attach to subjects on the left\n")
(display " - Words that attach to nouns on the right\n")
(display " - etc.\n\n")
(display "A human might label these 'noun', 'verb', 'adjective' --\n")
(display "but the system doesn't need those labels. It has the\n")
(display "medoid name (most typical member) instead.\n\n")
(display "This is EMERGENT GRAMMAR from statistics alone!\n")
(display "The categories were never programmed.\n")
(display "They emerged from patterns of grammatical connections.\n\n")
; The key insight about higher structure
(display "═══════════════════════════════════════════════════════════════\n")
(display " THE HIGHER STRUCTURE \n")
(display "═══════════════════════════════════════════════════════════════\n\n")
(display "Now imagine META-CLUSTERING:\n\n")
(display "Level 1: Words cluster by bond patterns\n")
(display " → discovers grammatical categories\n\n")
(display "Level 2: Clusters cluster by WHICH OTHER CLUSTERS they connect to\n")
(display " → discovers 'subject-like things', 'predicate-like things'\n\n")
(display "Level 3: Meta-clusters cluster by sentence-level patterns\n")
(display " → discovers contexts, frames, topics\n\n")
(display "Level 4: Contexts disambiguate:\n")
(display " 'bank' in [money]-cluster context → financial sense\n")
(display " 'bank' in [river]-cluster context → geographic sense\n\n")
(display "At every level: COUNT → CLUSTER → NAME BY MEDOID → REPEAT.\n")
(display "More levels of structure → emergent disambiguation.\n")