Topic: -={ Challenge }=- Group By Assoc

[Lee Mac]

The Challenge:

To emulate the behaviour of the Express Tools' acet-list-group-by-assoc function, (however the list should be in the correct order, unlike that function...). The function needn't accomodate for dotted pairs.

Example:

Code: [Select]

(setq lst '((1 123 234) (2 234 345) (3 345 456) (2 456 567) (3 567 678)))

==> ((1 123 234) (2 234 345) (3 345 456) (2 456 567) (3 567 678))


Code: [Select]

(reverse (acet-list-group-by-assoc lst))

==> ((1 123 234) (2 234 345 456 567) (3 345 456 567 678))

I'll kick us off, as an example:

Code: [Select]

(defun _GroupByAssoc ( lst / rtn a )
  (setq rtn (list (car lst)))

  (while (setq lst (cdr lst))
    (setq rtn
      (if (setq a (assoc (caar lst) rtn))
        (subst (cons (car a) (append (cdr a) (cdar lst))) a rtn)
        (cons (car lst) rtn))))
 
  (reverse rtn))

Enjoy,

Lee

[JohnK]

Here is my c++ entry.

Code: [Select]

int main ( )
/*
   sort a three dimensional array by first colum using the bubble sort.

   the array:
   (
    (1 123 234)
    (2 234 345)
    (3 345 456)
    (2 456 567)
    (3 567 678)
   )
*/
{
        int rows = 5,
            cols = 3;
        int r,
            c = 0;
        int tmp[1][3];
            // temp array to hold value while switch is made.
        int nums[5][3] = {
                {1, 123, 234},
                {2, 234, 345},
                {3, 345, 456},
                {2, 456, 567},
                {3, 567, 678}};
               
        cout << "\nOrig array is:\n";
        for(r=0; r<rows; r++)
                // print the array
        {
                for(c=0; c<cols; ++c) cout << '\t' << nums[r][c];
                // print each entry
               
                cout << endl;
                // add a line break
        }

        cout << endl;

        for(r=1; r<rows; r++)
        {
                // if array entry is bigger then the previous
                // entry, swap them
                if(nums[r][0] < nums[r-1][0])
                {
                        for(c=0; c<cols; c++)
                        {
                           tmp[0][c] = nums[r-1][c];
                           nums[r-1][c] = nums[r][c];
                           nums[r][c] = tmp[0][c];
                        }
                }
        }

        cout << "\nSorted array is:\n";
        for(r=0; r<rows; r++)
                // print the array
        {
                for(c=0; c<cols; ++c) cout << '\t' << nums[r][c];
                // print each entry

                cout << endl;
                // add a line break
        }

        return 0;
}

Orig array is:
        1       123     234
        2       234     345
        3       345     456
        2       456     567
        3       567     678


Sorted array is:
        1       123     234
        2       234     345
        2       456     567
        3       345     456
        3       567     678

[Lee Mac]

Thanks John 

It seems the challenge isn't as interesting as the other one, but I'm having fun anyway 

Here's an attempt at 'Bicursion' 

Code: [Select]

(defun _GroupByAssoc2 ( lst / g f )

  (defun g ( l )
    (if l
      (f (caar l) l)))

  (defun f ( x l )
    (cons
      (cons x (apply (function append)
                     (mapcar (function cdr)
                             (vl-remove-if-not
                               (function
                                 (lambda (pair) (= x (car pair)))) l))))
      (g (vl-remove-if (function (lambda (pair) (= x (car pair)))) l))))

  (g lst))


[qjchen]

Hi, Lee mac:)

When I finish the code, I feel it is similar to your first code.

Code: [Select]

(defun c:test ()
  (setq lst '((9 1111)
         (1 123 234) (2 234 345)
(3 345 456)
(2 456 567)
(4 678 789 90)
(3 567 678)
(1 111)
)
  )
  (chenGroupassoc lst)
)

