[plt-scheme] Fun with paren-shape

Why don't you add | so that you can write [ n | (< 0 n 11)] ? --  
Matthias


On Jun 5, 2007, at 8:32 AM, Jens Axel Søgaard wrote:

> Hi all,
>
> Here's a fun little hack. It provides concise
> syntax for integer ranges and vector references.
>
>  [a .. b]  => (interval a b)
>  (... expr1 [expr2] ...) => (... (vector-ref expr1 expr2) ...)
>
>
> Example:
>
> > (require index)
>
> > (define (sum xs) (apply + xs))
>
> > [1 .. 11]
> (1 2 3 4 5 6 7 8 9 10)
>
> > (sum [1 .. 11])
> 55
>
>
> > (define v (vector 'a 'b 'c))
> > (list v[0] v[1] v[2])
> (a b c)
>
> > (+ (vector 1 2)[0] 3)
> 4
>
>
> > (define (len o)
>     (cond
>       [(pair? o)   (length o)]
>       [(vector? o) (vector-length o)]
>       [(string? o) (string-length o)]
>       [(bytes? o)  (bytes-length o)]
>       [else        (error 'len "I give up" o)]))
>
> > (define v1 (vector 1 0 1))
> > (define v2 (vector 2 3 4))
>
> > (define (dot-product v1 v2)
>     (sum (map (λ (i) (* v1[i] v2[i]))
>               [0 .. (len v1)])))
> 6
>
>
> (module index mzscheme
>   (provide (rename my-app #%app))
>   (require-for-syntax (lib "stx.ss" "syntax"))
>
>   (define (interval n m)
>     (cond
>       [(>= n m) '()]
>       [(< n m) (cons n (interval (+ n 1) m))]))
>
>   (define-syntax (my-app stx)
>     (define (bracket-shaped? stx)
>       (equal? (syntax-property stx 'paren-shape) #\[))
>     (define (brackets? parens)
>       (syntax-case parens ()
>         [(x) (bracket-shaped? parens)]
>         [_ #f]))
>     (define (range? stx)
>       (syntax-case* stx (..) module-or-top-identifier=?
>         [(a .. b) (bracket-shaped? stx)]
>         [_        #f]))
>     (define (handle-brackets exprs)
>       ; vector brackets
>       (let loop ([exprs      exprs]
>                  [prev-exprs '()])
>         (cond
>           [(null? exprs)
>            (reverse prev-exprs)]
>           [(null? (cdr exprs))
>            (loop (cdr exprs) (cons (car exprs) prev-exprs))]
>           [(not (brackets? (cadr exprs)))
>            (loop (cdr exprs) (cons (car exprs) prev-exprs))]
>           [else
>            (loop (cddr exprs)
>                  (cons (quasisyntax/loc (cadr exprs)
>                          (vector-ref #,(car exprs) #,@(cadr exprs)))
>                        prev-exprs))])))
>     (define (handle-ranges exprs)
>       (let loop ([exprs      exprs]
>                  [prev-exprs '()])
>         (cond
>           [(null? exprs)
>            (reverse prev-exprs)]
>           [(not (range? (car exprs)))
>            (loop (cdr exprs) (cons (car exprs) prev-exprs))]
>           [else
>            (with-syntax ([[from .. to] (car exprs)])
>              (loop (cdr exprs)
>                    (cons (syntax/loc (car exprs)
>                            (interval from to))
>                          prev-exprs)))])))
>     (syntax-case* stx (..) module-or-top-identifier=?
>       [(_ a .. b)
>        (bracket-shaped? stx)
>        (quasisyntax/loc stx
>          (interval a b))]
>       [(_ expr . more )
>        (or (ormap brackets? (cddr (syntax->list stx)))
>            (ormap range?    (cdr (syntax->list stx))))
>        (with-syntax ([(expr ...)
>                       (handle-ranges
>                        (handle-brackets
>                         (cdr (syntax->list stx))))])
>          (quasisyntax/loc stx
>            (#%app expr ...)))]
>       [(_ . more)
>        (syntax/loc stx
>          (#%app . more))])))
>
> (require index)
>
> (define (sum xs)
>   (apply + xs))
>
> [1 .. 11]
> (sum [1 .. 11])
>
>
> (define v (vector 'a 'b 'c))
> (list v[0] v[1] v[2])
>
> (define (len o)
>   (cond
>     [(pair? o)   (length o)]
>     [(vector? o) (vector-length o)]
>     [(string? o) (string-length o)]
>     [(bytes? o)  (bytes-length o)]
>     [else        (error 'len "I give up" o)]))
>
> (define v1 (vector 1 0 1))
> (define v2 (vector 2 3 4))
>
> (define (dot-product v1 v2)
>   (sum (map (λ (i) (* v1[i] v2[i]))
>             [0 .. (len v1)])))
>
>
>
> -- 
> Jens Axel Søgaard
>
> _________________________________________________
>  For list-related administrative tasks:
>  http://list.cs.brown.edu/mailman/listinfo/plt-scheme