Initial Commit

Makefile

@@ -0,0 +1,4 @@
+
+clean:
+	cleanup
+	rm -rf compiled

compaction.rkt

@@ -0,0 +1,104 @@
+;; Compaction
+
+
+; Nullability:
+(define/fix (nullable? l)
+  #:bottom #f
+  (match l
+    [(∅)           #f]
+    [(ε _)          #t]
+    [(token _)          #f]
+    [(★ _)           #t]
+    [(δ p)             (nullable? p)]
+    [(∪ l1 l2)       (or (nullable? l1) (nullable? l2))]
+    [(∘ l1 l2)       (and (nullable? l1) (nullable? l2))]
+    [(→ l1 _)        (nullable? l1)]))
+
+; Compute the size of a set:
+(define (set-size s)
+  (define size 0)
+  (for ([_ s])
+    (set! size (+ size 1)))
+  size)
+
+(define (singleton? s)
+  (eqv? (set-size s) 1))
+
+(define (set-choose s)
+  (define el #f)
+  (for ([el* s])
+    (set! el el*))
+  el)
+
+; Checks whether a language is the empty string:
+(define/fix (is-null? l)
+  #:bottom #t
+  (match l
+    [(∅)          #f]
+    [(ε _)         #t]    
+    [(token _)         #f]
+    [(∪ l1 l2)      (and (is-null? l1)  (is-null? l2))]
+    [(∘ l1 l2)      (and (is-null? l1)  (is-null? l2))]
+    [(★ l1)         (or (is-null? l1) (is-empty? l1))]
+    [(→ l1 _)       (is-null? l1)]))
+
+; Matches a language if it is *exactly* the empty string:
+(define-match-expander nullp
+  (syntax-rules ()
+    [(_)    (app is-null? #t)]
+    [(_ el) (and (app is-null? #t) (app parse-null (and (? singleton?) (app set-choose el))))]))
+
+; Checks whether a language is the empty set:
+(define/fix (is-empty? l)
+  #:bottom #t
+  (match l
+    [(∅)         #t]
+    [(ε _)        #f]    
+    [(token _)        #f]
+    [(★ l1)        #f]
+    [(∪ l1 l2)     (and (is-empty? l1)  (is-empty? l2))]
+    [(∘ l1 l2)     (or  (is-empty? l1)  (is-empty? l2))]
+    [(→ l1 _)      (is-empty? l1)]))
+
+(define-match-expander emptyp
+  (syntax-rules ()
+    [(_) (app is-empty? #t)]))
+
+
+
+;;;; Optimizations for the grammar:
+
+(define/memoize (compact [l #:eq])
+  (match l
+    [(∅)       (∅)]
+    [(ε S)      (ε S)]
+    [(emptyp)      (∅)]
+    [(nullp)       (ε (parse-null l))]
+    [(token _)      l]
+
+    [(★ (emptyp))  (ε (set '()))]
+    [(★ l)         (★ (compact l))]
+
+    [(∪ (emptyp) l2)  (compact l2)]
+    [(∪ l1 (emptyp))  (compact l1)]
+
+    [(∘ (nullp t) l2)  (→ (compact l2) (lambda (w2) (cons t w2)))]
+    [(∘ l1 (nullp t))  (→ (compact l1) (lambda (w1) (cons w1 t)))]
+
+    [(∪ l1 l2)  (∪ (compact l1) (compact l2))]
+    [(∘ l1 l2)  (∘ (compact l1) (compact l2))]
+
+    [(→ (and e (nullp)) f) 
+     ; =>
+     (ε (for/set ([t (parse-null e)]) (f t)))]
+
+    [(→ (∘ (nullp t) l2) f)
+     ; =>
+     (→ (compact l2) (lambda (w2) (f (cons t w2))))]
+
+    [(→ (→ l f) g) 
+     ; =>
+     (→ (compact l) (compose g f))]
+
+    [(→ l f)    (→ (compact l) f)]))
+

derp-core.rkt

@@ -0,0 +1,61 @@
+(module derp-core
+  racket
+
+  (require "memoization.rkt")
+  (require "fixed-points.rkt")
+  (require "lazy-structs.rkt")
+
+  (provide (all-defined-out))
+
+  ; Atomic parsers:
+  (define-struct ∅      {})           ; empty set
+  (define-struct ε      {tree-set})   ; empty string
+  (define-struct token  {value?})      ; token class
+
+  ; Compound parsers:
+  (define-lazy-struct δ {lang})
+  (define-lazy-struct ∪ {this that})
+  (define-lazy-struct ∘ {left right})
+  (define-lazy-struct ★ {lang})
+  (define-lazy-struct → {lang reduce})
+
+  ; Derivative:
+  (define/memoize (D c p)
+    #:order ([p #:eq] [c #:equal])
+    (match p
+      [(∅)           (∅)]
+      [(ε _)         (∅)]
+      [(δ _)         (∅)]
+      [(token p?)    (cond
+                       [(p? c) (ε (set c))]
+                       [else   (∅)])]
+
+      [(∪ p1 p2)     (∪ (D c p1) 
+                        (D c p2))]
+      [(★ p1)        (∘ (D c p1) p)]
+      [(→ p1 f)      (→ (D c p1) f)]
+      [(∘ p1 p2)     (∪ (∘ (δ p1) (D c p2))
+                        (∘ (D c p1) p2))]))
+
+  ; Parsing null:
+  (define/fix (parse-null p)
+    #:bottom (set)
+    (match p
+      [(ε S)        S]
+      [(∅)          (set)]
+      [(δ p)        (parse-null p)]
+      [(token _)    (set)]
+
+      [(★ _)        (set '())]
+      [(∪ p1 p2)    (set-union (parse-null p1) (parse-null p2))]
+      [(∘ p1 p2)    (for*/set ([t1 (parse-null p1)]
+                               [t2 (parse-null p2)])
+                              (cons t1 t2))]
+      [(→ p1 f)     (for/set ([t (parse-null p1)])
+                             (f t))]))
+
+  ; Parse a list of tokens:
+  (define (parse w p)
+    (if (null? w)
+        (parse-null p)
+        (parse (cdr w) (D (car w) p)))))

derp-optimize.rkt

@@ -0,0 +1,82 @@
+(module derp-optimize
+  racket
+
+  (provide (all-defined-out))
+
+  (require (except-in "derp-core.rkt" ∅? ε?))
+  (require "memoization.rkt")
+  (require "fixed-points.rkt")
+
+  (define/fix (ε? L)
+    #:bottom #t
+    (match L
+      [(∅)           #f]
+      [(ε _)         #t]    
+      [(token _)     #f]
+      [(∪ L1 L2)     (and (ε? L1) (ε? L2))]
+      [(∘ L1 L2)     (and (ε? L1) (ε? L2))]
+      [(★ L1)        (or  (ε? L1) (∅? L1))]
+      [(→ L1 _)      (ε?  L1)]))
+
+  ; Compute the size of a set:
+  (define (set-choose s)
+    (define el #f)
+    (for ([el* s])
+      (set! el el*))
+    el)
+
+  ; Matches a language if it is *exactly* the empty string:
+  (define-match-expander nullp
+    (syntax-rules ()
+      [(_)    (? ε?)]
+      [(_ el) (and (? ε?) 
+                   (app parse-null (and (app set-count 1) 
+                                        (app set-choose el))))]))
+
+  ; Checks whether a language is the empty set:
+  (define/fix (∅? L)
+    #:bottom #f
+    (match L
+      [(∅)         #t]
+      [(ε _)       #f]    
+      [(token _)   #f]
+      [(★ L1)      #f]
+      [(∪ L1 L2)   (and (∅? L1) (∅? L2))]
+      [(∘ L1 L2)   (or  (∅? L1) (∅? L2))]
+      [(→ L1 _)    (∅?  L1)]))
+
+  ; Optimizing compaction.
+  ; (K L) is an equivalent, compacted version of L.
+  (define/memoize (K [L #:eq])
+    (match L
+      [(∅)         L]
+      [(ε _)       L]
+      [(? ∅?)      (∅)]
+      [(? ε?)      (ε (parse-null L))]
+      [(token _)   L]
+
+      [(★ (? ∅?))    (ε (set '()))]
+      [(★ L)         (★ (K L))]
+
+      [(∪ (? ∅?) L2)   (K L2)]
+      [(∪ L1 (? ∅?))   (K L1)]
+
+      [(∘ (nullp t) L2)   (→ (K L2) (λ (w2) (cons t w2)))]
+      [(∘ L1 (nullp t))   (→ (K L1) (λ (w1) (cons w1 t)))]
+
+      [(∪ L1 L2)   (∪ (K L1) (K L2))]
+      [(∘ L1 L2)   (∘ (K L1) (K L2))]
+
+      [(→ (and e (? ε?)) f) 
+       (ε (for/set ([t (parse-null e)]) (f t)))]
+
+      [(→ (∘ (nullp t) L2) f)   (→ (K L2) (λ (w2) (f (cons t w2))))]
+      [(→ (→ L f) g)            (→ (K L) (compose g f))]
+      [(→ L f)                  (→ (K L) f)]))
+
+  (define (parse/compact w L #:compactor [compact K])
+    (if (null? w)
+        (parse-null L)
+        (parse/compact (cdr w) (compact L)))))
+
+