gram.scm

(load "mk-vicare.scm")
(load "mk.scm")

;; ============================================================
;; Portable helpers (replacing racket/list)
;; ============================================================

(define (last lst)
  (if (null? (cdr lst))
      (car lst)
      (last (cdr lst))))

(define (drop-right lst n)
  (let loop ((lst lst) (len (- (length lst) n)) (acc '()))
    (if (zero? len)
        (reverse acc)
        (loop (cdr lst) (- len 1) (cons (car lst) acc)))))

(define (foldr f init lst)
  (if (null? lst)
      init
      (f (car lst) (foldr f init (cdr lst)))))

;; ============================================================
;; Rule Registry (for grammar rules / RTN support)
;; ============================================================

(define *rules* '())

(define (define-rule name pattern)
  (set! *rules* (cons (cons name pattern) *rules*)))

(define (lookup-rule name)
  (let ((entry (assq name *rules*)))
    (if entry (cdr entry)
        (error 'lookup-rule "unknown rule" name))))

(define (clear-rules!)
  (set! *rules* '()))

;; ============================================================
;; Regex Constructors (syntax sugar)
;; ============================================================

;; lit: single char or string -> nested cats of single chars
(define (lit x)
  (cond
    ((char? x) `(lit ,x))
    ((string? x)
     (let ((chars (string->list x)))
       (if (= (length chars) 1)
           `(lit ,(car chars))
           (foldr (lambda (c acc) `(cat (lit ,c) ,acc))
                  `(lit ,(last chars))
                  (drop-right chars 1)))))
    (else (error 'lit "expected char or string"))))

;; cat: variadic -> right-associative binary cats
(define (cat . rs)
  (cond
    ((null? rs) (error 'cat "need at least one regex"))
    ((null? (cdr rs)) (car rs))
    ((null? (cddr rs)) `(cat ,(car rs) ,(cadr rs)))
    (else `(cat ,(car rs) ,(apply cat (cdr rs))))))

;; alt: variadic -> right-associative binary alts
(define (alt . rs)
  (cond
    ((null? rs) (error 'alt "need at least one regex"))
    ((null? (cdr rs)) (car rs))
    ((null? (cddr rs)) `(alt ,(car rs) ,(cadr rs)))
    (else `(alt ,(car rs) ,(apply alt (cdr rs))))))

;; opt: optional
(define (opt r) `(opt ,r))

;; rep: one or more
(define (rep r) `(rep ,r))

;; rep*: zero or more (sugar for (opt (rep r)))
(define (rep* r) `(opt (rep ,r)))

;; sym: reference a named rule
(define (sym name) `(sym ,name))

;; ============================================================
;; set: byte-range character matching
;; ============================================================

;; byte-in-ranges?: check if an integer falls within any (lo . hi) range
(define (byte-in-ranges? b ranges)
  (and (not (null? ranges))
       (or (let ((lo (caar ranges))
                 (hi (cdar ranges)))
             (and (>= b lo) (<= b hi)))
           (byte-in-ranges? b (cdr ranges)))))

;; set: construct a set node from ranges
;; Each range is either (lo . hi) or a single integer (treated as a point)
(define (set . ranges)
  (let ((normalized
          (map (lambda (r)
                 (if (pair? r) r (cons r r)))
               ranges)))
    `(set ,@normalized)))

;; Named character classes (set based)
(define (digit) (set '(48 . 57)))
(define (lower) (set '(97 . 122)))
(define (upper) (set '(65 . 90)))
(define (alpha) (set '(65 . 90) '(97 . 122)))
(define (alnum) (set '(48 . 57) '(65 . 90) '(97 . 122)))
(define (blank) (set '(9 . 10) '(13 . 13) '(32 . 32)))
(define (any)   (set '(9 . 10) '(13 . 13) '(32 . 126)))

;; ============================================================
;; Regex Matching (matcho)
;; ============================================================

;; membero: relational list membership
(defrel (membero x lst)
  (fresh (h t)
    (== lst (cons h t))
    (conde
      ((== x h))
      ((membero x t)))))

;; matcho : regex × input × rest × visited → goal
;; Relates a regex to an input string (list of chars) and remainder
;; visited: list of (rule-name . input) pairs for cycle detection
(defrel (matcho regex input rest visited)
  (conde
    ;; lit: match a single character
    ((fresh (c)
       (== regex `(lit ,c))
       (== input (cons c rest))))

    ;; set: match a byte in any of the ranges
    ((fresh (ranges c)
       (== regex `(set . ,ranges))
       (== input (cons c rest))
       (project (c ranges)
         (if (or (var? c) (var? ranges))
             fail  ; can't check ranges with unbound variables
             (if (and (char? c) (byte-in-ranges? (char->integer c) ranges))
                 succeed
                 fail)))))

    ;; cat: sequencing - thread remainder through
    ((fresh (r1 r2 mid)
       (== regex `(cat ,r1 ,r2))
       (matcho r1 input mid visited)
       (matcho r2 mid rest visited)))

    ;; alt: choice
    ((fresh (r1 r2)
       (== regex `(alt ,r1 ,r2))
       (conde
         ((matcho r1 input rest visited))
         ((matcho r2 input rest visited)))))

    ;; opt: zero or one
    ((fresh (r)
       (== regex `(opt ,r))
       (conde
         ((matcho r input rest visited))
         ((== input rest)))))

    ;; rep: one or more
    ((fresh (r mid)
       (== regex `(rep ,r))
       (matcho r input mid visited)
       (conde
         ((matcho regex mid rest visited))
         ((== mid rest)))))

    ;; sym: reference another rule with cycle detection
    ;; Note: only works when name is ground (not during synthesis)
    ((fresh (name)
       (== regex `(sym ,name))
       (project (name input visited)
         (if (or (var? name) (var? input))
             fail  ; can't process sym with unbound variables
             (let ((key (cons name input)))
               (if (member key visited)
                   fail  ; cycle: same rule at same position
                   (let ((pattern (lookup-rule name)))
                     (matcho pattern input rest (cons key visited)))))))))))

;; not-matcho: regex must NOT match input
(define (not-matcho regex input)
  (project (regex input)
    (if (null? (run 1 (q) (matcho regex input '() '())))
        succeed
        fail)))

;; Helper: match entire string
(defrel (full-matcho regex str)
  (matcho regex str '() '()))

;; Convenience wrapper for parsing with rules (full match — rest must be empty)
(define (parse rule-name str)
  (run 1 (q) (matcho (sym rule-name) (string->list str) '() '())))

(define (parse? rule-name str)
  (not (null? (parse rule-name str))))

;; ============================================================
;; Reducer Abstraction
;; ============================================================

;; A reducer is: (node-type matched-input children) -> result
;; - Tree builder: constructs CST nodes
;; - Identity: just returns matched text (current behavior)

(define (make-tree-reducer)
  (lambda (node-type matched children)
    `(,node-type ,@children)))

(define (make-identity-reducer)
  (lambda (node-type matched children)
    matched))

;; parseo: grammar × input × rest × output × reducer × visited → goal
;; Like matcho but also produces structured output via the reducer.
;; The output is a list of "pieces" — either chars or sub-tree results.
(defrel (parseo regex input rest output reducer visited)
  (conde
    ;; lit: match a single character — output is the char
    ((fresh (c)
       (== regex `(lit ,c))
       (== input (cons c rest))
       (== output (list c))))

    ;; set: match a byte in any of the ranges
    ((fresh (ranges c)
       (== regex `(set . ,ranges))
       (== input (cons c rest))
       (== output (list c))
       (project (c ranges)
         (if (or (var? c) (var? ranges))
             fail  ; can't check ranges with unbound variables
             (if (and (char? c) (byte-in-ranges? (char->integer c) ranges))
                 succeed
                 fail)))))

    ;; cat: sequencing — collect outputs from both sides
    ((fresh (r1 r2 mid o1 o2)
       (== regex `(cat ,r1 ,r2))
       (parseo r1 input mid o1 reducer visited)
       (parseo r2 mid rest o2 reducer visited)
       (project (o1 o2)
         (== output (append o1 o2)))))

    ;; alt: choice — output from whichever branch matches
    ((fresh (r1 r2)
       (== regex `(alt ,r1 ,r2))
       (conde
         ((parseo r1 input rest output reducer visited))
         ((parseo r2 input rest output reducer visited)))))

    ;; opt: zero or one
    ((fresh (r)
       (== regex `(opt ,r))
       (conde
         ((parseo r input rest output reducer visited))
         ((== input rest)
          (== output '())))))

    ;; rep: one or more
    ((fresh (r mid o1 o2)
       (== regex `(rep ,r))
       (parseo r input mid o1 reducer visited)
       (conde
         ((fresh (o-rest)
            (parseo regex mid rest o-rest reducer visited)
            (project (o1 o-rest)
              (== output (append o1 o-rest)))))
         ((== mid rest)
          (== output o1)))))

    ;; sym: reference another rule — apply reducer at boundary
    ((fresh (name)
       (== regex `(sym ,name))
       (project (name input visited reducer)
         (if (or (var? name) (var? input))
             fail
             (let ((key (cons name input)))
               (if (member key visited)
                   fail
                   (let ((pattern (lookup-rule name)))
                     (fresh (sub-output)
                       (parseo pattern input rest sub-output reducer
                               (cons key visited))
                       (project (sub-output rest)
                         (let* ((n (- (length input) (length rest)))
                                (consumed (let take ((in input) (k n))
                                            (if (zero? k) '()
                                                (cons (car in)
                                                      (take (cdr in) (- k 1))))))
                                (matched (list->string consumed))
                                (result (reducer name matched sub-output)))
                           (== output (list result))))))))))))))

;; full-parseo: match entire string and produce output
(defrel (full-parseo regex str output reducer)
  (parseo regex str '() output reducer '()))