demo.scm

(load "gram.scm")
(load "tree.scm")
(load "phog.scm")

;; ============================================================
;; DEMO 1: Relational regex matching — works forwards AND backwards
;; ============================================================

(printf "\n=== DEMO 1: Relational regex matching ===\n\n")

;; Forward: does "hello" match (rep lower)?
(printf "Does 'hello' match (rep lower)? ~a\n"
  (not (null? (run 1 (q) (full-matcho (rep (lower)) (string->list "hello"))))))

;; Backward: GENERATE strings that match a pattern
(printf "\nGenerate strings matching 'ab' then 'c' or 'd':\n")
(for-each
  (lambda (chars) (printf "  ~a\n" (list->string chars)))
  (run* (s) (full-matcho (cat (lit "ab") (alt (lit "c") (lit "d"))) s)))

(printf "\nGenerate up to 5 strings matching '(' then 1+ of 'x' then ')':\n")
(for-each
  (lambda (chars) (printf "  ~a\n" (list->string chars)))
  (run 5 (s) (full-matcho (cat (lit "(") (cat (rep (lit "x")) (lit ")"))) s)))

;; Generate strings matching (alt (lit "yes") (lit "no"))
(printf "\nGenerate strings matching (alt 'yes' 'no'):\n")
(for-each
  (lambda (chars) (printf "  ~a\n" (list->string chars)))
  (run* (s) (full-matcho (alt (lit "yes") (lit "no")) s)))

;; ============================================================
;; DEMO 2: Grammar rules — define and parse
;; ============================================================

(printf "\n=== DEMO 2: Grammar rules ===\n\n")

