1. Forum
  2. Usenet
  3. COMP.LANG.LISP

  • Re: My LOOP is ugly

    From B. Pym@21:1/5 to Kenny Tilton on Sun Aug 18 04:25:34 2024
    Kenny Tilton wrote:

    (defun p2b (pairs &key ((:test test) #'eql))
    "((A 1) (A 2) (B 2) (C 2) (C 3)) ==> ((A 1 2) (B 2) (C 2 3))"
    (loop with bunch = nil
    for (one two) in pairs
    do (push two (cdr (or (assoc one bunch :test test)
    (car (push (list one) bunch)))))
    finally (return bunch)))

    newLISP

    ;; Alter a value in or add a value to an association list.
    (macro (ainc! Alist Key Value Function Deflt)
    (local (E-Message Val Func Def)
    (setq Func Function)
    (if (true? Func)
    (setq Val Value)
    (begin (setq Func +) (setq Val (or Value 1))))
    (setq Def Deflt)
    (if (= nil Def) (setq Def 0))
    (unless
    (catch
    (setf (assoc Key Alist)
    (list ($it 0) (Func Val ($it 1))))
    'E-Message)
    (if (starts-with E-Message "ERR: no reference")
    (setf Alist (cons (list Key (Func Val Def)) Alist))
    (throw E-Message)))))

    (define (p2b pairs)
    (let (bunch '())
    (dolist (xs pairs)
    (ainc! bunch (xs 0) (xs 1) cons '()))
    bunch))

    (p2b '((A 1) (A 2) (B 2) (C 2) (C 3)))
    ===>
    ((C (3 2)) (B (2)) (A (2 1)))

    --- SoupGate-Win32 v1.05
    * Origin: fsxNet Usenet Gateway (21:1/5)
  • From B. Pym@21:1/5 to B. Pym on Sun Jun 29 19:01:35 2025
    B. Pym wrote:

    Kenny Tilton wrote:

    (defun p2b (pairs &key ((:test test) #'eql))
    "((A 1) (A 2) (B 2) (C 2) (C 3)) ==> ((A 1 2) (B 2) (C 2 3))"
    (loop with bunch = nil
    for (one two) in pairs
    do (push two (cdr (or (assoc one bunch :test test)
    (car (push (list one) bunch)))))
    finally (return bunch)))

    Testing:

    (p2b '((A 1) (A 2) (B 2) (C 2) (C 3) (A 88)))
    ===>
    ((C 3 2) (B 2) (A 88 2 1))


    Gauche Scheme

    Let's use a collector that collects into an association-list.

    (let ((a (malistbag)))
    (for-each
    (lambda(xs) (apply a `(,@xs ,cons ())))
    '((A 1) (A 2) (B 2) (C 2) (C 3) (A 88)))
    (a))

    Given:

    ;; 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)
  • From B. Pym@21:1/5 to B. Pym on Fri Jul 11 22:59:50 2025
    B. Pym wrote:

    B. Pym wrote:

    Kenny Tilton wrote:

    (defun p2b (pairs &key ((:test test) #'eql))
    "((A 1) (A 2) (B 2) (C 2) (C 3)) ==> ((A 1 2) (B 2) (C 2 3))"
    (loop with bunch = nil
    for (one two) in pairs
    do (push two (cdr (or (assoc one bunch :test test)
    (car (push (list one) bunch)))))
    finally (return bunch)))

    Testing:

    (p2b '((A 1) (A 2) (B 2) (C 2) (C 3) (A 88)))
    ===>
    ((C 3 2) (B 2) (A 88 2 1))


    Gauche Scheme

    Let's use a collector that collects into an association-list.

    (let ((a (malistbag)))
    (for-each
    (lambda(xs) (apply a `(,@xs ,cons ())))
    '((A 1) (A 2) (B 2) (C 2) (C 3) (A 88)))
    (a))

    Given:


    Another way.

    (define (p2b pairs :optional (test equal?))
    (define alist (map list (delete-duplicates (map car pairs))))
    (define (proc k v) (push! (cdr (assoc k alist test)) v))
    (dolist (e pairs) (apply proc e))
    alist)

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