Commits

Anonymous committed bb4d80c

Add hash-table and trie based memoization support

Comments (0)

Files changed (1)

  repeated zero-or-more one-or-more
  any-of all-of none-of none-of*
  preceded-by followed-by enclosed-by
- as-string)
+ as-string memoize memo-table)
 
 (import chicken scheme)
 
-(use data-structures lazy-seq srfi-1 srfi-14 extras)
+(use data-structures lazy-seq srfi-1 srfi-14 srfi-69 extras trie)
 
 (define ((result value) input)
   (cons value input))
            (lambda (binding)
              (sequence* (more-bindings ...) body ...))))))
 
-(define ((sequence parser . parsers) input)
-  (let loop ((parsers (args-list parser parsers))
-             (parts '())
-             (input input))
-    (if (null? parsers)
-        (cons (reverse parts) input)
-        (and-let* ((value ((car parsers) input)))
-          (loop (cdr parsers)
-                (cons (car value) parts)
-                (cdr value))))))
+(define (sequence parser . parsers)
+  (let ((parsers (args-list parser parsers)))
+    (lambda (input)
+      (let loop ((parsers parsers)
+                 (parts '())
+                 (input input))
+        (if (null? parsers)
+            (cons (reverse parts) input)
+            (and-let* ((value ((car parsers) input)))
+              (loop (cdr parsers)
+                    (cons (car value) parts)
+                    (cdr value))))))))
 
 (define ((char-seq str) input)
   (let ((len (string-length str)))
   (sequence* ((parts parser))
     (result (apply conc (remove boolean? (flatten parts))))))
 
+(define memo-table
+  (make-parameter #f))
+
+(define (lazy-seq-prefix from to)
+  (let loop ((from from))
+    (if (or (eq? from to) (lazy-null? from))
+        '()
+        (cons (lazy-head from)
+              (loop (lazy-tail from))))))
+
+(define (parser-memo-ref memo input)
+  (let loop ((memo memo)
+             (input input)
+             (length 1))
+    (and (not (lazy-null? input))
+         (and-let* ((memo  (trie-ref* memo (lazy-head input)))
+                    (value (trie-value memo)))
+           (if (null? value)
+               (loop memo (lazy-tail input) (+ 1 length))
+               (cons (car value) length))))))
+
+(define (memo-ref parser input)
+  (and-let* ((parser-memo (hash-table-ref/default (memo-table) parser #f))
+             (result (parser-memo-ref parser-memo input)))
+    (cons (car result)
+          (let loop ((n (cdr result)) (input input))
+            (if (zero? n)
+                input
+                (loop (- n 1) (lazy-tail input)))))))
+
+(define (memo-set! parser input)
+  (and-let* ((result (parser input)))
+    (hash-table-update! (memo-table)
+                        parser
+                        (lambda (memo)
+                          (trie-insert! memo
+                                        (lazy-seq-prefix input (cdr result))
+                                        (car result))
+                          memo)
+                        make-trie)
+    result))
+
+(define ((memoize parser) input)
+  (if (memo-table)
+      (or (memo-ref parser input)
+          (memo-set! parser input))
+      (parser input)))
+
 (define (->lazy-seq x)
   (cond ((lazy-seq? x) x)
         ((string? x) (list->lazy-seq (string->list x)))
         ((input-port? x) (input-port->lazy-seq x read-char))
         (else (error "Don't know how to turn object into lazy-seq" x))))
 
-(define (parse parser input)
-  (let* ((input (->lazy-seq input))
-         (result (parser (->lazy-seq input))))
-    (if result
-        (values (car result) (cdr result))
-        (values result input))))
+(define (parse parser input #!key memoize)
+  (parameterize ((memo-table (if memoize (make-hash-table) (memo-table))))
+    (let* ((input (->lazy-seq input))
+           (result (parser (->lazy-seq input))))
+      (if result
+          (values (car result) (cdr result))
+          (values result input)))))
 
 )