From Newsgroup: comp.lang.lisp

B. Pym wrote:

Tamas Papp wrote:

1. What would be the best name for this function? Is it already in a (Quicklisp) library? (could not find it, don't want to reinvent the wheel).

--8<---------------cut here---------------start------------->8---
(defun separate-sequence (sequence predicate)
"Return two sequences of the same type, containing elements that
do and do not satisfy PREDICATE. Ordering of elements is preserved."
(values (remove-if (complement predicate) sequence)
(remove-if predicate sequence)))

;; Example
(separate-sequence '(0 1 2 3) #'oddp) ; => (1 3), (0 2) --8<---------------cut here---------------end--------------->8---

2. Any suggestions for a better implementation (one that traverses the sequence only once)? I came up with

--8<---------------cut here---------------start------------->8---
(defun separate-sequence (sequence predicate)
"Return two sequences of the same type, containing elements that do and do not satisfy PREDICATE. Ordering of elements is preserved."
(let (yes
no
(type (typecase sequence
(list 'list)
(vector `(simple-array ,(array-element-type sequence) '*))
(t (return-from separate-sequence
;; generic sequence, let built-ins handle it
(values (remove-if (complement predicate) sequence)
(remove-if predicate sequence)))))))
(map nil (lambda (element)
(if (funcall predicate element)
(push element yes)
(push element no)))
sequence)
(values (coerce (nreverse yes) type)
(coerce (nreverse no) type))))

Gauche Scheme

gosh> (partition even? (iota 20))
(0 2 4 6 8 10 12 14 16 18)
(1 3 5 7 9 11 13 15 17 19)

"!" is similar to "do".

(! (x :in (iota 20)
o cons x
e cons x
:if-else (odd? x))
#f @@ (values e o))

(0 2 4 6 8 10 12 14 16 18)
(1 3 5 7 9 11 13 15 17 19)

Given:

(define-syntax !-aux
(syntax-rules (<> @ @@ + - cons cdr :in :across :if :if-else ! :let )
[(_ (:let id val z ...) seen (lets ...) stuff ...)
(!-aux (z ...) seen (lets ... (id val)) stuff ...) ]
[(_ (:if bool z ...) (seen ... (v i u)) stuff ...)
(!-aux (z ...)
(seen ... (v i (if bool u v))) stuff ...) ]
;;
[(_ (:if-else bool z ...) (seen ... (a b c)(d e f)) stuff ...)
(!-aux (:let yes #f z ...)
(seen ... (a b (begin (set! yes bool) (if yes c a)))
(d e (if (not yes) f d))) stuff ...) ]
;;
[(_ (x :in lst z ...) seen lets bool stuff ...)
(!-aux (:let xs lst x (and (pair? xs)(pop! xs)) <> z ...)
seen lets (or (not x) bool) stuff ...) ]
[(_ (x :across vec z ...) seen lets bool stuff ...)
(!-aux (:let v vec :let i 0
x (and (< i (vector-length v))
(begin0 (vector-ref v i) (inc! i))) <>
z ...)
seen lets (or (not x) bool) stuff ...) ]
[(_ (a b <> z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a b b)) stuff ...) ]
[(_ (a b + z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a b (+ 1 a))) stuff ...) ]
[(_ (a + n z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a 0 (+ n a))) stuff ...) ]
[(_ (a b - z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a b (- a 1))) stuff ...) ]
[(_ (a cons b z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a '() (cons b a))) stuff ...) ]
[(_ (a b cdr z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a b (cdr a))) stuff ...) ]
[(_ (a b c z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a b c)) stuff ...) ]
[(_ (a b) (seen ...) stuff ...)
(!-aux () (seen ... (a b)) stuff ...) ]
[(_ (a) (seen ...) stuff ...)
(!-aux () (seen ... (a '())) stuff ...) ]
;;
[(_ () seen lets bool ! action ...)
(!-aux () seen lets bool #t (action ...)) ]
;;
[(_ () ((a b c) z ...) lets bool)
(!-aux () ((a b c) z ...) lets bool a) ]
[(_ () ((a b c) z ...) lets bool @)
(!-aux () ((a b c) z ...) lets bool (reverse a)) ]
[(_ () seen lets bool @ result stuff ...)
(!-aux () seen lets bool (reverse result) stuff ...) ]
;;
[(_ () seen lets bool @@ (what x ...) stuff ...)
(!-aux () seen lets bool (what (reverse x) ...) stuff ...) ]
[(_ () seen lets bool (what @ x z ...) stuff ...)
(!-aux () seen lets bool (what (reverse x) z ...) stuff ...) ]
[(_ () seen lets bool (what x @ y z ...) stuff ...)
(!-aux () seen lets bool (what x (reverse y) z ...) stuff ...) ]
;;
[(_ () ((a b c) z ...) lets 0 stuff ...)
(!-aux () ((a b c) z ...) lets (= 0 a) stuff ...) ]
[(_ () seen lets bool result stuff ...)
(let lets (do seen (bool result) stuff ...)) ]
))
(define-syntax !
(syntax-rules ()
[(_ specs bool stuff ...)
(!-aux specs () () bool stuff ...) ]
[(_ specs) (! specs #f) ]
))
--
[T]he problem is that lispniks are as cultish as any other devout group and basically fall down frothing at the mouth if they see [heterodoxy].
--- Kenny Tilton
The good news is, it's not Lisp that sucks, but Common Lisp. --- Paul Graham --- Synchronet 3.21a-Linux NewsLink 1.2