Return Styles: Pseud0ch, Terminal, Valhalla, NES, Geocities, Blue Moon.

Pages: 1-

List comprehensions in Scheme

Name: Anonymous 2009-12-08 13:45

I haven't been programming much Scheme recently, so I've been out of touch with my macro programming, So I decided to write this for you. Any critique welcome.
Notes:
This was written in PLT Scheme, but the macro itself should be portable.
Yes, I know I could have two macros instead of one, and that it would mean that I only had to export the interface I want.
append* is concatenate from SRFI 1.

#lang scheme
(define-syntax lc
  (syntax-rules (<-)
    ((lc "helper" return-expr)
     return-expr)
   
    ((lc "helper" (<- var val) return-expr)
     (map (lambda (var)
            return-expr)
          val))
   
    ((lc "helper" (<- var val) (<- var2 val2) expr ...)
     (append* (map (lambda (var)
                     (lc "helper" (<- var2 val2) expr ...))
                   val)))
   
    ((lc "helper" (<- var val) expr return-expr)
     (filter-map (lambda (var) (and expr return-expr))
                 val))
   
    ((lc "helper" (<- var val) expr rest ... return-expr)
     (append* (filter-map (lambda (var)
                            (and expr
                                 (lc "helper" rest ... return-expr)))
                          val)))
   
    ((lc return-expr (<- var val) expr ...)
     (lc "helper" (<- var val) expr ... return-expr))))

(require (planet schematics/schemeunit:3))

(define-test-suite list-comprehension-tests
  (check-equal? (lc (+ x 1) (<- x (list 1 2 3 4 5)))
                '(2 3 4 5 6))
  (check-equal? (lc #f (<- x '(1 2 3 4)))
                '(#f #f #f #f))
  (check-equal? (lc #f (<- x '(1 2 3)) (<- y '(1 2 3)))
                '(#f #f #f #f #f #f #f #f #f))
  (check-equal? (lc #f (<- x '(0 1)) (<- y '(1 2)) (<- z '(3 4)))
                '(#f #f #f #f #f #f #f #f))
  (check-equal? (lc x (<- x '(1 2 3 4)))
                '(1 2 3 4))
  (check-equal? (let ((x 4))
                  (lc x (<- x '(1 2 3 4))))
                '(1 2 3 4))
  (check-equal? (let ((y 4))
                  (lc 4 (<- x '(1 2 3 4))))
                '(4 4 4 4))
  (check-equal? (lc (list x y) (<- x '(1 2 3 4)) (<- y '(2 3 4)))
                '((1 2) (1 3) (1 4) (2 2) (2 3) (2 4) (3 2)
                        (3 3) (3 4) (4 2) (4 3) (4 4)))
  (check-equal? (lc x (<- x '(1 2 3 4)) (even? x)) ;;;;;;;;;;;;;;;;;;;;;
                '(2 4))
  (check-equal? (lc x (<- x '(1 2 3 4)) #f)
                '())
  (check-equal? (lc x (<- x '(1 2 3 4)) #t)
                '(1 2 3 4))
  (check-equal? (lc x (<- x '(1 2 3)) (<- y '(1 2 3)) (even? x))
                '(2 2 2))
  (check-equal? (lc x (<- x '(1 2 3)) (odd? x) (<- y '(1 2)))
                '(1 1 3 3))
  (check-equal? (lc (cons x y)
                    (<- x '(1 2 3)) (odd? x) (<- y '(2 3 4 5 6)) (even? y))
                '((1 . 2) (1 . 4) (1 . 6) (3 . 2) (3 . 4) (3 . 6)))
  (check-equal? (lc (+ x 1) (<- x '(1 2 3)) (<- y '(1 2 3)) #f)
                '())
  (check-equal? (lc (cons x y) (<- x '(1 2)) (<- y '(1 2 3)) #t)
                '((1 . 1) (1 . 2) (1 . 3) (2 . 1) (2 . 2) (2 . 3)))
  (check-equal? (lc (+ x y z) (<- x '(1 2)) (<- y '(3 4)) (<- z '(5 6)))
                '(9 10 10 11 10 11 11 12))
  (check-equal? (lc (list x y z) (<- x '(1 2)) (<- y '( 3 4)) (<- z '(5 6)))
                '((1 3 5) (1 3 6) (1 4 5) (1 4 6)
                          (2 3 5) (2 3 6) (2 4 5) (2 4 6)))
  (check-equal? (lc '() (<- x '(1 2 3)))
                '(() () ()))
  (check-equal? (lc x (<- x '()))
                '())
  (check-equal? (lc y (<- x '(1 2)) (<- y '()))
                '()))


(require (planet schematics/schemeunit:3/text-ui))
(run-tests list-comprehension-tests)

(require srfi/1)
(define (range start end)
  (if (< end start)
      #f
      (unfold (lambda (x) (= x end))
              (lambda (x) x)
              (lambda (x) (+ x 1))
              start)))
(define (compare-times)
  (let* ((x  (range 1 1000))
         (y  (range 1 1000)))
    (equal? (time (lc x (<- x x) (even? x) (<- y y)))
            (time (lc x (<- x x) (<- y y) (even? x))))))


21 success(es) 0 failure(s) 0 error(s) 21 test(s) run
0
(compare-times)
cpu time: 79 real time: 79 gc time: 0
cpu time: 396 real time: 398 gc time: 159
#t

Name: Anonymous 2009-12-08 13:48

[quote](require (planet schematics/schemeunit:3))[/quote]
:3

Name: Anonymous 2009-12-08 13:50

>>2
It's just for unit testing, you can always just take my word that it passes ;)

Don't change these.
Name: Email:
Entire Thread Thread List