hypercore-kb / opencog-kb / language-learning / mvp / run-mst-parsing.scm

;
; run-mst-parsing.scm -- MST Parsing step only
;
; Runs MST parsing on corpus to extract Sections.
; Assumes MI is already computed (run after Phase 2 MI step).
;
; Usage:
;   guile -s run-mst-parsing.scm
;

(use-modules (ice-9 format))
(use-modules (ice-9 textual-ports))
(use-modules (ice-9 ftw))
(use-modules (srfi srfi-1))

(use-modules (opencog) (opencog exec) (opencog persist) (opencog persist-rocks))
(use-modules (opencog lg))
(use-modules (opencog matrix))

; ═══════════════════════════════════════════════════════════════════
; TYPE ALIASES - MUST be before (opencog learn)
; ═══════════════════════════════════════════════════════════════════
(define (ParseNode name) (Anchor (string-append "parse:" name)))
(define (SentenceNode name) (Anchor (string-append "sentence:" name)))

(module-define! (resolve-module '(opencog lg)) 'ParseNode ParseNode)
(module-define! (resolve-module '(opencog lg)) 'SentenceNode SentenceNode)

;; NOW load learn
(use-modules (opencog learn))

; ═══════════════════════════════════════════════════════════════════
; CONFIGURATION
; ═══════════════════════════════════════════════════════════════════

(define *rocks-path* "rocks://data/pairs.rdb")
(define *corpus-dir* "corpus")

; ═══════════════════════════════════════════════════════════════════
; TEXT CORPUS READER
; ═══════════════════════════════════════════════════════════════════

(define (strip-gutenberg-header text)
  "Remove Project Gutenberg header/footer boilerplate."
  (let* ((start-marker "*** START OF THE PROJECT GUTENBERG EBOOK")
         (end-marker "*** END OF THE PROJECT GUTENBERG EBOOK")
         (start-pos (string-contains text start-marker))
         (end-pos (string-contains text end-marker)))
    (if start-pos
      (let ((after-header (substring text
              (+ start-pos (string-length start-marker)))))
        (let ((newline-pos (string-index after-header #\newline)))
          (if newline-pos
            (let ((body (substring after-header (+ newline-pos 1))))
              (if end-pos
                (let ((adjusted-end (- end-pos start-pos
                        (string-length start-marker) newline-pos 1)))
                  (if (> adjusted-end 0)
                    (substring body 0 (min adjusted-end (string-length body)))
                    body))
                body))
            after-header)))
      text)))

(define (read-corpus-text dir)
  "Read all .txt files from DIR, return concatenated text as blocks."
  (let* ((entries (scandir dir
                    (lambda (f) (string-suffix? ".txt" f))))
         (blocks '()))
    (for-each
      (lambda (filename)
        (let* ((path (string-append dir "/" filename))
               (text (call-with-input-file path get-string-all))
               (body (strip-gutenberg-header text)))
          (format #t "  ~a: ~a chars\n" filename (string-length body))
          (set! blocks (cons body blocks))))
      entries)
    (reverse blocks)))

; ═══════════════════════════════════════════════════════════════════
; MAIN
; ═══════════════════════════════════════════════════════════════════

(define (run-mst-parsing)
  (display "═══ MST Parsing Step ═══\n\n")
  (define start-time (car (gettimeofday)))

  ;; Open database
  (display "Opening database...\n")
  (define rsn (RocksStorageNode *rocks-path*))
  (cog-open rsn)

  ;; Load pairs (needed for MI lookup during parsing)
  (display "\nLoading word pairs (for MI lookup)...\n")
  (define ala (make-any-link-api))
  (define aca (add-count-api ala))
  (define asa (add-pair-stars aca))
  (asa 'fetch-pairs)
  (format #t "  Loaded ~a edges.\n" (cog-count-atoms 'Edge))

  ;; Check MI is present
  (display "\nVerifying MI values...\n")
  (print-matrix-summary-report asa)

  ;; Create MST observer
  (display "\nCreating MST observer...\n")
  (define mst-observer (make-block-mpg-pipe-observer))

  ;; Read and parse corpus
  (display "\nLoading corpus...\n")
  (let ((text-blocks (read-corpus-text *corpus-dir*))
        (block-count 0)
        (total-chars 0))

    (format #t "  Loaded ~a text blocks.\n\n" (length text-blocks))

    (display "Parsing corpus with MST...\n")
    (for-each
      (lambda (text-block)
        (set! block-count (+ block-count 1))
        (set! total-chars (+ total-chars (string-length text-block)))
        (format #t "  Block ~a/~a (~a chars, ~a total)...\n"
                block-count (length text-blocks)
                (string-length text-block) total-chars)
        (force-output)
        ;; MST parse the block
        (mst-observer text-block))
      text-blocks)

    (format #t "\n  Parsed ~a blocks, ~a total chars.\n" block-count total-chars))

  ;; Report Sections created
  (let ((num-sections (cog-count-atoms 'Section)))
    (format #t "\n  Sections created: ~a\n" num-sections))

  ;; Compute Section marginals
  (display "\nComputing Section marginals...\n")
  (define pca (make-pseudo-cset-api))
  (define psa (add-pair-stars pca))
  (psa 'fetch-pairs)

  (let ((num-sections (length (psa 'get-all-elts))))
    (when (> num-sections 0)
      (let ((btr (batch-transpose psa)))
        (btr 'mmt-marginals))
      (display "  Marginals computed.\n")
      (print-matrix-summary-report psa)))

  ;; Save
  (display "\nSaving to RocksDB...\n")
  (barrier rsn)

  (let ((elapsed (- (car (gettimeofday)) start-time)))
    (format #t "\n═══ MST Parsing Complete ═══\n")
    (format #t "Time: ~,1f minutes (~a seconds)\n" (/ elapsed 60.0) elapsed))

  (cog-close rsn)
  (display "Done.\n"))

(run-mst-parsing)