#!/usr/bin/env guile
!#
;;
;; run-cogserver.scm -- Start CogServer with GPU kernels pre-loaded
;;
;; Usage: cd mvp && guile -s run-cogserver.scm
;;
;; This loads all functions into the AtomSpace BEFORE starting cogserver,
;; so all connections share the same environment.
;;
;; Features:
;; - Loads Phase 1/2 data from RocksDB
;; - Pre-builds MI hash index for O(1) lookups
;; - Initializes GPU kernels (MI + PMFG)
;; - Provides parse-and-show for interactive parsing
;;
(use-modules (opencog) (opencog exec))
(use-modules (opencog persist) (opencog persist-rocks))
(use-modules (opencog sensory) (opencog opencl))
(use-modules (opencog lg))
(use-modules (srfi srfi-1))
(use-modules (ice-9 threads))
;; ═══════════════════════════════════════════════════════════════════
;; PATHS (absolute - OpenCL requires full paths)
;; ═══════════════════════════════════════════════════════════════════
(define *mvp-dir* "/storage/projects/code/hypercore-kb/opencog-kb/language-learning/mvp")
(define *rocks-path* "rocks://data/pairs.rdb") ; relative OK for RocksDB
(define *mi-kernel-path* (string-append *mvp-dir* "/mi-kernel.cl"))
(define *pmfg-kernel-path* (string-append *mvp-dir* "/pmfg-kernel.cl"))
(display "═══ CogServer Language Learning (GPU) ═══\n\n")
;; ═══════════════════════════════════════════════════════════════════
;; STATE (shared across all connections)
;; ═══════════════════════════════════════════════════════════════════
(define *rsn* #f)
(define *data-loaded* #f)
(define *mi-gpu-node* #f)
(define *pmfg-gpu-node* #f)
(define *gpu-ready* #f)
(define *mi-cache* (make-hash-table))
(define *mi-index-built* #f)
;; ═══════════════════════════════════════════════════════════════════
;; DATA LOADING
;; ═══════════════════════════════════════════════════════════════════
;; Startup mode: 'cold (all data) or 'warm (high-MI only)
(define *startup-mode* 'cold)
(define *mi-threshold* -100.0) ; Keep ALL edges — low-MI pairs needed for correct marginals
(define (load-phase1-data!)
"Load Phase 1 word pairs from RocksDB (full cold load)."
(if *data-loaded*
(display "Data already loaded.\n")
(let ((t0 (current-time)))
(display "Opening RocksDB...\n")
(set! *rsn* (RocksStorageNode *rocks-path*))
(cog-open *rsn*)
(display "Loading edges (this takes ~2 minutes)...\n")
(load-atoms-of-type 'Edge)
(let ((n-edges (length (cog-get-atoms 'Edge))))
(format #t "Loaded ~a edges in ~a seconds.\n" n-edges (- (current-time) t0)))
(set! *data-loaded* #t)
(display "Data loaded!\n\n"))))
(define (warm-start! min-mi)
"Load data and keep only high-MI pairs in RAM (faster startup, less RAM)."
(if *data-loaded*
(display "Data already loaded.\n")
(let ((t0 (current-time)))
(display "Opening RocksDB...\n")
(set! *rsn* (RocksStorageNode *rocks-path*))
(cog-open *rsn*)
;; First load all edges (RocksDB can't filter by value)
(display "Loading edges from RocksDB...\n")
(load-atoms-of-type 'Edge)
(let ((total-edges (length (cog-get-atoms 'Edge))))
(format #t "Loaded ~a edges in ~a seconds.\n" total-edges (- (current-time) t0)))
;; Now filter: keep only high-MI edges in RAM
(display (format #f "Filtering edges with MI >= ~a...\n" min-mi))
(let ((t1 (current-time))
(mi-key (Predicate "*-Mutual Info Key-*"))
(kept 0)
(pruned 0))
(for-each
(lambda (edge)
(let* ((v (cog-value edge mi-key))
(mi (if v (cog-value-ref v 1) 0.0)))
(if (>= mi min-mi)
(set! kept (+ kept 1))
(begin
(cog-extract! edge) ; Remove from RAM (stays in RocksDB)
(set! pruned (+ pruned 1))))))
(cog-get-atoms 'Edge))
(format #t "Kept ~a high-MI edges, pruned ~a low-MI edges in ~a seconds.\n"
kept pruned (- (current-time) t1)))
(set! *data-loaded* #t)
(format #t "Warm start complete. ~a edges in RAM.\n\n"
(length (cog-get-atoms 'Edge))))))
(define (load-word-pairs! word)
"Load all pairs containing WORD from RocksDB into RAM (on-demand fetch)."
(unless *rsn* (error "Database not open. Call warm-start! first."))
(let ((t0 (get-internal-real-time))
(word-atom (Word word)))
;; Fetch incoming edges for this word
(fetch-incoming-by-type word-atom 'Edge *rsn*)
(let ((pairs (cog-incoming-by-type word-atom 'Edge)))
(format #t "Loaded ~a pairs for '~a' in ~,2f ms.\n"
(length pairs) word
(/ (- (get-internal-real-time) t0) 1000.0))
pairs)))
;; ═══════════════════════════════════════════════════════════════════
;; MI INDEX BUILDING (pre-compute for fast lookup)
;; ═══════════════════════════════════════════════════════════════════
(define (build-mi-index!)
"Pre-build MI hash table from all edges for O(1) lookups."
(if *mi-index-built*
(display "MI index already built.\n")
(let ((t0 (current-time))
(edges (cog-get-atoms 'Edge))
(mi-key (Predicate "*-Mutual Info Key-*"))
(count 0))
(display "Building MI index from edges...\n")
(for-each
(lambda (edge)
;; Extract words from Edge structure: (Edge (Bond "ANY") (List (Word w1) (Word w2)))
(let* ((outgoing (cog-outgoing-set edge))
(list-atom (cadr outgoing)) ; The List containing words
(words (cog-outgoing-set list-atom))
(w1 (cog-name (car words)))
(w2 (cog-name (cadr words)))
(v (cog-value edge mi-key))
(mi (if v
(catch #t
(lambda () (cog-value-ref v 1))
(lambda args 0.0))
0.0)))
;; Store both directions
(hash-set! *mi-cache* (cons w1 w2) mi)
(hash-set! *mi-cache* (cons w2 w1) mi)
(set! count (+ count 1))
(when (zero? (modulo count 100000))
(format #t " Indexed ~a edges...\n" count))))
edges)
(set! *mi-index-built* #t)
(format #t "MI index built: ~a entries in ~a seconds.\n\n"
(hash-count (const #t) *mi-cache*)
(- (current-time) t0)))))
;; ═══════════════════════════════════════════════════════════════════
;; GPU INITIALIZATION
;; ═══════════════════════════════════════════════════════════════════
(define (init-gpu!)
"Initialize both GPU kernels (MI + PMFG) with warmup."
(display "Initializing GPU kernels...\n")
(catch #t
(lambda ()
;; MI kernel
(set! *mi-gpu-node* (OpenclNode (string-append "opencl://:" *mi-kernel-path*)))
(cog-execute! (SetValue *mi-gpu-node* (Predicate "*-open-*") (Type 'FloatValue)))
(display " MI kernel loaded.\n")
;; PMFG kernel
(set! *pmfg-gpu-node* (OpenclNode (string-append "opencl://:" *pmfg-kernel-path*)))
(cog-execute! (SetValue *pmfg-gpu-node* (Predicate "*-open-*") (Type 'FloatValue)))
(display " PMFG kernel loaded.\n")
;; Warm up kernels (JIT compile on first use)
(display " Warming up kernels (JIT compilation)...\n")
;; Warm up test_simple
(cog-set-value! (Anchor "warmup") (Predicate "in") (FloatValue 1.0))
(cog-set-value! (Anchor "warmup") (Predicate "out") (OpenclFloatValue 0.0))
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-write-*")
(Section (Item "test_simple")
(ConnectorSeq
(ValueOf (Anchor "warmup") (Predicate "in"))
(ValueOf (Anchor "warmup") (Predicate "out"))))))
(cog-execute! (ValueOf *pmfg-gpu-node* (Predicate "*-read-*")))
(display " test_simple compiled.\n")
;; Warm up pmfg_single
(cog-set-value! (Anchor "warmup") (Predicate "mi") (FloatValue 0.0 0.0 0.0 0.0))
(cog-set-value! (Anchor "warmup") (Predicate "words") (FloatValue 0.0 1.0))
(cog-set-value! (Anchor "warmup") (Predicate "nw") (FloatValue 2.0))
(cog-set-value! (Anchor "warmup") (Predicate "vs") (FloatValue 2.0))
(cog-set-value! (Anchor "warmup") (Predicate "edges") (OpenclFloatValue -1.0 -1.0 -1.0 -1.0))
(cog-set-value! (Anchor "warmup") (Predicate "ne") (OpenclFloatValue -1.0))
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-write-*")
(Section (Item "pmfg_single")
(ConnectorSeq
(ValueOf (Anchor "warmup") (Predicate "mi"))
(ValueOf (Anchor "warmup") (Predicate "words"))
(ValueOf (Anchor "warmup") (Predicate "nw"))
(ValueOf (Anchor "warmup") (Predicate "vs"))
(ValueOf (Anchor "warmup") (Predicate "edges"))
(ValueOf (Anchor "warmup") (Predicate "ne"))))))
(cog-execute! (ValueOf *pmfg-gpu-node* (Predicate "*-read-*")))
(display " pmfg_single compiled.\n")
(set! *gpu-ready* #t)
(display " GPU kernels ready!\n\n"))
(lambda (key . args)
(format #t "GPU init failed: ~a ~a\n" key args)
(set! *gpu-ready* #f))))
;; ═══════════════════════════════════════════════════════════════════
;; GPU MI COMPUTATION
;; ═══════════════════════════════════════════════════════════════════
(define (gpu-compute-mi! counts left-margs right-margs total-n)
"Compute MI values on GPU. Returns list of MI values."
(unless *gpu-ready* (error "GPU not initialized. Call (init-gpu!) first."))
(let* ((n-pairs (length counts))
(n-arr (make-list n-pairs (exact->inexact total-n))))
(cog-set-value! (Anchor "mi") (Predicate "counts")
(apply FloatValue (map exact->inexact counts)))
(cog-set-value! (Anchor "mi") (Predicate "left")
(apply FloatValue (map exact->inexact left-margs)))
(cog-set-value! (Anchor "mi") (Predicate "right")
(apply FloatValue (map exact->inexact right-margs)))
(cog-set-value! (Anchor "mi") (Predicate "n")
(apply FloatValue n-arr))
(cog-set-value! (Anchor "mi") (Predicate "out")
(apply OpenclFloatValue (make-list n-pairs 0.0)))
(cog-execute!
(SetValue *mi-gpu-node* (Predicate "*-write-*")
(Section (Item "compute_mi")
(ConnectorSeq
(ValueOf (Anchor "mi") (Predicate "out"))
(ValueOf (Anchor "mi") (Predicate "counts"))
(ValueOf (Anchor "mi") (Predicate "left"))
(ValueOf (Anchor "mi") (Predicate "right"))
(ValueOf (Anchor "mi") (Predicate "n"))))))
(cog-execute! (ValueOf *mi-gpu-node* (Predicate "*-read-*")))
(cog-value->list (cog-execute! (ValueOf (Anchor "mi") (Predicate "out"))))))
;; ═══════════════════════════════════════════════════════════════════
;; MI LOOKUP
;; ═══════════════════════════════════════════════════════════════════
(define (get-mi w1 w2)
"Get MI for word pair from pre-built index (O(1) lookup)."
(or (hash-ref *mi-cache* (cons w1 w2)) 0.0))
;; ═══════════════════════════════════════════════════════════════════
;; GPU PMFG PARSING
;; ═══════════════════════════════════════════════════════════════════
(define (gpu-pmfg-parse words)
"Parse sentence with GPU PMFG using MI weights."
(unless *gpu-ready* (error "GPU not initialized."))
(let* ((n (length words))
(sz (* n n)) ; atomese-simd uses first arg length as work size
(mi-list (make-list sz 0.0)))
(do ((i 0 (+ i 1))) ((>= i n))
(do ((j 0 (+ j 1))) ((>= j n))
(list-set! mi-list (+ (* i n) j)
(get-mi (list-ref words i) (list-ref words j)))))
(cog-set-value! (Anchor "pmfg") (Predicate "mi") (apply FloatValue mi-list))
;; All buffers must be padded to sz (= n*n) to match mi_matrix length,
;; because atomese-simd allocates GPU buffers based on first arg size.
(cog-set-value! (Anchor "pmfg") (Predicate "words")
(apply FloatValue (append (iota n) (make-list (- sz n) 0.0))))
(cog-set-value! (Anchor "pmfg") (Predicate "nw")
(apply FloatValue (cons (exact->inexact n) (make-list (- sz 1) 0.0))))
(cog-set-value! (Anchor "pmfg") (Predicate "vs")
(apply FloatValue (cons (exact->inexact n) (make-list (- sz 1) 0.0))))
(cog-set-value! (Anchor "pmfg") (Predicate "edges")
(apply OpenclFloatValue (make-list sz 0.0)))
(cog-set-value! (Anchor "pmfg") (Predicate "ne")
(apply OpenclFloatValue (make-list sz 0.0)))
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-write-*")
(Section (Item "pmfg_single")
(ConnectorSeq
(ValueOf (Anchor "pmfg") (Predicate "mi"))
(ValueOf (Anchor "pmfg") (Predicate "words"))
(ValueOf (Anchor "pmfg") (Predicate "nw"))
(ValueOf (Anchor "pmfg") (Predicate "vs"))
(ValueOf (Anchor "pmfg") (Predicate "edges"))
(ValueOf (Anchor "pmfg") (Predicate "ne"))))))
(cog-execute! (ValueOf *pmfg-gpu-node* (Predicate "*-read-*")))
(let* ((n-edges (inexact->exact (round (cog-value-ref
(cog-execute! (ValueOf (Anchor "pmfg") (Predicate "ne"))) 0))))
(edge-list (cog-value->list
(cog-execute! (ValueOf (Anchor "pmfg") (Predicate "edges"))))))
(let loop ((i 0) (edges '()))
(if (>= i n-edges) (reverse edges)
(let ((p1 (inexact->exact (round (list-ref edge-list (* i 2)))))
(p2 (inexact->exact (round (list-ref edge-list (+ (* i 2) 1))))))
(loop (+ i 1) (cons (list p1 p2
(get-mi (list-ref words p1)
(list-ref words p2)))
edges))))))))
;; ═══════════════════════════════════════════════════════════════════
;; CPU PMFG (fallback)
;; ═══════════════════════════════════════════════════════════════════
(define (edges-cross? i j k l)
(let ((i (min i j)) (j (max i j))
(k (min k l)) (l (max k l)))
(or (and (< i k) (< k j) (< j l))
(and (< k i) (< i l) (< l j)))))
(define (cpu-pmfg-parse words)
"CPU fallback for PMFG parsing."
(let* ((n (length words))
(word-vec (list->vector words)))
(if (< n 2) '()
(let* ((pairs
(let loop-i ((i 0) (pairs '()))
(if (>= i (- n 1)) pairs
(loop-i (+ i 1)
(let loop-j ((j (+ i 1)) (ps pairs))
(if (>= j n) ps
(loop-j (+ j 1)
(cons (list (get-mi (vector-ref word-vec i)
(vector-ref word-vec j))
i j)
ps))))))))
(sorted-pairs (sort pairs (lambda (a b) (> (car a) (car b))))))
(let loop ((remaining sorted-pairs) (edges '()))
(if (null? remaining) (reverse edges)
(let* ((pair (car remaining))
(mi (car pair)) (pos1 (cadr pair)) (pos2 (caddr pair))
(crosses? (any (lambda (e) (edges-cross? pos1 pos2 (car e) (cadr e))) edges)))
(loop (cdr remaining)
(if crosses? edges (cons (list pos1 pos2 mi) edges))))))))))
;; ═══════════════════════════════════════════════════════════════════
;; UNIFIED INTERFACE
;; ═══════════════════════════════════════════════════════════════════
(define (parse-sentence words)
"Parse sentence using CPU PMFG (fast for single sentences)."
;; Note: GPU PMFG has ~25s overhead per call, only useful for batch processing
(cpu-pmfg-parse words))
(define (parse-and-show sentence-string)
"Parse a sentence and display results."
(let* ((words (string-split sentence-string #\space))
(t0 (get-internal-real-time))
(edges (parse-sentence words))
(elapsed-ms (/ (- (get-internal-real-time) t0) 1000.0)))
(format #t "\nSentence: ~a\n" words)
(format #t "Method: CPU PMFG (indexed MI)\n")
(format #t "PMFG edges (~a) in ~,2f ms:\n" (length edges) elapsed-ms)
(for-each
(lambda (e)
(format #t " ~a -- ~a (MI=~,2f)\n"
(list-ref words (car e))
(list-ref words (cadr e))
(caddr e)))
edges)
(format #t "Total MI: ~,2f\n" (apply + (map caddr edges)))
edges))
;; ═══════════════════════════════════════════════════════════════════
;; STATUS
;; ═══════════════════════════════════════════════════════════════════
;; ═══════════════════════════════════════════════════════════════════
;; SHELL EXTENSIONS (wrappers for primitives not in shell)
;; ═══════════════════════════════════════════════════════════════════
(define (set-value! atom key value)
"Wrapper for cog-set-value! (not available in shell directly)."
(cog-set-value! atom key value))
(define (execute! atom)
"Wrapper for cog-execute! (not available in shell directly)."
(cog-execute! atom))
(define (get-value atom key)
"Wrapper for cog-value."
(cog-value atom key))
(define (test-gpu-simple n)
"Test simple GPU kernel to measure base overhead."
(let* ((input (make-list n 1.0))
(t0 (get-internal-real-time)))
;; Setup
(cog-set-value! (Anchor "gtest") (Predicate "in") (apply FloatValue input))
(cog-set-value! (Anchor "gtest") (Predicate "out") (apply OpenclFloatValue (make-list n 0.0)))
(let ((t1 (get-internal-real-time)))
;; Write
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-write-*")
(Section (Item "test_simple")
(ConnectorSeq
(ValueOf (Anchor "gtest") (Predicate "in"))
(ValueOf (Anchor "gtest") (Predicate "out"))))))
(let ((t2 (get-internal-real-time)))
;; Read
(cog-execute! (ValueOf *pmfg-gpu-node* (Predicate "*-read-*")))
(let ((t3 (get-internal-real-time)))
(format #t "\n=== GPU Simple Test (n=~a) ===\n" n)
(format #t " Setup: ~,2f ms\n" (/ (- t1 t0) 1000.0))
(format #t " Write: ~,2f ms\n" (/ (- t2 t1) 1000.0))
(format #t " Read: ~,2f ms\n" (/ (- t3 t2) 1000.0))
(format #t " TOTAL: ~,2f ms\n" (/ (- t3 t0) 1000.0)))))))
(define (profile-gpu-parse words)
"Profile GPU PMFG parsing step by step."
(let* ((n (length words))
(t0 (get-internal-real-time))
(times '()))
(define (mark! name)
(let ((elapsed (/ (- (get-internal-real-time) t0) 1000.0)))
(set! times (cons (cons name elapsed) times))
(set! t0 (get-internal-real-time))))
;; Step 1: MI lookups
(define mi-list (make-list (* n n) 0.0))
(do ((i 0 (+ i 1))) ((>= i n))
(do ((j 0 (+ j 1))) ((>= j n))
(list-set! mi-list (+ (* i n) j)
(get-mi (list-ref words i) (list-ref words j)))))
(mark! "1-mi-lookups")
;; Step 2: Value setup
(cog-set-value! (Anchor "gprof") (Predicate "mi") (apply FloatValue mi-list))
(cog-set-value! (Anchor "gprof") (Predicate "words") (apply FloatValue (iota n)))
(cog-set-value! (Anchor "gprof") (Predicate "nw") (FloatValue (exact->inexact n)))
(cog-set-value! (Anchor "gprof") (Predicate "vs") (FloatValue (exact->inexact n)))
(cog-set-value! (Anchor "gprof") (Predicate "edges")
(apply OpenclFloatValue (make-list (* 2 (* 3 n)) -1.0)))
(cog-set-value! (Anchor "gprof") (Predicate "ne") (OpenclFloatValue -1.0))
(mark! "2-value-setup")
;; Step 3: GPU write
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-write-*")
(Section (Item "pmfg_single")
(ConnectorSeq
(ValueOf (Anchor "gprof") (Predicate "mi"))
(ValueOf (Anchor "gprof") (Predicate "words"))
(ValueOf (Anchor "gprof") (Predicate "nw"))
(ValueOf (Anchor "gprof") (Predicate "vs"))
(ValueOf (Anchor "gprof") (Predicate "edges"))
(ValueOf (Anchor "gprof") (Predicate "ne"))))))
(mark! "3-gpu-write")
;; Step 4: GPU read
(cog-execute! (ValueOf *pmfg-gpu-node* (Predicate "*-read-*")))
(mark! "4-gpu-read")
;; Print results
(format #t "\n=== GPU Parse Profile (~a words) ===\n" n)
(let ((total 0))
(for-each (lambda (x)
(format #t " ~a: ~,2f ms\n" (car x) (cdr x))
(set! total (+ total (cdr x))))
(reverse times))
(format #t " TOTAL: ~,2f ms\n" total))
times))
;; ═══════════════════════════════════════════════════════════════════
;; STATUS & MEMORY
;; ═══════════════════════════════════════════════════════════════════
(define (get-memory-stats)
"Get approximate AtomSpace memory usage."
(let* ((n-words (length (cog-get-atoms 'Word)))
(n-edges (length (cog-get-atoms 'Edge)))
(n-atoms (+ n-words n-edges))
;; Rough estimates: Word ~200B, Edge ~500B, index overhead ~2x
(word-mb (/ (* n-words 200) 1048576.0))
(edge-mb (/ (* n-edges 500) 1048576.0))
(total-mb (* 2 (+ word-mb edge-mb))))
(list n-atoms n-words n-edges total-mb)))
(define (status)
"Show cogserver status."
(format #t "\n═══ CogServer Status ═══\n")
(format #t "Startup mode: ~a (MI threshold: ~a)\n" *startup-mode* *mi-threshold*)
(format #t "Data loaded: ~a\n" *data-loaded*)
(when *data-loaded*
(let* ((stats (get-memory-stats))
(n-atoms (car stats))
(n-words (cadr stats))
(n-edges (caddr stats))
(mb (cadddr stats))
(threshold-mb (* *max-ram-mb* *eviction-threshold*)))
(format #t "Atoms: ~a total (~a Words, ~a Edges)\n" n-atoms n-words n-edges)
(format #t "Est. RAM: ~,1f / ~,1f MB (~,1f%)\n"
mb *max-ram-mb* (* 100 (/ mb *max-ram-mb*)))
(when (> mb threshold-mb)
(display " ⚠ Above eviction threshold!\n"))))
(format #t "MI index: ~a (~a entries)\n"
(if *mi-index-built* "built" "not built")
(hash-count (const #t) *mi-cache*))
(format #t "GPU ready: ~a\n" *gpu-ready*)
(when *gpu-ready*
(format #t " MI kernel: ~a\n" (if *mi-gpu-node* "loaded" "none"))
(format #t " PMFG kernel: ~a\n" (if *pmfg-gpu-node* "loaded" "none")))
(display "════════════════════════\n\n"))
;; ═══════════════════════════════════════════════════════════════════
;; MEMORY WATCHDOG (Phase 3c)
;; ═══════════════════════════════════════════════════════════════════
(define *max-ram-mb* 4000) ; Target max RAM usage (MB) — need headroom for full MI distribution
(define *eviction-threshold* 0.75) ; Evict when RAM > 75% of max
(define *last-eviction-time* 0)
(define *eviction-cooldown* 300) ; Minimum seconds between evictions
(define (evict-cold-pairs! evict-threshold)
"Remove edges with MI < evict-threshold from RAM (they stay in RocksDB)."
(let ((t0 (current-time))
(mi-key (Predicate "*-Mutual Info Key-*"))
(evicted 0)
(kept 0))
(format #t "Evicting edges with MI < ~a...\n" evict-threshold)
(for-each
(lambda (edge)
(let* ((v (cog-value edge mi-key))
(mi (if v (cog-value-ref v 1) 0.0)))
(if (< mi evict-threshold)
(begin
;; Remove from MI cache
(let* ((outgoing (cog-outgoing-set edge))
(list-atom (cadr outgoing))
(words (cog-outgoing-set list-atom))
(w1 (cog-name (car words)))
(w2 (cog-name (cadr words))))
(hash-remove! *mi-cache* (cons w1 w2))
(hash-remove! *mi-cache* (cons w2 w1)))
;; Extract from AtomSpace (stays in RocksDB)
(cog-extract! edge)
(set! evicted (+ evicted 1)))
(set! kept (+ kept 1)))))
(cog-get-atoms 'Edge))
(set! *last-eviction-time* (current-time))
(format #t "Evicted ~a edges, kept ~a in ~a seconds.\n"
evicted kept (- (current-time) t0))
evicted))
(define (check-memory!)
"Check RAM usage and evict cold pairs if needed."
(let* ((stats (get-memory-stats))
(current-mb (cadddr stats))
(threshold-mb (* *max-ram-mb* *eviction-threshold*))
(now (current-time)))
(cond
;; Skip if recently evicted
((< (- now *last-eviction-time*) *eviction-cooldown*)
(format #t "Skipping eviction (cooldown: ~as remaining)\n"
(- *eviction-cooldown* (- now *last-eviction-time*))))
;; Evict if over threshold
((> current-mb threshold-mb)
(format #t "Memory pressure: ~,1f MB > ~,1f MB threshold\n"
current-mb threshold-mb)
;; Increase MI threshold by 0.5 to evict more cold pairs
(let ((new-threshold (+ *mi-threshold* 0.5)))
(format #t "Raising MI threshold from ~a to ~a\n"
*mi-threshold* new-threshold)
(set! *mi-threshold* new-threshold)
(evict-cold-pairs! new-threshold)))
(else
(format #t "Memory OK: ~,1f MB (threshold: ~,1f MB)\n"
current-mb threshold-mb)))))
(define (memory-watchdog-loop)
"Background thread that monitors memory usage."
(while (not *shutdown-requested*)
(sleep 60) ; Check every minute
(catch #t
(lambda () (check-memory!))
(lambda (key . args)
(format #t "Watchdog error: ~a ~a\n" key args)))))
;; Shell-accessible wrappers (printf escapes ! before \n - use heredoc instead)
(define (check-memory) (check-memory!))
(define (evict-cold mi-threshold) (evict-cold-pairs! mi-threshold))
(define (load-word word) (load-word-pairs! word))
;; ═══════════════════════════════════════════════════════════════════
;; INCREMENTAL MI RECOMPUTATION (Phase 3d)
;; ═══════════════════════════════════════════════════════════════════
(define *mi-recompute-interval* 3600) ; Recompute MI every hour
(define *last-mi-recompute* 0)
(define *dirty-pairs* (make-hash-table)) ; Pairs that need MI update
(define *total-pair-count* 0) ; N = sum of all pair counts
(define *left-marginals* (make-hash-table)) ; Word -> sum of left counts
(define *right-marginals* (make-hash-table)) ; Word -> sum of right counts
(define (mark-pair-dirty! edge)
"Mark a pair as needing MI recomputation."
(hash-set! *dirty-pairs* edge #t))
(define (compute-marginals!)
"Compute marginal counts from all edges in AtomSpace."
(let ((t0 (current-time))
(count-key (Predicate "*-TruthValueKey-*"))
(total 0))
(display "Computing marginals...\n")
;; Clear old marginals
(hash-clear! *left-marginals*)
(hash-clear! *right-marginals*)
;; Iterate all edges
(for-each
(lambda (edge)
(let* ((outgoing (cog-outgoing-set edge))
(list-atom (cadr outgoing))
(words (cog-outgoing-set list-atom))
(w1 (cog-name (car words)))
(w2 (cog-name (cadr words)))
(v (cog-value edge count-key))
(cnt (if v
(catch #t
(lambda () (inexact->exact (round (cog-value-ref v 2))))
(lambda args 0))
0)))
;; Accumulate marginals
(hash-set! *left-marginals* w1
(+ (hash-ref *left-marginals* w1 0) cnt))
(hash-set! *right-marginals* w2
(+ (hash-ref *right-marginals* w2 0) cnt))
(set! total (+ total cnt))))
(cog-get-atoms 'Edge))
(set! *total-pair-count* total)
(format #t "Marginals computed: N=~a, ~a left, ~a right in ~as\n"
total
(hash-count (const #t) *left-marginals*)
(hash-count (const #t) *right-marginals*)
(- (current-time) t0))))
(define (recompute-mi-for-edge! edge)
"Recompute MI for a single edge and update the MI cache."
(let* ((count-key (Predicate "*-TruthValueKey-*"))
(mi-key (Predicate "*-Mutual Info Key-*"))
(outgoing (cog-outgoing-set edge))
(list-atom (cadr outgoing))
(words (cog-outgoing-set list-atom))
(w1 (cog-name (car words)))
(w2 (cog-name (cadr words)))
(v (cog-value edge count-key))
(cnt (if v
(catch #t
(lambda () (cog-value-ref v 2))
(lambda args 0.0))
0.0))
(left-marg (hash-ref *left-marginals* w1 1))
(right-marg (hash-ref *right-marginals* w2 1))
(n (exact->inexact *total-pair-count*)))
(if (and (> cnt 0) (> left-marg 0) (> right-marg 0) (> n 0))
(let* ((p-pair (/ cnt n))
(p-left (/ left-marg n))
(p-right (/ right-marg n))
(mi (/ (log (/ p-pair (* p-left p-right))) (log 2))))
;; Update MI value on edge
(cog-set-value! edge mi-key (FloatValue 0.0 mi 0.0))
;; Update MI cache
(hash-set! *mi-cache* (cons w1 w2) mi)
(hash-set! *mi-cache* (cons w2 w1) mi)
mi)
0.0)))
(define (recompute-all-mi!)
"Recompute MI for all edges (batch operation)."
(let ((t0 (current-time))
(edges (cog-get-atoms 'Edge))
(count 0)
(mi-sum 0.0))
(display "Recomputing MI for all edges...\n")
;; First compute marginals
(compute-marginals!)
;; Then recompute MI for each edge
(for-each
(lambda (edge)
(let ((mi (recompute-mi-for-edge! edge)))
(set! mi-sum (+ mi-sum mi))
(set! count (+ count 1))
(when (zero? (modulo count 100000))
(format #t " Processed ~a edges...\n" count))))
edges)
;; Clear dirty set
(hash-clear! *dirty-pairs*)
(set! *last-mi-recompute* (current-time))
(format #t "MI recomputed: ~a edges, avg MI=~,2f in ~as\n"
count (/ mi-sum count) (- (current-time) t0))
count))
(define (recompute-dirty-mi!)
"Recompute MI only for dirty (changed) pairs."
(let ((dirty-count (hash-count (const #t) *dirty-pairs*)))
(if (zero? dirty-count)
(display "No dirty pairs to recompute.\n")
(let ((t0 (current-time)))
(format #t "Recomputing MI for ~a dirty pairs...\n" dirty-count)
;; Recompute marginals (needed for accurate MI)
(compute-marginals!)
;; Recompute MI for dirty pairs
(hash-for-each
(lambda (edge _)
(recompute-mi-for-edge! edge))
*dirty-pairs*)
;; Clear dirty set
(hash-clear! *dirty-pairs*)
(set! *last-mi-recompute* (current-time))
(format #t "MI recomputed for ~a pairs in ~as\n"
dirty-count (- (current-time) t0))))))
(define (mi-stats)
"Show MI statistics."
(let* ((edges (cog-get-atoms 'Edge))
(mi-key (Predicate "*-Mutual Info Key-*"))
(mi-vals '()))
(for-each
(lambda (edge)
(let ((v (cog-value edge mi-key)))
(when v
(set! mi-vals (cons (cog-value-ref v 1) mi-vals)))))
edges)
(if (null? mi-vals)
(display "No MI values found.\n")
(let* ((sorted (sort mi-vals >))
(n (length sorted))
(sum (apply + sorted))
(avg (/ sum n))
(max-mi (car sorted))
(min-mi (car (last-pair sorted))))
(format #t "\n═══ MI Statistics ═══\n")
(format #t "Edges with MI: ~a\n" n)
(format #t "Total N: ~a\n" *total-pair-count*)
(format #t "MI range: ~,2f to ~,2f\n" min-mi max-mi)
(format #t "Average MI: ~,2f\n" avg)
(format #t "Top 10 MI values: ~a\n" (take sorted (min 10 n)))
(display "═════════════════════\n\n")))))
;; Shell wrappers for MI functions
(define (recompute-mi) (recompute-all-mi!))
(define (recompute-dirty) (recompute-dirty-mi!))
;; ═══════════════════════════════════════════════════════════════════
;; PHASE 4: WORD CLUSTERING (Using Linas's learn module)
;; ═══════════════════════════════════════════════════════════════════
;;
;; NOTE: GPU is NOT practical for clustering (50,000× slower for small batches).
;; CPU agglomerative clustering with grammatical-MI is optimal.
;; See research: mvp/GPU_CLUSTERING_RESEARCH.md
;;
;; Linas's (opencog learn) provides:
;; - agglo-mi-rank.scm: Main clustering loop
;; - mi-similarity.scm: Grammatical-MI (not cosine!)
;; - gram-majority.scm: Majority voting for merges
;;
;; Clustering state (for simple demo - use learn module for production)
(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 *min-similarity* 0.30) ; Minimum cosine similarity to merge (jigsaw top scores ~0.45)
(define (load-word-classes!)
"Reload WordClassNode and MemberLink atoms from RocksDB into hash tables."
(format #t "Loading word classes from RocksDB...~%")
(load-atoms-of-type 'WordClassNode)
(load-atoms-of-type 'MemberLink)
(let ((class-nodes (cog-get-atoms 'WordClassNode)))
(for-each
(lambda (cn)
(let* ((name (cog-name cn))
(cid (string->number (substring name 1)))
(member-links (cog-incoming-by-type cn 'MemberLink))
(members (map (lambda (ml)
(cog-name (car (cog-outgoing-set ml))))
member-links)))
(when (and cid (> (length members) 0))
(hash-set! *word-classes* cid members)
(for-each (lambda (w) (hash-set! *word-to-class* w cid)) members)
(when (>= cid *next-class-id*)
(set! *next-class-id* (+ cid 1))))))
class-nodes)
(format #t "Loaded ~a word classes (~a words)~%"
(hash-count (const #t) *word-classes*)
(hash-count (const #t) *word-to-class*))))
(define *min-word-count* 100) ; Minimum word occurrences (high for speed)
(define (get-high-frequency-words min-count)
"Get words with at least MIN-COUNT occurrences."
(let ((word-counts (make-hash-table))
(count-key (Predicate "*-TruthValueKey-*")))
;; Count word occurrences from edges
(for-each
(lambda (edge)
(let* ((outgoing (cog-outgoing-set edge))
(list-atom (cadr outgoing))
(words (cog-outgoing-set list-atom))
(w1 (cog-name (car words)))
(w2 (cog-name (cadr words)))
(v (cog-value edge count-key))
(cnt (if v
(catch #t
(lambda () (inexact->exact (round (cog-value-ref v 2))))
(lambda args 0))
0)))
(hash-set! word-counts w1 (+ (hash-ref word-counts w1 0) cnt))
(hash-set! word-counts w2 (+ (hash-ref word-counts w2 0) cnt))))
(cog-get-atoms 'Edge))
;; Filter by minimum count and return as sorted list
(let ((result '()))
(hash-for-each
(lambda (word count)
(when (>= count min-count)
(set! result (cons (cons word count) result))))
word-counts)
;; Sort by count descending
(map car (sort result (lambda (a b) (> (cdr a) (cdr b))))))))
(define (get-top-words n)
"Get top N words by frequency."
(take (get-high-frequency-words 1) (min n (length (get-high-frequency-words 1)))))
;; Simple similarity based on shared neighbors (fast heuristic)
(define (shared-neighbor-similarity w1 w2)
"Compute Jaccard-like similarity: |shared neighbors| / |union neighbors|."
(let ((neighbors1 (make-hash-table))
(neighbors2 (make-hash-table))
(shared 0)
(total 0))
;; Get neighbors from MI cache
(hash-for-each
(lambda (key mi)
(when (pair? key)
(when (string=? (car key) w1) (hash-set! neighbors1 (cdr key) mi))
(when (string=? (car key) w2) (hash-set! neighbors2 (cdr key) mi))))
*mi-cache*)
;; Count shared and total
(hash-for-each
(lambda (n _)
(set! total (+ total 1))
(when (hash-ref neighbors2 n #f)
(set! shared (+ shared 1))))
neighbors1)
(hash-for-each
(lambda (n _)
(unless (hash-ref neighbors1 n #f)
(set! total (+ total 1))))
neighbors2)
(if (zero? total) 0.0 (/ (exact->inexact shared) total))))
(define (find-similar-pairs words threshold)
"Find all pairs with similarity >= threshold. Returns list of (sim w1 w2)."
(let ((pairs '())
(n (length words)))
(format #t "Computing similarities for ~a words...\n" n)
(do ((i 0 (+ i 1))) ((>= i (- n 1)))
(when (zero? (modulo i 10))
(format #t " Progress: ~a/~a words\n" i n))
(do ((j (+ i 1) (+ j 1))) ((>= j n))
(let* ((w1 (list-ref words i))
(w2 (list-ref words j))
(sim (shared-neighbor-similarity w1 w2)))
(when (>= sim threshold)
(set! pairs (cons (list sim w1 w2) pairs))))))
;; Sort by similarity descending
(sort pairs (lambda (a b) (> (car a) (car b))))))
(define (create-word-class! words)
"Create a new WordClassNode containing the given words."
(let* ((class-id *next-class-id*)
(class-name (format #f "C~a" class-id))
(class-node (WordClass class-name)))
(set! *next-class-id* (+ *next-class-id* 1))
;; Record class membership
(hash-set! *word-classes* class-id words)
(for-each
(lambda (word)
(hash-set! *word-to-class* word class-id)
;; Create MemberLink in AtomSpace
(MemberLink (Word word) class-node))
words)
;; Store to RocksDB
(when *rsn*
(store-atom class-node)
(for-each
(lambda (word)
(store-atom (MemberLink (Word word) class-node)))
words))
(format #t "Created class ~a: ~a\n" class-name words)
class-node))
(define (cluster-from-pairs! pairs max-merges)
"Create clusters from pre-computed similar pairs."
(let ((merges 0))
(for-each
(lambda (pair)
(when (< merges max-merges)
(let ((sim (car pair))
(w1 (cadr pair))
(w2 (caddr pair)))
(let ((c1 (hash-ref *word-to-class* w1 #f))
(c2 (hash-ref *word-to-class* w2 #f)))
(cond
;; Both unclustered: create new class
((and (not c1) (not c2))
(format #t "~a: '~a' + '~a' (sim=~,3f)\n" merges w1 w2 sim)
(create-word-class! (list w1 w2))
(set! merges (+ merges 1)))
;; One clustered, one not: add to existing
((and c1 (not c2))
(format #t "~a: '~a' → C~a (sim=~,3f)\n" merges w2 c1 sim)
(hash-set! *word-to-class* w2 c1)
(hash-set! *word-classes* c1 (cons w2 (hash-ref *word-classes* c1)))
(set! merges (+ merges 1)))
((and (not c1) c2)
(format #t "~a: '~a' → C~a (sim=~,3f)\n" merges w1 c2 sim)
(hash-set! *word-to-class* w1 c2)
(hash-set! *word-classes* c2 (cons w1 (hash-ref *word-classes* c2)))
(set! merges (+ merges 1))))))))
pairs)
merges))
(define (cluster-words! n-words n-merges)
"Run fast clustering on top N-WORDS, making up to N-MERGES."
(let* ((t0 (current-time))
(words (take (get-high-frequency-words 100) (min n-words 500))))
(format #t "\n═══ Phase 4: Word Clustering ═══\n")
(format #t "Top ~a words (count >= 100)\n" (length words))
(format #t "Similarity threshold: ~a\n\n" *min-similarity*)
;; Find similar pairs
(let ((pairs (find-similar-pairs words *min-similarity*)))
(format #t "\nFound ~a similar pairs above threshold.\n" (length pairs))
;; Create clusters from pairs
(let ((actual-merges (cluster-from-pairs! pairs n-merges)))
(let ((n-classes (hash-count (const #t) *word-classes*))
(n-clustered (hash-count (const #t) *word-to-class*)))
(format #t "\n═══ Clustering Results ═══\n")
(format #t "Merges performed: ~a\n" actual-merges)
(format #t "Classes created: ~a\n" n-classes)
(format #t "Words clustered: ~a\n" n-clustered)
(format #t "Time: ~a seconds\n" (- (current-time) t0))
(display "════════════════════════════\n\n"))))))
(define (show-clusters)
"Display all word classes."
(format #t "\n═══ Word Classes ═══\n")
(hash-for-each
(lambda (class-id words)
(format #t "C~a: ~a\n" class-id words))
*word-classes*)
(format #t "════════════════════\n\n"))
(define (get-word-class word)
"Get the class ID for a word, or #f if not clustered."
(hash-ref *word-to-class* word #f))
(define (get-class-words class-id)
"Get all words in a class."
(hash-ref *word-classes* class-id '()))
;; Shell wrappers (simplified interface)
(define (cluster n) (cluster-words! 100 n)) ; Top 100 words, n merges
(define (cluster-top n-words n-merges) (cluster-words! n-words n-merges))
(define (clusters) (show-clusters))
(define (top-words n) (take (get-high-frequency-words 1) n))
;; ═══════════════════════════════════════════════════════════════════
;; GRACEFUL SHUTDOWN
;; ═══════════════════════════════════════════════════════════════════
(define *shutdown-requested* #f)
(define (graceful-shutdown)
"Gracefully shut down CogServer, ensuring data is saved."
(set! *shutdown-requested* #t)
(display "\n\n═══ Shutting down... ═══\n")
(when *rsn*
(display "Flushing data to RocksDB...\n")
(catch #t
(lambda ()
(barrier *rsn*)
(display "Closing database...\n")
(cog-close *rsn*)
(display "Database closed.\n"))
(lambda (key . args)
(format #t "Warning during shutdown: ~a ~a\n" key args))))
(display "Goodbye!\n")
(exit 0))
;; ═══════════════════════════════════════════════════════════════════
;; PHASE 5: LEVEL 1 - SECTION PAIR COUNTING
;; ═══════════════════════════════════════════════════════════════════
;;
;; Level 1 operates on Sections (word + disjunct patterns) instead of words.
;; Key insight: If "bank(C0- C1+)" and "bank(C0- C2+)" end up in different
;; clusters, we've discovered word senses!
;;
;; Section storage
(define *sections* (make-hash-table)) ; word -> list of disjuncts
(define *section-counts* (make-hash-table)) ; (word . disjunct) -> count
(define *section-pairs* (make-hash-table)) ; (section1 . section2) -> count
(define (make-disjunct connectors)
"Create a disjunct string from connector list. Example: ((the -) (run +)) -> 'the- run+'"
(string-join
(map (lambda (c)
(string-append (car c) (if (string=? (cadr c) "-") "-" "+")))
connectors)
" "))
(define (parse-to-sections sentence-string)
"Parse sentence and extract Sections (word + disjunct patterns)."
(let* ((words (string-split sentence-string #\space))
(edges (parse-sentence words)) ; Use existing PMFG parser
(word-vec (list->vector words))
(sections '()))
;; For each word, collect its left and right connections
(do ((i 0 (+ i 1))) ((>= i (length words)))
(let ((word (vector-ref word-vec i))
(left-conns '())
(right-conns '()))
;; Find edges involving this word
(for-each
(lambda (edge)
(let ((p1 (car edge))
(p2 (cadr edge)))
(cond
((= p1 i) ; This word is on the left
(set! right-conns (cons (list (vector-ref word-vec p2) "+") right-conns)))
((= p2 i) ; This word is on the right
(set! left-conns (cons (list (vector-ref word-vec p1) "-") left-conns))))))
edges)
;; Create Section for this word
(let ((disjunct (make-disjunct (append (reverse left-conns) right-conns))))
(when (> (string-length disjunct) 0)
(set! sections (cons (cons word disjunct) sections))))))
(reverse sections)))
(define (rewrite-disjunct-with-classes disjunct)
"Replace word names in disjunct with class IDs."
(let ((parts (string-split disjunct #\space)))
(string-join
(map (lambda (part)
(let* ((word (substring part 0 (- (string-length part) 1)))
(dir (substring part (- (string-length part) 1)))
(class-id (hash-ref *word-to-class* word #f)))
(if class-id
(string-append "C" (number->string class-id) dir)
part))) ; Keep original if not in a class
parts)
" ")))
(define (count-section! word disjunct)
"Increment count for a Section (word + disjunct)."
(let ((key (cons word disjunct)))
(hash-set! *section-counts* key (+ (hash-ref *section-counts* key 0) 1))
;; Also track disjuncts per word
(let ((word-disjs (hash-ref *sections* word '())))
(unless (member disjunct word-disjs)
(hash-set! *sections* word (cons disjunct word-disjs))))))
(define (count-section-pair! s1 s2)
"Increment count for a Section pair."
(let ((key (cons s1 s2)))
(hash-set! *section-pairs* key (+ (hash-ref *section-pairs* key 0) 1))))
(define (process-sentence-level1! sentence-string)
"Process a sentence for Level 1: parse, extract sections, count pairs."
(let* ((sections (parse-to-sections sentence-string))
(n (length sections)))
;; Count individual sections
(for-each
(lambda (s)
(count-section! (car s) (cdr s)))
sections)
;; Count section pairs (window of 2)
(do ((i 0 (+ i 1))) ((>= i (- n 1)))
(let ((s1 (list-ref sections i))
(s2 (list-ref sections (+ i 1))))
(count-section-pair! s1 s2)
(count-section-pair! s2 s1))) ; Symmetric
(length sections)))
(define (batch-process-sentences! sentences)
"Process multiple sentences for Level 1."
(let ((t0 (current-time))
(total-sections 0)
(n-sentences (length sentences)))
(format #t "\n═══ Phase 5: Level 1 Processing ═══\n")
(format #t "Processing ~a sentences...\n" n-sentences)
(let loop ((remaining sentences) (i 0))
(unless (null? remaining)
(set! total-sections (+ total-sections
(process-sentence-level1! (car remaining))))
(when (zero? (modulo (+ i 1) 100))
(format #t " Processed ~a sentences...\n" (+ i 1)))
(loop (cdr remaining) (+ i 1))))
(format #t "\n═══ Level 1 Results ═══\n")
(format #t "Sentences processed: ~a\n" n-sentences)
(format #t "Total sections: ~a\n" total-sections)
(format #t "Unique sections: ~a\n" (hash-count (const #t) *section-counts*))
(format #t "Section pairs: ~a\n" (hash-count (const #t) *section-pairs*))
(format #t "Words with disjuncts: ~a\n" (hash-count (const #t) *sections*))
(format #t "Time: ~a seconds\n" (- (current-time) t0))
(display "════════════════════════\n\n")))
(define (show-word-sections word)
"Show all disjuncts (Sections) for a word."
(let ((disjs (hash-ref *sections* word '())))
(format #t "\n═══ Sections for '~a' ═══\n" word)
(if (null? disjs)
(format #t " (no sections found)\n")
(for-each
(lambda (d)
(let* ((key (cons word d))
(count (hash-ref *section-counts* key 0))
(class-d (rewrite-disjunct-with-classes d)))
(format #t " ~a: ~a (count=~a)\n" d class-d count)))
disjs))
(display "═══════════════════════\n\n")))
(define (level1-stats)
"Show Level 1 statistics."
(format #t "\n═══ Level 1 Statistics ═══\n")
(format #t "Words with sections: ~a\n" (hash-count (const #t) *sections*))
(format #t "Unique sections: ~a\n" (hash-count (const #t) *section-counts*))
(format #t "Section pairs: ~a\n" (hash-count (const #t) *section-pairs*))
;; Show top 10 sections by count
(let ((section-list '()))
(hash-for-each
(lambda (key count)
(set! section-list (cons (cons count key) section-list)))
*section-counts*)
(let ((sorted (take (sort section-list (lambda (a b) (> (car a) (car b))))
(min 10 (length section-list)))))
(format #t "\nTop sections:\n")
(for-each
(lambda (x)
(format #t " ~a: ~a (count=~a)\n"
(cadr x) (cddr x) (car x)))
sorted)))
(display "════════════════════════\n\n"))
;; Demo sentences for testing
(define *demo-sentences*
'("the dog chased the cat"
"a cat saw the dog"
"the big dog ran fast"
"she walked to the store"
"he read a good book"
"the store sells books"
"i like the new book"
"the cat is small"
"a big cat ran away"
"the dog is happy"))
(define (demo-level1)
"Run Level 1 demo with test sentences."
(batch-process-sentences! *demo-sentences*)
(show-word-sections "the")
(show-word-sections "dog")
(show-word-sections "cat"))
;; Shell wrappers
(define (level1) (level1-stats))
(define (sections word) (show-word-sections word))
(define (process-level1 sentences) (batch-process-sentences! sentences))
;; ═══════════════════════════════════════════════════════════════════
;; START COGSERVER
;; ═══════════════════════════════════════════════════════════════════
(format #t "Startup mode: ~a\n" *startup-mode*)
(format #t "MI threshold: ~a\n\n" *mi-threshold*)
;; Load data based on startup mode
(if (eq? *startup-mode* 'warm)
(warm-start! *mi-threshold*)
(load-phase1-data!))
;; Build MI index for fast lookups
(build-mi-index!)
;; Load persisted word classes from RocksDB
(load-word-classes!)
;; Initialize GPU
(init-gpu!)
;; Show status
(status)
;; Start cogserver using the proper Guile API
(display "Starting CogServer on port 17001...\n")
(use-modules (opencog cogserver))
(start-cogserver #:port 17001 #:web 18080)
(display "\n═══ CogServer Ready ═══\n")
(display "Connect: rlwrap telnet localhost 17001\n\n")
(display "Available commands:\n")
(display " (status) Show status\n")
(display " (parse-and-show \"w1 w2..\") Parse sentence\n")
(display " (get-mi \"w1\" \"w2\") Get MI for pair\n")
(display " (mi-stats) Show MI statistics\n")
(display " (recompute-mi) Recompute MI for all edges\n")
(display " (check-memory) Check RAM and evict if needed\n")
(display " (evict-cold mi) Evict edges with MI < threshold\n")
(display " (load-word \"word\") Load pairs for word from RocksDB\n")
(display " (cluster n) Cluster top 100 words, n merges\n")
(display " (cluster-top words merges) Cluster top N words\n")
(display " (clusters) Show word classes\n")
(display " (top-words n) Show top n words by frequency\n")
(display " (graceful-shutdown) Clean shutdown\n")
(display "\nCorpus learning (load \"corpus-learning.scm\" first):\n")
(display " (bootstrap!) Bootstrap from MI data\n")
(display " (run-corpus N) Run N sentences through loop\n")
(display " (run-corpus-all) Run all ~56K sentences\n")
(display " (corpus-status) Show learning status\n")
(display " (corpus-thresholds) Show adaptive thresholds\n")
(display " (corpus-vagueness) Show vagueness per word\n")
(display " (corpus-export) Export viz JSON\n")
(format #t "\nMemory watchdog: max ~a MB, evict at ~a%\n" *max-ram-mb* (* 100 *eviction-threshold*))
(display "Press Ctrl+C to stop.\n\n")
;; Set up SIGINT handler for graceful shutdown
(sigaction SIGINT (lambda (sig) (graceful-shutdown)))
;; Start memory watchdog in background thread
(display "Starting memory watchdog thread...\n")
(call-with-new-thread memory-watchdog-loop)
;; Keep running (check shutdown flag periodically)
(while (not *shutdown-requested*) (sleep 60))