experiments/unipat.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 233 b7410fbf9ddd
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
233
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
;; Unifying pattern-matching, parsing, and method dispatch
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
(define (alt p1 p2)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
  (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
    (p1 msg
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
	kt
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
	(lambda () (p2 msg kt kf)))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
;; { .foo (x, 2, y) -> .ok }
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
;;
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
;; seq(literal("foo"), seq(tuple(3, [bind(x, discard()), literal(2), bind(y, discard())]),
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
;;                         cut( ... )))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
(define (p . xs)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
  (write xs)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
  (newline)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    17
  (last xs))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
(define (seq p1 p2)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    20
  (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    21
    (p 'seq msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
    (if (null? msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
	(kt (seq p1 p2) msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
	(p1 (car msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
	    (lambda (sv remainder) (p2 (cdr msg) kt kf))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
	    kf))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
(define (empty-seq)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
  (literal '()))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
(define (tuple n pats)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    32
  (let ((tp (fold-right seq (empty-seq) pats)))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    33
    (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    34
      (p `(tuple ,n) msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    35
      (if (and (vector? msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    36
	       (= (vector-length msg) n))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
	  (tp (vector->list msg) kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
	  (kf)))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
(define (discard)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    41
  (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    42
    (p 'discard msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
    (kt msg '())))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
(define (literal v)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    46
  (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    47
    (p `(literal ,v) msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    48
    (if (eqv? msg v)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    49
	(kt msg '())
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    50
	(kf))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
(define (cut obj-producer-thunk)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
  (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
    (p 'cut msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
    (kt (obj-producer-thunk) msg)))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    57
(define (fail)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
  (lambda (msg kt kf)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
    (p 'fail msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
    (kf)))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
(define (feed parser msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
  (parser msg
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
	  (lambda (sv remainder)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
	    (p 'SUCCESS sv remainder)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    67
	    (if (null? remainder)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    68
		'complete
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    69
		(feed sv remainder)))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    70
	  (lambda ()
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    71
	    (p 'FAILURE)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    72
	    'incomplete)))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    73
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    74
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    75
;; { .x -> { .y -> 1 } ;
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    76
;;   .x -> { .z -> 2 } ;
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    77
;;   .z -> {  _ -> 3 } }
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    78
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    79
(define (t)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    80
  (alt (seq (literal 'x) (cut (lambda () (seq (literal 'y) (cut (lambda () 1))))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    81
       (alt (seq (literal 'x) (cut (lambda () (seq (literal 'z) (cut (lambda () 2))))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    82
	    (alt (seq (literal 'z) (cut (lambda () (seq (discard) (cut (lambda () 3))))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    83
		 (fail)))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    84
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    85
;; { .x .y -> 1 ;
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    86
;;   .x .z -> 2 ;
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    87
;;   .z  _ -> 3 }
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    88
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    89
(define (t2)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    90
  (alt (seq (literal 'x) (seq (literal 'y) (cut (lambda () 1))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    91
       (alt (seq (literal 'x) (seq (literal 'z) (cut (lambda () 2))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    92
	    (alt (seq (literal 'z) (seq (discard) (cut (lambda () 3))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    93
		 (fail)))))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    94
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    95
(define (drive name parser msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    96
  (p '------------DRIVE name msg)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    97
  (p '--> (feed parser msg))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    98
  (newline))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    99
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   100
(define (drive4 name parser)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   101
  (drive name parser '(x y))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   102
  (drive name parser '(x z))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   103
  (drive name parser '(x x))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   104
  (drive name parser '(z z)))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   105
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   106
(define (run)
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   107
  (drive4 't (t))
b7410fbf9ddd Sketch of the usefulness of arrow-meaning-cutpoint in backtracking pattern-match!
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   108
  (drive4 't2 (t2)))