;;
;; corpus-learning.scm -- Unified learning loop on real corpus (CogServer integration)
;;
;; Usage: Load into running CogServer via telnet:
;; rlwrap telnet localhost 17001
;; (load "corpus-learning.scm")
;; (bootstrap!)
;; (run-corpus 100)
;;
;; This bridges the standalone unified loop into the CogServer environment,
;; bootstrapping from 962K existing MI edges and running ~56K real Gutenberg
;; sentences through the recursive COUNT -> STRUCTURE -> CLUSTER architecture.
;;
;; Architecture:
;; ONE loop, same code at every level.
;; Level 0: word pairs -> word classes
;; Level 1: section pairs -> word senses
;; Level N: unit pairs -> Level N+1 units
;;
;; Two key metrics:
;; Surprise - how unexpected a parse is (triggers learning)
;; Vagueness - uncertainty about entities (reduced by learning)
;;
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-13))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 threads))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 1: LEVEL-GENERIC INTERFACE
;; ═══════════════════════════════════════════════════════════════════
;;
;; A "level" is defined by a record with:
;; - pair-type: what atoms to pair (Words at L0, Sections at L1)
;; - parse-fn: how to parse a sentence at this level
;; - count-fn: how to count pairs
;; - mi-fn: how to compute MI (GPU batch or CPU)
;; - cluster-fn: how to cluster similar units
;; - promote-fn: how to create next-level vocabulary from clusters
(define (make-level id name parse-fn count-fn mi-fn cluster-fn promote-fn)
"Create a level descriptor."
(list id name parse-fn count-fn mi-fn cluster-fn promote-fn))
(define (level-id lvl) (list-ref lvl 0))
(define (level-name lvl) (list-ref lvl 1))
(define (level-parse lvl) (list-ref lvl 2))
(define (level-count lvl) (list-ref lvl 3))
(define (level-mi lvl) (list-ref lvl 4))
(define (level-cluster lvl) (list-ref lvl 5))
(define (level-promote lvl) (list-ref lvl 6))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 1b: EVENT STREAMING (NDJSON output for real-time viz)
;; ═══════════════════════════════════════════════════════════════════
(define *cl-stream-port* #f)
(define *cl-stream-file* (string-append *mvp-dir* "/viz/stream.jsonl"))
(define *cl-stream-enabled* #t)
(define (cl-stream-open!)
"Open the NDJSON stream file for appending."
(when *cl-stream-enabled*
(when *cl-stream-port*
(catch #t (lambda () (close-port *cl-stream-port*)) (lambda _ #f)))
;; Truncate on open (fresh stream per session)
(set! *cl-stream-port* (open-file *cl-stream-file* "w"))
;; Write header event
(cl-emit! "init" `(("time" . ,(current-time))))
;; Emit existing class structure so live view can reconstruct
(hash-for-each
(lambda (class-id members)
(when (>= (length members) 2)
(let ((w1 (car members)))
(for-each
(lambda (w2)
(cl-emit! "merge" `(("w1" . ,w1) ("w2" . ,w2)
("sim" . 0.0)
("c" . ,class-id)
("iter" . -1))))
(cdr members)))))
*word-classes*)))
(define (cl-stream-close!)
"Close the stream file."
(when *cl-stream-port*
(close-port *cl-stream-port*)
(set! *cl-stream-port* #f)))
(define (cl-emit-json-value! v port)
"Write a single JSON value to port."
(cond
((string? v) (format port "~s" v))
((boolean? v) (display (if v "true" "false") port))
((integer? v) (format port "~a" v))
((number? v) (format port "~,4f" (exact->inexact v)))
((list? v)
(display "[" port)
(let loop ((items v) (first #t))
(when (not (null? items))
(unless first (display "," port))
(cl-emit-json-value! (car items) port)
(loop (cdr items) #f)))
(display "]" port))
(else (format port "~s" (format #f "~a" v)))))
(define (cl-emit! type alist)
"Emit one NDJSON event line. ALIST is a list of (key . value) pairs."
(when (and *cl-stream-enabled* *cl-stream-port*)
(catch #t
(lambda ()
(display "{" *cl-stream-port*)
(display (format #f "\"t\":~s" type) *cl-stream-port*)
(for-each
(lambda (pair)
(let ((k (car pair)) (v (cdr pair)))
(display "," *cl-stream-port*)
(format *cl-stream-port* "~s:" k)
(cl-emit-json-value! v *cl-stream-port*)))
alist)
(display "}\n" *cl-stream-port*)
(force-output *cl-stream-port*))
(lambda (key . args) #f)))) ; Silently ignore stream errors
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 2: STATE (prefixed *cl-* to avoid conflicts with CogServer)
;; ═══════════════════════════════════════════════════════════════════
;; define-once: keep existing value on reload, only set on first load
(define-syntax define-once
(syntax-rules ()
((_ var val)
(define var (if (defined? 'var) var val)))))
;; Loop control
(define *cl-running* #f) ; always reset on reload
(define-once *cl-current-level* 0)
;; Counters (survive reloads)
(define-once *cl-total-sentences* 0)
(define-once *cl-total-learns* 0)
(define-once *cl-sentences-since-mi* 0)
(define-once *cl-sentences-since-cluster* 0)
;; Adaptive thresholds (computed from data, NOT hardcoded)
(define *cl-surprise-percentile* 0.8) ; Learn from top 20% most surprising
(define-once *cl-surprise-threshold* 2.0) ; Initial - recalibrated from data
(define *cl-mi-drift-ratio* 0.05) ; Recompute MI when 5% new pairs
(define *cl-profile-drift-threshold* 0.1); Recluster when profiles drift > 10%
;; Rolling windows
(define *cl-surprise-window* 200) ; Window size for surprise distribution
(define-once *cl-recent-surprises* '()) ; For percentile computation
(define *cl-stability-window* 5) ; Consecutive 0-merge rounds for promotion
;; Level 0 state (word-level)
(define-once *cl-dirty-pairs* (make-hash-table)) ; Pairs needing MI recompute
(define-once *cl-dirty-count* 0) ; Number of dirty pairs
(define-once *cl-pair-counts-delta* (make-hash-table)); New pair counts since last MI
(define-once *cl-total-new-pairs* 0) ; Pairs added since last MI
(define-once *cl-baseline-mi* 0.0) ; Mean MI across all pairs
;; Level 1 state (section-level)
(define-once *cl-l1-pair-counts* (make-hash-table)) ; Section pair counts
(define-once *cl-l1-mi-cache* (make-hash-table)) ; Section pair MI
(define-once *cl-l1-dirty-pairs* (make-hash-table)) ; Dirty section pairs
(define-once *cl-l1-dirty-count* 0)
(define-once *cl-l1-total-new-pairs* 0)
(define-once *cl-l1-baseline-mi* 0.0)
(define-once *cl-l1-word-senses* (make-hash-table)) ; word -> list of sense clusters
(define-once *cl-l1-sense-map* (make-hash-table)) ; section-key -> sense-id
;; Merge history for hierarchy visualization
(define-once *cl-merge-history* '())
(define-once *cl-word-surprise* (make-hash-table)) ; word -> latest surprise value
(define-once *cl-cluster-iteration* 0)
(define-once *cl-merge-rounds-zero* 0) ; Consecutive 0-merge rounds
;; Emergent clustering state (replaces rank-based merging)
(define-once *cl-top-pair-score* 1.0) ; Highest cosine in last clustering round
(define-once *cl-entropy-history* '()) ; Rolling window of marginal entropies
(define *cl-entropy-window* 5) ; Window size for plateau detection
(define *cl-noise-floor* 0.15) ; Below this cosine, no structure remains
(define *cl-in-group-tightness* 0.7) ; Fraction of group that must agree
(define *cl-in-group-max-size* 8) ; Max natural group size
(define *cl-in-group-lower-bound* 0.10) ; Absolute cosine floor for group membership
(define *cl-max-groups-per-round* 3) ; Max seed groups to process per round
;; Benchmark accumulators (reset on bootstrap, accumulated during run)
(define-once *cl-bench-start-time* 0) ; (get-internal-real-time) at run start
(define-once *cl-bench-mi-total-ms* 0.0) ; Total MI recompute time (ms)
(define-once *cl-bench-mi-calls* 0) ; Number of MI recompute calls
(define-once *cl-bench-mi-pairs* 0) ; Total pairs processed by MI
(define-once *cl-bench-cluster-total-ms* 0.0) ; Total clustering time (ms)
(define-once *cl-bench-cluster-calls* 0) ; Number of cluster rounds
(define-once *cl-bench-evict-total-ms* 0.0) ; Total eviction time (ms)
(define-once *cl-bench-evict-calls* 0) ; Number of eviction calls
(define-once *cl-bench-export-total-ms* 0.0) ; Total export time (ms)
(define-once *cl-bench-export-calls* 0) ; Number of exports
(define-once *cl-bench-last-batch-ms* 0.0) ; Last batch processing time (ms)
;; Calibration state
(define *cl-calibration-interval* 5000) ; Recalibrate every N sentences
(define-once *cl-last-calibration* 0)
;; MI recompute trigger — accumulate this many dirty pairs before batch recompute.
;; GPU MI is always used when *gpu-ready* (266x faster at 50K pairs, crossover ~300).
(define *cl-gpu-mi-batch-size* 1000) ; Trigger MI recompute at this count
;; Clustering interval — sentences between cluster checks
;; Fewer top-words (200 vs 1000) means faster rounds, so can run more often
(define *cl-cluster-interval* 500)
;; Batch size for sentence processing pipeline
(define *cl-batch-size* 50)
;; Incremental neighbor index — track MI changes since last index build
(define *cl-mi-additions* '()) ; List of (w1 . w2) pairs added since last index
(define *cl-clustering-active* #f) ; True while background clustering runs
;; Grammar phase state
(define-once *cl-class-mi-cache* (make-hash-table)) ; (class-id-a . class-id-b) -> mean MI
(define-once *cl-grammar-available* #f) ; #t after first grammar export
(define-once *cl-grammar-surprise-threshold* 3.0) ; Initial grammar-surprise threshold
(define-once *cl-crawl-seen* (make-hash-table)) ; Files already processed
(define-once *cl-crawl-total-files* 0)
(define-once *cl-crawl-total-sentences* 0)
(define *cl-crawl-interval* 300) ; Seconds between re-scans
;; Curriculum-driven learning state (Level 1 query + Level 2 instrumentation)
(define-once *cl-source-names* (make-hash-table)) ; source-id -> directory name
(define-once *cl-source-stats* (make-hash-table)) ; source-id -> (sentence-count surprise-sum)
(define-once *cl-source-next-id* 0) ; Next source ID to assign
(define-once *cl-word-sentences* (make-hash-table)) ; word -> list of (source-id . sentence)
(define *cl-word-sentences-max* 50) ; Max examples to keep per word
(define-once *cl-query-count* 0) ; Total queries triggered
(define-once *cl-action-log* '()) ; (strategy source-id word surprise-before surprise-after)
(define-once *cl-action-mi-cache* (make-hash-table)) ; (strategy . source-id) -> mean-delta-surprise
(define *cl-action-mi-interval* 200) ; Recompute action MI every N queries
(define *cl-query-epsilon* 0.3) ; Exploration rate (30% random, 70% best)
(define *cl-query-min-surprise* 4.0) ; 2x default threshold triggers query
(define *cl-query-min-examples* 20) ; Query when word has < this many examples
(define-once *cl-source-dirs* '()) ; Ordered list of source directories for scanning
;; GPU-native AtomSpace integration
;; Sentences + MST edges are buffered, then flushed to GPU in batches.
;; GPU handles counting, MI, sections, and cosine — CogServer keeps its own
;; pair counting + MI for surprise/PMFG (already fast at ~1s/batch).
(define *gpu-native-ready* #f) ; set by cl-gpu-init!
(define *cl-gpu-sentence-buffer* '()) ; list of (words . edges)
(define *cl-gpu-buffer-size* 0)
(define *cl-gpu-flush-threshold* 500) ; flush every N sentences
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 3: BOOTSTRAP
;; ═══════════════════════════════════════════════════════════════════
(define (bootstrap)
"Bootstrap corpus learning from CogServer's existing MI data.
Computes baseline MI, initial surprise distribution, and threshold."
(format #t "~%═══ BOOTSTRAPPING CORPUS LEARNING ═══~%")
;; 1. Compute baseline MI from CogServer's *mi-cache*
(let ((mi-sum 0.0)
(mi-count 0)
(mi-values '()))
(hash-for-each
(lambda (key mi)
;; Only count each pair once (avoid double-counting symmetric entries)
(when (and (pair? key) (string<? (car key) (cdr key)))
(set! mi-sum (+ mi-sum mi))
(set! mi-count (+ mi-count 1))
(set! mi-values (cons mi mi-values))))
*mi-cache*)
(if (zero? mi-count)
(begin
(format #t "WARNING: No MI data in cache. Run with (run-corpus 100) to bootstrap.~%")
(set! *cl-baseline-mi* 1.0))
(begin
(set! *cl-baseline-mi* (/ mi-sum mi-count))
(format #t "Baseline MI: ~,3f (from ~a unique pairs)~%"
*cl-baseline-mi* mi-count)))
;; 2. Compute initial surprise distribution from 200 corpus sentences
(format #t "Computing initial surprise distribution...~%")
(let ((calibration-sentences (take-corpus-sentences 200)))
(for-each
(lambda (entry)
(let* ((sentence (if (pair? entry) (cdr entry) entry))
(words (string-split sentence #\space))
(edges (cpu-pmfg-parse words))
(surprise (cl-compute-surprise edges)))
(cl-update-surprise-window! surprise)))
calibration-sentences))
;; 3. Set threshold from percentile
(cl-recalibrate-threshold!)
;; 4. Initialize GPU-native AtomSpace bridge (optional — falls back to CPU)
(cl-gpu-init!)
;; 5. Reset benchmark accumulators
(set! *cl-bench-start-time* (get-internal-real-time))
(set! *cl-bench-mi-total-ms* 0.0)
(set! *cl-bench-mi-calls* 0)
(set! *cl-bench-mi-pairs* 0)
(set! *cl-bench-cluster-total-ms* 0.0)
(set! *cl-bench-cluster-calls* 0)
(set! *cl-bench-evict-total-ms* 0.0)
(set! *cl-bench-evict-calls* 0)
(set! *cl-bench-export-total-ms* 0.0)
(set! *cl-bench-export-calls* 0)
(format #t "~%Bootstrap complete.~%")
(format #t " Baseline MI: ~,3f~%" *cl-baseline-mi*)
(format #t " Surprise threshold: ~,3f (p~a)~%"
*cl-surprise-threshold*
(inexact->exact (round (* 100 *cl-surprise-percentile*))))
(format #t " MI cache entries: ~a~%"
(hash-count (const #t) *mi-cache*))
(format #t " Word classes: ~a~%"
(hash-count (const #t) *word-classes*))
(format #t "═══════════════════════════════════════~%~%")))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 4: CORPUS LOADING
;; ═══════════════════════════════════════════════════════════════════
(define *cl-corpus-files*
(list
(string-append *mvp-dir* "/corpus/alice-in-wonderland.txt")
(string-append *mvp-dir* "/corpus/pride-and-prejudice.txt")
(string-append *mvp-dir* "/corpus/sherlock-holmes.txt")
(string-append *mvp-dir* "/corpus/great-expectations.txt")
(string-append *mvp-dir* "/corpus/moby-dick.txt")))
(define (cl-clean-sentence line)
"Clean a line: lowercase, remove punctuation, collapse whitespace."
(let* ((lower (string-downcase line))
(no-punct (string-map
(lambda (c)
(cond
((char=? c #\return) #\space)
((or (char-alphabetic? c) (char-whitespace? c)) c)
(else #\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 (cl-load-corpus-file filename)
"Load sentences from a Gutenberg corpus file."
(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 (cl-clean-sentence line)))
(when (and cleaned (> (string-length cleaned) 10))
(set! sentences (cons cleaned sentences)))))
(loop)))))))
(lambda (key . args)
(format #t "Error loading ~a: ~a ~a~%" filename key args)))
(reverse sentences)))
(define *cl-all-sentences* #f) ; Cached loaded sentences: list of (book-idx . sentence)
;; Short book names for stream events
(define *cl-book-names*
#("alice" "pride" "sherlock" "expectations" "moby"))
(define (cl-load-all-corpus!)
"Load all corpus files and cache the result.
Each entry is (book-index . sentence-string)."
(unless *cl-all-sentences*
(let ((sentences '())
(book-idx 0))
(for-each
(lambda (file)
(format #t "Loading ~a...~%" file)
(let ((file-sentences (cl-load-corpus-file file)))
(format #t " ~a sentences~%" (length file-sentences))
(set! sentences
(append sentences
(map (lambda (s) (cons book-idx s))
file-sentences))))
(set! book-idx (+ book-idx 1)))
*cl-corpus-files*)
;; Curriculum learning: sort shortest sentences first
(set! *cl-all-sentences*
(sort sentences
(lambda (a b) (< (string-length (cdr a)) (string-length (cdr b))))))
(format #t "Total corpus: ~a sentences (sorted short→long for curriculum learning)~%~%"
(length *cl-all-sentences*))))
*cl-all-sentences*)
(define (take-corpus-sentences n)
"Get first N sentences from the corpus."
(cl-load-all-corpus!)
(take *cl-all-sentences* (min n (length *cl-all-sentences*))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 5: THE UNIFIED LOOP (level-generic)
;; ═══════════════════════════════════════════════════════════════════
(define (cl-learn-loop sentences)
"The ONE loop. Batch pipeline: parse batch → count → MI → cluster."
(format #t "~%═══ UNIFIED LEARNING LOOP ═══~%")
(format #t "Level: ~a | Sentences: ~a | Threshold: ~,3f | Batch: ~a~%~%"
*cl-current-level* (length sentences) *cl-surprise-threshold*
*cl-batch-size*)
(set! *cl-running* #t)
(cl-stream-open!)
(cl-emit! "start" `(("total" . ,(length sentences))
("level" . ,*cl-current-level*)
("threshold" . ,*cl-surprise-threshold*)
("baseline" . ,*cl-baseline-mi*)))
(let loop ((remaining sentences))
(when (and *cl-running* (not (null? remaining)))
;; Take a batch
(let* ((batch-size (min *cl-batch-size* (length remaining)))
(batch (take remaining batch-size))
(rest (drop remaining batch-size)))
;; ── PHASE 1a: Parallel parse (read-only, thread-safe) ──
;; cpu-pmfg-parse reads *mi-cache* (immutable during batch)
;; cl-compute-surprise reads baseline (immutable during batch)
;; cl-l1-section-edges reads *cl-l1-mi-cache* (immutable during batch)
(let* ((cur-level *cl-current-level*)
(parsed-batch
(par-map
(lambda (entry)
(let* ((book-idx (if (pair? entry) (car entry) -1))
(sentence (if (pair? entry) (cdr entry) entry))
(words (string-split sentence #\space)))
(if (< (length words) 3)
#f ; skip short sentences
(let* ((word-edges (cpu-pmfg-parse words))
(level-edges
(if (zero? cur-level)
word-edges
(cl-l1-section-edges words word-edges)))
(surprise (cl-compute-surprise level-edges)))
(vector words word-edges level-edges surprise book-idx)))))
batch)))
;; ── PHASE 1b: Serial updates (writes to shared state) ──
(for-each
(lambda (parsed)
(when parsed
(let ((words (vector-ref parsed 0))
(word-edges (vector-ref parsed 1))
(level-edges (vector-ref parsed 2))
(surprise (vector-ref parsed 3))
(book-idx (vector-ref parsed 4)))
(set! *cl-total-sentences* (+ *cl-total-sentences* 1))
(cl-update-surprise-window! surprise)
;; Update per-word surprise (EMA of edge-based surprise)
;; For each word, surprise = baseline - avg_MI(edges touching it)
(let ((n (length words))
(baseline (cl-level-baseline cur-level)))
(do ((k 0 (+ k 1))) ((>= k n))
(let* ((w (list-ref words k))
(my-edges (filter (lambda (e)
(or (= (car e) k) (= (cadr e) k)))
word-edges))
(word-sur
(if (null? my-edges)
10.0 ; isolated word = max surprise
(let ((avg (/ (apply + (map caddr my-edges))
(length my-edges))))
(max 0.0 (- baseline avg)))))
(old (hash-ref *cl-word-surprise* w #f)))
(hash-set! *cl-word-surprise* w
(if old
(+ (* 0.1 word-sur) (* 0.9 old))
word-sur)))))
;; Build inverse word index: word -> list of (source-id . sentence)
(let ((sent-str (string-join words " ")))
(for-each
(lambda (w)
(let ((existing (hash-ref *cl-word-sentences* w '())))
(when (< (length existing) *cl-word-sentences-max*)
(hash-set! *cl-word-sentences* w
(cons (cons book-idx sent-str) existing)))))
(delete-duplicates words string=?)))
;; Update per-source surprise stats
(when (>= book-idx 0)
(cl-update-source-stats! book-idx 1 surprise))
;; Extract sections from EVERY sentence (connector index needs them)
(when (zero? cur-level)
(cl-l0-extract-sections! words word-edges)
(cl-gpu-buffer-sentence! words word-edges))
;; Force learning when L1+ baseline=0 (warmup: no MI yet)
(let ((learned #f))
(if (or (> surprise *cl-surprise-threshold*)
(and (> cur-level 0)
(zero? (cl-level-baseline cur-level))))
(begin
(set! *cl-total-learns* (+ *cl-total-learns* 1))
(set! learned #t)
(cl-learn-at-level! words word-edges level-edges cur-level))
(cl-passive-count! words word-edges cur-level))
;; Stream event
(cl-emit! "s" `(("i" . ,*cl-total-sentences*)
("sur" . ,surprise)
("learn" . ,learned)
("bk" . ,book-idx)
("nw" . ,(length words))
("ne" . ,(length level-edges))
("lv" . ,cur-level)))))))
parsed-batch))
;; ── PHASE 2: Batch MI recompute (once per batch, not per sentence) ──
(when (cl-mi-drift-significant? *cl-current-level*)
(cl-recompute-mi-at-level! *cl-current-level*)
(cl-emit! "mi" `(("dirty" . ,(if (zero? *cl-current-level*)
*cl-dirty-count* *cl-l1-dirty-count*))
("base" . ,(cl-level-baseline *cl-current-level*))
("lv" . ,*cl-current-level*))))
;; ── PHASE 3: Clustering check (once per batch) ──
(when (and (not *cl-clustering-active*)
(cl-profiles-drifted? *cl-current-level*))
(cl-cluster-at-level! *cl-current-level*))
;; ── PHASE 4: Promotion check ──
(when (cl-level-stable? *cl-current-level*)
(cl-promote-level! *cl-current-level*)
(cl-emit! "promote" `(("from" . ,(- *cl-current-level* 1))
("to" . ,*cl-current-level*))))
;; ── Periodic maintenance ──
(when (and (> *cl-total-sentences* 0)
(zero? (modulo *cl-total-sentences* *cl-calibration-interval*)))
(cl-recalibrate-threshold!)
(cl-emit! "calibrate" `(("threshold" . ,*cl-surprise-threshold*))))
(when (and (> *cl-total-sentences* 0)
(zero? (modulo (quotient *cl-total-sentences* *cl-batch-size*) 10)))
(cl-show-status)
(cl-emit! "status" `(("sent" . ,*cl-total-sentences*)
("learns" . ,*cl-total-learns*)
("sur" . ,(cl-average-surprise))
("base" . ,*cl-baseline-mi*)
("classes" . ,(hash-count (const #t) *word-classes*))
("dirty" . ,*cl-dirty-count*)
("level" . ,*cl-current-level*))))
(when (and (> *cl-total-sentences* 4900)
(< (modulo *cl-total-sentences* 5000) 100))
(format #t "~%[Auto-export at sentence ~a]~%" *cl-total-sentences*)
(corpus-export))
;; ── Post-batch hooks (query triggers, etc.) ──
(when (not (null? *cl-post-batch-hooks*))
(let ((batch-words
(apply append
(filter-map
(lambda (parsed)
(and parsed (vector-ref parsed 0)))
parsed-batch))))
(for-each
(lambda (hook) (catch #t (lambda () (hook batch-words)) (lambda _ #f)))
*cl-post-batch-hooks*)))
(loop rest))))
(cl-emit! "end" `(("sent" . ,*cl-total-sentences*)
("learns" . ,*cl-total-learns*)
("classes" . ,(hash-count (const #t) *word-classes*))))
(cl-stream-close!)
(set! *cl-running* #f)
(format #t "~%═══ LOOP COMPLETE ═══~%")
(cl-show-status))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 6: LEVEL 0 IMPLEMENTATION (word pairs)
;; ═══════════════════════════════════════════════════════════════════
(define (cl-parse-at-level words level)
"Parse sentence at given level. Returns edge list."
(case level
((0) (cpu-pmfg-parse words))
((1) (cl-l1-parse words))
(else (cpu-pmfg-parse words)))) ; Fallback
(define (cl-learn-at-level! words word-edges level-edges level)
"Full learning: count pairs, extract sections, mark dirty.
WORD-EDGES: pre-computed cpu-pmfg-parse result (avoids redundant parse).
LEVEL-EDGES: level-specific edges (= word-edges at L0, section edges at L1).
When grammar is available at L0, use grammar-surprise to decide
whether to do full learning or passive counting."
(case level
((0)
(if (and *cl-grammar-available*
(< (cl-grammar-surprise words) *cl-grammar-surprise-threshold*))
(cl-l0-passive-count! words)
(cl-l0-learn! words level-edges)))
((1) (cl-l1-learn! words level-edges word-edges))
(else (cl-l0-learn! words level-edges))))
(define (cl-passive-count! words word-edges level)
"Passive counting only (low surprise).
WORD-EDGES: pre-computed cpu-pmfg-parse result."
(case level
((0) (cl-l0-passive-count! words))
((1) (cl-l1-passive-count! words word-edges))
(else (cl-l0-passive-count! words))))
;; --- Level 0: word pair learning ---
(define (cl-l0-learn! words edges)
"Learn from sentence at Level 0: count pairs."
;; Count all word pairs in a window
(cl-l0-count-pairs! words))
(define (cl-l0-passive-count! words)
"Passive pair counting at Level 0."
(cl-l0-count-pairs! words))
(define (cl-l0-count-pairs! words)
"Count word pairs in sliding window. Updates CogServer Edge atoms + dirty set."
(let ((n (length words))
(window 6)
(count-key (Predicate "*-TruthValueKey-*")))
(do ((i 0 (+ i 1))) ((>= i n))
(do ((j (+ i 1) (+ j 1))) ((or (>= j n) (> (- j i) window)))
(let* ((w1 (list-ref words i))
(w2 (list-ref words j))
;; Use existing Edge atom pattern from CogServer
(edge (Edge (Bond "ANY") (List (Word w1) (Word w2)))))
;; Increment count on the Edge atom
(let* ((v (cog-value edge count-key))
(old-count (if v (cog-value-ref v 2) 0.0))
(new-count (+ old-count 1.0)))
(cog-set-value! edge count-key (FloatValue 0.0 0.0 new-count)))
;; Mark as dirty for MI recomputation
(unless (hash-ref *cl-dirty-pairs* edge #f)
(hash-set! *cl-dirty-pairs* edge #t)
(set! *cl-dirty-count* (+ *cl-dirty-count* 1)))
;; Incrementally update marginals (avoids full edge scan)
(hash-set! *left-marginals* w1
(+ (hash-ref *left-marginals* w1 0) 1))
(hash-set! *right-marginals* w2
(+ (hash-ref *right-marginals* w2 0) 1))
(set! *total-pair-count* (+ *total-pair-count* 1))
;; Track delta
(let ((key (cons w1 w2)))
(hash-set! *cl-pair-counts-delta* key
(+ (hash-ref *cl-pair-counts-delta* key 0) 1))
(set! *cl-total-new-pairs* (+ *cl-total-new-pairs* 1)))
;; Store to RocksDB periodically
(when (and *rsn* (zero? (modulo *cl-total-new-pairs* 10000)))
(store-atom edge)))))))
(define (cl-l0-extract-sections! words edges)
"Extract sections from parse and count them (for Level 1 vocabulary)."
(let ((word-vec (list->vector words)))
(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)
(set! right-conns
(cons (list (vector-ref word-vec p2) "+") right-conns)))
((= p2 i)
(set! left-conns
(cons (list (vector-ref word-vec p1) "-") left-conns))))))
edges)
;; Create section
(let ((connectors (append (reverse left-conns) right-conns)))
(unless (null? connectors)
;; Use RAW disjuncts — full disjuncts capture grammar precisely
;; No class rewriting (avoids noise from unreliable classes)
(let ((raw-disjunct (cl-make-disjunct connectors)))
(count-section! word raw-disjunct))))))))
(define (cl-make-disjunct connectors)
"Create disjunct string from connector list."
(string-join
(map (lambda (c)
(string-append (car c) (cadr c)))
connectors)
" "))
(define (cl-rewrite-with-classes disjunct)
"Replace word names in disjunct with class IDs where available."
(let ((parts (string-split disjunct #\space)))
(string-join
(map (lambda (part)
(if (< (string-length part) 2)
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))))
parts)
" ")))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 7: LEVEL 1 IMPLEMENTATION (section pairs)
;; ═══════════════════════════════════════════════════════════════════
(define (cl-l1-section-edges words word-edges)
"Derive L1 section edges from pre-computed word-edges.
Reuses word-edges to avoid redundant cpu-pmfg-parse call."
(let* ((sections (cl-edges-to-sections words word-edges))
(sec-vec (list->vector sections))
(section-edges '()))
;; Build section-pair edges with MI from L1 cache
(do ((i 0 (+ i 1))) ((>= i (- (vector-length sec-vec) 1)))
(let* ((s1 (vector-ref sec-vec i))
(s2 (vector-ref sec-vec (+ i 1)))
(key (cons s1 s2))
(mi (hash-ref *cl-l1-mi-cache* key 0.0)))
(set! section-edges (cons (list i (+ i 1) mi) section-edges))))
(reverse section-edges)))
(define (cl-l1-parse words)
"Parse at Level 1: PMFG parse -> sections -> section-pair MI edges."
(cl-l1-section-edges words (cpu-pmfg-parse words)))
(define (cl-l1-learn! words edges . rest)
"Learn at Level 1: count section pairs.
EDGES are the L1 section edges (unused here — kept for interface compat).
Optional REST: (word-edges) to avoid redundant cpu-pmfg-parse."
;; Reuse pre-computed word-edges if provided, otherwise parse
(let ((word-edges (if (null? rest) (cpu-pmfg-parse words) (car rest))))
(cl-l0-learn! words word-edges)
;; Count section pairs using sections derived from the SAME parse
(let* ((sections (cl-edges-to-sections words word-edges))
(n (length sections)))
(do ((i 0 (+ i 1))) ((>= i (- n 1)))
(let* ((s1 (list-ref sections i))
(s2 (list-ref sections (+ i 1)))
(key (cons s1 s2))
(rkey (cons s2 s1)))
;; Count forward and reverse
(hash-set! *cl-l1-pair-counts* key
(+ (hash-ref *cl-l1-pair-counts* key 0) 1))
(hash-set! *cl-l1-pair-counts* rkey
(+ (hash-ref *cl-l1-pair-counts* rkey 0) 1))
;; Mark dirty
(unless (hash-ref *cl-l1-dirty-pairs* key #f)
(hash-set! *cl-l1-dirty-pairs* key #t)
(set! *cl-l1-dirty-count* (+ *cl-l1-dirty-count* 1)))
(set! *cl-l1-total-new-pairs* (+ *cl-l1-total-new-pairs* 1)))))))
(define (cl-l1-passive-count! words . rest)
"Passive counting at Level 1.
Optional REST: (word-edges) to avoid redundant cpu-pmfg-parse."
(cl-l0-passive-count! words)
;; Reuse pre-computed word-edges if provided, otherwise parse
(let* ((word-edges (if (null? rest) (cpu-pmfg-parse words) (car rest)))
(sections (cl-edges-to-sections words word-edges))
(n (length sections)))
(do ((i 0 (+ i 1))) ((>= i (- n 1)))
(let* ((s1 (list-ref sections i))
(s2 (list-ref sections (+ i 1)))
(key (cons s1 s2))
(rkey (cons s2 s1)))
(hash-set! *cl-l1-pair-counts* key
(+ (hash-ref *cl-l1-pair-counts* key 0) 1))
(hash-set! *cl-l1-pair-counts* rkey
(+ (hash-ref *cl-l1-pair-counts* rkey 0) 1))))))
(define (cl-edges-to-sections words edges)
"Build sections from a word list and its PMFG edges.
Returns list of (word . class-rewritten-disjunct) pairs.
Used by L1 parse, L1 learn, and L1 passive count — single source of truth."
(let* ((word-vec (list->vector words))
(sections '()))
(do ((i 0 (+ i 1))) ((>= i (length words)))
(let ((word (vector-ref word-vec i))
(left-conns '())
(right-conns '()))
(for-each
(lambda (edge)
(let ((p1 (car edge))
(p2 (cadr edge)))
(cond
((= p1 i)
(set! right-conns
(cons (list (vector-ref word-vec p2) "+") right-conns)))
((= p2 i)
(set! left-conns
(cons (list (vector-ref word-vec p1) "-") left-conns))))))
edges)
(unless (null? (append left-conns right-conns))
(let* ((raw-disj (cl-make-disjunct (append (reverse left-conns) right-conns)))
(class-disj (cl-rewrite-with-classes raw-disj)))
(set! sections (cons (cons word class-disj) sections))))))
(reverse sections)))
;; Backwards-compatible wrapper
(define (cl-get-sections words)
"Get sections for a sentence (parses internally)."
(cl-edges-to-sections words (cpu-pmfg-parse words)))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 8: SURPRISE & VAGUENESS
;; ═══════════════════════════════════════════════════════════════════
(define (cl-level-baseline level)
"Get baseline MI for the current level. Same metric at every level."
(case level
((0) *cl-baseline-mi*)
((1) *cl-l1-baseline-mi*)
(else *cl-baseline-mi*)))
(define (cl-compute-surprise edges)
"Compute surprise in bits. Same formula at every level —
surprise = baseline_MI(level) - avg_MI(parse edges).
High MI = expected = low surprise."
(if (null? edges)
10.0 ; Maximum surprise for unparseable
(let* ((mi-values (map caddr edges))
(avg-mi (/ (apply + mi-values) (max 1 (length mi-values))))
(baseline (cl-level-baseline *cl-current-level*)))
(if (zero? baseline)
;; No baseline yet — use raw variance as surprise signal
;; Higher avg-mi = more predictable = less surprising
(max 0.0 (- 10.0 avg-mi))
(max 0.0 (- baseline avg-mi))))))
(define (cl-update-surprise-window! surprise)
"Add surprise to rolling window."
(set! *cl-recent-surprises* (cons surprise *cl-recent-surprises*))
(when (> (length *cl-recent-surprises*) *cl-surprise-window*)
(set! *cl-recent-surprises*
(take *cl-recent-surprises* *cl-surprise-window*))))
(define (cl-recalibrate-threshold!)
"Recalibrate surprise threshold from the current distribution."
(when (> (length *cl-recent-surprises*) 10)
(let* ((sorted (sort (list-copy *cl-recent-surprises*) <))
(n (length sorted))
(idx (min (- n 1)
(inexact->exact (floor (* n *cl-surprise-percentile*))))))
(set! *cl-surprise-threshold* (list-ref sorted idx))
(set! *cl-last-calibration* *cl-total-sentences*)
(format #t " [Threshold recalibrated: ~,3f (p~a from ~a samples)]~%"
*cl-surprise-threshold*
(inexact->exact (round (* 100 *cl-surprise-percentile*)))
n))))
(define (cl-average-surprise)
"Average surprise over recent window."
(if (null? *cl-recent-surprises*)
0.0
(/ (apply + *cl-recent-surprises*)
(length *cl-recent-surprises*))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 9: ADAPTIVE MI RECOMPUTATION
;; ═══════════════════════════════════════════════════════════════════
(define (cl-mi-drift-significant? level)
"Check if MI needs recomputing based on dirty pair count."
(case level
((0)
;; Simple threshold check — no expensive hash-count per sentence
(>= *cl-dirty-count* *cl-gpu-mi-batch-size*))
((1)
(let ((total (hash-count (const #t) *cl-l1-mi-cache*)))
(and (> *cl-l1-dirty-count* 0)
(or (zero? total)
(> (/ *cl-l1-dirty-count* (max 1 total))
*cl-mi-drift-ratio*)))))
(else #f)))
(define (cl-recompute-mi-at-level! level)
"Recompute MI at the given level."
(case level
((0) (cl-l0-recompute-mi!))
((1) (cl-l1-recompute-mi!))
(else (format #t " [No MI recompute for level ~a]~%" level))))
(define (cl-l0-recompute-mi!)
"Recompute MI for Level 0 (word pairs). Uses GPU for large batches."
(let ((t0 (get-internal-real-time))
(n-dirty *cl-dirty-count*))
(format #t " [L0 MI recompute: ~a dirty pairs..." n-dirty)
;; Marginals are updated incrementally in cl-l0-count-pairs!
;; No need for full compute-marginals! scan (was scanning 962K+ edges)
;; Always use GPU MI when available (266x faster at scale, crossover ~300 pairs)
(if *gpu-ready*
;; GPU batch MI
(cl-l0-gpu-mi-batch!)
;; CPU fallback: recompute dirty pairs only
(hash-for-each
(lambda (edge _)
(catch #t
(lambda () (recompute-mi-for-edge! edge))
(lambda (key . args) #f))) ; Skip errors
*cl-dirty-pairs*))
;; Update baseline MI using a running estimate (avoids iterating 1.8M entries)
;; Only do full scan every 10th recomputation
(if (zero? (modulo *cl-cluster-iteration* 10))
(let ((mi-sum 0.0) (mi-count 0))
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (string<? (car key) (cdr key)))
(set! mi-sum (+ mi-sum mi))
(set! mi-count (+ mi-count 1))))
*mi-cache*)
(when (> mi-count 0)
(set! *cl-baseline-mi* (/ mi-sum mi-count)))))
;; Clear dirty set
(hash-clear! *cl-dirty-pairs*)
(set! *cl-dirty-count* 0)
(hash-clear! *cl-pair-counts-delta*)
(set! *cl-total-new-pairs* 0)
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(set! *cl-bench-mi-total-ms* (+ *cl-bench-mi-total-ms* elapsed-ms))
(set! *cl-bench-mi-calls* (+ *cl-bench-mi-calls* 1))
(set! *cl-bench-mi-pairs* (+ *cl-bench-mi-pairs* n-dirty))
(format #t " done in ~,1f ms, baseline=~,3f]~%"
elapsed-ms *cl-baseline-mi*))))
(define (cl-l0-gpu-mi-batch!)
"Batch GPU MI computation for dirty pairs."
(let ((edges-to-process '())
(count-key (Predicate "*-TruthValueKey-*")))
;; Collect all dirty edges with their data
(hash-for-each
(lambda (edge _)
(catch #t
(lambda ()
(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 (cog-value-ref v 2) 0.0))
(left-m (hash-ref *left-marginals* w1 1))
(right-m (hash-ref *right-marginals* w2 1)))
(set! edges-to-process
(cons (list edge w1 w2 cnt left-m right-m)
edges-to-process))))
(lambda (key . args) #f)))
*cl-dirty-pairs*)
(when (> (length edges-to-process) 0)
(let* ((counts (map (lambda (e) (list-ref e 3)) edges-to-process))
(lefts (map (lambda (e) (list-ref e 4)) edges-to-process))
(rights (map (lambda (e) (list-ref e 5)) edges-to-process))
(mi-values (gpu-compute-mi! counts lefts rights *total-pair-count*))
(mi-key (Predicate "*-Mutual Info Key-*")))
;; Update MI values + track additions for incremental neighbor index
(for-each
(lambda (entry mi)
(let ((edge (list-ref entry 0))
(w1 (list-ref entry 1))
(w2 (list-ref entry 2)))
(cog-set-value! edge mi-key (FloatValue 0.0 mi 0.0))
(hash-set! *mi-cache* (cons w1 w2) mi)
(hash-set! *mi-cache* (cons w2 w1) mi)
;; Track for incremental neighbor index update
(when (> mi 1.0)
(set! *cl-mi-additions* (cons (cons w1 w2) *cl-mi-additions*)))))
edges-to-process mi-values)
(format #t " GPU batch ~a pairs..." (length edges-to-process))))))
(define (cl-l1-recompute-mi!)
"Recompute MI for Level 1 (section pairs).
Same PMI formula as L0. Uses GPU when batch is large enough."
(let ((t0 (get-internal-real-time))
(total-count 0)
(left-marg (make-hash-table))
(right-marg (make-hash-table)))
(format #t " [L1 MI recompute: ~a dirty pairs..." *cl-l1-dirty-count*)
;; Compute marginals for section pairs (same formula as L0)
(hash-for-each
(lambda (key count)
(let ((s1 (car key)) (s2 (cdr key)))
(hash-set! left-marg s1 (+ (hash-ref left-marg s1 0) count))
(hash-set! right-marg s2 (+ (hash-ref right-marg s2 0) count))
(set! total-count (+ total-count count))))
*cl-l1-pair-counts*)
;; Collect all pairs for batch processing
(let ((all-keys '())
(all-counts '())
(all-lefts '())
(all-rights '()))
(hash-for-each
(lambda (key count)
(let ((s1 (car key)) (s2 (cdr key)))
(set! all-keys (cons key all-keys))
(set! all-counts (cons (exact->inexact count) all-counts))
(set! all-lefts (cons (exact->inexact (hash-ref left-marg s1 1)) all-lefts))
(set! all-rights (cons (exact->inexact (hash-ref right-marg s2 1)) all-rights))))
*cl-l1-pair-counts*)
(let ((n-pairs (length all-keys)))
(if *gpu-ready*
;; GPU batch — same kernel as L0, different data
(let ((mi-values (gpu-compute-mi! all-counts all-lefts all-rights total-count)))
(format #t " GPU batch ~a pairs..." n-pairs)
(for-each
(lambda (key mi)
(hash-set! *cl-l1-mi-cache* key mi))
all-keys mi-values)
;; Update L1 baseline
(let ((mi-sum (apply + mi-values)))
(when (> n-pairs 0)
(set! *cl-l1-baseline-mi* (/ mi-sum n-pairs)))))
;; CPU fallback — same PMI formula
(let ((mi-sum 0.0) (mi-count 0)
(n (exact->inexact total-count)))
(for-each
(lambda (key count left right)
(let* ((p-pair (/ count n))
(p-left (/ left n))
(p-right (/ right n))
(mi (if (and (> p-pair 0) (> p-left 0) (> p-right 0))
(/ (log (/ p-pair (* p-left p-right))) (log 2))
0.0)))
(hash-set! *cl-l1-mi-cache* key mi)
(set! mi-sum (+ mi-sum mi))
(set! mi-count (+ mi-count 1))))
all-keys all-counts all-lefts all-rights)
(when (> mi-count 0)
(set! *cl-l1-baseline-mi* (/ mi-sum mi-count)))))))
;; Clear dirty
(hash-clear! *cl-l1-dirty-pairs*)
(set! *cl-l1-dirty-count* 0)
(set! *cl-l1-total-new-pairs* 0)
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t " done in ~,1f ms, L1 baseline=~,3f]~%"
elapsed-ms *cl-l1-baseline-mi*))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 10: ADAPTIVE CLUSTERING
;; ═══════════════════════════════════════════════════════════════════
(define (cl-profiles-drifted? level)
"Check if word profiles have drifted enough to warrant reclustering."
(case level
((0)
(let ((n-classes (hash-count (const #t) *word-classes*))
(n-mi (hash-count (const #t) *mi-cache*)))
(cond
;; Bootstrap: first clustering when we have MI data (only once, then use interval)
((and (> n-mi 100) (zero? n-classes) (zero? *cl-cluster-iteration*)) #t)
;; Cluster after N sentences
((> (- *cl-total-sentences* *cl-sentences-since-cluster*)
*cl-cluster-interval*)
(set! *cl-sentences-since-cluster* *cl-total-sentences*)
#t)
(else #f))))
((1)
;; Level 1: re-cluster sections periodically
;; Use 5× the L0 interval since L1 clustering iterates all section-counts
(let ((n-section-mi (hash-count (const #t) *cl-l1-mi-cache*)))
(and (> n-section-mi 100)
(> (- *cl-total-sentences* *cl-sentences-since-cluster*)
(* 5 *cl-cluster-interval*))
(begin
(set! *cl-sentences-since-cluster* *cl-total-sentences*)
#t))))
(else #f)))
(define (cl-cluster-at-level! level)
"Run clustering at the given level."
(case level
((0) (cl-l0-cluster!))
((1) (cl-l1-cluster!))
(else (format #t " [No clustering for level ~a]~%" level))))
(define *cl-sim-index* (make-hash-table)) ; word -> hash of dimension -> value (pair-MI, cold start only)
(define *cl-mi-cutoff* 0.0) ; auto-computed MI threshold for vector dims
;; Connector-cosine clustering (replaces Phase A/B/C)
(define *cl-connector-index* (make-hash-table)) ; word → hash(connector → count)
(define *cl-connector-reverse-index* (make-hash-table)) ; connector → list of words
(define *cl-merges-per-round* 10) ; max new merges per clustering round (rank-based)
(define *cl-class-merge-floor* 2.0) ; disabled — class merges cause catastrophic convergence
(define *cl-add-to-class-floor* 0.70) ; minimum similarity to add word to existing class
(define *cl-cold-start-threshold* 10) ; switch from pair-MI at this many classes
(define *cl-max-class-size* 8) ; max members per class (prevents mega-classes)
;; ─── GPU-native AtomSpace init/flush ───
(define (cl-gpu-init!)
"Initialize the GPU-native AtomSpace bridge (libgpu-atomspace.so).
Loads gpu-atomspace.scm and calls gpu-init!."
(unless *gpu-native-ready*
(format #t " [Loading GPU-native AtomSpace bridge...]~%")
(catch #t
(lambda ()
(load (string-append *mvp-dir* "/gpu-atomspace.scm"))
((eval 'gpu-init! (current-module)))
(set! *gpu-native-ready* #t)
(format #t " [GPU-native AtomSpace ready]~%"))
(lambda (key . args)
(format #t " [GPU-native init failed: ~a ~a — falling back to CPU]~%" key args)
(set! *gpu-native-ready* #f)))))
(define (cl-gpu-flush!)
"Flush buffered sentences to GPU for counting + section extraction."
(when (and *gpu-native-ready* (> *cl-gpu-buffer-size* 0))
(let* ((buf (reverse *cl-gpu-sentence-buffer*))
(sentences (map car buf))
(all-edges (map cdr buf)))
(catch #t
(lambda ()
;; Count pairs on GPU
((eval 'gpu-process-sentences! (current-module)) sentences)
;; Extract sections from MST edges
;; Convert edges from (p1 p2 mi) format to (p1 . p2)
(let ((edge-pairs (map (lambda (edges)
(map (lambda (e) (cons (car e) (cadr e))) edges))
all-edges)))
((eval 'gpu-extract-sections! (current-module)) sentences edge-pairs)))
(lambda (key . args)
(format #t " [GPU flush error: ~a ~a]~%" key args))))
(set! *cl-gpu-sentence-buffer* '())
(set! *cl-gpu-buffer-size* 0)))
(define (cl-gpu-buffer-sentence! words edges)
"Buffer a sentence + its MST edges for GPU processing."
(when *gpu-native-ready*
(set! *cl-gpu-sentence-buffer*
(cons (cons words edges) *cl-gpu-sentence-buffer*))
(set! *cl-gpu-buffer-size* (+ *cl-gpu-buffer-size* 1))
(when (>= *cl-gpu-buffer-size* *cl-gpu-flush-threshold*)
(cl-gpu-flush!))))
(define (cl-build-neighbor-index! word-list)
"Build pair-MI similarity vectors (cold start only, < 10 classes).
MI cutoff: baseline/3."
(let ((t0 (get-internal-real-time))
(n-dims 0))
(hash-clear! *cl-sim-index*)
(set! *cl-mi-cutoff* (max 0.5 (/ *cl-baseline-mi* 3.0)))
(for-each (lambda (w) (hash-set! *cl-sim-index* w (make-hash-table))) word-list)
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (> mi *cl-mi-cutoff*))
(let ((w1 (car key)) (w2 (cdr key)))
(let ((idx1 (hash-ref *cl-sim-index* w1 #f))
(idx2 (hash-ref *cl-sim-index* w2 #f)))
(when idx1
(hash-set! idx1 w2 mi)
(set! n-dims (+ n-dims 1)))
(when idx2
(hash-set! idx2 w1 mi)
(set! n-dims (+ n-dims 1)))))))
*mi-cache*)
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t "(pair-MI index ~a words, ~a dims, MI>~,1f in ~,1fs) "
(length word-list) n-dims *cl-mi-cutoff*
(/ elapsed-ms 1000.0)))))
(define (cl-fast-similarity w1 w2)
"Cosine similarity on vector index (pair-MI or jigsaw, depending on phase).
cosine(w1,w2) = Σ(a*b) / (||v1|| * ||v2||)"
(let ((v1 (hash-ref *cl-sim-index* w1 #f))
(v2 (hash-ref *cl-sim-index* w2 #f)))
(if (or (not v1) (not v2))
0.0
(let ((dot 0.0)
(norm1-sq 0.0)
(norm2-sq 0.0))
;; Iterate v1's disjuncts: accumulate dot product + norm1²
(hash-for-each
(lambda (disj c1)
(set! norm1-sq (+ norm1-sq (* c1 c1)))
(let ((c2 (hash-ref v2 disj #f)))
(when c2
(set! dot (+ dot (* c1 c2))))))
v1)
;; Iterate v2's disjuncts: accumulate norm2²
(hash-for-each
(lambda (disj c2)
(set! norm2-sq (+ norm2-sq (* c2 c2))))
v2)
(let ((denom (* (sqrt norm1-sq) (sqrt norm2-sq))))
(if (< denom 1e-10) 0.0 (/ dot denom)))))))
;; ─── Connector-cosine functions ───
(define (cl-rewrite-connector connector)
"Rewrite a single connector with class IDs. e.g. 'the-' → 'C7-' if 'the' is in class 7."
(if (< (string-length connector) 2)
connector
(let* ((word (substring connector 0 (- (string-length connector) 1)))
(dir (substring connector (- (string-length connector) 1)))
(class-id (hash-ref *word-to-class* word #f)))
(if class-id
(string-append "C" (number->string class-id) dir)
connector))))
(define (cl-build-connector-index! word-list)
"Build CONNECTOR vectors for all words. Each word gets a hash of connector → count.
Individual connectors ('the-', 'sat+') are dimensions, NOT full disjuncts.
This gives ~50-100 dims per word (vs thousands for full disjuncts),
making cosine meaningful at scale.
Also builds reverse index: connector → list of words (for candidate pre-filter).
Uses RAW connectors (no class rewriting) — class rewriting causes all function
words to converge to the same class-ID connectors, destroying discrimination."
(let ((t0 (get-internal-real-time))
(n-dims 0))
(hash-clear! *cl-connector-index*)
(hash-clear! *cl-connector-reverse-index*)
(for-each
(lambda (w)
(let ((disjs (hash-ref *sections* w '()))
(vec (make-hash-table)))
(for-each
(lambda (d)
(let ((count (hash-ref *section-counts* (cons w d) 0)))
(when (> count 0)
;; Split disjunct into individual connectors
(let ((connectors (filter (lambda (c) (> (string-length c) 0))
(string-split d #\space))))
(for-each
(lambda (conn)
;; Use RAW connectors — no class rewriting.
;; Class rewriting causes connector profiles to converge
;; for all function words (they share class-ID connectors),
;; leading to catastrophic merges (he+the+of → one class).
(hash-set! vec conn
(+ (hash-ref vec conn 0) count))
(set! n-dims (+ n-dims 1)))
connectors)))))
disjs)
;; Only add if word has any connectors
(when (> (hash-count (const #t) vec) 0)
(hash-set! *cl-connector-index* w vec)
;; Build reverse index: connector → list of words sharing it
(hash-for-each
(lambda (conn _)
(hash-set! *cl-connector-reverse-index* conn
(cons w (hash-ref *cl-connector-reverse-index* conn '()))))
vec))))
word-list)
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(format #t "(connector index ~a words, ~a dims in ~,1fs) "
(hash-count (const #t) *cl-connector-index*) n-dims
(/ elapsed-ms 1000.0)))))
(define (cl-connector-cosine w1 w2)
"Cosine similarity on individual connector vectors."
(let ((v1 (hash-ref *cl-connector-index* w1 #f))
(v2 (hash-ref *cl-connector-index* w2 #f)))
(if (or (not v1) (not v2))
0.0
(let ((dot 0.0) (norm1-sq 0.0) (norm2-sq 0.0))
(hash-for-each
(lambda (conn c1)
(set! norm1-sq (+ norm1-sq (* c1 c1)))
(let ((c2 (hash-ref v2 conn #f)))
(when c2 (set! dot (+ dot (* c1 c2))))))
v1)
(hash-for-each
(lambda (conn c2)
(set! norm2-sq (+ norm2-sq (* c2 c2))))
v2)
(let ((denom (* (sqrt norm1-sq) (sqrt norm2-sq))))
(if (< denom 1e-10) 0.0 (/ dot denom)))))))
;; ─── In-group expansion + knee detection (emergent clustering) ───
(define (cl-find-in-group w1 w2 candidates epsilon tightness lower-bound max-size)
"Expand seed pair (w1,w2) into a natural group by adding candidates
that are cosine-similar to all existing members within epsilon of benchmark."
(let ((benchmark (cl-connector-cosine w1 w2))
(ingroup (list w1 w2)))
(let ((minscore (- benchmark epsilon)))
(let loop ((cands candidates))
(cond
((null? cands) ingroup)
((>= (length ingroup) max-size) ingroup)
(else
(let ((candidate (car cands)))
(if (or (equal? candidate w1) (equal? candidate w2)
(member candidate ingroup))
(loop (cdr cands))
(let* ((insz (length ingroup))
(tight (if (= insz 2) 2
(inexact->exact (round (* tightness insz)))))
(maxfail (- insz tight))
(failcnt 0)
(rejected #f))
;; Test candidate against all current group members
(let member-loop ((members ingroup))
(when (and (not (null? members)) (not rejected))
(let ((score (cl-connector-cosine candidate (car members))))
(cond
((< score lower-bound)
(set! rejected #t))
((< score minscore)
(set! failcnt (+ failcnt 1))
(when (> failcnt maxfail)
(set! rejected #t))))
(member-loop (cdr members)))))
(unless rejected
(set! ingroup (append ingroup (list candidate))))
(loop (cdr cands)))))))))))
(define (cl-optimal-in-group w1 w2 candidates)
"Find the natural group boundary using knee detection.
Sweep epsilon from tight to loose; when group size jumps sharply,
the previous group was the natural boundary."
(let ((step 0.02)
(max-epsi 0.5)
(max-jump 2.5)
(win-slots 5)
(best-group (list w1 w2)))
(let ((window (make-list win-slots 2)))
(let loop ((n 1))
(if (> (* n step) max-epsi)
best-group
(let* ((epsilon (* n step))
(group (cl-find-in-group w1 w2 candidates epsilon
*cl-in-group-tightness* *cl-in-group-lower-bound*
*cl-in-group-max-size*))
(size (length group))
(prev-size (car window))
(new-window (append (cdr window) (list size)))
(jump (- size prev-size)))
(set! window new-window)
(if (or (>= jump max-jump) (>= size *cl-in-group-max-size*))
best-group ; Knee found — group wants to explode
(begin
(set! best-group group)
(loop (+ n 1))))))))))
;; ─── Emergent metric functions ───
(define (cl-compute-marginal-entropy)
"Mean entropy across classified words in connector index.
H(w) = -Σ p(c|w) log₂ p(c|w) for each word w."
(let ((total-h 0.0) (n-words 0))
(hash-for-each
(lambda (word conn-hash)
(let ((total-count 0.0))
(hash-for-each (lambda (c v) (set! total-count (+ total-count v))) conn-hash)
(when (> total-count 0)
(let ((h 0.0))
(hash-for-each
(lambda (c v)
(let ((p (/ v total-count)))
(when (> p 0) (set! h (- h (* p (/ (log p) (log 2))))))))
conn-hash)
(set! total-h (+ total-h h))
(set! n-words (+ n-words 1))))))
*cl-connector-index*)
(if (> n-words 0) (/ total-h n-words) 0.0)))
(define (cl-structure-exhausted?)
"Emergent promotion signal: top-pair cosine below noise floor,
entropy plateau, or consecutive zero-change rounds."
(or
;; Signal 1: top-pair cosine dropped below noise floor
(< *cl-top-pair-score* *cl-noise-floor*)
;; Signal 2: entropy plateaued (all values within 1% of mean)
(and (>= (length *cl-entropy-history*) *cl-entropy-window*)
(let* ((recent (take *cl-entropy-history* *cl-entropy-window*))
(mean (/ (apply + recent) (length recent)))
(max-delta (apply max (map (lambda (h) (abs (- h mean))) recent))))
(< (/ max-delta (max mean 0.001)) 0.01)))
;; Signal 3: consecutive zero-change rounds (all words already classified)
(>= *cl-merge-rounds-zero* 3)))
(define (add-word-to-class! word class-id)
"Add a word to an existing word 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)
;; AtomSpace + RocksDB
(let ((class-node (WordClass (format #f "C~a" class-id))))
(MemberLink (Word word) class-node)
(when *rsn* (store-atom (MemberLink (Word word) class-node)))))))
(define (merge-classes! c1 c2)
"Merge class C2 into C1. All members of C2 become members of C1."
(let ((m2 (hash-ref *word-classes* c2 '())))
(for-each (lambda (w) (add-word-to-class! w c1)) m2)
(hash-remove! *word-classes* c2)))
(define (cl-l0-cluster!)
"Level 0 clustering: agglomerative merge using connector cosine.
Cold start (< 10 classes): pair-MI for initial pair discovery.
Warm: connector-based cosine with reverse-index pre-filter."
(let* ((t0 (get-internal-real-time))
(words (get-high-frequency-words 50)) ; min-count 50
(top-words (take words (min 1000 (length words))))
(n-classes (hash-count (const #t) *word-classes*)))
(format #t " [L0 clustering: ~a words, ~a classes..." (length top-words) n-classes)
(let ((merges 0)
(additions 0)
(class-merges 0))
(if (< n-classes *cl-cold-start-threshold*)
;; ── COLD START: pair-MI for initial pair discovery ──
;; Use top-100 words to keep O(n²) manageable (~4,950 pairs)
;; Adaptive threshold (mean + 2σ) since pair-MI cosine scores differ from connector cosine
(begin
(cl-build-neighbor-index! top-words)
(let* ((unclassified (filter (lambda (w)
(not (hash-ref *word-to-class* w #f)))
top-words))
(unc-top (take unclassified (min 100 (length unclassified))))
(n (length unc-top))
(candidates '()))
;; Brute-force pairs among top unclassified
(do ((i 0 (+ i 1))) ((>= i (- n 1)))
(do ((j (+ i 1) (+ j 1))) ((>= j n))
(set! candidates (cons (cons (list-ref unc-top i)
(list-ref unc-top j))
candidates))))
;; Score + sort
(let* ((scored (map (lambda (pair)
(cons (cl-fast-similarity (car pair) (cdr pair)) pair))
candidates))
(sorted (sort scored (lambda (a b) (> (car a) (car b)))))
;; Adaptive threshold: mean + 2σ of non-zero scores
(nonzero (filter (lambda (s) (> (car s) 0.001)) scored))
(n-nz (length nonzero))
(cold-thresh
(if (< n-nz 10)
*min-similarity*
(let* ((sum (fold + 0.0 (map car nonzero)))
(mean (/ sum n-nz))
(var (/ (fold + 0.0
(map (lambda (s)
(let ((d (- (car s) mean)))
(* d d)))
nonzero))
n-nz))
(std (sqrt var))
(computed (+ mean (* 2.0 std))))
(max 0.15 (min 0.8 computed))))))
(format #t " cold-start ~a candidates, thresh=~,3f..." (length candidates) cold-thresh)
(for-each
(lambda (entry)
(when (< merges 200)
(let ((sim (car entry))
(w1 (cadr entry))
(w2 (cddr entry)))
(when (and (> sim cold-thresh)
(not (hash-ref *word-to-class* w1 #f))
(not (hash-ref *word-to-class* w2 #f)))
(create-word-class! (list w1 w2))
(set! merges (+ merges 1))
(set! *cl-merge-history*
(cons (list *cl-current-level* w1 w2
(- *next-class-id* 1)
*cl-cluster-iteration* sim)
*cl-merge-history*))
(cl-emit! "merge" `(("w1" . ,w1) ("w2" . ,w2)
("sim" . ,sim)
("c" . ,(- *next-class-id* 1))
("iter" . ,*cl-cluster-iteration*)))))))
sorted))))
;; ── WARM: emergent in-group connector-cosine clustering ──
;; Uses in-group expansion + knee detection to find natural groups.
;; When top-pair cosine drops below noise floor, no merges happen.
;; GPU path: brute-force pairwise cosine on dense matrix (<1s).
;; CPU path: reverse-index pre-filter + cosine scoring (21-25s).
(begin
(let ((candidates '()))
;; Always build connector index (needed for in-group cosine lookups)
(cl-build-connector-index! top-words)
;; Generate candidates: GPU brute-force or CPU reverse-index
(if *gpu-native-ready*
;; GPU path: brute-force all pairs
(begin
(catch #t
(lambda ()
(set! candidates
((eval 'gpu-connector-cosine-candidates! (current-module))
top-words #:threshold 0.001 #:max-output 50000)))
(lambda (key . args)
(format #t " GPU connector-cosine failed: ~a, falling back to CPU..." key)
(set! candidates '())))) ; fall through to CPU below
;; CPU path: reverse-index pre-filter
(let ((scored-set (make-hash-table)))
(hash-for-each
(lambda (conn word-list)
(let ((wl (delete-duplicates word-list)))
(when (and (> (length wl) 1) (< (length wl) 200))
(do ((ws wl (cdr ws))) ((null? ws))
(do ((ws2 (cdr ws) (cdr ws2))) ((null? ws2))
(let* ((w1 (car ws))
(w2 (car ws2))
(key (if (string<? w1 w2)
(cons w1 w2)
(cons w2 w1))))
(unless (hash-ref scored-set key #f)
(hash-set! scored-set key #t)
(let ((sim (cl-connector-cosine w1 w2)))
(when (> sim 0.001)
(set! candidates
(cons (list sim w1 w2) candidates)))))))))))
*cl-connector-reverse-index*)))
(let ((t-idx (get-internal-real-time)))
(format #t " ~a candidates in ~,1fs..."
(length candidates)
(/ (- t-idx t0) 1000000000.0))
;; Sort by score descending
(let ((sorted (sort candidates (lambda (a b) (> (car a) (car b))))))
;; Record top-pair score for emergent metrics
(set! *cl-top-pair-score*
(if (> (length sorted) 0) (car (car sorted)) 0.0))
;; Show top scores for debugging
(when (> (length sorted) 0)
(format #t "top: ~{~,3f~^ ~}..."
(map car (take sorted (min 5 (length sorted))))))
(if (< *cl-top-pair-score* *cl-noise-floor*)
;; No structure remaining — skip all merging
(format #t " no structure (top ~,3f < floor ~,3f)..."
*cl-top-pair-score* *cl-noise-floor*)
;; Process up to *cl-max-groups-per-round* seed groups
(let ((processed (make-hash-table))
(groups-done 0)
(candidate-words
;; Extract unique words from sorted candidates
(let ((ws (make-hash-table)))
(for-each (lambda (e)
(hash-set! ws (cadr e) #t)
(hash-set! ws (caddr e) #t))
sorted)
(hash-map->list (lambda (k v) k) ws))))
(for-each
(lambda (entry)
(when (< groups-done *cl-max-groups-per-round*)
(let ((sim (car entry))
(w1 (cadr entry))
(w2 (caddr entry)))
;; Skip if either word already processed in this round
(unless (or (hash-ref processed w1 #f)
(hash-ref processed w2 #f))
;; Find natural group via knee detection
(let ((group (cl-optimal-in-group w1 w2 candidate-words)))
(format #t "~% group(~a): ~{~a~^ ~}"
(length group) group)
;; Mark all group members as processed
(for-each (lambda (w) (hash-set! processed w #t)) group)
(set! groups-done (+ groups-done 1))
;; Apply CASE 1/2/3/4 logic for all pairs within the group
(let group-loop ((remaining group))
(when (>= (length remaining) 2)
(let* ((wa (car remaining))
(wb (cadr remaining))
(gsim (cl-connector-cosine wa wb))
(c1 (hash-ref *word-to-class* wa #f))
(c2 (hash-ref *word-to-class* wb #f)))
(cond
;; CASE 1: both unclassified → create new class
((and (not c1) (not c2))
(create-word-class! (list wa wb))
(set! merges (+ merges 1))
(set! *cl-merge-history*
(cons (list *cl-current-level* wa wb
(- *next-class-id* 1)
*cl-cluster-iteration* gsim)
*cl-merge-history*))
(cl-emit! "merge" `(("w1" . ,wa) ("w2" . ,wb)
("sim" . ,gsim)
("c" . ,(- *next-class-id* 1))
("iter" . ,*cl-cluster-iteration*)))
;; Add remaining group members to this new class
(let ((new-cid (- *next-class-id* 1)))
(for-each
(lambda (wc)
(unless (or (equal? wc wa) (equal? wc wb)
(hash-ref *word-to-class* wc #f))
(let ((csim (cl-connector-cosine wc wa)))
(when (> csim *cl-add-to-class-floor*)
(add-word-to-class! wc new-cid)
(set! additions (+ additions 1))
(set! *cl-merge-history*
(cons (list *cl-current-level* wc
(format #f "+C~a" new-cid)
new-cid *cl-cluster-iteration* csim)
*cl-merge-history*))
(cl-emit! "merge" `(("w1" . ,wc) ("w2" . ,(format #f "C~a" new-cid))
("sim" . ,csim)
("c" . ,new-cid)
("iter" . ,*cl-cluster-iteration*)))))))
(cddr remaining))))
;; CASE 2: one classified, one not → add to class
((and (not c1) c2
(> gsim *cl-add-to-class-floor*)
(< (length (hash-ref *word-classes* c2 '()))
*cl-max-class-size*))
(add-word-to-class! wa c2)
(set! additions (+ additions 1))
(set! *cl-merge-history*
(cons (list *cl-current-level* wa
(format #f "+C~a" c2)
c2 *cl-cluster-iteration* gsim)
*cl-merge-history*))
(cl-emit! "merge" `(("w1" . ,wa) ("w2" . ,(format #f "C~a" c2))
("sim" . ,gsim)
("c" . ,c2)
("iter" . ,*cl-cluster-iteration*)))
;; Continue with remaining group members
(group-loop (cdr remaining)))
((and c1 (not c2)
(> gsim *cl-add-to-class-floor*)
(< (length (hash-ref *word-classes* c1 '()))
*cl-max-class-size*))
(add-word-to-class! wb c1)
(set! additions (+ additions 1))
(set! *cl-merge-history*
(cons (list *cl-current-level* wb
(format #f "+C~a" c1)
c1 *cl-cluster-iteration* gsim)
*cl-merge-history*))
(cl-emit! "merge" `(("w1" . ,wb) ("w2" . ,(format #f "C~a" c1))
("sim" . ,gsim)
("c" . ,c1)
("iter" . ,*cl-cluster-iteration*)))
(group-loop (cdr remaining)))
;; CASE 3: both classified in different classes
((and c1 c2 (not (= c1 c2)))
(let* ((m1 (hash-ref *word-classes* c1 '()))
(m2 (hash-ref *word-classes* c2 '()))
(combined-size (+ (length m1) (length m2))))
(when (and m1 m2
(> gsim *cl-class-merge-floor*)
(<= combined-size *cl-max-class-size*))
(format #t "~% merge C~a(~{~a~^/~}) + C~a(~{~a~^/~}) sim=~,3f"
c1 m1 c2 m2 gsim)
(merge-classes! c1 c2)
(set! class-merges (+ class-merges 1))
(set! *cl-merge-history*
(cons (list *cl-current-level*
(format #f "C~a" c1) (format #f "C~a" c2)
c1 *cl-cluster-iteration* gsim)
*cl-merge-history*))))
(group-loop (cdr remaining)))
;; CASE 4: both in same class → skip
(else (group-loop (cdr remaining))))))))))))
sorted))))
;; Compute entropy and append to history
(let ((entropy (cl-compute-marginal-entropy)))
(set! *cl-entropy-history*
(cons entropy *cl-entropy-history*))
(when (> (length *cl-entropy-history*) (* 2 *cl-entropy-window*))
(set! *cl-entropy-history*
(take *cl-entropy-history* (* 2 *cl-entropy-window*))))
(format #t " H=~,3f..." entropy))))))
;; Track merge rate for stability
(set! *cl-cluster-iteration* (+ *cl-cluster-iteration* 1))
(let ((total-changes (+ merges additions class-merges)))
(if (zero? total-changes)
(set! *cl-merge-rounds-zero* (+ *cl-merge-rounds-zero* 1))
(set! *cl-merge-rounds-zero* 0))
;; Stream cluster summary
(cl-emit! "cluster" `(("merges" . ,total-changes)
("classes" . ,(hash-count (const #t) *word-classes*))
("iter" . ,*cl-cluster-iteration*)))
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(set! *cl-bench-cluster-total-ms* (+ *cl-bench-cluster-total-ms* elapsed-ms))
(set! *cl-bench-cluster-calls* (+ *cl-bench-cluster-calls* 1))
(format #t " ~a new, ~a joined, ~a merged, ~a classes in ~,1f ms]~%"
merges additions class-merges
(hash-count (const #t) *word-classes*)
elapsed-ms)
;; Push class assignments to GPU for substitution
(when (and *gpu-native-ready* (> (+ merges additions class-merges) 0))
(catch #t
(lambda ()
(let ((assignments '()))
(hash-for-each
(lambda (word class-id)
(set! assignments (cons (cons word class-id) assignments)))
*word-to-class*)
((eval 'gpu-assign-classes! (current-module)) assignments)
((eval 'gpu-substitute! (current-module)))))
(lambda (key . args)
(format #t " [GPU class sync failed: ~a]~%" key))))
;; Evict cold data to reduce GC pressure, then export viz
(cl-evict-cold-data!)
(corpus-export)
;; Grammar phase: build class-MI cache and export dictionary
(when (> (+ merges additions class-merges) 0)
(cl-build-class-mi-cache!)
(cl-export-grammar!)))))))
;; ── Memory eviction ──
;; Evicts low-value entries from *section-counts* and *mi-cache*
;; to reduce GC live set. Called after each clustering round.
(define *cl-section-min-count* 3) ; Evict sections with count < this
(define *cl-mi-evict-ratio* 3) ; Evict MI < baseline / this
(define (cl-evict-cold-data!)
"Evict low-MI pairs to reduce GC pressure. Keeps sections (needed for connector index)."
(let ((t0 (get-internal-real-time))
(mi-before (hash-count (const #t) *mi-cache*))
(mi-cutoff (/ *cl-baseline-mi* *cl-mi-evict-ratio*))
(mi-evicted 0)
(mi-to-remove '()))
;; Collect MI entries to evict (MI < cutoff)
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (< mi mi-cutoff))
(set! mi-to-remove (cons key mi-to-remove))))
*mi-cache*)
;; Remove them
(for-each
(lambda (key)
(hash-remove! *mi-cache* key)
(set! mi-evicted (+ mi-evicted 1)))
mi-to-remove)
;; Force GC to reclaim the freed memory
(gc)
(let ((elapsed-ms (/ (- (get-internal-real-time) t0) 1000000.0)))
(set! *cl-bench-evict-total-ms* (+ *cl-bench-evict-total-ms* elapsed-ms))
(set! *cl-bench-evict-calls* (+ *cl-bench-evict-calls* 1))
(format #t " [Eviction: MI ~a→~a (-~a, cutoff=~,2f), sections=~a in ~,0f ms]~%"
mi-before (- mi-before mi-evicted) mi-evicted
mi-cutoff
(hash-count (const #t) *section-counts*)
elapsed-ms))))
(define (cl-l1-cluster!)
"Level 1 clustering: find word senses by clustering sections."
(format #t " [L1 clustering: finding word senses...]~%")
;; Group sections by word
(let ((word-sections (make-hash-table)))
(hash-for-each
(lambda (key count)
(when (> count 2) ; Minimum count
(let ((word (car key))
(disj (cdr key)))
(hash-set! word-sections word
(cons (cons disj count)
(hash-ref word-sections word '()))))))
*section-counts*)
;; For each word with multiple sections, check if they cluster into senses
(hash-for-each
(lambda (word section-list)
(when (> (length section-list) 2)
;; Simple sense detection: group sections by shared connectors
(let ((senses (cl-detect-senses word section-list)))
(when (> (length senses) 1)
(hash-set! *cl-l1-word-senses* word senses)
(format #t " ~a: ~a senses~%" word (length senses))))))
word-sections)))
(define (cl-detect-senses word section-list)
"Detect word senses from section patterns. Returns list of sense groups."
;; Simple heuristic: group by shared connector words
(let ((groups '())
(assigned (make-hash-table)))
(for-each
(lambda (section)
(let ((disj (car section)))
(unless (hash-ref assigned disj #f)
;; Find which existing group this disjunct is most similar to
(let ((best-group #f)
(best-overlap 0))
(for-each
(lambda (group)
;; (caar group) is a section pair (disj . count) — extract disj string
(let ((overlap (cl-disjunct-overlap disj (car (caar group)))))
(when (> overlap best-overlap)
(set! best-overlap overlap)
(set! best-group group))))
groups)
;; Add to best group or create new one
(if (and best-group (> best-overlap 0))
(set-car! best-group (cons section (car best-group)))
(set! groups (cons (list (list section)) groups)))
(hash-set! assigned disj #t)))))
section-list)
(map car groups)))
(define (cl-disjunct-overlap d1 d2)
"Count shared connector words between two disjunct strings."
(let ((parts1 (string-split d1 #\space))
(parts2 (string-split d2 #\space))
(overlap 0))
(for-each
(lambda (p1)
(when (member p1 parts2)
(set! overlap (+ overlap 1))))
parts1)
overlap))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 11: LEVEL PROMOTION
;; ═══════════════════════════════════════════════════════════════════
(define (cl-level-stable? level)
"Check if the current level has stabilized using emergent metrics.
Structure exhaustion (top-pair below noise floor or entropy plateau)
replaces the hard-coded zero-merge-rounds check."
(and
;; Need minimum data
(> *cl-total-sentences* 2000)
;; Need clustering to have run at least a few times
(> *cl-cluster-iteration* 3)
;; Must have discovered structure (no empty promotions)
(> (hash-count (const #t) *word-classes*) 20)
;; Emergent signal: structure exhausted
(cl-structure-exhausted?)))
(define (cl-promote-level! level)
"Promote to the next learning level."
(format #t "~%═══ PROMOTING: Level ~a → Level ~a ═══~%"
level (+ level 1))
(format #t "Word classes at Level ~a: ~a~%"
level (hash-count (const #t) *word-classes*))
;; Show clusters
(hash-for-each
(lambda (id words)
(format #t " C~a: ~a~%" id (take words (min 5 (length words)))))
*word-classes*)
;; Advance level
(set! *cl-current-level* (+ *cl-current-level* 1))
;; Reset stability tracking
(set! *cl-merge-rounds-zero* 0)
(set! *cl-cluster-iteration* 0)
(format #t "Now learning at Level ~a~%═══════════════════════════════════════~%~%"
*cl-current-level*))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 12: SHELL COMMANDS
;; ═══════════════════════════════════════════════════════════════════
(define (corpus-reset)
"Reset learning state without losing MI cache or RocksDB data.
Use this to restart the learning loop from scratch."
(set! *cl-running* #f)
(set! *cl-current-level* 0)
(set! *cl-total-sentences* 0)
(set! *cl-total-learns* 0)
(set! *cl-sentences-since-mi* 0)
(set! *cl-sentences-since-cluster* 0)
(set! *cl-recent-surprises* '())
(set! *cl-surprise-threshold* 2.0)
(hash-clear! *cl-dirty-pairs*)
(set! *cl-dirty-count* 0)
(hash-clear! *cl-pair-counts-delta*)
(set! *cl-total-new-pairs* 0)
(hash-clear! *cl-l1-pair-counts*)
(hash-clear! *cl-l1-mi-cache*)
(hash-clear! *cl-l1-dirty-pairs*)
(set! *cl-l1-dirty-count* 0)
(set! *cl-l1-total-new-pairs* 0)
(set! *cl-l1-baseline-mi* 0.0)
(hash-clear! *cl-l1-word-senses*)
(hash-clear! *cl-l1-sense-map*)
(set! *cl-merge-history* '())
(hash-clear! *cl-word-surprise*)
(set! *cl-cluster-iteration* 0)
(set! *cl-merge-rounds-zero* 0)
(set! *cl-top-pair-score* 1.0)
(set! *cl-entropy-history* '())
(set! *cl-last-calibration* 0)
(set! *cl-mi-additions* '())
(set! *cl-clustering-active* #f)
(hash-clear! *cl-sim-index*)
(hash-clear! *cl-connector-index*)
(hash-clear! *cl-connector-reverse-index*)
(set! *cl-gpu-sentence-buffer* '())
(set! *cl-gpu-buffer-size* 0)
(hash-clear! *cl-class-mi-cache*)
(set! *cl-grammar-available* #f)
(set! *cl-grammar-surprise-threshold* 3.0)
(hash-clear! *cl-crawl-seen*)
(set! *cl-crawl-total-files* 0)
(set! *cl-crawl-total-sentences* 0)
(format #t "Learning state reset. MI cache preserved (~a entries).~%"
(hash-count (const #t) *mi-cache*)))
(define (run-corpus n)
"Run first N sentences through the unified loop."
;; Auto-bootstrap if baseline MI not set
(when (zero? *cl-baseline-mi*)
(bootstrap))
(let ((sentences (take-corpus-sentences n)))
(format #t "Running ~a sentences through unified loop~%" (length sentences))
(cl-learn-loop sentences)))
(define (run-corpus-all)
"Run all ~56K corpus sentences through the unified loop."
(let ((sentences (cl-load-all-corpus!)))
(format #t "Running all ~a sentences~%" (length sentences))
(cl-learn-loop sentences)))
;; ═══════════════════════════════════════════════════════════════════
;; MULTI-EPOCH LEARNING
;; ═══════════════════════════════════════════════════════════════════
(define *cl-max-epochs* 20) ; Safety limit
(define *cl-epoch-stale-limit* 3) ; Stop after N epochs with no new merges
(define-once *cl-epoch* 0) ; Current epoch number
(define *cl-epoch-stop* #f) ; Stop signal for epoch loop
(define (run-epochs . args)
"Run the corpus repeatedly in epochs until promotion or convergence.
Optional arg: max epochs (default *cl-max-epochs*).
Each epoch: full corpus pass → force MI recompute → force cluster → export.
Stops when: level promotes, max epochs, or no merges for 3 consecutive epochs."
(let ((max-ep (if (null? args) *cl-max-epochs* (car args)))
(sentences (cl-load-all-corpus!)))
;; Auto-bootstrap if needed
(when (zero? *cl-baseline-mi*)
(bootstrap))
(format #t "~%══════════════════════════════════════════~%")
(format #t " MULTI-EPOCH LEARNING~%")
(format #t " Corpus: ~a sentences~%" (length sentences))
(format #t " Max epochs: ~a~%" max-ep)
(format #t " Current level: ~a~%" *cl-current-level*)
(format #t " Word classes: ~a~%" (hash-count (const #t) *word-classes*))
(format #t "══════════════════════════════════════════~%~%")
(set! *cl-running* #t)
(set! *cl-epoch-stop* #f)
(let epoch-loop ((ep 1)
(stale-count 0)
(prev-level *cl-current-level*)
(prev-classes (hash-count (const #t) *word-classes*))
(prev-merges (length *cl-merge-history*)))
(when (and (<= ep max-ep) (not *cl-epoch-stop*))
(set! *cl-epoch* ep)
(format #t "~%╔══ EPOCH ~a / ~a ══════════════════════════════╗~%" ep max-ep)
(format #t "║ Level: ~a | Classes: ~a | Merges so far: ~a~%"
*cl-current-level*
(hash-count (const #t) *word-classes*)
(length *cl-merge-history*))
(format #t "║ Avg surprise: ~,3f | Threshold: ~,3f~%"
(cl-average-surprise) *cl-surprise-threshold*)
(format #t "╚══════════════════════════════════════════════════╝~%~%")
;; Run full corpus pass (re-arm running flag — cl-learn-loop clears it on exit)
(set! *cl-running* #t)
(cl-learn-loop sentences)
;; Re-arm: cl-learn-loop clears *cl-running* on exit
(set! *cl-running* #t)
;; Between epochs: force a full MI recompute + cluster round
;; (the loop may not have triggered these if thresholds weren't met)
(format #t "~% [Epoch ~a post-processing...]~%" ep)
;; Force MI recompute if any dirty pairs remain
(when (> *cl-dirty-count* 0)
(format #t " Forcing MI recompute (~a dirty pairs)...~%" *cl-dirty-count*)
(cl-recompute-mi-at-level! *cl-current-level*))
;; Force clustering round (regardless of interval timer)
(format #t " Forcing cluster round...~%")
(set! *cl-clustering-active* #f)
(cl-cluster-at-level! *cl-current-level*)
;; Recalibrate surprise threshold for next epoch
(cl-recalibrate-threshold!)
(format #t " Recalibrated threshold: ~,3f~%" *cl-surprise-threshold*)
;; Export for visualization
(format #t " Exporting visualization data...~%")
(corpus-export)
;; Check outcomes
(let* ((new-level *cl-current-level*)
(new-classes (hash-count (const #t) *word-classes*))
(new-merges (length *cl-merge-history*))
(epoch-new-merges (- new-merges prev-merges))
(epoch-new-classes (- new-classes prev-classes))
(promoted (> new-level prev-level)))
(format #t "~% ── Epoch ~a results ──~%" ep)
(format #t " New merges this epoch: ~a~%" epoch-new-merges)
(format #t " New classes: ~a (total: ~a)~%" epoch-new-classes new-classes)
(format #t " Avg surprise: ~,3f~%" (cl-average-surprise))
(format #t " Stale epochs: ~a / ~a~%"
(if (zero? epoch-new-merges) (+ stale-count 1) 0)
*cl-epoch-stale-limit*)
(cond
;; Level promoted — success!
(promoted
(format #t "~%══ PROMOTED to Level ~a after ~a epochs! ══~%~%" new-level ep)
;; Continue learning at the new level
(epoch-loop (+ ep 1) 0 new-level new-classes new-merges))
;; No merges for too many consecutive epochs — converged
((and (zero? epoch-new-merges)
(>= (+ stale-count 1) *cl-epoch-stale-limit*))
(format #t "~%══ CONVERGED: No new merges for ~a epochs. ══~%"
*cl-epoch-stale-limit*)
(format #t " Final: ~a classes, ~a total merges~%"
new-classes new-merges)
(format #t " Avg surprise: ~,3f (threshold: ~,3f)~%~%"
(cl-average-surprise) *cl-surprise-threshold*))
;; Continue
(else
(let ((new-stale (if (zero? epoch-new-merges) (+ stale-count 1) 0)))
(epoch-loop (+ ep 1) new-stale new-level new-classes new-merges)))))))))
(define (stop-epochs)
"Stop the epoch loop after the current epoch completes."
(set! *cl-epoch-stop* #t)
(set! *cl-running* #f)
(format #t "Stopping after current epoch completes...~%"))
(define (corpus-status)
"Show current corpus learning status."
(format #t "~%═══ Corpus Learning Status ═══~%")
(format #t "Level: ~a~%" *cl-current-level*)
(format #t "Sentences: ~a (learned: ~a, ~,1f%)~%"
*cl-total-sentences*
*cl-total-learns*
(if (> *cl-total-sentences* 0)
(* 100.0 (/ *cl-total-learns* *cl-total-sentences*))
0.0))
(format #t "Avg surprise: ~,3f bits~%" (cl-average-surprise))
(format #t "Surprise threshold: ~,3f (p~a)~%"
*cl-surprise-threshold*
(inexact->exact (round (* 100 *cl-surprise-percentile*))))
(format #t "Baseline MI: ~,3f~%" *cl-baseline-mi*)
(format #t "~%Level 0:~%")
(format #t " MI cache: ~a entries~%"
(hash-count (const #t) *mi-cache*))
(format #t " Dirty pairs: ~a~%" *cl-dirty-count*)
(format #t " Word classes: ~a~%"
(hash-count (const #t) *word-classes*))
(format #t " Sections: ~a~%"
(hash-count (const #t) *section-counts*))
(format #t " Cluster iterations: ~a (top-pair: ~,3f, noise floor: ~,3f)~%"
*cl-cluster-iteration* *cl-top-pair-score* *cl-noise-floor*)
(format #t " Structure exhausted: ~a~%" (cl-structure-exhausted?))
(when (> *cl-current-level* 0)
(format #t "~%Level 1:~%")
(format #t " Section pairs: ~a~%"
(hash-count (const #t) *cl-l1-pair-counts*))
(format #t " Section MI cache: ~a~%"
(hash-count (const #t) *cl-l1-mi-cache*))
(format #t " Word senses: ~a~%"
(hash-count (const #t) *cl-l1-word-senses*)))
(format #t "~%Grammar phase:~%")
(format #t " Grammar available: ~a~%" *cl-grammar-available*)
(format #t " Class-MI cache: ~a entries~%"
(hash-count (const #t) *cl-class-mi-cache*))
(format #t " Grammar surprise threshold: ~,3f~%" *cl-grammar-surprise-threshold*)
(format #t " Files crawled: ~a (~a sentences)~%"
*cl-crawl-total-files* *cl-crawl-total-sentences*)
(format #t "~%Curriculum learning:~%")
(format #t " Sources: ~a | Source dirs: ~a~%" *cl-source-next-id* (length *cl-source-dirs*))
(format #t " Word index: ~a words~%" (hash-count (const #t) *cl-word-sentences*))
(format #t " Query triggers: ~a | Action log: ~a~%"
*cl-query-count* (length *cl-action-log*))
(format #t "~%Merge history: ~a merges~%" (length *cl-merge-history*))
(format #t "Running: ~a~%" *cl-running*)
(format #t "═══════════════════════════════~%~%"))
(define (corpus-stop)
"Gracefully stop the learning loop."
(set! *cl-running* #f)
(format #t "Corpus learning stopped.~%"))
(define (corpus-thresholds)
"Show current adaptive thresholds."
(format #t "~%═══ Adaptive Thresholds ═══~%")
(format #t "Surprise:~%")
(format #t " Current threshold: ~,3f bits~%" *cl-surprise-threshold*)
(format #t " Percentile: p~a~%"
(inexact->exact (round (* 100 *cl-surprise-percentile*))))
(format #t " Window size: ~a (have ~a)~%"
*cl-surprise-window* (length *cl-recent-surprises*))
(when (> (length *cl-recent-surprises*) 0)
(let ((sorted (sort (list-copy *cl-recent-surprises*) <)))
(format #t " Min: ~,3f Median: ~,3f Max: ~,3f~%"
(car sorted)
(list-ref sorted (quotient (length sorted) 2))
(last sorted))))
(format #t "~%MI recomputation:~%")
(format #t " Drift ratio: ~,3f (~,1f% of pairs must be new)~%"
*cl-mi-drift-ratio* (* 100 *cl-mi-drift-ratio*))
(format #t " GPU batch size: ~a~%" *cl-gpu-mi-batch-size*)
(format #t " Dirty pairs: ~a~%" *cl-dirty-count*)
(format #t "~%Clustering (emergent):~%")
(format #t " Sentences between clusters: ~a~%" *cl-sentences-since-cluster*)
(format #t " Top-pair cosine: ~,3f (noise floor: ~,3f)~%"
*cl-top-pair-score* *cl-noise-floor*)
(format #t " Marginal entropy: ~,3f~%"
(if (null? *cl-entropy-history*) 0.0 (car *cl-entropy-history*)))
(format #t " Entropy history: ~a values~%" (length *cl-entropy-history*))
(format #t " Structure exhausted: ~a~%" (cl-structure-exhausted?))
(format #t "═══════════════════════════════~%~%"))
(define (corpus-vagueness)
"Show vagueness per word/class."
(format #t "~%═══ Vagueness Report ═══~%")
;; Vagueness = 1 / (1 + evidence)
;; Evidence = number of distinct MI neighbors
(let ((word-vagueness '()))
(let ((words-seen (make-hash-table)))
(hash-for-each
(lambda (key mi)
(when (pair? key)
(hash-set! words-seen (car key)
(+ (hash-ref words-seen (car key) 0) 1))))
*mi-cache*)
(hash-for-each
(lambda (word neighbors)
(set! word-vagueness
(cons (cons word (/ 1.0 (+ 1 neighbors)))
word-vagueness)))
words-seen))
;; Sort by vagueness descending (most vague first)
(let ((sorted (sort word-vagueness
(lambda (a b) (> (cdr a) (cdr b))))))
(format #t "Most vague words (few connections):~%")
(for-each
(lambda (entry)
(format #t " ~a: ~,3f~%" (car entry) (cdr entry)))
(take sorted (min 20 (length sorted))))
(format #t "~%Least vague words (many connections):~%")
(for-each
(lambda (entry)
(format #t " ~a: ~,3f~%" (car entry) (cdr entry)))
(take (reverse sorted) (min 10 (length sorted))))))
(format #t "═══════════════════════════════~%~%"))
(define *cl-sentinel-words*
'("left-word" "right-word" "LEFT-WALL" "RIGHT-WALL" "###LEFT-WALL###" "###RIGHT-WALL###"))
(define (cl-sentinel? w)
"Check if word is a sentinel/marker that should be excluded."
(or (member w *cl-sentinel-words*)
(string-prefix? "###" w)
(string-prefix? "left-" w)
(string-prefix? "right-" w)))
(define (corpus-export)
"Export visualization data: top MI pairs + high-frequency words, histograms, communities."
;; Skip if compartment mode is active (compartment-export handles multi-atomspace viz)
(if (and (defined? '*comp-active*)
(module-variable (current-module) '*comp-active*)
(module-ref (current-module) '*comp-active*))
#t ; no-op when in compartment mode
(let ((filename (string-append *mvp-dir* "/viz/data.json"))
(max-pairs 5000) ;; Top pairs to export
(max-words 2000) ;; Max words to include
(export-t0 (get-internal-real-time)))
;; Recompute dirty L0 MI pairs so export reflects current state
(when (> *cl-dirty-count* 0)
(format #t "Recomputing ~a dirty L0 pairs before export...~%" *cl-dirty-count*)
(cl-recompute-mi-at-level! 0))
(format #t "Building export graph from ~a MI cache entries...~%"
(hash-count (const #t) *mi-cache*))
;; Step 0: Build MI histogram from ALL pairs (not just exported ones)
;; This is the key insight Linas wants - the full distribution reveals structure
(let ((mi-bins (make-hash-table)) ; bin-index -> count
(mi-bin-width 0.1)
(mi-total-count 0)
(mi-sum 0.0)
(mi-sum-sq 0.0)
(mi-min 999.0)
(mi-max -999.0)
(surprise-bins (make-hash-table)) ; bin-index -> count
(surprise-bin-width 0.2)
;; Track word degree and MI sum across ALL pairs for frequency ranking
(global-word-degree (make-hash-table))
(global-word-mi-sum (make-hash-table)) ; word -> sum of MI values
;; Per-word top MI pairs index (built during scan, used for freq word export)
(global-word-top-pairs (make-hash-table)))
;; Scan entire MI cache for histogram + global degree
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (number? mi))
(let ((w1 (car key)) (w2 (cdr key)))
(when (string<? w1 w2) ; count each pair once
(set! mi-total-count (+ mi-total-count 1))
(set! mi-sum (+ mi-sum mi))
(set! mi-sum-sq (+ mi-sum-sq (* mi mi)))
(when (< mi mi-min) (set! mi-min mi))
(when (> mi mi-max) (set! mi-max mi))
(let ((bin (inexact->exact (floor (/ mi mi-bin-width)))))
(hash-set! mi-bins bin (+ 1 (hash-ref mi-bins bin 0))))
;; Track global degree and build per-word top-MI index
;; (avoids O(V*E) nested scan later)
(when (and (not (cl-sentinel? w1)) (not (cl-sentinel? w2))
(> (string-length w1) 1) (> (string-length w2) 1))
(hash-set! global-word-degree w1
(+ 1 (hash-ref global-word-degree w1 0)))
(hash-set! global-word-degree w2
(+ 1 (hash-ref global-word-degree w2 0)))
(hash-set! global-word-mi-sum w1
(+ mi (hash-ref global-word-mi-sum w1 0.0)))
(hash-set! global-word-mi-sum w2
(+ mi (hash-ref global-word-mi-sum w2 0.0)))
;; Store top MI pairs per word (keep top 20 by MI)
(when (> mi 1.0)
(let ((entry (list w1 w2 mi)))
(for-each
(lambda (w)
(let* ((existing (hash-ref global-word-top-pairs w '()))
(updated (cons entry existing)))
;; Only trim when list gets large (amortized)
(if (> (length updated) 40)
(hash-set! global-word-top-pairs w
(list-head
(sort updated (lambda (a b) (> (caddr a) (caddr b))))
20))
(hash-set! global-word-top-pairs w updated))))
(list w1 w2)))))))))
*mi-cache*)
;; Build surprise histogram: compute per-word vagueness from MI data
;; Vagueness = baseline - avgMI(word). High vagueness = poorly known.
;; Falls back to *cl-word-surprise* if populated (same session as learner).
(if (> (hash-count (const #t) *cl-word-surprise*) 0)
;; Use learning session's surprise values
(hash-for-each
(lambda (word surprise)
(when (number? surprise)
(let ((bin (inexact->exact (floor (/ surprise surprise-bin-width)))))
(hash-set! surprise-bins bin (+ 1 (hash-ref surprise-bins bin 0))))))
*cl-word-surprise*)
;; Compute per-word average MI distribution (works in any session)
;; Shows how "informatively connected" each word is
(hash-for-each
(lambda (word mi-total)
(let* ((degree (hash-ref global-word-degree word 1))
(avg-mi (/ mi-total (max 1 degree)))
(bin (inexact->exact (floor (/ avg-mi surprise-bin-width)))))
(hash-set! surprise-bins bin (+ 1 (hash-ref surprise-bins bin 0)))))
global-word-mi-sum))
;; MI stats
(let* ((mi-mean (if (> mi-total-count 0) (/ mi-sum mi-total-count) 0.0))
(mi-variance (if (> mi-total-count 1)
(- (/ mi-sum-sq mi-total-count) (* mi-mean mi-mean))
0.0))
(mi-std (sqrt (max 0.0 mi-variance))))
(format #t " MI histogram: ~a unique pairs, range [~,2f, ~,2f], mean=~,3f, std=~,3f~%"
mi-total-count mi-min mi-max mi-mean mi-std)
;; Step 1: Collect ALL MI pairs with MI>2.0
(let ((all-pairs '()))
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (> mi 2.0))
(let ((w1 (car key)) (w2 (cdr key)))
(when (and (string<? w1 w2)
(not (cl-sentinel? w1))
(not (cl-sentinel? w2))
(> (string-length w1) 1)
(> (string-length w2) 1))
(set! all-pairs (cons (list w1 w2 mi) all-pairs))))))
*mi-cache*)
(format #t " ~a pairs (MI>2.0, filtered)~%" (length all-pairs))
;; Sort by MI descending, take top N
(let* ((sorted-pairs (sort all-pairs (lambda (a b) (> (caddr a) (caddr b)))))
(top-pairs (if (> (length sorted-pairs) max-pairs)
(list-head sorted-pairs max-pairs)
sorted-pairs)))
;; Step 2: Extract words from top pairs + high-frequency words
(let ((word-set (make-hash-table))
(word-neighbors (make-hash-table))
(word-degree (make-hash-table))
(word-total-mi (make-hash-table)))
;; Build from top pairs
(for-each
(lambda (p)
(let ((w1 (car p)) (w2 (cadr p)) (mi (caddr p)))
(hash-set! word-set w1 #t)
(hash-set! word-set w2 #t)
(hash-set! word-neighbors w1
(cons (cons w2 mi) (hash-ref word-neighbors w1 '())))
(hash-set! word-neighbors w2
(cons (cons w1 mi) (hash-ref word-neighbors w2 '())))
(hash-set! word-degree w1 (+ 1 (hash-ref word-degree w1 0)))
(hash-set! word-degree w2 (+ 1 (hash-ref word-degree w2 0)))
(hash-set! word-total-mi w1 (+ mi (hash-ref word-total-mi w1 0.0)))
(hash-set! word-total-mi w2 (+ mi (hash-ref word-total-mi w2 0.0)))))
top-pairs)
;; FIX EXPORT BIAS: Also include top-frequency words (by global degree)
;; These are common words like "the", "and", "of" that have many MI connections
;; but may not appear in the top-MI pairs (which are dominated by rare vocabulary)
(let* ((all-global-words (hash-map->list cons global-word-degree))
(sorted-by-freq (sort all-global-words (lambda (a b) (> (cdr a) (cdr b)))))
(top-freq-words (map car (if (> (length sorted-by-freq) 500)
(list-head sorted-by-freq 500)
sorted-by-freq)))
(freq-added 0))
;; For each high-frequency word not already in the export set,
;; add it and its top MI neighbors (using pre-built index, not re-scanning)
(for-each
(lambda (w)
(unless (hash-ref word-set w #f)
;; Look up pre-built top pairs index (O(1) instead of O(2.16M))
(let* ((w-pairs (hash-ref global-word-top-pairs w '()))
(w-top (if (> (length w-pairs) 20)
(list-head (sort w-pairs (lambda (a b) (> (caddr a) (caddr b)))) 20)
(sort w-pairs (lambda (a b) (> (caddr a) (caddr b)))))))
(when (>= (length w-top) 2)
(set! freq-added (+ freq-added 1))
(for-each
(lambda (p)
(let ((w1 (car p)) (w2 (cadr p)) (mi (caddr p)))
(hash-set! word-set w1 #t)
(hash-set! word-set w2 #t)
(hash-set! word-neighbors w1
(cons (cons w2 mi) (hash-ref word-neighbors w1 '())))
(hash-set! word-neighbors w2
(cons (cons w1 mi) (hash-ref word-neighbors w2 '())))
(hash-set! word-degree w1 (+ 1 (hash-ref word-degree w1 0)))
(hash-set! word-degree w2 (+ 1 (hash-ref word-degree w2 0)))
(hash-set! word-total-mi w1 (+ mi (hash-ref word-total-mi w1 0.0)))
(hash-set! word-total-mi w2 (+ mi (hash-ref word-total-mi w2 0.0)))))
w-top)))))
top-freq-words)
(format #t " Added ~a high-frequency words to export~%" freq-added))
(let ((all-words (hash-map->list (lambda (k v) k) word-set)))
;; Keep words with degree >= 2 (has at least 2 connections)
(let* ((connected-words (filter
(lambda (w) (>= (hash-ref word-degree w 0) 2))
all-words))
(words-by-degree (sort connected-words
(lambda (a b)
(> (hash-ref word-degree a 0)
(hash-ref word-degree b 0)))))
(export-words (if (> (length words-by-degree) max-words)
(list-head words-by-degree max-words)
words-by-degree))
(export-set (make-hash-table))
(n (length export-words)))
(format #t " ~a words with degree>=2 (of ~a total)~%"
(length connected-words) (length all-words))
(for-each (lambda (w) (hash-set! export-set w #t)) export-words)
;; Rebuild pairs list: include both top-MI pairs AND frequency-word pairs
(let ((all-export-pairs '()))
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (> mi 1.0))
(let ((w1 (car key)) (w2 (cdr key)))
(when (and (string<? w1 w2)
(hash-ref export-set w1 #f)
(hash-ref export-set w2 #f)
(not (cl-sentinel? w1))
(not (cl-sentinel? w2)))
(set! all-export-pairs (cons (list w1 w2 mi) all-export-pairs))))))
*mi-cache*)
;; Sort and limit
(let* ((sorted-export (sort all-export-pairs (lambda (a b) (> (caddr a) (caddr b)))))
(limited-pairs (if (> (length sorted-export) (* max-pairs 2))
(list-head sorted-export (* max-pairs 2))
sorted-export)))
;; Filter pairs: both words must be in export set
;; Then iteratively prune words with < 2 edges in export graph
(let loop-prune ((current-words export-words)
(current-set export-set)
(pass 0))
(let* ((current-pairs (filter
(lambda (p)
(and (hash-ref current-set (car p) #f)
(hash-ref current-set (cadr p) #f)))
limited-pairs))
;; Recompute degree in the export graph
(export-degree (make-hash-table)))
(for-each (lambda (p)
(hash-set! export-degree (car p)
(+ 1 (hash-ref export-degree (car p) 0)))
(hash-set! export-degree (cadr p)
(+ 1 (hash-ref export-degree (cadr p) 0))))
current-pairs)
;; Remove words with fewer than 2 edges in the export graph
(let* ((pruned-words (filter
(lambda (w) (>= (hash-ref export-degree w 0) 2))
current-words))
(removed (- (length current-words) (length pruned-words))))
(if (and (> removed 0) (< pass 5))
;; Re-prune with tighter set
(let ((new-set (make-hash-table)))
(for-each (lambda (w) (hash-set! new-set w #t)) pruned-words)
(format #t " Pass ~a: pruned ~a words with <2 export edges~%"
pass removed)
(loop-prune pruned-words new-set (+ pass 1)))
;; Stable - continue with these words and pairs
(let ((export-pairs current-pairs)
(export-words current-words)
(n (length current-words)))
(format #t " ~a words, ~a pairs for export~%" n (length export-pairs))
;; Step 3: Community detection on filtered sparse graph
(format #t " Running community detection on filtered graph...~%")
(let ((word-idx (make-hash-table))
(idx-word (make-hash-table)))
;; Build index
(let loop ((ws export-words) (i 0))
(when (not (null? ws))
(hash-set! word-idx (car ws) i)
(hash-set! idx-word i (car ws))
(loop (cdr ws) (+ i 1))))
;; Label propagation on the sparse filtered graph
(let ((labels (make-vector n 0)))
(let init ((i 0))
(when (< i n) (vector-set! labels i i) (init (+ i 1))))
;; Only use high-MI neighbors for community detection
(let iter-loop ((iter 0))
(when (< iter 25)
(let ((changed 0))
(let word-loop ((ws export-words))
(when (not (null? ws))
(let* ((w (car ws))
(i (hash-ref word-idx w 0))
(neighbors (hash-ref word-neighbors w '()))
(votes (make-hash-table)))
;; Only vote from neighbors in export set
(for-each
(lambda (nb)
(let* ((nw (car nb)) (mi (cdr nb))
(ni (hash-ref word-idx nw #f)))
(when (and ni (> mi 3.0))
(let ((lbl (vector-ref labels ni)))
(hash-set! votes lbl
(+ mi (hash-ref votes lbl 0.0)))))))
neighbors)
(let ((best-lbl (vector-ref labels i))
(best-score -1.0))
(hash-for-each
(lambda (lbl score)
(when (> score best-score)
(set! best-score score)
(set! best-lbl lbl)))
votes)
(when (not (= best-lbl (vector-ref labels i)))
(vector-set! labels i best-lbl)
(set! changed (+ changed 1)))))
(word-loop (cdr ws))))
(format #t " iter ~a: ~a changes~%" iter changed)
(when (> changed 0) (iter-loop (+ iter 1))))))
;; Renumber communities by size
(let ((comm-members (make-hash-table)))
(let idx-loop ((i 0))
(when (< i n)
(let ((lbl (vector-ref labels i)))
(hash-set! comm-members lbl
(cons (hash-ref idx-word i)
(hash-ref comm-members lbl '()))))
(idx-loop (+ i 1))))
(let* ((comm-list (hash-map->list cons comm-members))
(sorted-comms (sort comm-list
(lambda (a b)
(> (length (cdr a)) (length (cdr b))))))
(word-community (make-hash-table))
(community-id 0))
;; Only communities with 3+ members
(for-each
(lambda (comm)
(when (>= (length (cdr comm)) 3)
(for-each
(lambda (w) (hash-set! word-community w community-id))
(cdr comm))
(set! community-id (+ community-id 1))))
sorted-comms)
(format #t " ~a communities (3+ members)~%" community-id)
;; Step 4: Write JSON
(format #t " Writing data.json...~%")
(call-with-output-file filename
(lambda (port)
(format port "{~%")
;; Stats (enhanced with MI distribution stats)
(format port " \"stats\": {~%")
(format port " \"level\": ~a,~%" *cl-current-level*)
(format port " \"totalSentences\": ~a,~%" *cl-total-sentences*)
(format port " \"totalLearns\": ~a,~%" *cl-total-learns*)
(format port " \"learnRate\": ~,3f,~%"
(if (> *cl-total-sentences* 0)
(* 100.0 (/ *cl-total-learns* *cl-total-sentences*))
0.0))
(format port " \"avgSurprise\": ~,3f,~%" (cl-average-surprise))
(format port " \"totalPairs\": ~a,~%" (length export-pairs))
(format port " \"totalClusters\": ~a,~%" community-id)
(format port " \"miCacheSize\": ~a,~%"
(hash-count (const #t) *mi-cache*))
(format port " \"miMean\": ~,4f,~%" (exact->inexact mi-mean))
(format port " \"miStd\": ~,4f,~%" (exact->inexact mi-std))
(format port " \"miMin\": ~,4f,~%" (exact->inexact mi-min))
(format port " \"miMax\": ~,4f,~%" (exact->inexact mi-max))
(format port " \"miTotalPairs\": ~a,~%" mi-total-count)
(format port " \"epoch\": ~a,~%" *cl-epoch*)
(format port " \"wordClasses\": ~a,~%"
(hash-count (const #t) *word-classes*))
(format port " \"l1Senses\": ~a,~%"
(hash-count (const #t) *cl-l1-word-senses*))
(format port " \"l1SectionPairs\": ~a,~%"
(hash-count (const #t) *cl-l1-pair-counts*))
(format port " \"l1Baseline\": ~,3f,~%"
*cl-l1-baseline-mi*)
(format port " \"grammarAvailable\": ~a,~%"
(if *cl-grammar-available* "true" "false"))
(format port " \"classMiPairs\": ~a,~%"
(hash-count (const #t) *cl-class-mi-cache*))
(format port " \"crawlFiles\": ~a,~%"
*cl-crawl-total-files*)
(format port " \"crawlSentences\": ~a,~%"
*cl-crawl-total-sentences*)
;; Benchmark stats
(let* ((elapsed-s (/ (- (get-internal-real-time) *cl-bench-start-time*) 1000000000.0))
(sent-per-sec (if (> elapsed-s 0) (/ *cl-total-sentences* elapsed-s) 0.0))
(mi-avg-ms (if (> *cl-bench-mi-calls* 0)
(/ *cl-bench-mi-total-ms* *cl-bench-mi-calls*) 0.0))
(cluster-avg-ms (if (> *cl-bench-cluster-calls* 0)
(/ *cl-bench-cluster-total-ms* *cl-bench-cluster-calls*) 0.0))
(export-avg-ms (if (> *cl-bench-export-calls* 0)
(/ *cl-bench-export-total-ms* *cl-bench-export-calls*) 0.0)))
(format port " \"benchRuntimeSec\": ~,1f,~%" elapsed-s)
(format port " \"benchSentPerSec\": ~,1f,~%" sent-per-sec)
(format port " \"benchMiTotalMs\": ~,1f,~%" *cl-bench-mi-total-ms*)
(format port " \"benchMiCalls\": ~a,~%" *cl-bench-mi-calls*)
(format port " \"benchMiAvgMs\": ~,1f,~%" mi-avg-ms)
(format port " \"benchMiPairs\": ~a,~%" *cl-bench-mi-pairs*)
(format port " \"benchClusterTotalMs\": ~,1f,~%" *cl-bench-cluster-total-ms*)
(format port " \"benchClusterCalls\": ~a,~%" *cl-bench-cluster-calls*)
(format port " \"benchClusterAvgMs\": ~,1f,~%" cluster-avg-ms)
(format port " \"benchEvictTotalMs\": ~,1f,~%" *cl-bench-evict-total-ms*)
(format port " \"benchEvictCalls\": ~a,~%" *cl-bench-evict-calls*)
(format port " \"benchExportTotalMs\": ~,1f,~%" *cl-bench-export-total-ms*)
(format port " \"benchExportCalls\": ~a,~%" *cl-bench-export-calls*)
(format port " \"benchExportAvgMs\": ~,1f,~%" export-avg-ms))
;; Promotion estimate (emergent metrics)
(let* ((n-classes (hash-count (const #t) *word-classes*))
(prom-sent (> *cl-total-sentences* 2000))
(prom-iter (> *cl-cluster-iteration* 3))
(prom-classes (> n-classes 20))
(prom-exhausted (cl-structure-exhausted?))
(checks-passed (+ (if prom-sent 1 0) (if prom-iter 1 0)
(if prom-classes 1 0)
(if prom-exhausted 1 0))))
(format port " \"promChecks\": ~a,~%" checks-passed)
(format port " \"promTotal\": 4,~%")
(format port " \"promSentences\": ~a,~%" (if prom-sent "true" "false"))
(format port " \"promIterations\": ~a,~%" (if prom-iter "true" "false"))
(format port " \"promClasses\": ~a,~%" (if prom-classes "true" "false"))
(format port " \"promExhausted\": ~a,~%" (if prom-exhausted "true" "false"))
(format port " \"promTopScore\": ~,4f,~%" (exact->inexact *cl-top-pair-score*))
(format port " \"promNoiseFloor\": ~,4f,~%" *cl-noise-floor*)
(format port " \"promEntropy\": ~,4f,~%"
(if (null? *cl-entropy-history*) 0.0
(exact->inexact (car *cl-entropy-history*))))
(format port " \"promEntropyPlateau\": ~a~%"
(if (and (>= (length *cl-entropy-history*) *cl-entropy-window*)
(let* ((recent (take *cl-entropy-history* *cl-entropy-window*))
(mean (/ (apply + recent) (length recent)))
(max-delta (apply max (map (lambda (h) (abs (- h mean))) recent))))
(< (/ max-delta (max mean 0.001)) 0.01)))
"true" "false")))
(format port " },~%")
;; MI Histogram - the key insight panel
(format port " \"miHistogram\": [~%")
(let* ((bin-keys (sort (hash-map->list cons mi-bins)
(lambda (a b) (< (car a) (car b)))))
(first #t))
(for-each
(lambda (entry)
(unless first (format port ",~%"))
(format port " [~,1f, ~a]"
(* (car entry) mi-bin-width)
(cdr entry))
(set! first #f))
bin-keys))
(format port "~% ],~%")
;; Surprise Histogram
(format port " \"surpriseHistogram\": [~%")
(let* ((sbin-keys (sort (hash-map->list cons surprise-bins)
(lambda (a b) (< (car a) (car b)))))
(first #t))
(for-each
(lambda (entry)
(unless first (format port ",~%"))
(format port " [~,1f, ~a]"
(* (car entry) surprise-bin-width)
(cdr entry))
(set! first #f))
sbin-keys))
(format port "~% ],~%")
;; Words
(format port " \"words\": {~%")
(let ((first #t))
(for-each
(lambda (w)
(let* ((neighbors (hash-ref word-neighbors w '()))
(sorted-nb (if (> (length neighbors) 10)
(list-head
(sort neighbors
(lambda (a b) (> (cdr a) (cdr b))))
10)
(sort neighbors
(lambda (a b) (> (cdr a) (cdr b))))))
(degree (hash-ref word-degree w 0))
(total-mi (hash-ref word-total-mi w 0.0))
(community (hash-ref word-community w -1))
(class-id (hash-ref *word-to-class* w #f))
(senses (hash-ref *cl-l1-word-senses* w #f))
(sense-count (if senses (length senses) 0))
(g-degree (hash-ref global-word-degree w 0)))
(unless first (format port ",~%"))
(format port " ~s: {" w)
;; Per-word surprise: from learning EMA,
;; fallback to vagueness = baseline - avg_MI
(let ((ws (hash-ref *cl-word-surprise* w #f)))
(format port "\"surprise\": ~,3f, "
(or ws
(if (and (> g-degree 0)
(> *cl-baseline-mi* 0))
(max 0.0
(- *cl-baseline-mi*
(/ (exact->inexact total-mi)
g-degree)))
0.0))))
(format port "\"cluster\": ~a, " community)
(format port "\"degree\": ~a, " degree)
(format port "\"globalDegree\": ~a, " g-degree)
(format port "\"totalMI\": ~,3f"
(exact->inexact total-mi))
(when class-id
(format port ", \"classId\": ~a" class-id))
(when (> sense-count 0)
(format port ", \"senses\": ~a" sense-count))
(format port "}")
(set! first #f)))
export-words))
(format port "~% },~%")
;; Pairs
(format port " \"pairs\": [~%")
(let ((first #t))
(for-each
(lambda (p)
(unless first (format port ",~%"))
(format port " [~s, ~s, ~,3f]"
(car p) (cadr p) (caddr p))
(set! first #f))
export-pairs))
(format port "~% ],~%")
;; Word classes
(format port " \"classes\": {~%")
(let ((first #t))
(hash-for-each
(lambda (cid members)
(unless first (format port ",~%"))
(format port " \"~a\": [" cid)
(let ((mfirst #t))
(for-each
(lambda (w)
(unless mfirst (format port ", "))
(format port "~s" w)
(set! mfirst #f))
members))
(format port "]")
(set! first #f))
*word-classes*))
(format port "~% },~%")
;; Hierarchy
(format port " \"hierarchy\": [~%")
(let ((first #t))
(for-each
(lambda (merge)
(unless first (format port ",~%"))
(format port " [~s, ~s, ~a, ~,3f]"
(list-ref merge 1)
(list-ref merge 2)
(list-ref merge 3)
(list-ref merge 5))
(set! first #f))
(reverse *cl-merge-history*)))
(format port "~% ]~%")
(format port "}~%")))
(let ((export-elapsed (/ (- (get-internal-real-time) export-t0) 1000000.0)))
(set! *cl-bench-export-total-ms* (+ *cl-bench-export-total-ms* export-elapsed))
(set! *cl-bench-export-calls* (+ *cl-bench-export-calls* 1))
(format #t "Exported ~a words, ~a pairs, ~a communities to ~a (~,0f ms)~%"
n (length export-pairs)
community-id filename export-elapsed)))))))))))))))))))))))
(define (cl-show-status)
"Brief inline status during loop."
(format #t "~%--- ~a sentences | L~a | learns: ~a (~,1f%) | surprise: ~,3f | baseline: ~,3f | classes: ~a | dirty: ~a ---~%"
*cl-total-sentences*
*cl-current-level*
*cl-total-learns*
(if (> *cl-total-sentences* 0)
(* 100.0 (/ *cl-total-learns* *cl-total-sentences*))
0.0)
(cl-average-surprise)
(cl-level-baseline *cl-current-level*)
(hash-count (const #t) *word-classes*)
(if (zero? *cl-current-level*) *cl-dirty-count* *cl-l1-dirty-count*))
;; Show L1 stats when active
(when (> *cl-current-level* 0)
(format #t " L1: ~a section pairs | ~a MI entries | baseline: ~,3f | senses: ~a | L0-dirty: ~a~%"
(hash-count (const #t) *cl-l1-pair-counts*)
(hash-count (const #t) *cl-l1-mi-cache*)
*cl-l1-baseline-mi*
(hash-count (const #t) *cl-l1-word-senses*)
*cl-dirty-count*)))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 13: GRAMMAR PHASE — Close the Learning Loop
;; ═══════════════════════════════════════════════════════════════════
;;
;; After clustering produces word classes, we:
;; 1. Build class-pair MI cache (aggregate word-pair MI into class-pair MI)
;; 2. Export grammar as Link Grammar dictionary
;; 3. Parse new sentences with grammar (class-based MI)
;; 4. Measure grammar-surprise (what the grammar can't explain)
;; 5. Focus learning on surprising sentences
;; 6. Crawl directories for new text files
;;
;; This closes the loop: learn → grammar → evaluate → learn what's missing
;; ── 13a: Class-pair MI cache ──
(define (cl-build-class-mi-cache!)
"Aggregate word-pair MI into class-pair MI.
For each (w1 . w2) → MI in *mi-cache*:
c1 = *word-to-class*[w1], c2 = *word-to-class*[w2]
If both classified: accumulate MI into (c1 . c2) sum + count
Final: divide sums by counts → mean MI per class pair.
O(|mi-cache|) — single pass over ~1.8M entries."
(let ((sums (make-hash-table))
(counts (make-hash-table))
(n-entries 0))
(hash-for-each
(lambda (key mi)
(when (and (pair? key) (number? mi) (string<? (car key) (cdr key)))
(let ((c1 (hash-ref *word-to-class* (car key) #f))
(c2 (hash-ref *word-to-class* (cdr key) #f)))
(when (and c1 c2)
(let ((ckey (if (< c1 c2) (cons c1 c2) (cons c2 c1))))
(hash-set! sums ckey (+ (hash-ref sums ckey 0.0) mi))
(hash-set! counts ckey (+ (hash-ref counts ckey 0) 1))
(set! n-entries (+ n-entries 1)))))))
*mi-cache*)
;; Compute means
(hash-clear! *cl-class-mi-cache*)
(hash-for-each
(lambda (ckey sum)
(let ((cnt (hash-ref counts ckey 1)))
(hash-set! *cl-class-mi-cache* ckey (/ sum cnt))))
sums)
(format #t " [Class-MI cache: ~a class pairs from ~a word pairs]~%"
(hash-count (const #t) *cl-class-mi-cache*) n-entries)))
;; ── 13b: Grammar dictionary export ──
(define (cl-export-grammar!)
"Export learned word classes as a Link Grammar dictionary.
For each word class Cn with members {w1, w2, ...}:
1. Collect all sections from *section-counts* for any member word
2. Rewrite connectors using class IDs: 'the-' → 'C7-'
3. Merge duplicate disjuncts (sum counts across class members)
4. Compute cost = -0.5 × log₂(count / max_count) + 0.1
5. Drop disjuncts with count < 3
6. Write standard LG dict: mvp/dict-learned/learned.dict"
(let ((dict-file (string-append *mvp-dir* "/dict-learned/learned.dict"))
(n-classes (hash-count (const #t) *word-classes*))
(n-words-exported 0)
(n-disjuncts-exported 0))
(call-with-output-file dict-file
(lambda (port)
;; Header
(format port "%~%")
(format port "% Auto-generated grammar — ~a classes, ~a sentences~%"
n-classes *cl-total-sentences*)
(format port "% Generated by corpus-learning.scm~%")
(format port "%~%~%")
;; Find global max count for cost normalization
(let ((global-max-count 1))
(hash-for-each
(lambda (key count)
(when (> count global-max-count)
(set! global-max-count count)))
*section-counts*)
;; For each word class, collect members and their sections
(hash-for-each
(lambda (class-id members)
(when (>= (length members) 1)
;; Collect and merge disjuncts across all members
(let ((class-disjuncts (make-hash-table))) ; class-rewritten-disjunct → total-count
(for-each
(lambda (word)
(let ((disjs (hash-ref *sections* word '())))
(for-each
(lambda (disj)
(let ((count (hash-ref *section-counts* (cons word disj) 0)))
(when (>= count 3)
;; Rewrite connectors with class IDs
(let ((class-disj (cl-rewrite-with-classes disj)))
(hash-set! class-disjuncts class-disj
(+ (hash-ref class-disjuncts class-disj 0) count))))))
disjs)))
members)
;; Write dictionary entry if we have disjuncts
(let ((disj-list '()))
(hash-for-each
(lambda (disj count)
(set! disj-list (cons (cons disj count) disj-list)))
class-disjuncts)
(when (> (length disj-list) 0)
;; Sort by count descending
(set! disj-list (sort disj-list (lambda (a b) (> (cdr a) (cdr b)))))
;; Write word list
(format port "~a:~%"
(string-join
(map (lambda (w) (format #f "\"~a\"" w)) members)
" "))
;; Write disjuncts with costs
(let ((first #t))
(for-each
(lambda (entry)
(let* ((disj (car entry))
(count (cdr entry))
;; Cost: lower count = higher cost (less likely)
;; -0.5 * log2(count/max) + 0.1
(cost (+ (* -0.5
(/ (log (/ (exact->inexact count)
(exact->inexact global-max-count)))
(log 2)))
0.1))
;; Convert disjunct "the- sat+" to LG format "(the- & sat+)"
(connectors (filter (lambda (c) (> (string-length c) 0))
(string-split disj #\space)))
(lg-disj (string-append
"("
(string-join connectors " & ")
")")))
(if first
(format port " ~a~,1f" lg-disj cost)
(format port " or~% ~a~,1f" lg-disj cost))
(set! first #f)
(set! n-disjuncts-exported (+ n-disjuncts-exported 1))))
disj-list))
(format port ";~%~%")
(set! n-words-exported
(+ n-words-exported (length members))))))))
*word-classes*))
;; UNKNOWN-WORD entry for words not in any class
(format port "~%<UNKNOWN-WORD>:~%")
(format port " (ANY+)2.5 or~%")
(format port " (ANY-)2.5;~%")))
(set! *cl-grammar-available* #t)
(format #t " [Grammar exported: ~a words, ~a disjuncts → ~a]~%"
n-words-exported n-disjuncts-exported dict-file)))
;; ── 13c: Grammar parse (PMFG with class-based MI) ──
(define (cl-grammar-parse words)
"Parse sentence using class-based MI instead of word-pair MI.
For each word pair (wi, wj):
ci = *word-to-class*[wi], cj = *word-to-class*[wj]
If both classified: mi = *cl-class-mi-cache*[(ci . cj)]
Else: mi = *mi-cache*[(wi . wj)] (fallback to word-pair MI)
Feeds these MI values into PMFG parser."
(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)
(let* ((wi (vector-ref word-vec i))
(wj (vector-ref word-vec j))
(ci (hash-ref *word-to-class* wi #f))
(cj (hash-ref *word-to-class* wj #f))
(mi (if (and ci cj)
(let ((ckey (if (< ci cj)
(cons ci cj)
(cons cj ci))))
(hash-ref *cl-class-mi-cache* ckey
(get-mi wi wj)))
(get-mi wi wj))))
(cons (list mi 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))))))))))
;; ── 13d: Grammar surprise metric ──
(define (cl-grammar-surprise words)
"Measure how well the learned grammar explains a sentence.
Compares word-pair parse (raw MI) vs class-based parse (grammar MI).
High grammar-surprise = grammar can't explain this sentence well.
Returns a non-negative number: 0 = grammar fully explains it."
(if (not *cl-grammar-available*)
0.0 ; No grammar yet — no grammar-surprise
(let* ((word-edges (cpu-pmfg-parse words))
(gram-edges (cl-grammar-parse words))
;; Build edge sets as (min . max) position pairs
(word-edge-set (make-hash-table))
(gram-edge-set (make-hash-table))
(missing-mi-sum 0.0)
(n-missing 0))
;; Build sets
(for-each
(lambda (e)
(let ((key (cons (min (car e) (cadr e)) (max (car e) (cadr e)))))
(hash-set! word-edge-set key (caddr e))))
word-edges)
(for-each
(lambda (e)
(let ((key (cons (min (car e) (cadr e)) (max (car e) (cadr e)))))
(hash-set! gram-edge-set key (caddr e))))
gram-edges)
;; Count edges in word-parse NOT in gram-parse, weighted by MI
(hash-for-each
(lambda (key mi)
(unless (hash-ref gram-edge-set key #f)
(set! missing-mi-sum (+ missing-mi-sum (max 0 mi)))
(set! n-missing (+ n-missing 1))))
word-edge-set)
;; Normalize by sentence length
(if (< (length words) 2) 0.0
(/ missing-mi-sum (length words))))))
;; ── 13e: Filesystem crawler ──
(define (cl-load-text-file filename)
"Load sentences from a text file. Auto-detects Gutenberg format.
Non-Gutenberg files: treat entire content as text, split on sentence boundaries."
(let ((sentences '())
(is-gutenberg #f)
(in-content #f))
(catch #t
(lambda ()
(call-with-input-file filename
(lambda (port)
;; First pass: check if it's Gutenberg format
(let check-loop ()
(let ((line (read-line port)))
(unless (eof-object? line)
(when (string-contains line "*** START")
(set! is-gutenberg #t))
(check-loop))))
;; Rewind
(seek port 0 SEEK_SET)
(if is-gutenberg
;; Gutenberg: use existing logic
(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 (cl-clean-sentence line)))
(when (and cleaned (> (string-length cleaned) 10))
(set! sentences (cons cleaned sentences)))))
(loop))))
;; Plain text: take all lines
(let loop ()
(let ((line (read-line port)))
(unless (eof-object? line)
(let ((cleaned (cl-clean-sentence line)))
(when (and cleaned (> (string-length cleaned) 10))
(set! sentences (cons cleaned sentences))))
(loop))))))))
(lambda (key . args)
(format #t "Error loading ~a: ~a ~a~%" filename key args)))
(reverse sentences)))
(define (cl-get-source-id dir)
"Get or create a source ID for a directory name.
Source IDs are derived from the immediate parent directory name
(e.g., 'stage1-definitions' from corpus/incoming/stage1-definitions/)."
(let ((dir-name (basename dir)))
(let ((existing-id #f))
(hash-for-each
(lambda (id name)
(when (string=? name dir-name)
(set! existing-id id)))
*cl-source-names*)
(or existing-id
(let ((new-id *cl-source-next-id*))
(set! *cl-source-next-id* (+ *cl-source-next-id* 1))
(hash-set! *cl-source-names* new-id dir-name)
(hash-set! *cl-source-stats* new-id (cons 0 0.0))
(format #t " New source ~a: ~a~%" new-id dir-name)
new-id)))))
(define (cl-update-source-stats! source-id n-sentences surprise-sum)
"Update per-source statistics."
(let ((old (hash-ref *cl-source-stats* source-id (cons 0 0.0))))
(hash-set! *cl-source-stats* source-id
(cons (+ (car old) n-sentences)
(+ (cdr old) surprise-sum)))))
(define (cl-crawl-directory! dir)
"Scan DIR for .txt files not yet processed. Load, clean, learn.
Recursively scans subdirectories. Tags sentences by source directory."
(format #t "~%═══ CRAWLING: ~a ═══~%~%" dir)
(when (zero? *cl-baseline-mi*)
(bootstrap))
;; Register this directory as a source
(let ((source-id (cl-get-source-id dir))
(all-sentences '())
(files-processed 0))
;; Track source directories for query scanning
(unless (member dir *cl-source-dirs*)
(set! *cl-source-dirs* (append *cl-source-dirs* (list dir))))
(catch #t
(lambda ()
(let crawl ((current-dir dir))
(let ((d (opendir current-dir)))
(let loop ()
(let ((entry (readdir d)))
(unless (eof-object? entry)
(unless (or (string=? entry ".") (string=? entry ".."))
(let ((full-path (string-append current-dir "/" entry)))
(catch #t
(lambda ()
(if (eq? (stat:type (stat full-path)) 'directory)
;; Recurse into subdirectories
(crawl full-path)
;; Process .txt files
(when (and (string-suffix? ".txt" entry)
(not (hash-ref *cl-crawl-seen* full-path #f)))
(format #t " Loading ~a...~%" full-path)
(let ((file-sentences (cl-load-text-file full-path)))
(format #t " ~a sentences~%" (length file-sentences))
(hash-set! *cl-crawl-seen* full-path #t)
(set! *cl-crawl-total-files*
(+ *cl-crawl-total-files* 1))
(set! *cl-crawl-total-sentences*
(+ *cl-crawl-total-sentences* (length file-sentences)))
(set! files-processed (+ files-processed 1))
(set! all-sentences
(append all-sentences file-sentences))))))
(lambda (key . args)
(format #t " Skip ~a: ~a~%" full-path key)))))
(loop))))
(closedir d))))
(lambda (key . args)
(format #t "Error crawling ~a: ~a ~a~%" dir key args)))
(if (zero? (length all-sentences))
(format #t "No new .txt files found in ~a~%~%" dir)
(begin
(format #t "~%Loaded ~a new files, ~a sentences total (source ~a: ~a)~%"
files-processed (length all-sentences)
source-id (hash-ref *cl-source-names* source-id "unknown"))
;; Sort short→long (curriculum learning)
(let ((sorted (sort all-sentences
(lambda (a b) (< (string-length a) (string-length b))))))
;; Wrap as (source-id . sentence) entries for cl-learn-loop
(let ((entries (map (lambda (s) (cons source-id s)) sorted)))
(cl-learn-loop entries)))))))
(define (cl-watch-directory! dir)
"Continuously watch DIR for new .txt files. Re-scan every *cl-crawl-interval* seconds.
Stops when *cl-running* is set to #f."
(format #t "~%═══ WATCHING: ~a (every ~a sec) ═══~%~%" dir *cl-crawl-interval*)
(set! *cl-running* #t)
(let loop ()
(when *cl-running*
(cl-crawl-directory! dir)
(format #t " [Sleeping ~a seconds...]~%" *cl-crawl-interval*)
(sleep *cl-crawl-interval*)
(loop)))
(format #t "Watch mode stopped.~%"))
;; ── 13f: Shell commands for grammar phase ──
(define (crawl-dir dir)
"One-shot: process all .txt files in DIR."
(cl-crawl-directory! dir))
(define (watch-dir dir)
"Continuous: re-scan DIR every 5 min for new files."
(cl-watch-directory! dir))
(define (crawl-status)
"Show crawler status."
(format #t "~%═══ Crawler Status ═══~%")
(format #t "Files processed: ~a~%" *cl-crawl-total-files*)
(format #t "Total sentences: ~a~%" *cl-crawl-total-sentences*)
(format #t "Files seen:~%")
(hash-for-each
(lambda (path _)
(format #t " ~a~%" path))
*cl-crawl-seen*)
(format #t "Grammar available: ~a~%" *cl-grammar-available*)
(format #t "Class-MI cache: ~a entries~%"
(hash-count (const #t) *cl-class-mi-cache*))
(format #t "═══════════════════════════════~%~%"))
(define (grammar-status)
"Show grammar phase status."
(format #t "~%═══ Grammar Phase Status ═══~%")
(format #t "Grammar available: ~a~%" *cl-grammar-available*)
(format #t "Class-MI cache: ~a entries~%"
(hash-count (const #t) *cl-class-mi-cache*))
(format #t "Grammar surprise threshold: ~,3f~%" *cl-grammar-surprise-threshold*)
(when *cl-grammar-available*
(format #t "~%Test parses:~%")
(let ((test-sentences '(("the" "cat" "sat" "on" "the" "mat")
("every" "quasar" "oscillated" "rapidly"))))
(for-each
(lambda (words)
(let ((gs (cl-grammar-surprise words)))
(format #t " ~a → grammar-surprise: ~,3f~%" words gs)))
test-sentences)))
(format #t "═══════════════════════════════~%~%"))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION 14: CURRICULUM-DRIVEN LEARNING — Bottom-Up Meets Top-Down
;; ═══════════════════════════════════════════════════════════════════
;;
;; Bottom-up: curated data (Wikipedia definitions, Q&A pairs) teaches
;; question-word classes, definitional patterns, cause-effect grammar.
;; Top-down: high surprise triggers queries for more data about unknowns.
;; Meeting point: grammar of questions (bottom-up) + when to ask (top-down).
;; ── 14a: Inverse word index query ──
(define (cl-sentences-with word)
"Return sentences from the inverse word index containing WORD,
grouped by source. Returns alist: ((source-id sentences...) ...)"
(let ((entries (hash-ref *cl-word-sentences* word '()))
(by-source (make-hash-table)))
(for-each
(lambda (entry)
(let* ((src (car entry))
(sent (cdr entry))
(existing (hash-ref by-source src '())))
(hash-set! by-source src (cons sent existing))))
entries)
(hash-map->list cons by-source)))
;; ── 14b: Query strategies ──
(define (cl-scan-source-for-word dir word max-sentences)
"Scan a source directory for sentences containing WORD.
Returns list of cleaned sentences (up to MAX-SENTENCES)."
(let ((found '())
(count 0))
(catch #t
(lambda ()
(let crawl ((current-dir dir))
(when (< count max-sentences)
(let ((d (opendir current-dir)))
(let loop ()
(when (< count max-sentences)
(let ((entry (readdir d)))
(unless (eof-object? entry)
(unless (or (string=? entry ".") (string=? entry ".."))
(let ((full-path (string-append current-dir "/" entry)))
(catch #t
(lambda ()
(if (eq? (stat:type (stat full-path)) 'directory)
(crawl full-path)
(when (string-suffix? ".txt" entry)
(call-with-input-file full-path
(lambda (port)
(let file-loop ()
(when (< count max-sentences)
(let ((line (read-line port)))
(unless (eof-object? line)
(let ((cleaned (cl-clean-sentence line)))
(when (and cleaned
(> (string-length cleaned) 10)
(string-contains cleaned word))
(set! found (cons cleaned found))
(set! count (+ count 1))))
(file-loop))))))))))
(lambda _ #f))))
(loop)))))
(closedir d)))))
(lambda _ #f))
(reverse found)))
(define (cl-query-strategy-grep-source word)
"Strategy 1: Grep a source directory for sentences containing WORD.
Picks the source with the most existing examples (familiarity heuristic)."
(if (null? *cl-source-dirs*)
'()
(let* ((best-dir (car *cl-source-dirs*))
(best-count 0))
;; Find source with most examples of this word
(for-each
(lambda (dir)
(let* ((src-id (cl-get-source-id dir))
(entries (filter (lambda (e) (= (car e) src-id))
(hash-ref *cl-word-sentences* word '()))))
(when (> (length entries) best-count)
(set! best-count (length entries))
(set! best-dir dir))))
*cl-source-dirs*)
(let ((sentences (cl-scan-source-for-word best-dir word 20)))
(cons (cl-get-source-id best-dir) sentences)))))
(define (cl-query-strategy-grep-class word)
"Strategy 2: Grep for sentences containing any word in the same nascent cluster.
If WORD is unclassified, find its nearest neighbor by MI."
(let* ((class-id (hash-ref *word-to-class* word #f))
(class-words
(if class-id
(hash-ref *word-classes* class-id '())
;; Unclassified: find top MI neighbor
(let ((best-w #f) (best-mi 0.0))
(hash-for-each
(lambda (key mi)
(when (and (pair? key)
(or (string=? (car key) word) (string=? (cdr key) word))
(> mi best-mi))
(set! best-mi mi)
(set! best-w (if (string=? (car key) word) (cdr key) (car key)))))
*mi-cache*)
(if best-w (list word best-w) (list word))))))
;; Collect sentences for all words in the group
(if (null? *cl-source-dirs*)
'()
(let ((dir (car *cl-source-dirs*))
(all-sentences '()))
(for-each
(lambda (w)
(let ((entries (hash-ref *cl-word-sentences* w '())))
(set! all-sentences
(append all-sentences (map cdr entries)))))
(take class-words (min 5 (length class-words))))
;; If not enough from index, scan first source
(when (< (length all-sentences) 10)
(for-each
(lambda (w)
(set! all-sentences
(append all-sentences
(cl-scan-source-for-word dir w 5))))
(take class-words (min 3 (length class-words)))))
(cons (cl-get-source-id dir)
(delete-duplicates
(take all-sentences (min 20 (length all-sentences)))
string=?))))))
(define (cl-query-strategy-random-source word)
"Strategy 3: Pick a random source, take random sentences (exploration baseline)."
(if (null? *cl-source-dirs*)
'()
(let* ((idx (random (length *cl-source-dirs*)))
(dir (list-ref *cl-source-dirs* idx))
(src-id (cl-get-source-id dir)))
;; Just take whatever sentences we find (not filtered by word)
(let ((sentences '())
(count 0))
(catch #t
(lambda ()
(let ((d (opendir dir)))
(let loop ()
(when (< count 20)
(let ((entry (readdir d)))
(unless (eof-object? entry)
(when (string-suffix? ".txt" entry)
(let ((full-path (string-append dir "/" entry)))
(catch #t
(lambda ()
(call-with-input-file full-path
(lambda (port)
(let file-loop ()
(when (< count 20)
(let ((line (read-line port)))
(unless (eof-object? line)
(let ((cleaned (cl-clean-sentence line)))
(when (and cleaned (> (string-length cleaned) 10))
;; Random sampling: take ~10% of lines
(when (< (random 10) 1)
(set! sentences (cons cleaned sentences))
(set! count (+ count 1)))))
(file-loop))))))))
(lambda _ #f))))
(loop)))))
(closedir d)))
(lambda _ #f))
(cons src-id (reverse sentences))))))
;; ── 14c: Query trigger ──
(define (cl-query-for-word! word)
"Trigger a query for more data about WORD.
Picks a strategy (epsilon-greedy) and feeds results through cl-learn-loop."
(let* ((surprise-before (hash-ref *cl-word-surprise* word 5.0))
;; Epsilon-greedy strategy selection
(strategy
(if (< (random 100) (* 100 *cl-query-epsilon*))
;; Exploration: random strategy
(list-ref '("grep-source" "grep-class" "random-source")
(random 3))
;; Exploitation: pick best known strategy
(cl-best-strategy)))
;; Execute the chosen strategy
(result
(cond
((string=? strategy "grep-source")
(cl-query-strategy-grep-source word))
((string=? strategy "grep-class")
(cl-query-strategy-grep-class word))
((string=? strategy "random-source")
(cl-query-strategy-random-source word))
(else '()))))
(when (and (pair? result) (not (null? (cdr result))))
(let* ((source-id (car result))
(sentences (cdr result)))
(format #t " [Query: ~a for '~a' → ~a sentences from source ~a]~%"
strategy word (length sentences) source-id)
;; Feed through learning pipeline
(let ((entries (map (lambda (s) (cons source-id s)) sentences)))
;; Don't recurse into full learn-loop (avoid nested loops)
;; Just count pairs and update MI incrementally
(for-each
(lambda (entry)
(let* ((sentence (cdr entry))
(words (string-split sentence #\space)))
(when (>= (length words) 3)
(let* ((edges (cpu-pmfg-parse words))
(surprise (cl-compute-surprise edges)))
(cl-learn-at-level! words edges edges 0)
;; Update word index for these new sentences
(for-each
(lambda (w)
(let ((existing (hash-ref *cl-word-sentences* w '())))
(when (< (length existing) *cl-word-sentences-max*)
(hash-set! *cl-word-sentences* w
(cons (cons source-id sentence) existing)))))
(delete-duplicates words string=?))))))
entries))
;; Record action
(let ((surprise-after (hash-ref *cl-word-surprise* word surprise-before)))
(cl-record-action! strategy source-id word surprise-before surprise-after))
(set! *cl-query-count* (+ *cl-query-count* 1))
;; Recompute action MI periodically
(when (zero? (modulo *cl-query-count* *cl-action-mi-interval*))
(cl-recompute-action-mi!))
;; Stream event
(cl-emit! "query" `(("word" . ,word)
("strategy" . ,strategy)
("source" . ,source-id)
("n" . ,(length sentences))
("sur_before" . ,surprise-before)
("sur_after" . ,(hash-ref *cl-word-surprise* word surprise-before))))))))
(define (cl-check-query-triggers! words)
"Check if any words in the sentence should trigger a query.
Called from cl-learn-loop after processing a batch."
(for-each
(lambda (word)
(let ((word-sur (hash-ref *cl-word-surprise* word #f))
(class-id (hash-ref *word-to-class* word #f))
(n-examples (length (hash-ref *cl-word-sentences* word '()))))
(when (and word-sur
(> word-sur *cl-query-min-surprise*)
(not class-id)
(< n-examples *cl-query-min-examples*)
;; Rate limit: max 1 query per batch
(< (random 100) 5))
(cl-query-for-word! word))))
(delete-duplicates words string=?)))
;; ── 14d: Level 2 instrumentation ──
(define (cl-record-action! strategy source-id word surprise-before surprise-after)
"Record a query action for Level 2 MI computation."
(set! *cl-action-log*
(cons (list strategy source-id word surprise-before surprise-after)
*cl-action-log*)))
(define (cl-recompute-action-mi!)
"Compute mean delta-surprise per (strategy . source-id) pair.
Updates *cl-action-mi-cache*."
(let ((accum (make-hash-table)))
;; Accumulate (sum count) per (strategy . source-id)
(for-each
(lambda (entry)
(let* ((strategy (list-ref entry 0))
(source-id (list-ref entry 1))
(delta (- (list-ref entry 3) (list-ref entry 4))) ; before - after = reduction
(key (cons strategy source-id))
(old (hash-ref accum key (cons 0.0 0))))
(hash-set! accum key
(cons (+ (car old) delta) (+ (cdr old) 1)))))
*cl-action-log*)
;; Compute means
(set! *cl-action-mi-cache* (make-hash-table))
(hash-for-each
(lambda (key sum-count)
(hash-set! *cl-action-mi-cache* key
(/ (car sum-count) (max 1 (cdr sum-count)))))
accum)
(format #t " [Action MI recomputed: ~a strategy-source pairs]~%"
(hash-count (const #t) *cl-action-mi-cache*))))
(define (cl-best-strategy)
"Pick the strategy with the highest mean surprise reduction.
Falls back to grep-source if no data yet."
(let ((best-strategy "grep-source")
(best-mi -999.0))
(hash-for-each
(lambda (key mean-delta)
(when (> mean-delta best-mi)
(set! best-mi mean-delta)
(set! best-strategy (car key))))
*cl-action-mi-cache*)
best-strategy))
;; ── 14e: Wire query trigger into learn loop ──
;; The query trigger is called from within the batch processing loop.
;; We hook it into the periodic maintenance section by adding it to
;; the batch end. This requires a small addition to cl-learn-loop.
;; Instead of modifying cl-learn-loop directly (already complex),
;; we expose cl-check-query-triggers! and call it from the batch
;; processing via a post-batch hook.
(define *cl-post-batch-hooks* '())
(define (cl-add-post-batch-hook! fn)
"Register a function to call after each batch in cl-learn-loop."
(set! *cl-post-batch-hooks* (cons fn *cl-post-batch-hooks*)))
;; Register the query trigger hook (active only when source dirs are configured)
(cl-add-post-batch-hook!
(lambda (batch-words)
(when (not (null? *cl-source-dirs*))
(cl-check-query-triggers! batch-words))))
;; ── 14f: Shell commands for curriculum learning ──
(define (source-stats)
"Show per-source statistics."
(format #t "~%═══ Source Statistics ═══~%")
(format #t "Sources: ~a | Source dirs: ~a | Queries: ~a~%~%"
*cl-source-next-id* (length *cl-source-dirs*) *cl-query-count*)
(hash-for-each
(lambda (id name)
(let* ((stats (hash-ref *cl-source-stats* id (cons 0 0.0)))
(n (car stats))
(surprise-sum (cdr stats))
(mean-surprise (if (> n 0) (/ surprise-sum n) 0.0)))
(format #t " Source ~a (~a): ~a sentences, mean surprise: ~,3f~%"
id name n mean-surprise)))
*cl-source-names*)
(format #t "~%Source directories:~%")
(for-each
(lambda (dir) (format #t " ~a~%" dir))
*cl-source-dirs*)
(format #t "═══════════════════════════════~%~%"))
(define (action-status)
"Show query trigger and action instrumentation status."
(format #t "~%═══ Action Status (Level 2) ═══~%")
(format #t "Total queries: ~a~%" *cl-query-count*)
(format #t "Action log entries: ~a~%" (length *cl-action-log*))
(format #t "Action MI cache: ~a strategy-source pairs~%~%"
(hash-count (const #t) *cl-action-mi-cache*))
;; Show strategy effectiveness
(format #t "Strategy effectiveness (mean surprise reduction):~%")
(let ((strategies (make-hash-table)))
(hash-for-each
(lambda (key mean-delta)
(let* ((strategy (car key))
(source-id (cdr key))
(source-name (hash-ref *cl-source-names* source-id "?")))
(format #t " ~a × source ~a (~a): ~,3f~%"
strategy source-id source-name mean-delta)))
*cl-action-mi-cache*))
(format #t "~%Best strategy: ~a~%" (cl-best-strategy))
(format #t "Epsilon (exploration rate): ~,2f~%" *cl-query-epsilon*)
(format #t "Query triggers: surprise > ~,1f, unclassified, < ~a examples~%"
*cl-query-min-surprise* *cl-query-min-examples*)
;; Show recent actions
(when (not (null? *cl-action-log*))
(format #t "~%Recent actions (last 10):~%")
(for-each
(lambda (entry)
(format #t " ~a '~a' src=~a Δsur=~,3f~%"
(list-ref entry 0) ; strategy
(list-ref entry 2) ; word
(list-ref entry 1) ; source-id
(- (list-ref entry 3) (list-ref entry 4)))) ; surprise reduction
(take *cl-action-log* (min 10 (length *cl-action-log*)))))
(format #t "═══════════════════════════════~%~%"))
(define (word-index-stats)
"Show inverse word index statistics."
(format #t "~%═══ Word Index Statistics ═══~%")
(let ((total-entries 0)
(max-entries 0)
(max-word "")
(word-count 0))
(hash-for-each
(lambda (word entries)
(set! word-count (+ word-count 1))
(set! total-entries (+ total-entries (length entries)))
(when (> (length entries) max-entries)
(set! max-entries (length entries))
(set! max-word word)))
*cl-word-sentences*)
(format #t "Words indexed: ~a~%" word-count)
(format #t "Total entries: ~a~%" total-entries)
(format #t "Max entries: ~a (~a examples)~%"
max-word max-entries)
(format #t "Max per word: ~a~%" *cl-word-sentences-max*))
(format #t "═══════════════════════════════~%~%"))
;; ═══════════════════════════════════════════════════════════════════
;; LOADED MESSAGE
;; ═══════════════════════════════════════════════════════════════════
;; Alias: docs and plan say bootstrap!, code defines bootstrap
(define bootstrap! bootstrap)
(format #t "~%═══ Corpus Learning Module Loaded ═══~%")
(format #t "Commands:~%")
(format #t " (bootstrap!) Bootstrap from CogServer MI data~%")
(format #t " (run-corpus N) Run first N sentences~%")
(display " (run-corpus-all) Run all 56K sentences\n")
(format #t " (corpus-status) Show learning status~%")
(format #t " (corpus-reset) Reset state (keep MI cache)~%")
(format #t " (corpus-stop) Stop learning loop~%")
(format #t " (corpus-thresholds) Show adaptive thresholds~%")
(format #t " (corpus-vagueness) Show vagueness per word~%")
(format #t " (corpus-export) Export viz JSON~%")
(format #t "Grammar phase:~%")
(format #t " (grammar-status) Show grammar phase status~%")
(format #t " (crawl-dir \"/path\") Process .txt files in directory~%")
(format #t " (watch-dir \"/path\") Continuously watch for new .txt files~%")
(format #t " (crawl-status) Show crawler status~%")
(format #t "Curriculum learning:~%")
(format #t " (source-stats) Show per-source statistics~%")
(format #t " (action-status) Show query trigger + action MI~%")
(format #t " (word-index-stats) Show inverse word index stats~%")
(format #t " (cl-sentences-with w) Sentences containing word~%")
(format #t "═══════════════════════════════════════~%~%")