(clear-rules!)
(define-rule 'digit-str (rep (digit)))
(define-rule 'sign (alt (lit "+") (lit "-")))
(define-rule 'integer (cat (opt (sym 'sign)) (sym 'digit-str)))

(printf "parse? integer '+42':  ~a\n" (parse? 'integer "+42"))
(printf "parse? integer '-7':   ~a\n" (parse? 'integer "-7"))
(printf "parse? integer '100':  ~a\n" (parse? 'integer "100"))
(printf "parse? integer 'abc':  ~a\n" (parse? 'integer "abc"))

;; ============================================================
;; DEMO 3: parseo — structured output / CST building
;; ============================================================

(printf "\n=== DEMO 3: parseo — parse with CST output ===\n\n")

(printf "Parse '+42' as integer, tree output:\n")
(let ((results (run 1 (out)
                 (full-parseo (sym 'integer) (string->list "+42") out (make-tree-reducer)))))
  (for-each (lambda (r) (printf "  ~a\n" r)) results))

(printf "\nParse '100' as integer, tree output:\n")
(let ((results (run 1 (out)
                 (full-parseo (sym 'integer) (string->list "100") out (make-tree-reducer)))))
  (for-each (lambda (r) (printf "  ~a\n" r)) results))

;; ============================================================
;; DEMO 4: Learn a grammar from a corpus
;; ============================================================

(printf "\n=== DEMO 4: Learn grammar from corpus ===\n\n")

;; Corpus: simple arithmetic expressions as CSTs
(define arith-corpus
  (list
    '(expr (num "43") (*token* plus "+") (num "2"))
    '(expr (num "1") (*token* minus "-") (num "99"))
    '(expr (num "7"))
    '(expr (num "100") (*token* plus "+") (num "200"))
    '(expr (num "5") (*token* plus "+") (num "3"))
    '(expr (num "10") (*token* minus "-") (num "1"))))

;; Bind at top-level so later demos can reference them
(define arith-phog-table #f)
(define arith-pattern-table #f)

(let-values (((pt pp) (extract-phog-stats arith-corpus)))
  (set! arith-phog-table pt)
  (set! arith-pattern-table pp)
  (let ((grammar (learn-grammar arith-corpus pt 10 pp)))
    (printf "Learned grammar:\n")
    (print-grammar grammar)

    ;; Parse corpus examples
    (printf "\nParsing corpus examples:\n")
    (for-each
      (lambda (text)
        (printf "  parse? expr ~a: ~a\n" text (parse? 'expr text)))
      '("43+2" "1-99" "7" "100+200"))

    ;; Generalization: unseen expressions
    (printf "\nGeneralization to unseen inputs:\n")
    (for-each
      (lambda (text)
        (printf "  parse? expr ~a: ~a\n" text (parse? 'expr text)))
      '("999+1" "0-0" "42" "55+55"))

    ;; Rejects invalid inputs
    (printf "\nRejects invalid inputs:\n")
    (for-each
      (lambda (text)
        (printf "  parse? expr ~a: ~a\n" text (parse? 'expr text)))
      '("abc" "+42" "1+" "999a" ""))))

;; ============================================================
;; DEMO 5: Learn a more complex grammar — let statements
;; ============================================================

(printf "\n=== DEMO 5: Let-statement grammar ===\n\n")

(define let-corpus
  (list
    '(program
       (let-stmt (*token* let-kw "let") " " (ident "x") " = " (expr (num "42")))
       ";\n"
       (let-stmt (*token* let-kw "let") " " (ident "y") " = "
                 (expr (num "1") (*token* plus "+") (num "2"))))
    '(program
       (let-stmt (*token* let-kw "let") " " (ident "foo") " = " (expr (num "7"))))))

(let-values (((phog-table pattern-table) (extract-phog-stats let-corpus)))
  (let ((grammar (learn-grammar let-corpus phog-table 10 pattern-table)))
    (printf "Learned grammar:\n")
    (print-grammar grammar)

    (printf "\nParsing:\n")
    (for-each
      (lambda (text)
        (printf "  parse? let-stmt ~a: ~a\n" text (parse? 'let-stmt text)))
      '("let x = 42" "let foo = 7" "let z = 99" "let abc = 1+2"))

    ;; Structural verification
    (printf "\nStructural verification:\n")
    (let ((results (verify-grammar-structural let-corpus)))
      (print-structural-verification results))))

;; ============================================================
;; DEMO 6: PHOG statistics — see what the model learns
;; ============================================================

(printf "\n=== DEMO 6: PHOG statistics ===\n\n")

;; What does the model think comes at position 1 of expr (after num)?
(printf "P(child | expr, pos=1, parent=#f, gp=#f, lsib=num):\n")
(let ((probs (phog-lookup arith-phog-table 'expr '(expr 1 #f #f num))))
  (for-each
    (lambda (p) (printf "  ~a: ~a\n" (car p) (exact->inexact (cdr p))))
    probs))

;; What about position 0?
(printf "\nP(child | expr, pos=0, parent=#f, gp=#f, lsib=#f):\n")
(let ((probs (phog-lookup arith-phog-table 'expr '(expr 0 #f #f #f))))
  (for-each
    (lambda (p) (printf "  ~a: ~a\n" (car p) (exact->inexact (cdr p))))
    probs))

;; ============================================================
;; DEMO 7: condp-budgeted — biased search
;; ============================================================

(printf "\n=== DEMO 7: Biased search with condp-budgeted ===\n\n")

;; Two branches: 'common' has many options, 'rare' has many too.
;; With conde they interleave 1:1. With condp-budgeted 3:1, common dominates.
(printf "conde (fair interleave) first 10:\n  ~a\n"
  (run 10 (q)
    (conde
      ((membero q '(c1 c2 c3 c4 c5 c6 c7 c8)))
      ((membero q '(r1 r2 r3 r4 r5 r6 r7 r8))))))

(printf "\ncondp-budgeted (3:1 bias) first 10:\n  ~a\n"
  (run 10 (q)
    (condp-budgeted
      3 (lambda (st) ((membero q '(c1 c2 c3 c4 c5 c6 c7 c8)) st))
      1 (lambda (st) ((membero q '(r1 r2 r3 r4 r5 r6 r7 r8)) st)))))

;; ============================================================
;; DEMO 8: JSON corpus — tiered parallel search
;; ============================================================

(printf "\n=== DEMO 8: JSON — tiered parallel search ===\n\n")

(load "corpus-json.scm")

(printf "Corpus: ~a trees, ~a nonterminal types\n\n" (length corpus) (length (cst-collect-types corpus)))

;; Show a few example trees (short ones)
(printf "Sample trees:\n")
(let ((short-trees (filter (lambda (t) (<= (string-length (cst->string t)) 30)) corpus)))
  (for-each
    (lambda (t) (printf "  ~s => ~a\n" (cst->string t) t))
    (if (> (length short-trees) 5) (list-head short-trees 5) short-trees)))

(printf "\nLearning grammar (tiered parallel search)...\n\n")
(let-values (((phog-table pattern-table) (extract-phog-stats corpus)))
  (let ((grammar (learn-grammar corpus phog-table 10 pattern-table)))
    (printf "\n~a rules learned:\n\n" (length grammar))
    (print-grammar grammar)

    ;; Spot-check short instances
    (printf "\nSpot-check parsing (short instances, <=15 chars):\n")
    (for-each
      (lambda (type-name)
        (let* ((instances (cst-collect-instances corpus type-name))
               (short (filter (lambda (inst) (<= (string-length (cst->string inst)) 15)) instances))
               (to-test (if (> (length short) 3) (list-head short 3) short)))
          (for-each
            (lambda (inst)
              (let* ((text (cst->string inst))
                     (ok (parse? type-name text)))
                (printf "  ~a ~s => ~a\n" type-name text (if ok "ok" "FAIL"))))
            to-test)))
      (cst-collect-types corpus))))

(printf "\n--- Done! ---\n")