;
; atomspace-matrix-learner.scm - Continuous learning using (opencog matrix)
;
; "The AtomSpace way" - uses the official matrix module for:
; 1. Batch MI computation (all pairs at once)
; 2. O(1) cached MI lookups (no recomputation per query)
; 3. MeetLink pattern matching for structure queries
;
; Same learning approach as atomspace-learner.scm but different internals:
; Current: compute PMI on demand → O(n) per lookup → blocks queries
; Matrix: batch compute MI → O(1) cached lookup → queries never block
;
(use-modules (opencog))
(use-modules (opencog exec))
(use-modules (opencog matrix))
(use-modules (ice-9 format))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 popen))
(use-modules (srfi srfi-1))
;; ═══════════════════════════════════════════════════════════════════
;; CONFIGURATION
;; ═══════════════════════════════════════════════════════════════════
(define *window-size* 5)
(define *min-word-length* 2)
(define *total-observations* 0)
(define *manual-observations* 0)
(define *auto-observations* 0)
(define *mi-stale* #t) ;; Flag: MI needs recomputation
(define *structure-predicates* '("contains" "has" "includes" "is" "are" "type" "kind"))
(define *action-predicates* '("create" "make" "build" "send" "sign" "verify" "use" "call"))
;; Tool bindings - only hardcoded bridge between concepts and reality
(define *tool-bindings*
'(("grep" . tool-grep)
("wirecore" . "/storage/projects/code/hypercore-kb/hyper-fleeky/repos/wirecore")
("codebase" . "/storage/projects/code/hypercore-kb/hyper-fleeky/repos/wirecore")))
;; ═══════════════════════════════════════════════════════════════════
;; MATRIX PAIR API - The AtomSpace way
;; ═══════════════════════════════════════════════════════════════════
(define *pair-pred* (Predicate "word-pair"))
(define *cnt-key* (Predicate "*-TruthValueKey-*"))
(define (make-word-pair-api)
"Matrix API object for word pairs.
Custom get-count/set-count because cog-set-value-ref! is missing."
(let ((base (make-edge-pair-api
'EdgeLink *pair-pred*
'ConceptNode 'ConceptNode
(Any "left-word") (Any "right-word")
"word-pairs" "Word co-occurrence pairs")))
(define (get-count PAIR)
(let ((val (cog-value PAIR *cnt-key*)))
(if val (cog-value-ref val 2) 0)))
(define (set-count PAIR N)
(cog-set-value! PAIR *cnt-key* (FloatValue 0 0 N)))
(define (inc-count PAIR N)
(set-count PAIR (+ (get-count PAIR) N)))
;; Safe get-pair that catches errors from cog-link receiving #f
(define (safe-get-pair L-ATOM R-ATOM)
(catch #t
(lambda () (base 'get-pair L-ATOM R-ATOM))
(lambda args '())))
(lambda (message . args)
(case message
((get-count) (apply get-count args))
((set-count) (apply set-count args))
((inc-count) (apply inc-count args))
((get-pair) (apply safe-get-pair args))
((provides) (let ((symb (car args)))
(case symb
((get-count) get-count)
((set-count) set-count)
((inc-count) inc-count)
((get-pair) safe-get-pair)
(else (base 'provides symb)))))
(else (apply base message args))))))
;; Global matrix objects
(define *pair-api* (make-word-pair-api))
(define *pair-stars* (add-pair-stars *pair-api*))
(define *freq-api* #f) ;; Created after first MI computation
;; ═══════════════════════════════════════════════════════════════════
;; TOKENIZATION
;; ═══════════════════════════════════════════════════════════════════
(define (tokenize text)
"Split text into words, lowercase, filter short words"
(filter
(lambda (w) (> (string-length w) *min-word-length*))
(map string-downcase
(filter (lambda (s) (> (string-length s) 0))
(string-split
(string-filter (lambda (c) (or (char-alphabetic? c) (char=? c #\space))) text)
#\space)))))
;; ═══════════════════════════════════════════════════════════════════
;; ATOMSPACE STORAGE - UNITS (word nodes with counts)
;; ═══════════════════════════════════════════════════════════════════
(define (word-node word)
(cog-new-node 'ConceptNode (string-append "word:" word)))
(define (find-word-node word)
(cog-node 'ConceptNode (string-append "word:" word)))
(define *unit-count-key* (Predicate "unit-count"))
(define (observe-unit! word)
(let ((node (word-node word)))
(let ((current (cog-value node *unit-count-key*)))
(if current
(cog-set-value! node *unit-count-key*
(FloatValue (+ 1 (car (cog-value->list current)))))
(cog-set-value! node *unit-count-key*
(FloatValue 1))))
(set! *total-observations* (+ 1 *total-observations*))
node))
(define (get-unit-count word)
(let ((node (find-word-node word)))
(if node
(let ((val (cog-value node *unit-count-key*)))
(if val (car (cog-value->list val)) 0))
0)))
(define (get-all-words)
(filter string?
(filter-map
(lambda (n)
(let ((name (cog-name n)))
(if (and (string? name)
(> (string-length name) 5)
(string-prefix? "word:" name))
(substring name 5)
#f)))
(cog-get-atoms 'ConceptNode #t))))
;; ═══════════════════════════════════════════════════════════════════
;; PAIR OBSERVATION - Uses matrix API
;; ═══════════════════════════════════════════════════════════════════
(define (observe-pair! word1 word2)
"Observe a word pair using the matrix pair API"
(let* ((ordered (if (string<? word1 word2)
(list word1 word2) (list word2 word1)))
(w1 (word-node (car ordered)))
(w2 (word-node (cadr ordered)))
(pair (*pair-api* 'make-pair w1 w2)))
(*pair-api* 'inc-count pair 1)
(set! *mi-stale* #t)
pair))
(define (get-pair-count word1 word2)
(let* ((ordered (if (string<? word1 word2)
(list word1 word2) (list word2 word1)))
(w1 (find-word-node (car ordered)))
(w2 (find-word-node (cadr ordered))))
(if (and w1 w2)
(let ((pair (*pair-api* 'get-pair w1 w2)))
(if (null? pair) 0 (*pair-api* 'get-count pair)))
0)))
;; ═══════════════════════════════════════════════════════════════════
;; BATCH MI COMPUTATION - The key difference from manual approach
;; ═══════════════════════════════════════════════════════════════════
(define (recompute-mi!)
"Batch recompute MI for ALL pairs. Call after accumulating new data."
(when *mi-stale*
(display "[matrix] Recomputing MI for all pairs...\n")
(let ((start (current-time)))
;; Refresh the stars (pair lists may have changed)
(set! *pair-stars* (add-pair-stars *pair-api*))
;; Batch compute
(batch-all-pair-mi *pair-stars* #f)
;; Create freq API for lookups
(set! *freq-api* (add-pair-freq-api *pair-stars*))
(set! *mi-stale* #f)
(display (format #f "[matrix] MI computed in ~a seconds. Pairs: ~a\n"
(- (current-time) start)
(length (*pair-stars* 'get-all-elts)))))))
;; ═══════════════════════════════════════════════════════════════════
;; ASSOCIATION LOOKUP - O(1) cached reads
;; ═══════════════════════════════════════════════════════════════════
(define (get-associations word n)
"Get top N associations by cached MI. O(1) per pair lookup."
(unless *freq-api*
(recompute-mi!))
(let ((word-node (find-word-node word)))
(if (not word-node)
'()
(let* ((pairs (*pair-stars* 'right-stars word-node))
;; Also check left-stars (our pairs are alphabetically ordered)
(lpairs (*pair-stars* 'left-stars word-node))
(all-pairs (append pairs lpairs))
(scored (filter-map
(lambda (pair)
(let ((mi (catch #t
(lambda () (*freq-api* 'pair-fmi pair))
(lambda args 0))))
(and (number? mi) (> mi 0)
(let* ((left (*pair-stars* 'left-element pair))
(right (*pair-stars* 'right-element pair))
(other (if (equal? left word-node) right left))
(name (cog-name other)))
(and (string? name)
(> (string-length name) 5)
(string-prefix? "word:" name)
(cons mi (substring name 5)))))))
all-pairs))
(deduped (delete-duplicates scored
(lambda (a b) (string=? (cdr a) (cdr b)))))
(sorted (sort deduped (lambda (a b) (> (car a) (car b))))))
(take sorted (min n (length sorted)))))))
(define (compute-pmi word1 word2)
"Get cached MI between two words (O(1) if MI is computed)"
(unless *freq-api*
(recompute-mi!))
(catch #t
(lambda ()
(let* ((w1 (find-word-node word1))
(w2 (find-word-node word2)))
(if (and w1 w2)
(let ((pair (*pair-api* 'get-pair w1 w2)))
(if (null? pair) 0
(*freq-api* 'pair-fmi pair)))
0)))
(lambda args 0)))
;; ═══════════════════════════════════════════════════════════════════
;; STRUCTURE DISCOVERY - Store as EvaluationLinks
;; ═══════════════════════════════════════════════════════════════════
(define (store-structure! subject predicate object confidence)
(let* ((subj-node (word-node subject))
(pred-node (cog-new-node 'PredicateNode predicate))
(obj-node (word-node object))
(eval-link (cog-new-link 'EvaluationLink
pred-node
(cog-new-link 'ListLink subj-node obj-node))))
(cog-set-value! eval-link (Predicate "confidence") (FloatValue confidence))
eval-link))
(define (discover-contains! word)
(let ((assocs (get-associations word 20)))
(when (member "contains" (map cdr assocs))
(let ((contains-mi (compute-pmi word "contains")))
(when (> contains-mi 0.5)
(for-each
(lambda (assoc)
(let ((other (cdr assoc)) (mi (car assoc)))
(when (and (not (member other *structure-predicates*))
(> mi 1.0)
(> (compute-pmi other "contains") 0))
(store-structure! word "contains" other mi))))
assocs))))))
(define (discover-action! word)
(let ((assocs (get-associations word 20)))
(for-each
(lambda (assoc)
(let ((other (cdr assoc)) (mi (car assoc)))
(when (member other *action-predicates*)
(store-structure! other "operates-on" word mi))))
assocs)))
(define (discover-all-structures!)
(for-each
(lambda (word)
(catch #t
(lambda () (discover-contains! word) (discover-action! word))
(lambda (key . args)
(display (format #f "[discover] Error on '~a': ~a\n" word key)))))
(get-all-words)))
;; ═══════════════════════════════════════════════════════════════════
;; QUERY - MeetLink pattern matching
;; ═══════════════════════════════════════════════════════════════════
(define (query-contains word)
"Use MeetLink to find what WORD contains"
(let ((subj-node (find-word-node word)))
(if (not subj-node)
'()
(let ((result (cog-execute!
(Meet
(TypedVariable (Variable "$obj") (Type "ConceptNode"))
(Evaluation
(Predicate "contains")
(List subj-node (Variable "$obj")))))))
(filter-map
(lambda (atom)
(let ((name (cog-name atom)))
(and (string? name)
(> (string-length name) 5)
(string-prefix? "word:" name)
(substring name 5))))
(cog-outgoing-set result))))))
(define (query-what-has word)
"Use MeetLink to find what CONTAINS word"
(let ((obj-node (find-word-node word)))
(if (not obj-node)
'()
(let ((result (cog-execute!
(Meet
(TypedVariable (Variable "$subj") (Type "ConceptNode"))
(Evaluation
(Predicate "contains")
(List (Variable "$subj") obj-node))))))
(filter-map
(lambda (atom)
(let ((name (cog-name atom)))
(and (string? name)
(> (string-length name) 5)
(string-prefix? "word:" name)
(substring name 5))))
(cog-outgoing-set result))))))
;; ═══════════════════════════════════════════════════════════════════
;; GROUNDING & VAGUENESS
;; ═══════════════════════════════════════════════════════════════════
(define (unit-vagueness word)
(let ((count (get-unit-count word))
(assocs (get-associations word 10)))
(let* ((assoc-count (length assocs))
(assoc-strength (if (null? assocs) 0 (apply + (map car assocs))))
(evidence (+ count assoc-count assoc-strength)))
(/ 1.0 (+ 1 evidence)))))
(define (grounding-score word)
(let ((assocs (get-associations word 20)))
(apply + (filter-map
(lambda (a) (and (member (cdr a) *action-predicates*) (car a)))
assocs))))
(define (structural-score word)
(let ((assocs (get-associations word 20)))
(apply + (filter-map
(lambda (a) (and (member (cdr a) *structure-predicates*) (car a)))
assocs))))
(define (gap-type word)
(let ((g (grounding-score word)) (s (structural-score word)))
(cond
((and (< g 1.0) (< s 1.0)) 'unknown)
((and (> s 1.0) (< g 1.0)) 'ungrounded)
((and (> g 1.0) (< s 1.0)) 'unstructured)
(else 'grounded))))
;; ═══════════════════════════════════════════════════════════════════
;; PROCESSING - Feed text and learn
;; ═══════════════════════════════════════════════════════════════════
(define (process-text! text)
(let ((words (tokenize text)))
(for-each observe-unit! words)
(let loop ((i 0))
(when (< i (length words))
(let ((w1 (list-ref words i)))
(let inner ((j (+ i 1)))
(when (and (< j (length words))
(< (- j i) *window-size*))
(observe-pair! w1 (list-ref words j))
(inner (+ j 1)))))
(loop (+ i 1))))
(length words)))
(define (process-text-manual! text)
(let ((n (process-text! text)))
(set! *manual-observations* (+ *manual-observations* n)) n))
(define (process-text-auto! text)
(let ((n (process-text! text)))
(set! *auto-observations* (+ *auto-observations* n)) n))
;; ═══════════════════════════════════════════════════════════════════
;; CALL/RESPONSE
;; ═══════════════════════════════════════════════════════════════════
(define (is-question? text)
(let ((lower (string-downcase text)))
(or (string-suffix? "?" text)
(string-prefix? "what " lower)
(string-prefix? "how " lower)
(string-prefix? "who " lower))))
(define (extract-query-term text)
(let* ((clean (string-trim-right text (lambda (c) (char=? c #\?))))
(words (tokenize clean))
(stop-words '("what" "is" "are" "the" "how" "do" "you" "can" "does"))
(content-words (filter (lambda (w) (not (member w stop-words))) words)))
(if (null? content-words) #f (car (reverse content-words)))))
(define (safe-string-list lst)
(filter (lambda (x) (and (string? x) (not (string-null? x)))) lst))
(define (generate-response query-term)
(let ((count (get-unit-count query-term)))
(if (= count 0)
(format #f "I don't know about '~a' yet." query-term)
(let* ((assocs (get-associations query-term 5))
(assoc-words (safe-string-list (map cdr assocs)))
(contains (query-contains query-term))
(contains-words (safe-string-list contains)))
(cond
((not (null? contains-words))
(format #f "~a contains: ~a" query-term (string-join contains-words ", ")))
((not (null? assoc-words))
(format #f "~a relates to: ~a" query-term (string-join assoc-words ", ")))
(else
(format #f "I've seen '~a' ~a times but don't know what it relates to."
query-term count)))))))
(define (respond text)
(if (is-question? text)
(let ((term (extract-query-term text)))
(if term (generate-response term)
"I couldn't understand what you're asking about."))
(begin (process-text! text) (format #f "Learned from: ~a" text))))
;; ═══════════════════════════════════════════════════════════════════
;; TOOLS
;; ═══════════════════════════════════════════════════════════════════
(define (tool-grep pattern path)
(let* ((cmd (format #f "grep -r -i --include='*.js' --include='*.scm' '~a' ~a 2>/dev/null | head -10"
pattern path))
(port (open-input-pipe cmd))
(lines '()))
(let loop ((line (read-line port)))
(if (eof-object? line)
(begin (close-pipe port) (reverse lines))
(begin (set! lines (cons line lines)) (loop (read-line port)))))))
;; ═══════════════════════════════════════════════════════════════════
;; PURE PMI SELF-DIRECTED SEARCH (same as atomspace-learner.scm)
;; ═══════════════════════════════════════════════════════════════════
(define (resolve-binding concept)
(let ((entry (assoc concept *tool-bindings*)))
(if entry (cdr entry) #f)))
(define (find-tool-for-action word)
(let ((tool-names (map car *tool-bindings*))
(assocs (get-associations word 15)))
(let ((direct (filter (lambda (a) (member (cdr a) tool-names)) assocs)))
(if (not (null? direct))
(cdr (car direct))
#f))))
(define (find-search-location word)
(let ((location-hints '("wirecore" "codebase" "directory" "files"))
(assocs (get-associations word 15)))
(let ((direct (filter (lambda (a) (member (cdr a) location-hints)) assocs)))
(if (not (null? direct))
(cdr (car direct))
#f))))
(define (reason-search-plan word)
(let ((tool (find-tool-for-action word))
(location (find-search-location word)))
(if (and tool location)
(let* ((assocs (get-associations word 5))
(patterns (cons word
(filter-map
(lambda (a)
(let ((other (cdr a)))
(and (not (string=? other word))
(not (member other '("grep" "search" "wirecore"
"codebase" "files" "directory"
"tool" "pattern")))
(not (member other *structure-predicates*))
(not (member other *action-predicates*))
(string-append word ".*" other))))
assocs))))
(list (cons 'tool tool)
(cons 'location location)
(cons 'patterns patterns)
(cons 'reasoning
(format #f "~a → ~a(~a) → search ~a"
word (or tool "?") location
(string-join patterns ", ")))))
(begin
(when (not tool)
(display (format #f "[reason] ~a: no PMI path to tool\n" word)))
(when (not location)
(display (format #f "[reason] ~a: no PMI path to location\n" word)))
#f))))
(define (learnable-word? word)
(and (find-tool-for-action word) (find-search-location word)))
;; ═══════════════════════════════════════════════════════════════════
;; SELF-LEARNING LOOP
;; ═══════════════════════════════════════════════════════════════════
(define (get-learning-priorities)
(let* ((all-words (get-all-words))
(scored (map (lambda (w)
(list w (unit-vagueness w) (grounding-score w) (structural-score w)))
all-words))
(prioritized (sort scored
(lambda (a b)
(or (> (cadr a) (cadr b))
(and (= (cadr a) (cadr b))
(< (caddr a) (caddr b))))))))
prioritized))
(define (learn-about! word)
(let ((before-vague (unit-vagueness word))
(total-learned 0))
(display (format #f "\n[learn] Target: ~a (gap: ~a, vagueness: ~,3f)\n"
word (gap-type word) before-vague))
(let ((plan (reason-search-plan word)))
(if (not plan)
(display (format #f "[learn] BLOCKED: Cannot reason about '~a'\n" word))
(let* ((location-concept (assoc-ref plan 'location))
(patterns (assoc-ref plan 'patterns))
(reasoning (assoc-ref plan 'reasoning))
(location-path (resolve-binding location-concept)))
(display (format #f "[learn] PMI reasoning: ~a\n" reasoning))
(when location-path
(for-each
(lambda (pattern)
(let ((results (tool-grep pattern location-path)))
(when (not (null? results))
(display (format #f "[learn] Found ~a results for '~a'\n"
(length results) pattern))
(for-each
(lambda (line)
(let ((colon-pos (string-index line #\:)))
(when colon-pos
(process-text-auto! (substring line (+ colon-pos 1)))
(set! total-learned (+ total-learned 1)))))
results))))
patterns)))))
;; Mark MI as stale after new data
(when (> total-learned 0)
(set! *mi-stale* #t))
(discover-contains! word)
(discover-action! word)
(let ((after-vague (unit-vagueness word)))
(display (format #f "[learn] Processed ~a lines. Vagueness: ~,3f → ~,3f\n"
total-learned before-vague after-vague))
total-learned)))
;; ═══════════════════════════════════════════════════════════════════
;; DISPLAY
;; ═══════════════════════════════════════════════════════════════════
(define (show-stats)
(format #f "Words: ~a\nObservations: ~a (manual: ~a, auto: ~a)\nPairs: ~a\nStructures: ~a\nMI stale: ~a"
(length (get-all-words))
*total-observations* *manual-observations* *auto-observations*
(length (*pair-stars* 'get-all-elts))
(length (cog-get-atoms 'EvaluationLink #t))
*mi-stale*))
(define (show-unit word)
(let* ((count (get-unit-count word))
(vague (unit-vagueness word))
(g-score (grounding-score word))
(s-score (structural-score word))
(assocs (get-associations word 10))
(contains (safe-string-list (query-contains word)))
(assoc-strs (safe-string-list
(map (lambda (a)
(if (and (pair? a) (number? (car a)) (string? (cdr a)))
(format #f "~a(~,1f)" (cdr a) (car a)) #f))
(take assocs (min 5 (length assocs)))))))
(string-join
(list
(format #f "~a:" word)
(format #f " count: ~a" count)
(format #f " vagueness: ~,2f" vague)
(format #f " grounding: ~,2f" g-score)
(format #f " structure: ~,2f" s-score)
(format #f " associations: ~a"
(if (null? assoc-strs) "none" (string-join assoc-strs ", ")))
(format #f " contains: ~a"
(if (null? contains) "unknown" (string-join contains ", "))))
"\n")))
(define (show-learning-priorities n)
(let ((priorities (get-learning-priorities)))
(string-join
(cons (format #f "Top ~a learning priorities:\n" (min n (length priorities)))
(map (lambda (p)
(format #f " ~a: vagueness=~,2f grounding=~,2f structure=~,2f"
(car p) (cadr p) (caddr p) (cadddr p)))
(take priorities (min n (length priorities)))))
"\n")))