hi, I need to write a function (join_similar expr) where expr is
adata structure with the following format ( (x1 y1) (x2 y2) (x3 y3)...
(xn yn)),

join_similar will return an expression like ( (x1 y1 y2) (x3 y3) ...)
when x1=x2

for instance:
*(join_similar '((3 4) (7 5) (3 6) (7 8) (3 9) (0 1))

would return:
((3 4 6 9) (7 5 8) (0 1))

Kenny Tilton wrote:

Lieven Marchand wrote:

CL-USER 9 > (defun join-similar (list)
(loop with ht = (make-hash-table)
for (first second) in list
do
(pushnew second (gethash first ht nil))
finally (return (loop for first being each hash-key in ht using (hash-value rest) collect (cons first rest)))))
JOIN-SIMILAR

Isn't LOOP beautiful? <g,d&r>

<g> No...

(defun join-similar (pairs &aux result)
(dolist (pair pairs (nreverse result))
(nconc (or (assoc (first pair) result)
(first (push (list (first pair)) result)))
(list (second pair)))))

Gauche Scheme

(use gauche.collection) ;; group-collection

(define (meld groups)
(map (lambda(xs) (cons (caar xs) (map cadr xs))) groups))

(define (join-similar pairs)
(meld (group-collection pairs :key car :test equal?)))

(join-similar '((foo 4)(bar 7)(foo 5)(bar 8)(fun 9)))

===>
((foo 4 5) (bar 7 8) (fun 9))

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

B. Pym wrote:

hi, I need to write a function (join_similar expr) where expr is
adata structure with the following format ( (x1 y1) (x2 y2) (x3 y3)...
(xn yn)),

join_similar will return an expression like ( (x1 y1 y2) (x3 y3) ...)
when x1=x2

for instance:
*(join_similar '((3 4) (7 5) (3 6) (7 8) (3 9) (0 1))

would return:
((3 4 6 9) (7 5 8) (0 1))

Kenny Tilton wrote:

Lieven Marchand wrote:

CL-USER 9 > (defun join-similar (list)
(loop with ht = (make-hash-table)
for (first second) in list
do
(pushnew second (gethash first ht nil))
finally (return (loop for first being each hash-key in ht using (hash-value rest) collect (cons first rest)))))
JOIN-SIMILAR

Isn't LOOP beautiful? <g,d&r>

<g> No...

(defun join-similar (pairs &aux result)
(dolist (pair pairs (nreverse result))
(nconc (or (assoc (first pair) result)
(first (push (list (first pair)) result)))
(list (second pair)))))

Gauche Scheme

(use gauche.collection) ;; group-collection

(define (meld groups)
(map (lambda(xs) (cons (caar xs) (map cadr xs))) groups))

(define (join-similar pairs)
(meld (group-collection pairs :key car :test equal?)))

(join-similar '((foo 4)(bar 7)(foo 5)(bar 8)(fun 9)))

===>
((foo 4 5) (bar 7 8) (fun 9))

Without "cheating" by using group-collection.

(define (join-similar pairs)
(let1 keys (delete-duplicates (map car pairs))
(map
(lambda(key)
(cons key
(map last (filter (lambda(xs) (equal? key (car xs))) pairs))))
keys)))

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

B. Pym wrote:

B. Pym wrote:

hi, I need to write a function (join_similar expr) where expr is
adata structure with the following format ( (x1 y1) (x2 y2) (x3 y3)... (xn yn)),

join_similar will return an expression like ( (x1 y1 y2) (x3 y3) ...) when x1=x2

for instance:
*(join_similar '((3 4) (7 5) (3 6) (7 8) (3 9) (0 1))

would return:
((3 4 6 9) (7 5 8) (0 1))

Kenny Tilton wrote:

Lieven Marchand wrote:

CL-USER 9 > (defun join-similar (list)
(loop with ht = (make-hash-table)
for (first second) in list
do
(pushnew second (gethash first ht nil))
finally (return (loop for first being each hash-key in ht using (hash-value rest) collect (cons first rest)))))
JOIN-SIMILAR

Isn't LOOP beautiful? <g,d&r>

<g> No...

(defun join-similar (pairs &aux result)
(dolist (pair pairs (nreverse result))
(nconc (or (assoc (first pair) result)
(first (push (list (first pair)) result)))
(list (second pair)))))

Gauche Scheme

(use gauche.collection) ;; group-collection

(define (meld groups)
(map (lambda(xs) (cons (caar xs) (map cadr xs))) groups))

(define (join-similar pairs)
(meld (group-collection pairs :key car :test equal?)))

(join-similar '((foo 4)(bar 7)(foo 5)(bar 8)(fun 9)))

===>
((foo 4 5) (bar 7 8) (fun 9))

Without "cheating" by using group-collection.

(define (join-similar pairs)
(let1 keys (delete-duplicates (map car pairs))
(map
(lambda(key)
(cons key
(map last (filter (lambda(xs) (equal? key (car xs))) pairs))))
keys)))

Using Tilton's approach.

(define (foo pairs :optional (alist '()))
(dolist (p pairs alist)
(if-let1 e (assoc (car p) alist)
(append! e (cdr p))
(push! alist (list-copy p))) ;; Avoid immutability.
))

(foo '((foo 4)(bar 7)(foo 5)(bar 8)(fun 9)))
===>
((fun 9) (bar 7 8) (foo 4 5))

--
"It suffices that the past is exempt from mutation."
--- Charles Brockden Brown (Wieland)

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

B. Pym wrote:

Kenny Tilton wrote:

(defun join-similar (pairs &aux result)
(dolist (pair pairs (nreverse result))
(nconc (or (assoc (first pair) result)
(first (push (list (first pair)) result)))
(list (second pair)))))

He didn't notice that

(list (second pair)))))

ought to have been

(cdr pair))))


His solution and my last one seem to indicate that
non-functional (mutating) programming can result in
concise code.

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

B. Pym wrote:

hi, I need to write a function (join_similar expr) where expr is
adata structure with the following format ( (x1 y1) (x2 y2) (x3 y3)...
(xn yn)),

join_similar will return an expression like ( (x1 y1 y2) (x3 y3) ...)
when x1=x2

for instance:
*(join_similar '((3 4) (7 5) (3 6) (7 8) (3 9) (0 1))

would return:
((3 4 6 9) (7 5 8) (0 1))

Kenny Tilton wrote:

Lieven Marchand wrote:

CL-USER 9 > (defun join-similar (list)
(loop with ht = (make-hash-table)
for (first second) in list
do
(pushnew second (gethash first ht nil))
finally (return (loop for first being each hash-key in ht using (hash-value rest) collect (cons first rest)))))
JOIN-SIMILAR

Isn't LOOP beautiful? <g,d&r>

<g> No...

(defun join-similar (pairs &aux result)
(dolist (pair pairs (nreverse result))
(nconc (or (assoc (first pair) result)
(first (push (list (first pair)) result)))
(list (second pair)))))

Gauche Scheme

Using a collector that collects into an association list.

(define (join-similar pairs)
(let1 a (malistbag)
(dolist (xs pairs) (a (car xs) (cadr xs) cons ()))
(a)))

(join-similar '((foo 4)(bar 7)(foo 5)(bar 8)(fun 9)))
===>
((fun 9) (foo 5 4) (bar 8 7))

Given:


(define (mbag init func :optional (pass-through #f))
(let ((val init) (func func) (pass-through pass-through))
(lambda args
(if (null? args)
val
(begin
(set! val
;; A "kons" may have been supplied.
((if (null? (cdr args)) func (cadr args))
(car args) val))
(if pass-through
(car args)
val))))))
(define (mlistbag :optional (pass-through #t))
(let ((bag (mbag '() cons pass-through)))
(lambda args
(if (null? args)
(reverse (bag))
(apply bag args)))))

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

B. Pym wrote:

B. Pym wrote:

hi, I need to write a function (join_similar expr) where expr is
adata structure with the following format ( (x1 y1) (x2 y2) (x3 y3)... (xn yn)),

join_similar will return an expression like ( (x1 y1 y2) (x3 y3) ...) when x1=x2

for instance:
*(join_similar '((3 4) (7 5) (3 6) (7 8) (3 9) (0 1))

would return:
((3 4 6 9) (7 5 8) (0 1))

Kenny Tilton wrote:

Lieven Marchand wrote:

CL-USER 9 > (defun join-similar (list)
(loop with ht = (make-hash-table)
for (first second) in list
do
(pushnew second (gethash first ht nil))
finally (return (loop for first being each hash-key in ht using (hash-value rest) collect (cons first rest)))))
JOIN-SIMILAR

Isn't LOOP beautiful? <g,d&r>

<g> No...

(defun join-similar (pairs &aux result)
(dolist (pair pairs (nreverse result))
(nconc (or (assoc (first pair) result)
(first (push (list (first pair)) result)))
(list (second pair)))))

Gauche Scheme

Using a collector that collects into an association list.

(define (join-similar pairs)
(let1 a (malistbag)
(dolist (xs pairs) (a (car xs) (cadr xs) cons ()))
(a)))

(join-similar '((foo 4)(bar 7)(foo 5)(bar 8)(fun 9)))
===>
((fun 9) (foo 5 4) (bar 8 7))

Given:

Wrong functions were given previously. Here are the right ones.

;; Non-destructive.
(define (update-alist alist k v :optional (func #f) (default 0))
(define (alter-entry e)
(if func
(let ((new-v (func v (if e (cdr e) default))))
(cons k new-v))
(cons k v)))
(let go ((the-list alist) (seen '()))
(cond ((null? the-list) (cons (alter-entry #f) seen))
((equal? k (caar the-list))
(append (cons (alter-entry (car the-list)) seen)
(cdr the-list)))
(#t (go (cdr the-list) (cons (car the-list) seen))))))

(define (malistbag)
(let ((bag '()))
(case-lambda
[() bag]
[(k) (let ((e (assoc k bag))) (and e (cdr e)))]
[(k val) (set! bag (update-alist bag k val))]
[(k val func) (set! bag (update-alist bag k val func))]
[(k val func def) (set! bag (update-alist bag k val func def))])))

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