;
; continuous-learner.scm - Unified continuous learning with bidirectional PMI
;
; ONE algorithm that works both UP (abstraction) and DOWN (grounding):
;
; COUNT → PMI → CLUSTER (up) / GROUND (down)
;
; Grounding is detected by PMI patterns:
; - High PMI with action verbs = grounded (we know how to USE it)
; - Low PMI with actions = vague (need to learn operations)
;
; This replaces the separate layer1/layer2/layer3 + gap-detector approach
;
(use-modules (opencog))
(use-modules (ice-9 format))
(use-modules (srfi srfi-1))
;; ═══════════════════════════════════════════════════════════════════
;; UNIT: The single abstraction for everything
;; ═══════════════════════════════════════════════════════════════════
;; A unit is anything we're tracking: word, cluster, concept, operation
;; Units live in a flat space, connected by weighted edges (PMI)
(define *units* '()) ; ((id . properties) ...)
(define *pair-counts* '()) ; (((id1 . id2) . count) ...)
(define *unit-counts* '()) ; ((id . count) ...)
(define *total-observations* 0)
(define (reset-learner!)
(set! *units* '())
(set! *pair-counts* '())
(set! *unit-counts* '())
(set! *total-observations* 0))
;; ═══════════════════════════════════════════════════════════════════
;; COUNTING: The fundamental operation
;; ═══════════════════════════════════════════════════════════════════
(define (observe-unit! id)
"Observe a unit (increment count)"
(let ((entry (assoc id *unit-counts*)))
(if entry
(set-cdr! entry (+ 1 (cdr entry)))
(set! *unit-counts* (cons (cons id 1) *unit-counts*))))
(set! *total-observations* (+ 1 *total-observations*)))
(define (observe-pair! id1 id2)
"Observe a pair (increment co-occurrence count)"
(let* ((key (if (string<? id1 id2) (cons id1 id2) (cons id2 id1)))
(entry (assoc key *pair-counts*)))
(if entry
(set-cdr! entry (+ 1 (cdr entry)))
(set! *pair-counts* (cons (cons key 1) *pair-counts*)))))
(define (get-unit-count id)
(let ((entry (assoc id *unit-counts*)))
(if entry (cdr entry) 0)))
(define (get-pair-count id1 id2)
(let* ((key (if (string<? id1 id2) (cons id1 id2) (cons id2 id1)))
(entry (assoc key *pair-counts*)))
(if entry (cdr entry) 0)))
;; ═══════════════════════════════════════════════════════════════════
;; PMI: Measure of association strength
;; ═══════════════════════════════════════════════════════════════════
(define (compute-pmi id1 id2)
"Pointwise Mutual Information between two units"
(let ((pair-count (get-pair-count id1 id2))
(count1 (get-unit-count id1))
(count2 (get-unit-count id2)))
(if (or (= pair-count 0) (= count1 0) (= count2 0) (= *total-observations* 0))
0
(let* ((p-pair (/ pair-count *total-observations*))
(p1 (/ count1 *total-observations*))
(p2 (/ count2 *total-observations*)))
(if (or (= p1 0) (= p2 0))
0
(/ (log (/ p-pair (* p1 p2))) (log 2)))))))
(define (get-associations id n)
"Get top N associations for a unit by PMI"
(let* ((all-ids (map car *unit-counts*))
(others (filter (lambda (x) (not (equal? x id))) all-ids))
(scored (map (lambda (other)
(cons (compute-pmi id other) other))
others))
(positive (filter (lambda (p) (> (car p) 0)) scored))
(sorted (sort positive (lambda (a b) (> (car a) (car b))))))
(take sorted (min n (length sorted)))))
;; ═══════════════════════════════════════════════════════════════════
;; VAGUENESS: Inverse of evidence (counting-based)
;; ═══════════════════════════════════════════════════════════════════
(define (unit-vagueness id)
"How uncertain are we about this unit? Based purely on counts."
(let ((count (get-unit-count id))
(assocs (get-associations id 10)))
;; Vagueness = 1 / (1 + evidence)
;; Evidence = count + number of associations + strength of associations
(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 (overall-vagueness)
"Average vagueness across all units"
(if (null? *unit-counts*)
1.0
(let ((vagueness-sum (apply + (map (lambda (entry)
(unit-vagueness (car entry)))
*unit-counts*))))
(/ vagueness-sum (length *unit-counts*)))))
;; ═══════════════════════════════════════════════════════════════════
;; GROUNDING: Detected via PMI with operational vocabulary
;; ═══════════════════════════════════════════════════════════════════
;; These words indicate OPERATIONS - things you can DO
(define *action-words*
'("create" "make" "build" "generate" "send" "receive" "sign" "verify"
"encode" "decode" "encrypt" "decrypt" "connect" "open" "close"
"read" "write" "call" "return" "produce" "contains" "has" "uses"))
;; These words indicate STRUCTURE - what something IS
(define *structure-words*
'("is" "are" "means" "type" "kind" "part" "field" "property"
"component" "element" "member" "contains" "includes"))
(define (grounding-score id)
"How grounded is this unit? Based on PMI with action words."
(let ((assocs (get-associations id 20)))
;; Count associations with action words and their strength
(let loop ((assocs assocs) (score 0))
(if (null? assocs)
score
(let* ((assoc (car assocs))
(pmi (car assoc))
(other (cdr assoc)))
(if (member other *action-words*)
(loop (cdr assocs) (+ score pmi))
(loop (cdr assocs) score)))))))
(define (structural-score id)
"How well do we understand the structure? PMI with structure words."
(let ((assocs (get-associations id 20)))
(let loop ((assocs assocs) (score 0))
(if (null? assocs)
score
(let* ((assoc (car assocs))
(pmi (car assoc))
(other (cdr assoc)))
(if (member other *structure-words*)
(loop (cdr assocs) (+ score pmi))
(loop (cdr assocs) score)))))))
(define (is-grounded? id)
"Is this unit grounded? Needs both structural and operational knowledge."
(let ((g-score (grounding-score id))
(s-score (structural-score id))
(vague (unit-vagueness id)))
;; Grounded if: low vagueness AND some operational association
(and (< vague 0.3) (> g-score 1.0))))
;; ═══════════════════════════════════════════════════════════════════
;; GAP DETECTION: What we DON'T know (via counting)
;; ═══════════════════════════════════════════════════════════════════
(define (detect-gaps)
"Find knowledge gaps - units with high vagueness or missing grounding"
(let ((gaps '()))
(for-each
(lambda (entry)
(let* ((id (car entry))
(count (cdr entry))
(vague (unit-vagueness id))
(g-score (grounding-score id))
(s-score (structural-score id)))
;; Gap types based on what's missing:
(cond
;; High vagueness = don't know much at all
((> vague 0.5)
(set! gaps (cons (list 'unknown id vague
(format #f "seen ~a times, vagueness ~,2f" count vague))
gaps)))
;; Know structure but not operations
((and (> s-score 1.0) (< g-score 0.5))
(set! gaps (cons (list 'ungrounded id (- 1 g-score)
(format #f "structural(~,1f) but no operations(~,1f)"
s-score g-score))
gaps)))
;; Know operations but not structure
((and (> g-score 1.0) (< s-score 0.5))
(set! gaps (cons (list 'unstructured id (- 1 s-score)
(format #f "operational(~,1f) but no structure(~,1f)"
g-score s-score))
gaps))))))
*unit-counts*)
;; Sort by priority (highest first)
(sort gaps (lambda (a b) (> (caddr a) (caddr b))))))
(define (gap-to-question gap)
"Convert gap to a question based on what's missing"
(let ((type (car gap))
(id (cadr gap)))
(case type
((unknown) (format #f "What is ~a?" id))
((ungrounded) (format #f "How do you use/create/operate on ~a?" id))
((unstructured) (format #f "What are the parts/structure of ~a?" id))
(else (format #f "Tell me about ~a" id)))))
;; ═══════════════════════════════════════════════════════════════════
;; PROCESSING: Feed text and learn
;; ═══════════════════════════════════════════════════════════════════
(define *window-size* 5)
(define (tokenize text)
"Split text into words"
(filter
(lambda (w) (> (string-length w) 2))
(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)))))
(define (process-text! text)
"Process text: observe units and pairs"
(let ((words (tokenize text)))
;; Observe each word
(for-each observe-unit! words)
;; Observe pairs within window
(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)))
;; ═══════════════════════════════════════════════════════════════════
;; CLUSTERING: Going UP (abstraction via similarity)
;; ═══════════════════════════════════════════════════════════════════
(define (profile-similarity id1 id2)
"Jaccard similarity of association profiles"
(let ((assocs1 (map cdr (get-associations id1 10)))
(assocs2 (map cdr (get-associations id2 10))))
(if (or (null? assocs1) (null? assocs2))
0
(let* ((intersection (filter (lambda (x) (member x assocs2)) assocs1))
(union (delete-duplicates (append assocs1 assocs2))))
(if (null? union)
0
(/ (length intersection) (length union)))))))
(define (find-similar id threshold n)
"Find units similar to id (by profile)"
(let* ((all-ids (map car *unit-counts*))
(others (filter (lambda (x) (not (equal? x id))) all-ids))
(scored (map (lambda (other)
(cons (profile-similarity id other) other))
others))
(above-threshold (filter (lambda (p) (> (car p) threshold)) scored))
(sorted (sort above-threshold (lambda (a b) (> (car a) (car b))))))
(take sorted (min n (length sorted)))))
;; ═══════════════════════════════════════════════════════════════════
;; DISPLAY
;; ═══════════════════════════════════════════════════════════════════
(define (show-stats)
"Show learning statistics"
(format #f "Units: ~a
Pairs: ~a
Observations: ~a
Overall vagueness: ~,2f"
(length *unit-counts*)
(length *pair-counts*)
*total-observations*
(overall-vagueness)))
(define (show-unit id)
"Show everything we know about a unit"
(let ((count (get-unit-count id))
(vague (unit-vagueness id))
(g-score (grounding-score id))
(s-score (structural-score id))
(assocs (get-associations id 10))
(similar (find-similar id 0.1 5)))
(string-join
(list
(format #f "~a:" id)
(format #f " count: ~a" count)
(format #f " vagueness: ~,2f" vague)
(format #f " grounding: ~,2f" g-score)
(format #f " structure: ~,2f" s-score)
(format #f " grounded?: ~a" (is-grounded? id))
(format #f " associations: ~a"
(string-join (map (lambda (a)
(format #f "~a(~,1f)" (cdr a) (car a)))
(take assocs (min 5 (length assocs))))
", "))
(format #f " similar to: ~a"
(if (null? similar)
"none"
(string-join (map (lambda (s)
(format #f "~a(~,1f)" (cdr s) (car s)))
similar)
", "))))
"\n")))
(define (show-gaps n)
"Show top N gaps"
(let ((gaps (take (detect-gaps) (min n (length (detect-gaps))))))
(if (null? gaps)
"No knowledge gaps detected"
(string-join
(cons (format #f "Top ~a gaps:" (length gaps))
(map (lambda (g)
(format #f "\n[~a] ~a (priority: ~,2f)\n ~a\n Question: ~a"
(car g) (cadr g) (caddr g) (cadddr g)
(gap-to-question g)))
gaps))
""))))
(define (show-grounded)
"Show which units are grounded"
(let* ((all (map car *unit-counts*))
(grounded (filter is-grounded? all))
(ungrounded (filter (lambda (x) (not (is-grounded? x))) all)))
(format #f "Grounded (~a): ~a\nUngrounded (~a): ~a"
(length grounded)
(string-join (take grounded (min 10 (length grounded))) ", ")
(length ungrounded)
(string-join (take ungrounded (min 10 (length ungrounded))) ", "))))