;;
;; gpu-pmfg.scm -- GPU-accelerated PMFG for linguistic analysis
;;
;; Integrates pmfg-kernel.cl with atomese-simd OpenclNode.
;;
;; Key insight: Linguistic "planarity" = no crossing dependencies
;; in linear word order. Much simpler than general graph planarity!
;;
(use-modules (srfi srfi-1))
(use-modules (opencog) (opencog exec))
(use-modules (opencog sensory) (opencog opencl))
(use-modules (opencog persist))
(use-modules (opencog lg))
;; ═══════════════════════════════════════════════════════════════════
;; GPU STATE
;; ═══════════════════════════════════════════════════════════════════
(define *pmfg-gpu-node* #f)
(define *pmfg-kernel-path* "pmfg-kernel.cl")
(define *pmfg-gpu-enabled* #f)
;; ═══════════════════════════════════════════════════════════════════
;; INITIALIZATION
;; ═══════════════════════════════════════════════════════════════════
(define (init-pmfg-gpu!)
"Initialize GPU for PMFG computation."
(display "Initializing GPU for PMFG...\n")
(catch #t
(lambda ()
;; Copy kernel to /tmp (required by atomese-simd)
(copy-file *pmfg-kernel-path* "/tmp/pmfg-kernel.cl")
;; Create OpenCL node
(set! *pmfg-gpu-node* (OpenclNode "opencl://:/tmp/pmfg-kernel.cl"))
;; Open device with FloatValue output
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-open-*") (Type 'FloatValue)))
(set! *pmfg-gpu-enabled* #t)
(display "PMFG GPU initialized.\n")
*pmfg-gpu-node*)
(lambda (key . args)
(format #t "GPU init failed: ~a ~a\n" key args)
(set! *pmfg-gpu-enabled* #f)
#f)))
(define (close-pmfg-gpu!)
"Release GPU resources."
(when *pmfg-gpu-node*
(catch #t
(lambda ()
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-close-*") (List)))
(set! *pmfg-gpu-enabled* #f)
(display "PMFG GPU closed.\n"))
(lambda (key . args)
(format #t "GPU close error: ~a\n" key)))))
(define (pmfg-gpu-status)
"Check PMFG GPU status."
(format #t "PMFG GPU enabled: ~a\n" *pmfg-gpu-enabled*)
(when *pmfg-gpu-enabled*
(format #t "GPU device: ~a\n"
(cog-value *pmfg-gpu-node* (Predicate "*-description-*"))))
*pmfg-gpu-enabled*)
;; ═══════════════════════════════════════════════════════════════════
;; VOCABULARY MANAGEMENT
;; ═══════════════════════════════════════════════════════════════════
;; Word to index mapping
(define *word-to-index* (make-hash-table))
(define *index-to-word* (make-hash-table))
(define *vocab-size* 0)
(define (build-vocabulary! words)
"Build word-to-index mapping from list of words."
(set! *word-to-index* (make-hash-table))
(set! *index-to-word* (make-hash-table))
(let loop ((ws words) (idx 0))
(if (null? ws)
(begin
(set! *vocab-size* idx)
(format #t "Vocabulary built: ~a words\n" idx))
(let ((w (car ws)))
(unless (hash-ref *word-to-index* w)
(hash-set! *word-to-index* w idx)
(hash-set! *index-to-word* idx w)
(loop (cdr ws) (+ idx 1)))
(loop (cdr ws) idx)))))
(define (word->index word)
"Get index for word, -1 if unknown."
(or (hash-ref *word-to-index* word) -1))
(define (index->word idx)
"Get word for index."
(hash-ref *index-to-word* idx))
;; ═══════════════════════════════════════════════════════════════════
;; MI MATRIX MANAGEMENT
;; ═══════════════════════════════════════════════════════════════════
(define *mi-matrix-anchor* (Anchor "PMFG MI Matrix"))
(define *mi-matrix-key* (Predicate "mi-matrix"))
(define (build-mi-matrix! llobj)
"Build flattened MI matrix from pair matrix API."
(display "Building MI matrix for GPU...\n")
;; Get all pairs and build vocabulary
(define pairs (llobj 'get-all-elts))
(define all-words '())
;; Collect all words
(for-each
(lambda (pair)
(let* ((left-right (cog-outgoing-set (cog-outgoing-atom pair 1)))
(left-word (cog-name (car left-right)))
(right-word (cog-name (cadr left-right))))
(set! all-words (cons left-word all-words))
(set! all-words (cons right-word all-words))))
pairs)
;; Build vocabulary
(build-vocabulary! (delete-duplicates all-words))
;; Create flattened MI matrix (vocab_size × vocab_size)
(define matrix-size (* *vocab-size* *vocab-size*))
(define mi-values (make-list matrix-size 0.0))
;; Fill in MI values
(define count 0)
(for-each
(lambda (pair)
(let* ((left-right (cog-outgoing-set (cog-outgoing-atom pair 1)))
(left-word (cog-name (car left-right)))
(right-word (cog-name (cadr left-right)))
(left-idx (word->index left-word))
(right-idx (word->index right-word))
(mi-val (cog-value pair (Predicate "*-Mutual Info Key-*"))))
(when (and mi-val (>= left-idx 0) (>= right-idx 0))
(let ((mi (cog-value-ref mi-val 0))
(idx1 (+ (* left-idx *vocab-size*) right-idx))
(idx2 (+ (* right-idx *vocab-size*) left-idx)))
;; Set both directions (symmetric)
(list-set! mi-values idx1 mi)
(list-set! mi-values idx2 mi)
(set! count (+ count 1))))))
pairs)
(format #t "MI matrix built: ~a × ~a (~a non-zero)\n"
*vocab-size* *vocab-size* count)
;; Store as FloatValue
(cog-set-value! *mi-matrix-anchor* *mi-matrix-key*
(apply FloatValue mi-values))
count)
;; ═══════════════════════════════════════════════════════════════════
;; PMFG PARSING
;; ═══════════════════════════════════════════════════════════════════
(define (pmfg-parse-sentence-gpu words)
"Parse sentence using GPU PMFG.
words: list of word strings
Returns: list of edges ((pos1 . pos2) ...)
"
(unless *pmfg-gpu-enabled*
(error "GPU not initialized. Call (init-pmfg-gpu!) first."))
(let* ((n (length words))
(word-indices (map word->index words))
(max-edges (* 3 n -6)))
(if (< n 2)
'() ; No edges for < 2 words
;; Set up data for GPU
(let* ((word-arr (apply FloatValue (map exact->inexact word-indices)))
(n-words-arr (FloatValue (exact->inexact n)))
(edges-out (apply FloatValue (make-list (* max-edges 2) 0.0)))
(n-edges-out (FloatValue 0.0)))
;; Anchor data
(cog-set-value! (Anchor "pmfg-input") (Predicate "words") word-arr)
(cog-set-value! (Anchor "pmfg-input") (Predicate "n-words") n-words-arr)
(cog-set-value! (Anchor "pmfg-output") (Predicate "edges") edges-out)
(cog-set-value! (Anchor "pmfg-output") (Predicate "n-edges") n-edges-out)
;; Run kernel
(cog-execute!
(SetValue *pmfg-gpu-node* (Predicate "*-write-*")
(Section
(Item "pmfg_single")
(ConnectorSeq
(ValueOf *mi-matrix-anchor* *mi-matrix-key*)
(ValueOf (Anchor "pmfg-input") (Predicate "words"))
(ValueOf (Anchor "pmfg-input") (Predicate "n-words"))
(ValueOf (Anchor "pmfg-output") (Predicate "edges"))
(ValueOf (Anchor "pmfg-output") (Predicate "n-edges"))
(Number *vocab-size*)))))
;; Read result
(cog-execute! (ValueOf *pmfg-gpu-node* (Predicate "*-read-*")))
;; Extract edges
(let* ((result-edges (cog-execute!
(ValueOf (Anchor "pmfg-output") (Predicate "edges"))))
(result-n (cog-execute!
(ValueOf (Anchor "pmfg-output") (Predicate "n-edges"))))
(n-edges (inexact->exact (round (cog-value-ref result-n 0))))
(edge-list (cog-value->list result-edges)))
;; Convert to pairs
(let loop ((i 0) (edges '()))
(if (>= i n-edges)
(reverse edges)
(let ((pos1 (inexact->exact (round (list-ref edge-list (* i 2)))))
(pos2 (inexact->exact (round (list-ref edge-list (+ (* i 2) 1))))))
(loop (+ i 1) (cons (cons pos1 pos2) edges))))))))))
;; ═══════════════════════════════════════════════════════════════════
;; CPU FALLBACK (for comparison/testing)
;; ═══════════════════════════════════════════════════════════════════
(define (edges-cross? i j k l)
"Check if edges (i,j) and (k,l) cross in linear order."
(let ((i (min i j)) (j (max i j))
(k (min k l)) (l (max k l)))
(or (and (< i k) (< k j) (< j l))
(and (< k i) (< i l) (< l j)))))
(define (pmfg-parse-sentence-cpu words mi-lookup)
"Parse sentence using CPU PMFG.
words: list of word strings
mi-lookup: procedure (word1 word2) -> MI value
Returns: list of edges ((pos1 . pos2) ...)
"
(let* ((n (length words))
(word-vec (list->vector words))
(max-edges (max 0 (- (* 3 n) 6))))
(if (< n 2)
'()
;; Build all pairs with MI
(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)
(cons (list (mi-lookup
(vector-ref word-vec i)
(vector-ref word-vec j))
i j)
ps))))))))
;; Sort by MI descending
(sorted-pairs (sort pairs (lambda (a b) (> (car a) (car b))))))
;; Greedy PMFG construction
(let loop ((remaining sorted-pairs) (edges '()) (n-edges 0))
(if (or (null? remaining) (>= n-edges max-edges))
(reverse edges)
(let* ((pair (car remaining))
(pos1 (cadr pair))
(pos2 (caddr pair))
(crosses? (any (lambda (e)
(edges-cross? pos1 pos2 (car e) (cdr e)))
edges)))
(if crosses?
(loop (cdr remaining) edges n-edges)
(loop (cdr remaining)
(cons (cons pos1 pos2) edges)
(+ n-edges 1))))))))))
;; ═══════════════════════════════════════════════════════════════════
;; SECTION EXTRACTION
;; ═══════════════════════════════════════════════════════════════════
(define (edges-to-sections words edges)
"Convert PMFG edges to Sections.
Returns: alist ((word . (left-connectors . right-connectors)) ...)
"
(let ((sections (make-hash-table)))
;; Initialize
(for-each (lambda (w) (hash-set! sections w (cons '() '()))) words)
;; Process edges
(for-each
(lambda (edge)
(let* ((pos1 (car edge))
(pos2 (cdr edge))
(w1 (list-ref words pos1))
(w2 (list-ref words pos2)))
(if (< pos1 pos2)
(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)))))
(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)
(hash-map->list cons sections)))
;; ═══════════════════════════════════════════════════════════════════
;; TESTING
;; ═══════════════════════════════════════════════════════════════════
(define (test-pmfg-cpu)
"Test CPU PMFG parser."
(display "\n═══ PMFG CPU Test ═══\n\n")
;; Mock MI lookup (higher MI for adjacent words)
(define (mock-mi w1 w2)
(let ((words '("the" "quick" "brown" "fox" "jumps")))
(let ((p1 (list-index (lambda (x) (string=? x w1)) words))
(p2 (list-index (lambda (x) (string=? x w2)) words)))
(if (and p1 p2)
(/ 10.0 (+ 1 (abs (- p1 p2)))) ; Higher for adjacent
0.0))))
(define words '("the" "quick" "brown" "fox" "jumps"))
(format #t "Words: ~a\n" words)
(define edges (pmfg-parse-sentence-cpu words mock-mi))
(format #t "PMFG edges: ~a\n" edges)
(format #t "Edge count: ~a (max: ~a)\n" (length edges) (- (* 3 (length words)) 6))
(define sections (edges-to-sections words edges))
(format #t "\nSections:\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"))
;; ═══════════════════════════════════════════════════════════════════
;; EXPORTS
;; ═══════════════════════════════════════════════════════════════════
(export init-pmfg-gpu!)
(export close-pmfg-gpu!)
(export pmfg-gpu-status)
(export build-vocabulary!)
(export build-mi-matrix!)
(export pmfg-parse-sentence-gpu)
(export pmfg-parse-sentence-cpu)
(export edges-to-sections)
(export test-pmfg-cpu)