Introduces cond/let. A cond that supports variable bindings. The idea is to reduce right drift. Thoughts? For examples named #:let see remove3 and remove4.

cond-star.rkt

#lang racket
(require (for-syntax syntax/parse)
         (only-in srfi/1 car+cdr)
         rackunit)

; This file implements an extension of cond that
; supports variable bindings

; A "#let-clause" of the form
;   #:let ([var/vars expr] ...),
; where var/vars is of the form
;     id   or   (id ...), 
; will bind the variables to the result of evaluting
; the expressions expr. The scope of var consists of 
; the clauses following the #:let-clause. That is,
; the variables are not in scope in the expressions.

; A "#let*-clause" of the form
;   #:let* ([var/vars expr] ...),
; where var/vars is of the form
;     id   or   (id ...), 
; will bind the variables to the result of evaluting
; the expressions expr. The scope of var consists of
; both of the following expressions as well as 
; the clauses following the #:let-clause. 

; In a #:letrec-clause the scope of the variables
; include the expression.

; Named let is also supported:
;   #:let name ([arg expr] ...)
;   clause ...
; corresponds to the named let:
;   (let name ([arg expr] ...) 
;     (cond* clause ...))

;;; Implementation

(begin-for-syntax
  (define-syntax-class vars
    (pattern (var:id ...) #:attr vars #'(var ...))
    (pattern var1:id      #:attr vars #'(var1))))

(define-syntax (cond* stx)
  (syntax-parse stx
    #:literals (else)
    [(_ #:let ([ids:vars e:expr] ...) clause ...)
     #'(let-values ([ids.vars e] ...) (cond* clause ...))]
    [(_ #:let ~! id:id ([arg:id init-expr] ...) clause ...)
     #'(let id ([arg init-expr] ...) (cond* clause ...))]
    [(_ #:let* ~! ([ids:vars e:expr] ...) clause ...)
     #'(let*-values ([ids.vars e] ...) (cond* clause ...))]
    [(_ #:letrec ~! ([ids:vars e:expr] ...) clause ...)
     #'(letrec-values ([ids.vars e] ...) (cond* clause ...))]
    
    [(_ [else then-body ...])
     #'(cond [else then-body ...])]
    [(_ clause0 clause ...)
     #`(cond clause0 [else (cond* clause ...)])]
    [(_) 
     #'(cond)]))

 

;;; Examples

; This implements partition from racket/list.
; (The error checking code was removed.)

(define (partition pred l)
  (let loop ([l l] [i '()] [o '()])
    (cond*
      [(empty? l) (values (reverse i) (reverse o))]
      #:let ([(x l) (car+cdr l)])
      [(pred x)   (loop l (cons x i) o)]
      [else       (loop l i (cons x o))])))

; Here is the original:

;  (define (partition pred l)
;    (let loop ([l l] [i '()] [o '()])
;      (if (null? l)
;          (values (reverse i) (reverse o))
;          (let ([x (car l)] [l (cdr l)])
;            (if (pred x) (loop l (cons x i) o) (loop l i (cons x o)))))))

; This examples removes any elements in r that occurs in l.

(define (remove l r)
  (let rloop ([r r])
    (cond*
      [(empty? r) '()]
      #:let ([first-r (car r)])
      [else (let loop ([l-rest l])
              (cond
                [(null? l-rest) (cons first-r (rloop (cdr r)))]
                [(equal? (car l-rest) first-r) (rloop (cdr r))]
                [else (loop (cdr l-rest))]))])))

(define (remove2 l r)
  (let rloop ([r r])
    (cond*
      [(empty? r) '()]
      #:let ([first-r (car r)])
      #:letrec 
      ([loop 
        (λ (l-rest) 
          (cond
            [(null? l-rest) (cons first-r (rloop (cdr r)))]
            [(equal? (car l-rest) first-r) (rloop (cdr r))]
            [else (loop (cdr l-rest))]))])
      [else (loop l)])))

(define (remove3 l r)
  (let rloop ([r r])
    (cond*
      [(empty? r) '()]
      #:let ([first-r (car r)])
      #:let loop ([l-rest l])
      [(null? l-rest) (cons first-r (rloop (cdr r)))]
      [(equal? (car l-rest) first-r) (rloop (cdr r))]
      [else (loop (cdr l-rest))])))

(define (remove4 l r)
  (cond*
   #:let rloop ([r r])
   [(empty? r) '()]
   #:let ([first-r (car r)])
   #:let loop ([l-rest l])
   [(null? l-rest) (cons first-r (rloop (cdr r)))]
   [(equal? (car l-rest) first-r) (rloop (cdr r))]
   [else (loop (cdr l-rest))]))

(check-equal? (remove '(1 2) '(3 1 3 2 3 4 2 1)) '(3 3 3 4))
(check-equal? (remove2 '(1 2) '(3 1 3 2 3 4 2 1)) '(3 3 3 4))
(check-equal? (remove3 '(1 2) '(3 1 3 2 3 4 2 1)) '(3 3 3 4))
(check-equal? (remove4 '(1 2) '(3 1 3 2 3 4 2 1)) '(3 3 3 4))

;  (define (remove l r)
;    (let rloop ([r r])
;      (cond
;        [(null? r) null]
;        [else (let ([first-r (car r)])
;                (let loop ([l-rest l])
;                  (cond
;                    [(null? l-rest) (cons first-r (rloop (cdr r)))]
;                    [(equal? (car l-rest) first-r) (rloop (cdr r))]
;                    [else (loop (cdr l-rest))])))])))


;;; Example

; This example implements filter-map from racket/list.

(define (filter-map f l . ls)
  ; (check-filter-arguments 'filter-map f l ls)
  (cond* [(empty? ls)
             (let loop ([l l])
               (cond* [(empty? l) '()]
                         #:let ([x (f (car l))])
                         [x    (cons x (loop (cdr l)))]
                         [else (loop (cdr l))]))]
            #:let ([len (length l)])
            [(andmap (lambda (l) (= len (length l))) ls)
             (let loop ([l l] [ls ls])
               (cond* [(empty? l) '()]
                         #:let ([x (apply f (car l) (map car ls))])
                         [x    (cons x (loop (cdr l) (map cdr ls)))]
                         [else (loop (cdr l) (map cdr ls))]))]
            [else
             (raise-arguments-error 'filter-map "all lists must have same size")]))

; Here is the original:

#;(define (filter-map f l . ls)
    ; (check-filter-arguments 'filter-map f l ls)
    (if (pair? ls)
        (let ([len (length l)])
          (if (andmap (lambda (l) (= len (length l))) ls)
              (let loop ([l l] [ls ls])
                (if (null? l)
                    null
                    (let ([x (apply f (car l) (map car ls))])
                      (if x
                          (cons x (loop (cdr l) (map cdr ls)))
                          (loop (cdr l) (map cdr ls))))))
              (raise-arguments-error 'filter-map "all lists must have same size")))
        (let loop ([l l])
          (if (null? l)
              null
              (let ([x (f (car l))])
                (if x (cons x (loop (cdr l))) (loop (cdr l))))))))



; A few tests


(check-equal?
 (cond*
  [(= 1 2) 'boom]
  #:let ([x 3])
  [(= x 4) 5]
  [(= x 3) 'passed]
  [else 'boom])
 'passed)

(check-equal?
 (cond*
  [(= 1 2) 'boom]
  #:let ([x 3])
  [(= x 4) 5]
  #:let ([y 3])
  [(= x y) 'passed]
  [else 'boom])
 'passed)

(check-equal?
 (cond*
  [(= 1 2) 'boom]
  #:let* ([(x y) (values 3 4)])
  #:let* ([x 5])
  [(= x (+ y 1)) 'passed]
  [else 'boom])
 'passed)

(check-equal?
 (cond*
  #:let* ([(x y) (values 3 4)])
  #:let* ([x 5])
  [else (list x y)])
 (list 5 4))

(check-equal?
 (cond*
  #:let* ([x 1] 
          [y (+ x 1)]
          [x (+ y 1)])
  [else x])
 3)

(check-equal?
 (cond*
  #:let* ([x 1] 
          [y (+ x 1)]
          [x (+ y 1)])
  [else x])
 3)


(check-equal? (filter-map (λ (x y) (if (odd? x) (list x y) #f))
                          '(1 2 3) '(4 5 6))
              '((1 4) (3 6)))