;;
;; mst-parser.scm -- Custom MST parser using AtomSpace directly
;;
;; This bypasses Link Grammar and reads MI values directly from AtomSpace.
;; Designed for GPU acceleration via batch processing.
;;
;; Algorithm: Prim's MST (simple, O(V²) per sentence)
;; For GPU: Batch many sentences, parallelize edge weight lookups
;;
(use-modules (srfi srfi-1)) ; list operations
(use-modules (opencog) (opencog exec))
(use-modules (opencog persist))
(use-modules (opencog lg)) ; Word, Edge, Bond, etc.
;; ═══════════════════════════════════════════════════════════════════
;; MI VALUE LOOKUP
;; ═══════════════════════════════════════════════════════════════════
;; Key where MI values are stored
(define *mi-key* (Predicate "mi"))
(define *fmi-key* (Predicate "*-Mutual Info Key-*"))
(define (get-mi-value word1 word2)
"Get MI value for word pair. Returns 0 if not found."
;; Try both orderings since MI(a,b) = MI(b,a)
(let* ((pair1 (cog-link 'Edge (Bond "ANY") (List (Word word1) (Word word2))))
(pair2 (cog-link 'Edge (Bond "ANY") (List (Word word2) (Word word1))))
(pair (or pair1 pair2)))
(if pair
(let ((val (cog-value pair *fmi-key*)))
(if val
(cog-value-ref val 0)
;; Try alternate key
(let ((val2 (cog-value pair *mi-key*)))
(if val2 (cog-value-ref val2 0) 0.0))))
0.0)))
;; ═══════════════════════════════════════════════════════════════════
;; PRIM'S MST ALGORITHM
;; ═══════════════════════════════════════════════════════════════════
(define (prim-mst words)
"Find Maximum Spanning Tree using Prim's algorithm.
Returns list of edges: ((word1 . word2) ...)
words: list of word strings
Prim's algorithm (for maximum spanning tree):
1. Start with first word in tree
2. Repeat until all words in tree:
- Find max-weight edge from tree to non-tree
- Add that edge and word to tree
"
(let* ((n (length words))
(word-vec (list->vector words)))
(if (< n 2)
'() ; No edges for 0 or 1 words
;; Track which words are in tree
(let loop ((in-tree (list 0)) ; indices in tree
(not-in-tree (iota (- n 1) 1)) ; indices not in tree
(edges '())) ; collected edges
(if (null? not-in-tree)
edges ; Done - return edges
;; Find max edge from tree to non-tree
(let find-max ((best-weight -inf.0)
(best-from #f)
(best-to #f)
(from-list in-tree))
(if (null? from-list)
;; Found best edge, add it
(if best-from
(loop (cons best-to in-tree)
(delete best-to not-in-tree)
(cons (cons (vector-ref word-vec best-from)
(vector-ref word-vec best-to))
edges))
;; No edge found (disconnected graph)
edges)
;; Check all edges from current 'from' node
(let check-to ((to-list not-in-tree)
(cur-best-weight best-weight)
(cur-best-from best-from)
(cur-best-to best-to))
(if (null? to-list)
;; Done with this from-node
(find-max cur-best-weight cur-best-from cur-best-to
(cdr from-list))
;; Check this edge
(let* ((from-idx (car from-list))
(to-idx (car to-list))
(w1 (vector-ref word-vec from-idx))
(w2 (vector-ref word-vec to-idx))
(weight (get-mi-value w1 w2)))
(if (> weight cur-best-weight)
(check-to (cdr to-list) weight from-idx to-idx)
(check-to (cdr to-list) cur-best-weight
cur-best-from cur-best-to))))))))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION EXTRACTION
;; ═══════════════════════════════════════════════════════════════════
(define (edges-to-sections words edges)
"Convert MST edges to Sections (word + connector-set).
For each word, collect its connections:
- Left connections (word appears on right of edge)
- Right connections (word appears on left of edge)
Returns: alist of (word . ((left-words) . (right-words)))
"
(let ((word-positions (make-hash-table)))
;; Build position map
(let loop ((ws words) (pos 0))
(when (not (null? ws))
(hash-set! word-positions (car ws) pos)
(loop (cdr ws) (+ pos 1))))
;; Build connector sets for each word
(let ((sections (make-hash-table)))
;; Initialize all words
(for-each
(lambda (w)
(hash-set! sections w (cons '() '()))) ; (left . right)
words)
;; Process edges
(for-each
(lambda (edge)
(let* ((w1 (car edge))
(w2 (cdr edge))
(pos1 (hash-ref word-positions w1))
(pos2 (hash-ref word-positions w2)))
(if (< pos1 pos2)
;; w1 is left of w2
(begin
;; w1 connects right to w2
(let ((s1 (hash-ref sections w1)))
(hash-set! sections w1
(cons (car s1) (cons w2 (cdr s1)))))
;; w2 connects left to w1
(let ((s2 (hash-ref sections w2)))
(hash-set! sections w2
(cons (cons w1 (car s2)) (cdr s2)))))
;; w2 is left of w1
(begin
(let ((s2 (hash-ref sections w2)))
(hash-set! sections w2
(cons (car s2) (cons w1 (cdr s2)))))
(let ((s1 (hash-ref sections w1)))
(hash-set! sections w1
(cons (cons w2 (car s1)) (cdr s1))))))))
edges)
;; Convert to alist
(hash-map->list cons sections))))
;; ═══════════════════════════════════════════════════════════════════
;; ATOMSPACE SECTION STORAGE
;; ═══════════════════════════════════════════════════════════════════
(define *section-count-key* (Predicate "*-TruthValueKey-*"))
(define (store-section word left-connectors right-connectors)
"Store a Section in AtomSpace with count.
Section format:
(Section
(Word \"word\")
(ConnectorSeq
(Connector (Word \"left1\") (ConnectorDir \"-\"))
(Connector (Word \"right1\") (ConnectorDir \"+\"))))
"
(let* ((left-conns (map (lambda (w)
(Connector (Word w) (ConnectorDir "-")))
left-connectors))
(right-conns (map (lambda (w)
(Connector (Word w) (ConnectorDir "+")))
right-connectors))
(all-conns (append left-conns right-conns))
(section (if (null? all-conns)
#f ; No section for isolated words
(Section
(Word word)
(apply ConnectorSeq all-conns)))))
(when section
;; Increment count: (cog-inc-value! atom key index increment)
(cog-inc-value! section *section-count-key* 0 1))))
;; ═══════════════════════════════════════════════════════════════════
;; MAIN PARSER
;; ═══════════════════════════════════════════════════════════════════
(define (tokenize text)
"Simple tokenizer: lowercase, split on whitespace, remove punctuation."
(let* ((lower (string-downcase text))
(cleaned (string-map
(lambda (c)
(if (or (char-alphabetic? c) (char-whitespace? c))
c
#\space))
lower))
(words (string-split cleaned #\space)))
(filter (lambda (w) (> (string-length w) 0)) words)))
(define (mst-parse-sentence text)
"Parse a sentence using MST, extract and store Sections.
Returns the MST edges.
"
(let* ((words (tokenize text))
(edges (prim-mst words))
(sections (edges-to-sections words edges)))
;; Store sections in AtomSpace
(for-each
(lambda (s)
(let ((word (car s))
(left (car (cdr s)))
(right (cdr (cdr s))))
(store-section word left right)))
sections)
edges))
(define (mst-parse-batch sentences)
"Parse multiple sentences, return total edges and sections count."
(let ((total-edges 0)
(total-sections 0))
(for-each
(lambda (text)
(let* ((words (tokenize text))
(edges (prim-mst words))
(sections (edges-to-sections words edges)))
(set! total-edges (+ total-edges (length edges)))
(set! total-sections (+ total-sections (length sections)))
;; Store sections
(for-each
(lambda (s)
(store-section (car s) (cadr s) (cddr s)))
sections)))
sentences)
(cons total-edges total-sections)))
;; ═══════════════════════════════════════════════════════════════════
;; TESTING
;; ═══════════════════════════════════════════════════════════════════
(define (test-mst-parser)
"Quick test of MST parser."
(display "\n═══ MST Parser Test ═══\n\n")
;; Test tokenizer
(display "Tokenizer test:\n")
(let ((tokens (tokenize "The quick, brown fox!")))
(format #t " Input: \"The quick, brown fox!\"\n")
(format #t " Tokens: ~a\n\n" tokens))
;; Test MST on small graph (without MI lookup)
(display "Prim's MST test (mock MI):\n")
(let ((words '("the" "cat" "sat")))
(format #t " Words: ~a\n" words)
(let ((edges (prim-mst words)))
(format #t " MST edges: ~a\n\n" edges)))
;; Test section extraction
(display "Section extraction test:\n")
(let* ((words '("the" "cat" "sat" "down"))
(edges '(("the" . "cat") ("cat" . "sat") ("sat" . "down")))
(sections (edges-to-sections words edges)))
(format #t " Words: ~a\n" words)
(format #t " Edges: ~a\n" edges)
(format #t " Sections:\n")
(for-each
(lambda (s)
(format #t " ~a: left=~a right=~a\n"
(car s) (cadr s) (cddr s)))
sections))
(display "\n═══ Test Complete ═══\n"))
;; ═══════════════════════════════════════════════════════════════════
;; BENCHMARK
;; ═══════════════════════════════════════════════════════════════════
(define (benchmark-mst-parser n-sentences)
"Benchmark MST parser speed."
(display "\n═══ MST Parser Benchmark ═══\n\n")
(let* ((test-sentences
'("the cat sat on the mat"
"a quick brown fox jumps over the lazy dog"
"machine learning algorithms process large datasets"
"the weather forecast predicts rain tomorrow"
"students study mathematics and science"))
(start-time (current-time)))
;; Parse n-sentences worth
(let loop ((i 0))
(when (< i n-sentences)
(mst-parse-sentence (list-ref test-sentences
(modulo i (length test-sentences))))
(loop (+ i 1))))
(let ((elapsed (- (current-time) start-time)))
(format #t "Parsed ~a sentences in ~a seconds\n" n-sentences elapsed)
(if (> elapsed 0)
(format #t "Rate: ~,1f sentences/second\n"
(/ n-sentences elapsed))
(display "Rate: too fast to measure (< 1 second)\n"))
elapsed)))
;; Export public functions
(export get-mi-value)
(export prim-mst)
(export edges-to-sections)
(export mst-parse-sentence)
(export mst-parse-batch)
(export test-mst-parser)
(export benchmark-mst-parser)