(defun chenGroupassoc (lst / res a b item)
  (setq res (list (car lst)))
  (while (setq lst (cdr lst))
    (setq a (car lst) b (car a))
    (if (not (setq item (assoc b res)))
      (setq res (append res (list a)))
        (setq res (subst (append item (cdr a)) item res))))
)


[gile]

Hi

A cross recursive example

Code: [Select]

(defun GroupByAssoc (lst / f1 f2)
  (defun f1 (a l / b)
    (if (setq b (assoc (car a) l))
      (f1 (append a (cdr b)) (vl-remove b l))
      (cons a (f2 l))
    )
  )
  (defun f2 (l)
    (if (cdr l)
      (f1 (car l) (cdr l))
      l
    )
  )
  (f1 (car lst) (cdr lst))
)

[Lee Mac]

Very nice Gile!  I like it 

[Lee Mac]

Another to mess with the mind 

Code: [Select]

(defun _GroupByAssoc3 ( lst / g f )

  (defun g ( a b )
    (if a
      (if (assoc (caar a) b)
        (g (cdr a) b)
        (g (cdr a)
           (cons
             (cons (caar a)
                (f (caar a) a)) b))) b))

  (defun f ( x l )
    (if l
      (if (= x (caar l))
        (append (cdar l) (f x (cdr l)))
        (f x (cdr l)))))

  (reverse (g lst nil)))


[ElpanovEvgeniy]

my version:

Code: [Select]

(defun gba-ee (l / a)
 (setq l (vl-sort l (function (lambda (a b) (>= (car a) (car b)))))
       a nil
 )
 (while l
  (setq a (cons (car l) a)
        l (cdr l)
  )
  (while (and l (= (caar l) (caar a)))
   (setq a (cons (cons (caar l) (append (cdar l) (cdar a))) (cdr a))
         l (cdr l)
   )
  )
 )
 a
)

[Lee Mac]

Nice idea Evgeniy 

[ElpanovEvgeniy]

Nice idea Evgeniy 

I hope this idea will give odds to speed ...

[Lee Mac]

Nice idea Evgeniy 

I hope this idea will give odds to speed ...

But would Sorting reduce speed for longer lists... 

[ElpanovEvgeniy]

But would Sorting reduce speed for longer lists... 

Yes, sorting is very fast!
Particularly noticeable is in large lists...

