Generalised cut

cutn.scm

;; generalised cut

;; (import (scheme base) (scheme write))
(import (rnrs))

;; FIXME I think there's a better way
(define-syntax remove-duplicate
  (syntax-rules ()
    ((_ (e* ...) reserve next)
     (remove-duplicate "pair" () (e* ...) (e* ...) reserve next))

    ((_ "pair" (p* ...) (e e* ...) (o* ...) reserve next)
     (remove-duplicate "pair" (p* ... (e e)) (e* ...) (o* ...) reserve next))

    ((_ "pair" (p* ...) () (o* ...) reserve next)
     (remove-duplicate "do" (p* ...) (o* ...) reserve next))

    ;; e* = ((e e) ...)
    ((_ "do" (e* ...) (e o* ...) reserve next)
     (letrec-syntax ((foo (syntax-rules (e)
                            ((_ resv (r (... ...)) 
                                ((e n) rest* (... ...)) 
                                (out (... ...)))
                             (foo "found" resv 
                                  (r (... ...) (n n))
                                  (rest* (... ...))
                                  (out (... ...))))
                            ((_ resv (r (... ...))
                                ((d n) rest (... ...))
                                (out (... ...)))
                             (foo resv (r (... ...) (n n))
                                  (rest (... ...))
                                  (out (... ...))))
                            ;; not found
                            ((_ resv (r (... ...)) () (o out (... ...)))
                             (remove-duplicate "do" 
                                               (r (... ...)) (out (... ...))
                                               resv next))
                            ;; don't add
                            ((_ "found" resv 
                                (r (... ...)) 
                                ((e n) rest* (... ...))
                                (out (... ...)))
                             (foo "found" resv 
                                  (r (... ...))
                                  (rest* (... ...))
                                  (out (... ...))))
                            ((_ "found" resv 
                                (r (... ...))
                                ((d n) rest* (... ...))
                                (out (... ...)))
                             (foo "found" resv 
                                  (r (... ...) (n n))
                                  (rest* (... ...))
                                  (out (... ...))))
                            ((_ "found" resv (r (... ...)) () (o out (... ...)))
                             (remove-duplicate "do"
                                               (r (... ...)) (out (... ...))
                                               resv next)))))
       (foo reserve () (e* ...) (e o* ...))))
    ((_ "do" ((d r) ...) () resv next) (next (r ...) resv))))

;; auxiliary macro
;; this is because I don't how to escape 'escaped ellipsis'
;; assume input (e ...) contains only unique identifier
(define-syntax insert
  (syntax-rules ()
    ;; the same trick as remove-duplicate
    ((_ reserve (r ...) (d ...) (e ...) sort)
     (insert "pair" reserve (r ...) () (d ...) (e ...) sort))
    ((_ "pair" reserve (r ...) (p* ...) (d ...) (e e* ...) sort)
     (insert "pair" reserve (r ...) (p* ... (e e)) (d ...) (e* ...) sort))
    ((_ "pair" reserve (r ...) ((e1 e2) ...) (d d* ...) () sort)
     (letrec-syntax ((bar (syntax-rules (d)
                            ((_ resv (rr (... ...)) 
                                next (e* (... ...))
                                (d e) rest (... ...))
                             (sort resv 
                                   (rr (... ...) e) 
                                   next ;; (d* ...)
                                   (e* (... ...))))
                            ((_ resv (rr (... ...)) 
                                next (e* (... ...))
                                n rest (... ...))
                             (bar resv (rr (... ...)) 
                                  next (e* (... ...))
                                  rest (... ...)))
                            ((_ resv (rr (... ...)) next (e* (... ...)))
                             (sort resv 
                                   (rr (... ...))
                                   ()
                                   (e* (... ...)))))))
       (bar reserve (r ...) (d* ...) (e1 ...) (e1 e2) ...)))))

(define-syntax emit-cut
  (syntax-rules ()
    ((_ (defined ...) (collected ...) (proc body ...))
     (letrec-syntax ((sort (syntax-rules ()
                             ;; sort the targets as its defined
                             ;; this is entry point of CPS macro
                             ((_ (e (... ...)) (reserved def (... ...)))
                              (sort reserved () (def (... ...)) (e (... ...))))
                             ;; recursive macro 
                             ((_ reserved 
                                 (sorted (... ...))
                                 (d d* (... ...))
                                 (e (... ...)))
                              (insert reserved
                                      (sorted (... ...)) 
                                      (d d* (... ...))
                                      (e (... ...))
                                      sort))
                             ((_ reserved (sorted (... ...)) () (e (... ...)))
                              (lambda (sorted (... ...))
                                reserved)))))
       (remove-duplicate (collected ...) 
                         ((proc body ...) defined ...)
                         sort)))))

;; NB: the generated lambda has the same identifier of the given literals.
(define-syntax collect-literals
  (syntax-rules ()
    ((_ (literals ...) body next)
     (collect-literals "pattern" doit () () (literals ...) body next))
    ;; generate syntax-rules' pattern
    ((collect-literals "pattern" recname (pat* ...) (lites ...)
                       (literal literals ...) body next)
     (collect-literals "pattern" recname 
                       (pat* ... ((_ (tt* (... ...)) lites*
                                     (new-body (... ...))
                                     (literal rest (... ...))
                                     (e rest2 (... ...)))
                                  (recname (tt* (... ...) e) lites*
                                           (new-body (... ...) e)
                                           (rest (... ...))
                                           (rest2 (... ...)))))
                       (lites ... literal)
                       (literals ...)
                       body next))
    ((collect-literals "pattern" recname (pat* ...) (literals ...) 
                       () (body ...) next)
     (letrec-syntax ((recname (syntax-rules (literals ...)
                                ((_ (tt (... ...)) lites
                                    (new-body (... ...)) () ())
                                 (next lites 
                                       (tt (... ...))
                                       (new-body (... ...))))
                                 pat* ...
                                ;; fallback
                                ((_ (tt (... ...)) lites (new-body (... ...))
                                    (expr rest (... ...))
                                    (expr2 rest2 (... ...)))
                                 (recname (tt (... ...)) lites
                                          (new-body (... ...) expr)
                                          (rest (... ...))
                                          (rest2 (... ...)))))))

       (recname () (literals ...) () 
                (body ...)
                (body ...))))))

;; helper
(define-syntax define-auxilary-syntax
  (syntax-rules ()
    ((_ name name* ...)
     (begin
       (define-syntax name (syntax-rules ()))
       (define-auxilary-syntax name* ...)))
    ((_) (begin))))


;; main macro
(define-syntax define-cutn
  (syntax-rules ()
    ((_ name literal literals ...)
     (begin
       (define-auxilary-syntax literal literals ...)
       (define-syntax name
         (syntax-rules ()
           ((_ body (... ...))
            (collect-literals (literal literals ...) 
                              (body (... ...)) emit-cut))))))))

;; test
(define-cutn cut5 *1 *2 *3 *4 *5)
(display ((cut5 list *2 *1 *1 *2) 1 3)) (newline)