1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/experiments/unipat.scm	Sat Oct 08 15:36:03 2011 -0400
     1.3 @@ -0,0 +1,108 @@
     1.4 +;; Unifying pattern-matching, parsing, and method dispatch
     1.5 +
     1.6 +(define (alt p1 p2)
     1.7 +  (lambda (msg kt kf)
     1.8 +    (p1 msg
     1.9 +	kt
    1.10 +	(lambda () (p2 msg kt kf)))))
    1.11 +
    1.12 +;; { .foo (x, 2, y) -> .ok }
    1.13 +;;
    1.14 +;; seq(literal("foo"), seq(tuple(3, [bind(x, discard()), literal(2), bind(y, discard())]),
    1.15 +;;                         cut( ... )))
    1.16 +
    1.17 +(define (p . xs)
    1.18 +  (write xs)
    1.19 +  (newline)
    1.20 +  (last xs))
    1.21 +
    1.22 +(define (seq p1 p2)
    1.23 +  (lambda (msg kt kf)
    1.24 +    (p 'seq msg)
    1.25 +    (if (null? msg)
    1.26 +	(kt (seq p1 p2) msg)
    1.27 +	(p1 (car msg)
    1.28 +	    (lambda (sv remainder) (p2 (cdr msg) kt kf))
    1.29 +	    kf))))
    1.30 +
    1.31 +(define (empty-seq)
    1.32 +  (literal '()))
    1.33 +
    1.34 +(define (tuple n pats)
    1.35 +  (let ((tp (fold-right seq (empty-seq) pats)))
    1.36 +    (lambda (msg kt kf)
    1.37 +      (p `(tuple ,n) msg)
    1.38 +      (if (and (vector? msg)
    1.39 +	       (= (vector-length msg) n))
    1.40 +	  (tp (vector->list msg) kt kf)
    1.41 +	  (kf)))))
    1.42 +
    1.43 +(define (discard)
    1.44 +  (lambda (msg kt kf)
    1.45 +    (p 'discard msg)
    1.46 +    (kt msg '())))
    1.47 +
    1.48 +(define (literal v)
    1.49 +  (lambda (msg kt kf)
    1.50 +    (p `(literal ,v) msg)
    1.51 +    (if (eqv? msg v)
    1.52 +	(kt msg '())
    1.53 +	(kf))))
    1.54 +
    1.55 +(define (cut obj-producer-thunk)
    1.56 +  (lambda (msg kt kf)
    1.57 +    (p 'cut msg)
    1.58 +    (kt (obj-producer-thunk) msg)))
    1.59 +
    1.60 +(define (fail)
    1.61 +  (lambda (msg kt kf)
    1.62 +    (p 'fail msg)
    1.63 +    (kf)))
    1.64 +
    1.65 +
    1.66 +(define (feed parser msg)
    1.67 +  (parser msg
    1.68 +	  (lambda (sv remainder)
    1.69 +	    (p 'SUCCESS sv remainder)
    1.70 +	    (if (null? remainder)
    1.71 +		'complete
    1.72 +		(feed sv remainder)))
    1.73 +	  (lambda ()
    1.74 +	    (p 'FAILURE)
    1.75 +	    'incomplete)))
    1.76 +
    1.77 +
    1.78 +;; { .x -> { .y -> 1 } ;
    1.79 +;;   .x -> { .z -> 2 } ;
    1.80 +;;   .z -> {  _ -> 3 } }
    1.81 +
    1.82 +(define (t)
    1.83 +  (alt (seq (literal 'x) (cut (lambda () (seq (literal 'y) (cut (lambda () 1))))))
    1.84 +       (alt (seq (literal 'x) (cut (lambda () (seq (literal 'z) (cut (lambda () 2))))))
    1.85 +	    (alt (seq (literal 'z) (cut (lambda () (seq (discard) (cut (lambda () 3))))))
    1.86 +		 (fail)))))
    1.87 +
    1.88 +;; { .x .y -> 1 ;
    1.89 +;;   .x .z -> 2 ;
    1.90 +;;   .z  _ -> 3 }
    1.91 +
    1.92 +(define (t2)
    1.93 +  (alt (seq (literal 'x) (seq (literal 'y) (cut (lambda () 1))))
    1.94 +       (alt (seq (literal 'x) (seq (literal 'z) (cut (lambda () 2))))
    1.95 +	    (alt (seq (literal 'z) (seq (discard) (cut (lambda () 3))))
    1.96 +		 (fail)))))
    1.97 +
    1.98 +(define (drive name parser msg)
    1.99 +  (p '------------DRIVE name msg)
   1.100 +  (p '--> (feed parser msg))
   1.101 +  (newline))
   1.102 +
   1.103 +(define (drive4 name parser)
   1.104 +  (drive name parser '(x y))
   1.105 +  (drive name parser '(x z))
   1.106 +  (drive name parser '(x x))
   1.107 +  (drive name parser '(z z)))
   1.108 +
   1.109 +(define (run)
   1.110 +  (drive4 't (t))
   1.111 +  (drive4 't2 (t2)))