;
; layer2.scm - Word clustering by PMI profile similarity
;
; Layer 2: Cluster words that have similar association patterns.
; Words with similar PMI profiles → same cluster.
;
; "fish" and "bird" both associate with "swim/fly", "water/sky", "fins/feathers"
; → They cluster together as ANIMALS
;
; AtomSpace representation:
; (MemberLink (Concept "word:fish") (Concept "cluster:C0"))
;
(use-modules (opencog))
(use-modules (ice-9 format))
(use-modules (srfi srfi-1))
;; ═══════════════════════════════════════════════════════════════════
;; CONFIGURATION
;; ═══════════════════════════════════════════════════════════════════
(define *min-word-freq* 3) ; Only cluster words seen >= this
(define *profile-size* 10) ; Top N associations for profile
(define *similarity-threshold* 0.2) ; Jaccard similarity to join cluster
(define *cluster-counter* 0)
;; ═══════════════════════════════════════════════════════════════════
;; PMI PROFILES
;; ═══════════════════════════════════════════════════════════════════
(define (get-pmi-profile word)
"Get top associations as a set (for Jaccard comparison)"
(let ((assocs (layer1-associations word *profile-size*)))
(map cdr assocs))) ; Just the words, not scores
(define (jaccard-similarity set1 set2)
"Jaccard similarity: |intersection| / |union|"
(if (or (null? set1) (null? set2))
0
(let* ((s1 (list->set set1))
(s2 (list->set set2))
(intersection (set-intersection s1 s2))
(union (set-union s1 s2)))
(if (= (set-size union) 0)
0
(/ (set-size intersection) (set-size union))))))
;; Simple set operations using lists
(define (list->set lst)
(delete-duplicates lst))
(define (set-intersection s1 s2)
(filter (lambda (x) (member x s2)) s1))
(define (set-union s1 s2)
(delete-duplicates (append s1 s2)))
(define (set-size s)
(length s))
;; ═══════════════════════════════════════════════════════════════════
;; CLUSTERING
;; ═══════════════════════════════════════════════════════════════════
(define *clusters* '()) ; ((cluster-id . (word1 word2 ...)) ...)
(define *word-to-cluster* '()) ; ((word . cluster-id) ...)
(define (get-clusterable-words)
"Get words with enough frequency to cluster"
(filter
(lambda (word)
(let ((node (find-word word)))
(and node (>= (get-word-count node) *min-word-freq*))))
(get-all-words)))
(define (find-best-cluster word profiles)
"Find cluster with best similarity, or #f"
(let ((word-profile (get-pmi-profile word)))
(if (null? word-profile)
#f
(let loop ((clusters *clusters*)
(best-cluster #f)
(best-sim *similarity-threshold*))
(if (null? clusters)
best-cluster
(let* ((cluster (car clusters))
(cluster-id (car cluster))
(members (cdr cluster))
;; Use first member's profile as cluster representative
(rep-profile (hash-ref profiles (car members) '()))
(sim (jaccard-similarity word-profile rep-profile)))
(if (> sim best-sim)
(loop (cdr clusters) cluster-id sim)
(loop (cdr clusters) best-cluster best-sim))))))))
(define (create-cluster word)
"Create new cluster with word as first member"
(let ((cluster-id (format #f "C~a" *cluster-counter*)))
(set! *cluster-counter* (+ 1 *cluster-counter*))
(set! *clusters* (cons (cons cluster-id (list word)) *clusters*))
(set! *word-to-cluster* (cons (cons word cluster-id) *word-to-cluster*))
;; Store in AtomSpace
(cog-new-link 'MemberLink
(cog-new-node 'ConceptNode (string-append "word:" word))
(cog-new-node 'ConceptNode (string-append "cluster:" cluster-id)))
cluster-id))
(define (add-to-cluster word cluster-id)
"Add word to existing cluster"
(set! *clusters*
(map (lambda (c)
(if (string=? (car c) cluster-id)
(cons (car c) (cons word (cdr c)))
c))
*clusters*))
(set! *word-to-cluster* (cons (cons word cluster-id) *word-to-cluster*))
;; Store in AtomSpace
(cog-new-link 'MemberLink
(cog-new-node 'ConceptNode (string-append "word:" word))
(cog-new-node 'ConceptNode (string-append "cluster:" cluster-id))))
(define (layer2-recluster)
"Rebuild all clusters from current PMI data"
(display "[layer2] Reclustering...\n")
;; Clear existing clusters
(set! *clusters* '())
(set! *word-to-cluster* '())
(set! *cluster-counter* 0)
;; Note: Not deleting old MemberLinks from AtomSpace
;; (cog-delete! doesn't exist in this version)
;; Clusters are tracked in alists anyway
;; Get clusterable words and their profiles
(let* ((words (get-clusterable-words))
(profiles (make-hash-table)))
;; Build profile cache
(for-each
(lambda (w)
(hash-set! profiles w (get-pmi-profile w)))
words)
;; Cluster each word
(for-each
(lambda (word)
(let ((best (find-best-cluster word profiles)))
(if best
(add-to-cluster word best)
(create-cluster word))))
words)
(display (format #f "[layer2] Created ~a clusters from ~a words\n"
(length *clusters*) (length words)))))
;; ═══════════════════════════════════════════════════════════════════
;; QUERIES
;; ═══════════════════════════════════════════════════════════════════
(define (layer2-get-cluster word)
"Get cluster ID for a word"
(let ((entry (assoc word *word-to-cluster*)))
(if entry (cdr entry) #f)))
(define (layer2-get-members cluster-id)
"Get all words in a cluster"
(let ((entry (assoc cluster-id *clusters*)))
(if entry (cdr entry) '())))
(define (layer2-cluster-count)
(length *clusters*))
(define (show-clusters)
"Display all clusters"
(if (null? *clusters*)
"No clusters yet. Run /recluster after more data."
(string-join
(map (lambda (c)
(format #f "~a: ~a" (car c)
(string-join (take (cdr c) (min 5 (length (cdr c)))) ", ")))
*clusters*)
"\n")))
(define (show-cluster word)
"Show cluster for a specific word"
(let ((cluster-id (layer2-get-cluster word)))
(if cluster-id
(let ((members (layer2-get-members cluster-id)))
(format #f "'~a' is in ~a with: ~a"
word cluster-id
(string-join
(filter (lambda (w) (not (string=? w word))) members)
", ")))
(format #f "'~a' not in any cluster (need more data or /recluster)" word))))
;; ═══════════════════════════════════════════════════════════════════
;; LAYER 2 PROCESSING
;; ═══════════════════════════════════════════════════════════════════
(define *inputs-since-cluster* 0)
(define *cluster-interval* 200) ; Recluster every N inputs
(define (layer2-process text)
"Process text - trigger recluster if needed"
(set! *inputs-since-cluster* (+ 1 *inputs-since-cluster*))
(when (> *inputs-since-cluster* *cluster-interval*)
(layer2-recluster)
(set! *inputs-since-cluster* 0)))