;; test-gpu-cluster.scm — Full GPU clustering experiment
;;
;; Runs iterative agglomerative clustering entirely on GPU:
;; count → MI → sections → cosine → merge → substitute → repeat
;;
;; Run: guile -l test-gpu-cluster.scm
(use-modules (ice-9 rdelim)
(ice-9 time)
(ice-9 format)
(srfi srfi-1))
(load "gpu-atomspace.scm")
;; Force unbuffered output
(setvbuf (current-output-port) 'line)
;; ═══════════════════════════════════════════════════════════════════
;; CORPUS LOADING
;; ═══════════════════════════════════════════════════════════════════
(define *mvp*
"/storage/projects/code/hypercore-kb/opencog-kb/language-learning/mvp")
(define (clean-sentence line)
(let* ((lower (string-downcase line))
(no-punct (string-map
(lambda (c)
(if (or (char-alphabetic? c) (char-whitespace? c))
c #\space))
lower))
(words (string-split no-punct #\space))
(non-empty (filter (lambda (w) (> (string-length w) 0)) words)))
(if (null? non-empty) #f (string-join non-empty " "))))
(define (load-corpus-file filename)
(let ((sentences '()) (in-content #f))
(catch #t
(lambda ()
(call-with-input-file filename
(lambda (port)
(let loop ()
(let ((line (read-line port)))
(unless (eof-object? line)
(when (string-contains line "*** START") (set! in-content #t))
(when (string-contains line "*** END") (set! in-content #f))
(when in-content
(let ((cleaned (clean-sentence line)))
(when (and cleaned (> (string-length cleaned) 10))
(set! sentences (cons cleaned sentences)))))
(loop)))))))
(lambda (key . args)
(format #t "Error: ~a ~a~%" key args)))
(reverse sentences)))
(define (load-all-corpus)
(let ((all '()))
(for-each
(lambda (file)
(format #t "Loading ~a..." file)
(let ((sents (load-corpus-file (string-append *mvp* "/corpus/" file))))
(format #t " ~a sentences~%" (length sents))
(set! all (append all sents))))
'("alice-in-wonderland.txt" "pride-and-prejudice.txt"
"sherlock-holmes.txt" "great-expectations.txt" "moby-dick.txt"))
(sort all (lambda (a b) (< (string-length a) (string-length b))))))
;; Simple MST: chain edges
(define (chain-edges words)
(let ((n (length words)))
(let loop ((i 0) (edges '()))
(if (>= i (- n 1))
(reverse edges)
(loop (+ i 1) (cons (cons i (+ i 1)) edges))))))
;; ═══════════════════════════════════════════════════════════════════
;; CLUSTERING STATE
;; ═══════════════════════════════════════════════════════════════════
(define *word-classes* (make-hash-table)) ; class-id → list of words
(define *word-to-class* (make-hash-table)) ; word → class-id
(define *next-class-id* 0)
(define (create-class! words)
"Create a new word class containing the given words."
(let ((cid *next-class-id*))
(set! *next-class-id* (+ cid 1))
(hash-set! *word-classes* cid words)
(for-each (lambda (w) (hash-set! *word-to-class* w cid)) words)
cid))
(define (add-to-class! word class-id)
"Add a word to an existing class."
(let ((members (hash-ref *word-classes* class-id '())))
(unless (member word members)
(hash-set! *word-classes* class-id (cons word members))
(hash-set! *word-to-class* word class-id))))
(define (merge-classes! c1 c2)
"Merge class c2 into c1."
(let ((m1 (hash-ref *word-classes* c1 '()))
(m2 (hash-ref *word-classes* c2 '())))
(hash-set! *word-classes* c1 (append m1 m2))
(hash-remove! *word-classes* c2)
(for-each (lambda (w) (hash-set! *word-to-class* w c1)) m2)))
(define (class-assignments)
"Return alist of (word . class-id) for GPU."
(let ((result '()))
(hash-for-each
(lambda (w cid) (set! result (cons (cons w cid) result)))
*word-to-class*)
result))
(define (show-classes)
"Print all classes."
(let ((classes '()))
(hash-for-each
(lambda (cid members)
(set! classes (cons (cons cid members) classes)))
*word-classes*)
(let ((sorted (sort classes (lambda (a b) (> (length (cdr a)) (length (cdr b)))))))
(for-each
(lambda (c)
(format #t " C~a (~a): ~{~a~^, ~}~%"
(car c) (length (cdr c)) (cdr c)))
sorted))))
;; ═══════════════════════════════════════════════════════════════════
;; MAIN EXPERIMENT
;; ═══════════════════════════════════════════════════════════════════
(format #t "~%═══ GPU Clustering Experiment ═══~%~%")
;; Load corpus
(define all-sentences (load-all-corpus))
(format #t "~%Total corpus: ~a sentences~%~%" (length all-sentences))
;; Init GPU
(gpu-init!)
;; ── Phase 1: Count all sentences ──
(define max-sents 20000)
(define batch-size 2000)
(format #t "--- Phase 1: Counting ~a sentences ---~%" max-sents)
(let ((t-start (get-internal-real-time)))
(let loop ((offset 0))
(when (< offset max-sents)
(let* ((end (min (+ offset batch-size) max-sents))
(batch (take (drop all-sentences offset) (- end offset)))
(word-lists (map (lambda (s)
(filter (lambda (w) (> (string-length w) 0))
(string-split s #\space)))
batch))
(edges (map chain-edges word-lists)))
(gpu-process-sentences! word-lists)
(gpu-extract-sections! word-lists edges)
(format #t " ~a/~a..." end max-sents)
(loop end))))
(format #t " done in ~,1fs~%" (/ (- (get-internal-real-time) t-start) 1e9)))
(gpu-status)
;; ── Phase 2: Compute MI ──
(format #t "~%--- Phase 2: Computing MI ---~%")
(gpu-compute-mi!)
;; ── Phase 3: Iterative clustering ──
(define *cosine-threshold* 0.5)
(define *class-merge-floor* 0.4)
(define *max-class-size* 15)
(define *merges-per-round* 10)
(define *num-rounds* 10)
(format #t "~%--- Phase 3: Clustering (~a rounds) ---~%"
*num-rounds*)
(format #t " cosine threshold: ~,2f~%" *cosine-threshold*)
(format #t " class merge floor: ~,2f~%" *class-merge-floor*)
(format #t " max class size: ~a~%" *max-class-size*)
(format #t " merges per round: ~a~%~%" *merges-per-round*)
(let round-loop ((round 1))
(when (<= round *num-rounds*)
(let ((t0 (get-internal-real-time)))
(format #t "Round ~a: " round)
;; Get cosine candidates from GPU
(let* ((cands (gpu-cosine-candidates #:threshold *cosine-threshold*
#:max-output 10000))
(t-cos (/ (- (get-internal-real-time) t0) 1e9))
(new-classes 0)
(joins 0)
(class-merges 0)
(changes-left *merges-per-round*))
(format #t "~a candidates in ~,2fs..." (length cands) t-cos)
;; Process candidates top-down
(for-each
(lambda (c)
(when (> changes-left 0)
(let* ((w1 (car c))
(w2 (cadr c))
(sim (caddr c))
(c1 (hash-ref *word-to-class* w1 #f))
(c2 (hash-ref *word-to-class* w2 #f)))
(cond
;; Both unclassified → create new class
((and (not c1) (not c2))
(create-class! (list w1 w2))
(set! new-classes (+ new-classes 1))
(set! changes-left (- changes-left 1)))
;; One classified, one not → add to class
((and (not c1) c2
(< (length (hash-ref *word-classes* c2 '()))
*max-class-size*))
(add-to-class! w1 c2)
(set! joins (+ joins 1))
(set! changes-left (- changes-left 1)))
((and c1 (not c2)
(< (length (hash-ref *word-classes* c1 '()))
*max-class-size*))
(add-to-class! w2 c1)
(set! joins (+ joins 1))
(set! changes-left (- changes-left 1)))
;; Both in different classes → merge if strong enough
((and c1 c2 (not (= c1 c2))
(> sim *class-merge-floor*))
(let* ((m1 (hash-ref *word-classes* c1 '()))
(m2 (hash-ref *word-classes* c2 '()))
(combined (+ (length m1) (length m2))))
(when (<= combined *max-class-size*)
(format #t "~% merge C~a(~{~a~^/~}) + C~a(~{~a~^/~}) sim=~,3f"
c1 m1 c2 m2 sim)
(merge-classes! c1 c2)
(set! class-merges (+ class-merges 1))
(set! changes-left (- changes-left 1)))))
(else #f)))))
cands)
;; Push class assignments to GPU + substitute
(let ((total (+ new-classes joins class-merges)))
(when (> total 0)
(gpu-assign-classes! (class-assignments))
(gpu-substitute!)
;; Recompute MI after substitution
(gpu-compute-mi! #:dirty-only #t))
(let ((elapsed (/ (- (get-internal-real-time) t0) 1e9)))
(format #t "~% ~a new, ~a joined, ~a merged → ~a classes in ~,1fs~%"
new-classes joins class-merges
(hash-count (const #t) *word-classes*)
elapsed)))
(round-loop (+ round 1))))))
;; ── Results ──
(format #t "~%═══ Final Classes (~a total) ═══~%~%"
(hash-count (const #t) *word-classes*))
(show-classes)
(format #t "~%═══ DONE ═══~%")
(gpu-shutdown!)