[It's Alive!]

What's the difference between 'cross recursive' and 'Bicursion'... just so I know I'm properly dressed   

[Lee Mac]

What's the difference between 'cross recursive' and 'Bicursion'... 

Bicursion is a term I picked up from this thread 

[Lee Mac]

Quick speed test:

Code: [Select]

Intel Core2Duo @ 2.1GHz
3GB RAM

Elapsed milliseconds / relative speed for 16384 iteration(s):

    (MAC_GROUPBYASSOC LST)......1201 / 5.61 <fastest>
    (GILE_GROUPBYASSOC LST).....1264 / 5.33
    (GBA-EE LST)................1872 / 3.60
    (MAC_GROUPBYASSOC3 LST).....1903 / 3.54
    (MAC_GROUPBYASSOC2 LST).....6740 / 1.00 <slowest>


[MP]

[Lee Mac]

A test with a longer list reveals more... 

Code: [Select]

List Length: 80

Elapsed milliseconds / relative speed for 16384 iteration(s):

    (GILE_GROUPBYASSOC LST)......1310 / 8.00 <fastest>
    (GBA-EE LST).................4056 / 2.58
    (MAC_GROUPBYASSOC LST)......10484 / 1.00 <slowest>

My laptop's not fast enough to process lists much longer than that 

[Lee Mac]

Another 

Code: [Select]

(defun Mac_GroupByAssoc4 ( lst / item rtn out)
  (setq item (caar lst) rtn (cdar lst))

  (while (setq lst (cdr lst))
   
    (while (and lst (setq a (assoc item lst)))
     
      (setq rtn (append rtn (cdr a)) lst (vl-remove a lst)))
   
    (setq out (cons (cons item rtn) out) item (caar lst) rtn (cdar lst)))
 
  (reverse out))


[Lee Mac]

Code: [Select]

List Length: 5

Elapsed milliseconds / relative speed for 32768 iteration(s):

    (MAC_GROUPBYASSOC4 LST).....1482 / 1.41 <fastest>
    (MAC_GROUPBYASSOC LST)......1528 / 1.37
    (GILE_GROUPBYASSOC LST).....1576 / 1.33
    (GBA-EE LST)................2090 / 1.00 <slowest>


Code: [Select]

List Length: 80

Elapsed milliseconds / relative speed for 16384 iteration(s):

    (MAC_GROUPBYASSOC4 LST).....1139 / 8.49 <fastest>
    (GILE_GROUPBYASSOC LST).....1170 / 8.27
    (GBA-EE LST)................3697 / 2.62
    (MAC_GROUPBYASSOC LST)......9672 / 1.00 <slowest>

 

[ElpanovEvgeniy]

Hi Lee!

Code: [Select]

(Mac_GroupByAssoc4 '((1 2) (1 2) (1 2))) ;=>> ((1 2 2))
(GroupByAssoc '((1 2) (1 2) (1 2)))      ;=>> ((1 2 2))
(gba-ee '((1 2) (1 2) (1 2)))           ;=>> ((1 2 2 2))


[Lee Mac]

I wondered who'd be the first to spot that...

[ElpanovEvgeniy]

I wondered who'd be the first to spot that...

Now I do not know, I must make a new version?  :kewl:

[Lee Mac]

I wondered who'd be the first to spot that...

Now I do not know, I must make a new version?  :kewl:

No, I think your version is the correct way to deal with that situation - I just wish there was a function like vl-remove that would only remove the first occurence of an item. 

[Lee Mac]

I thought I'd try to write my own, but I cannot seem to get this to work 

Code: [Select]

(defun vl-remove-1st (x l / foo)

    (defun foo (y)
      (if (equal x y)
        (defun foo (y) nil)))

    (vl-remove-if (function foo) l))


[MP]

Don't have time to optimize but ...

Code: [Select]

(defun remove-first-if ( foo lst / bar )
   
    (defun bar (x) (if (foo x) (defun foo (x) nil)))   

    (vl-remove-if 'bar lst)

)

(remove-first-if

    (lambda (x) (eq 2 x))   
   
   '(0 1 2 2 3 4 5 6 7 8)   
   
)

=> (0 1 2 3 4 5 6 7 8)

[Lee Mac]

Thanks Michael - appreciated.

I couldn't work out why my solution failed though 

With my code

Code: [Select]

(defun vl-remove-1st (x l / foo)

    (defun foo (y)
      (if (equal x y)
        (defun foo (y) nil)))

    (vl-remove-if (function foo) l))

For say,

Code: [Select]

(vl-remove-1st 1 '(1 2 3 1 2 3))

I would have thought the first item is fed to foo, the IF statement evaluates and redefines foo (hence returning T, and so the first item is removed), and subsequent evaluation of foo would return nil (hence no more items are removed).

What is wrong in my reasoning?

[ElpanovEvgeniy]

my version remove first

Code: [Select]

(defun r1 (x l)
 (cond
  ((not l)nil)
  ((= x (car l))(cdr l))
  ((cons (car l)(r1 x(cdr l))))))

[Lee Mac]

As usual - nice idea Evgeniy! 

[ElpanovEvgeniy]

Code: [Select]

(defun r2 (x l / ll)
 ;;iteration
 (while (and l (/= (car l) x))
  (setq ll (cons (car l) ll)
        l  (cdr l)
  ) ;_  setq
 ) ;_  while
 (if l
  (append (reverse ll) (cdr l))
  (reverse ll)
 ) ;_  if
)

[gile]

A new version which doesn't remove duplicated items

Code: [Select]

(defun GroupByAssoc (lst / f1 f2)
  (defun f1 (a l / b)
    (if (setq b (assoc (car a) l))
      (f1 (append a (cdr b)) (removefirst b l))
      (cons a (f2 l))
    )
  )
  (defun f2 (l)
    (if (cdr l)
      (f1 (car l) (cdr l))
      l
    )
  )
  (f1 (car lst) (cdr lst))
)

(defun removefirst (item lst)
  (if (or (equal item (car lst)) (null lst))
    (cdr lst)
    (cons (car lst) (removefirst item (cdr lst)))
  )
)

[CAB]

My clumsy attempt.

Code: [Select]

(defun remove1 (x lst / itm result)
  (while (setq itm (car lst))
    (setq lst (cdr lst))
    (if (= x itm)
      (setq x nil)
      (setq result (cons itm result))
    )
  )
  (reverse result)
)

[Lee Mac]

Nice one Alan 

Its a shame, all of these solutions will be slower than vl-remove - so its looking like Evgeniy may snatch it for longer lists....

Code: [Select]

List Length: 5

Benchmarking ..................Elapsed milliseconds / relative speed for 32768 iteration(s):

    (MAC_GROUPBYASSOC LST).......1217 / 1.28 <fastest>
    (MAC_GROUPBYASSOC5 LST)......1326 / 1.18
    (GILE_GROUPBYASSOC2 LST).....1389 / 1.12
    (GBA-EE LST).................1560 / 1.00 <slowest>


Code: [Select]

List Length: 80

Benchmarking ................Elapsed milliseconds / relative speed for 8192 iteration(s):

    (GBA-EE LST)..................1529 / 11.57 <fastest>
    (MAC_GROUPBYASSOC LST)........4446 / 3.98
    (GILE_GROUPBYASSOC2 LST).....16443 / 1.08
    (MAC_GROUPBYASSOC5 LST)......17690 / 1.00 <slowest>


Code: [Select]

(defun Mac_GroupByAssoc5 ( lst / item rtn out)
  (setq item (caar lst) rtn (cdar lst))

  (while (setq lst (cdr lst))
   
    (while (and lst (setq a (assoc item lst)))
     
      (setq rtn (append rtn (cdr a)) lst (r1 a lst)))
   
    (setq out (cons (cons item rtn) out) item (caar lst) rtn (cdar lst)))
 
  (reverse out))

(defun r1 (x l) ; ElpanovEvgeniy
    (cond (  (not l) nil)
          (  (equal x (car l)) (cdr l))
          (  (cons (car l) (r1 x (cdr l))))))


[T.Willey]

Late to the party, but didn't see one that did it the way I had in my head, so it is.

Code: [Select]

(defun gba-tmw ( lst / a b r )
   
    (while (setq a (car lst))
        (cond
            ((not r) (setq r (list a)))
            ((setq b (assoc (car a) r)) (setq r (subst (cons (car b) (append (cdr b) (cdr a))) b r)))
            (t (setq r (cons a r)))
        )
        (setq lst (cdr lst))
    )
    (vl-sort r (function (lambda ( a b ) (< (car a ) (car b)))))
)

Here is one that will sort the nested lists also, incase that also desired.

Code: [Select]

(defun gba-tmw2 ( lst / a b r )
    ; (setq lst '((1 123 234) (2 234 345) (3 345 456) (2 456 567 133) (3 567 678 125)))
    (while (setq a (car lst))
        (cond
            ((not r) (setq r (list a)))
            ((setq b (assoc (car a) r)) (setq r (subst (cons (car b) (append (cdr b) (cdr a))) b r)))
            (t (setq r (cons a r)))
        )
        (setq lst (cdr lst))
    )
    (vl-sort
        (mapcar (function (lambda (a) (cons (car a) (vl-sort (cdr a) (function (lambda (x y) (< x y))))))) r)
        (function (lambda ( a b ) (< (car a ) (car b))))
    )
)