;
; autodiscover.scm - Self-discovering layer architecture
;
; ONE operation at every level: COUNT → CLUSTER → repeat
; Layers emerge from data, not from code.
;
(use-modules (opencog))
(use-modules (ice-9 format))
(use-modules (srfi srfi-1))
;; ═══════════════════════════════════════════════════════════════════
;; GENERIC UNIT
;; ═══════════════════════════════════════════════════════════════════
(define (make-unit id level members)
(list id level members))
(define (unit-id u) (car u))
(define (unit-level u) (cadr u))
(define (unit-members u) (caddr u))
(define (atomic-unit? u) (null? (unit-members u)))
;; ═══════════════════════════════════════════════════════════════════
;; LEVEL STORAGE (using alists)
;; ═══════════════════════════════════════════════════════════════════
(define *levels* '()) ; ((level . (units . pair-counts)) ...)
(define (get-level n)
(let ((entry (assoc n *levels*)))
(if entry
(cdr entry)
(cons '() '()))))
(define (set-level! n units counts)
(let ((entry (assoc n *levels*)))
(if entry
(set-cdr! entry (cons units counts))
(set! *levels* (cons (cons n (cons units counts)) *levels*)))))
(define (level-units n) (car (get-level n)))
(define (level-counts n) (cdr (get-level n)))
(define (current-max-level)
(if (null? *levels*)
-1
(apply max (map car *levels*))))
;; ═══════════════════════════════════════════════════════════════════
;; GENERIC COUNTING
;; ═══════════════════════════════════════════════════════════════════
(define (count-unit-pairs units window-size)
"Count co-occurring pairs within window. Returns (pair-counts . unit-counts)"
(let ((pair-counts '())
(unit-counts '()))
;; Count individual units
(for-each
(lambda (u)
(let* ((uid (unit-id u))
(entry (assoc uid unit-counts)))
(if entry
(set-cdr! entry (+ 1 (cdr entry)))
(set! unit-counts (cons (cons uid 1) unit-counts)))))
units)
;; Count pairs within window
(for-each
(lambda (i)
(for-each
(lambda (j)
(when (< j (length units))
(let* ((u1 (list-ref units i))
(u2 (list-ref units j))
(key (cons (unit-id u1) (unit-id u2)))
(entry (assoc key pair-counts)))
(if entry
(set-cdr! entry (+ 1 (cdr entry)))
(set! pair-counts (cons (cons key 1) pair-counts))))))
(iota (min window-size (- (length units) i 1)) (+ i 1))))
(iota (max 0 (- (length units) 1))))
(cons pair-counts unit-counts)))
;; ═══════════════════════════════════════════════════════════════════
;; GENERIC CLUSTERING
;; ═══════════════════════════════════════════════════════════════════
(define (get-unit-profile unit-id pair-counts top-n)
"Get top associations for a unit"
(let ((profile '()))
(for-each
(lambda (entry)
(let ((key (car entry))
(count (cdr entry)))
(cond
((equal? (car key) unit-id)
(set! profile (cons (cons (cdr key) count) profile)))
((equal? (cdr key) unit-id)
(set! profile (cons (cons (car key) count) profile))))))
pair-counts)
(map car (take (sort profile (lambda (a b) (> (cdr a) (cdr b))))
(min top-n (length profile))))))
(define (profile-similarity p1 p2)
"Jaccard similarity between profiles"
(if (or (null? p1) (null? p2))
0
(let* ((s1 (delete-duplicates p1))
(s2 (delete-duplicates p2))
(intersection (filter (lambda (x) (member x s2)) s1))
(union (delete-duplicates (append s1 s2))))
(if (null? union)
0
(/ (length intersection) (length union))))))
(define (cluster-units units pair-counts threshold)
"Cluster units by profile similarity"
(if (null? units)
'()
(let ((clusters '())
(cluster-counter 0)
(profiles '())
;; Deduplicate units by ID, keeping first occurrence
(unique-units (let ((seen '()))
(filter (lambda (u)
(let ((uid (unit-id u)))
(if (member uid seen)
#f
(begin
(set! seen (cons uid seen))
#t))))
units))))
;; Build profiles for unique units
(for-each
(lambda (u)
(set! profiles
(cons (cons (unit-id u) (get-unit-profile (unit-id u) pair-counts 10))
profiles)))
unique-units)
;; Cluster by similarity
(for-each
(lambda (u)
(let* ((uid (unit-id u))
(profile (cdr (assoc uid profiles)))
(best-cluster #f)
(best-sim threshold))
;; Find best matching cluster
(for-each
(lambda (c)
(let* ((cluster-id (car c))
(members (cdr c))
(rep (car members))
(rep-profile (cdr (or (assoc rep profiles) '(#f . ())))))
(when rep-profile
(let ((sim (profile-similarity profile rep-profile)))
(when (> sim best-sim)
(set! best-sim sim)
(set! best-cluster cluster-id))))))
clusters)
;; Add to cluster or create new
(if best-cluster
(set! clusters
(map (lambda (c)
(if (equal? (car c) best-cluster)
(cons (car c) (cons uid (cdr c)))
c))
clusters))
(let ((new-id (format #f "L~a-C~a"
(+ 1 (unit-level u))
cluster-counter)))
(set! cluster-counter (+ 1 cluster-counter))
(set! clusters (cons (cons new-id (list uid)) clusters))))))
unique-units)
;; Convert to units
(map (lambda (c)
(make-unit (car c) (+ 1 (unit-level (car unique-units))) (cdr c)))
clusters))))
;; ═══════════════════════════════════════════════════════════════════
;; RECURSIVE DISCOVERY
;; ═══════════════════════════════════════════════════════════════════
(define (discover-next-level current-level)
"Discover the next level of abstraction"
(let ((units (level-units current-level)))
(if (< (length units) 2)
#f
(let* ((counts-result (count-unit-pairs units 3))
(pair-counts (car counts-result))
(clusters (cluster-units units pair-counts 0.1))
(num-clusters (length clusters))
(num-units (length units)))
;; Stop if: no clusters, only 1 cluster, or no reduction (same count)
(if (or (null? clusters)
(<= num-clusters 1)
(>= num-clusters num-units)) ; No actual clustering happened
#f
(let ((next-level (+ 1 current-level)))
(let ((next-counts (count-unit-pairs clusters 3)))
(set-level! next-level clusters (car next-counts))
next-level)))))))
(define (discover-all-levels)
"Discover all levels until fixed point"
(let loop ((level 0))
(let ((next (discover-next-level level)))
(if next
(begin
(display (format #f "[autodiscover] Level ~a: ~a units\n"
next (length (level-units next))))
(if (< (length (level-units next)) 2)
(display "[autodiscover] Stopped - too few units\n")
(loop next)))
(display (format #f "[autodiscover] Stopped at level ~a (no new structure)\n" level))))))
;; ═══════════════════════════════════════════════════════════════════
;; INTERFACE
;; ═══════════════════════════════════════════════════════════════════
(define (autodiscover-process text)
"Process text through auto-discovery"
(let ((tokens (map (lambda (w) (make-unit w 0 '()))
(tokenize text))))
(when (not (null? tokens))
(let* ((current (get-level 0))
(current-units (car current))
(all-units (append current-units tokens))
(counts-result (count-unit-pairs all-units 5)))
(set-level! 0 all-units (car counts-result))))))
(define (autodiscover-rebuild)
"Rebuild all levels from scratch"
(display "[autodiscover] Rebuilding all levels...\n")
;; Clear levels above 0
(set! *levels* (filter (lambda (e) (= (car e) 0)) *levels*))
(discover-all-levels)
(format #f "Discovered ~a levels" (+ 1 (current-max-level))))
(define (show-autodiscover-stats)
"Show discovered structure"
(let ((max-level (current-max-level)))
(if (< max-level 0)
"No data yet"
(string-join
(cons (format #f "Discovered ~a levels:" (+ 1 max-level))
(map (lambda (n)
(format #f " Level ~a: ~a units" n (length (level-units n))))
(iota (+ 1 max-level))))
"\n"))))
(define (show-level n)
"Show units at a level"
(let ((units (level-units n)))
(if (null? units)
(format #f "Level ~a: empty" n)
(string-join
(cons (format #f "Level ~a (~a units):" n (length units))
(map (lambda (u)
(if (atomic-unit? u)
(format #f " ~a" (unit-id u))
(format #f " ~a: {~a}"
(unit-id u)
(string-join (take (unit-members u)
(min 5 (length (unit-members u))))
", "))))
(take units (min 15 (length units)))))
"\n"))))