Kent M. Pitman wrote:

(defun shrug (list)
(loop for (x . sublist-and-more) on list
for more = (member x sublist-and-more)
when more
collect `(g ,x ,(ldiff sublist-and-more more))))

SHRUG

(shrug '(a b c a d b d))

((G A (B C)) (G B (C A D)) (G D (B)))

newLISP

(define (shrug xs (x (pop xs)))
(and xs
(if (match (list '* x '*) xs)
(cons (list 'g x ($it 0)) (shrug xs))
(shrug xs))))

(shrug '(a b c a d b d))

((g a (b c)) (g b (c a d)) (g d (b)))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

B. Pym wrote:

Kent M. Pitman wrote:

(defun shrug (list)
(loop for (x . sublist-and-more) on list
for more = (member x sublist-and-more)
when more
collect `(g ,x ,(ldiff sublist-and-more more))))

SHRUG

(shrug '(a b c a d b d))

((G A (B C)) (G B (C A D)) (G D (B)))

newLISP

(define (shrug xs (x (pop xs)))
(and xs
(if (match (list '* x '*) xs)
(cons (list 'g x ($it 0)) (shrug xs))
(shrug xs))))

(shrug '(a b c a d b d))

((g a (b c)) (g b (c a d)) (g d (b)))

Shorter:

(define (shrug xs (x (pop xs)))
(and xs
(if (find x xs)
(cons (list 'g x (0 $it xs)) (shrug xs))
(shrug xs))))
-

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

XPost: comp.lang.scheme

Frank Buss wrote:

Looks like the Haskell syntax is not good enough, because there is Template Haskell and doesn't look like it is invented by people who don't know how
to write it with higher order functions, because there are functions in the Haskell List package like this:

-- | The 'zip4' function takes four lists and returns a list of
-- quadruples, analogous to 'zip'.
zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
zip4 = zipWith4 (,,,)

Scheme

(map list '[2 3 4] '[20 30 40] '[200 300 400] '[2000 3000 4000])
===>
((2 20 200 2000) (3 30 300 3000) (4 40 400 4000))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

B. Pym wrote:

Kent M. Pitman wrote:

(defun shrug (list)
(loop for (x . sublist-and-more) on list
for more = (member x sublist-and-more)
when more
collect `(g ,x ,(ldiff sublist-and-more more))))

SHRUG

(shrug '(a b c a d b d))

((G A (B C)) (G B (C A D)) (G D (B)))

Gauche Scheme

Using recursion instead of looping and the symbol !
instead of the less distinctive G.

(define (shrug List)
(if (pair? List)
(let* ((x (pop! List)) (more (member x List)))
(if more
(cons `(! ,x ,(drop-right List (length more))) (shrug List))
(shrug List)))
()))

(shrug '(a b c a d b d))
===>
((! a (b c)) (! b (c a d)) (! d (b)))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

XPost: comp.lang.scheme

So the product of the sums of the elements of two lists could be
written using iterate as:

(iter (x in xs)
(y in ys)
(if (= (+ x y) 0) (leave 0))
(multiply (+ x y) into z)
(finally z))

"!" is similar to "do".

(define (mul-sums xs ys)
(! (z 1 (* z (+ x y))
x :in xs
y :in ys)
(or (not x) (= 0 z))))

(mul-sums '(2 3 4) '(5 6 7))
===>
693

(mul-sums '(2 3 4) '(5 -3 goof))
===>
0

Given:

(define-syntax !-aux
(syntax-rules (<> @ + - cons cdr :in :across :if ! )
[(_ (:if bool z ...) (seen ... (v i u)) stuff ...)
(!-aux (z ...)
(seen ... (v i (if bool u v))) stuff ...) ]
[(_ (x :in lst z ...) seen (lets ...) stuff ...)
(!-aux (x (and (pair? xs)(pop! xs)) <> z ...)
seen (lets ... (xs lst)) stuff ...) ]
[(_ (x :across vec z ...) seen (lets ...) stuff ...)
(!-aux (x (and (< i (vector-length v))
(begin0 (vector-ref v i) (inc! i))) <>
z ...)
seen (lets ... (v vec) (i 0)) 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 a b c ! action ...)
(!-aux () seen lets (a b c) #t (action ...)) ]
[(_ () seen lets a b ! action ...)
(!-aux () seen lets (a b) #t (action ...)) ]
[(_ () seen lets a ! action ...)
(!-aux () seen lets a #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 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 ...) ]
))

--
[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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)