From Newsgroup: comp.lang.scheme

B. Pym wrote:

(defun duplic8 (the-list element)
(loop for x in the-list
if (eql x element)
append (list x x)
else
append (list x)))

If you like loop, I like this better:

(defun duplic8 (the-list element)
(loop for x in the-list
collect x
when (eql x element) collect x))

(define (duplicate the-list el)
(append-map
(lambda(x) (if (equal? el x) (list x x) (list x)))
the-list))

Gauche Scheme

"!" is similar to "do".

(define (duplic8 the-list el)
(! (r cons x :rep? (eqv? x el)
x :in the-list)
#f @))

(duplicate '(3 4 5) 4)
===>
(3 4 4 5)

Given:

(define-syntax !-aux
(syntax-rules (<> @ @@ + - cons append cdr :in :across :along
:if :if-else ! :rep?
:let := )
[(_ (:let id val z ...) seen (lets ...) stuff ...)
(!-aux (z ...) seen (lets ... (id val)) stuff ...) ]
[(_ (:= id val z ...) stuff ...)
(!-aux (:let id #f dummy #f (set! id val) z ...) stuff ...) ]
[(_ (:rep? bool z ...) (seen ... (v i (op x V))) stuff ...)
(!-aux (z ...)
(seen ... (v i (if bool (op x (op x V)) (op x V))))
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 ...) ]
[(_ (ch :along str z ...) seen lets bool stuff ...)
(!-aux (:let s str :let i 0
ch (and (< i (string-length s))
(begin0 (string-ref s i) (inc! i))) <>
z ...)
seen lets (or (not ch) bool) stuff ...) ]
[(_ (a b <> z ...) stuff ...)
(!-aux (a b b z ...) stuff ...) ]
;;
[(_ (a b + z ...) stuff ...)
(!-aux (a b (+ 1 a) z ...) stuff ...) ]
[(_ (a + n z ...) stuff ...)
(!-aux (a 0 (+ n a) z ...) stuff ...) ]
[(_ (a b - z ...) stuff ...)
(!-aux (a b (- a 1) z ...) stuff ...) ]
;;
[(_ (a cons b z ...) stuff ...)
(!-aux (a '() (cons b a) z ...) stuff ...) ]
[(_ (a append b z ...) stuff ...)
(!-aux (a '() (append b a) z ...) stuff ...) ]
[(_ (a b cdr z ...) stuff ...)
(!-aux (a b (cdr a) z ...) 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