TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: Lee Mac on April 03, 2010, 08:38:46 AM
-
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:
(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))
(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:
(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
-
Here is my c++ entry.
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
-
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' :-)
(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))
-
Hi, Lee mac:)
When I finish the code, I feel it is similar to your first code.
(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))))
)
-
Hi
A cross recursive example
(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))
)
-
Very nice Gile! I like it :-)
-
Another to mess with the mind :lol:
(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)))
-
my version:
(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
)
-
Nice idea Evgeniy :-)
-
Nice idea Evgeniy :-)
I hope this idea will give odds to speed ... :)
-
Nice idea Evgeniy :-)
I hope this idea will give odds to speed ... :)
But would Sorting reduce speed for longer lists... :angel:
-
But would Sorting reduce speed for longer lists... :angel:
Yes, sorting is very fast!
Particularly noticeable is in large lists...
-
What's the difference between 'cross recursive' and 'Bicursion'... just so I know I'm properly dressed :laugh:
-
What's the difference between 'cross recursive' and 'Bicursion'... :laugh:
Bicursion is a term I picked up from this (http://www.theswamp.org/index.php?topic=4064.0)thread :-)
-
Quick speed test:
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>
-
(http://i39.tinypic.com/110f02x.jpg)
-
A test with a longer list reveals more... :evil:
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 :|
-
Another :-)
(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))
-
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>
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>
8-)
-
Hi Lee! :)
(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))
-
I wondered who'd be the first to spot that...
-
I wondered who'd be the first to spot that...
Now I do not know, I must make a new version? :kewl:
-
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. :-(
-
I thought I'd try to write my own, but I cannot seem to get this to work :-(
(defun vl-remove-1st (x l / foo)
(defun foo (y)
(if (equal x y)
(defun foo (y) nil)))
(vl-remove-if (function foo) l))
-
Don't have time to optimize but ...
(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)
-
Thanks Michael - appreciated.
I couldn't work out why my solution failed though :-(
With my code
(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,
(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?
-
my version remove first
(defun r1 (x l)
(cond
((not l)nil)
((= x (car l))(cdr l))
((cons (car l)(r1 x(cdr l))))))
-
As usual - nice idea Evgeniy! :lol:
-
(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
)
-
A new version which doesn't remove duplicated items
(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)))
)
)
-
My clumsy attempt.
(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)
)
-
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....
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>
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>
(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))))))
-
Late to the party, but didn't see one that did it the way I had in my head, so it is.
(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.
(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))))
)
)