TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: Lee Mac on May 23, 2011, 03:58:40 PM
-
I think the Assoc++ function has been around for some time, something along the lines of:
([color=BLUE]defun[/color] _Assoc++ ( key alist )
(
([color=BLUE]lambda[/color] ( pair )
([color=BLUE]if[/color] pair
([color=BLUE]subst[/color] ([color=BLUE]list[/color] key ([color=BLUE]1+[/color] ([color=BLUE]cadr[/color] pair))) pair alist)
([color=BLUE]cons[/color] ([color=BLUE]list[/color] key 1) alist)
)
)
([color=BLUE]assoc[/color] key alist)
)
)
Wherein, if a key is already present in the association list, its associated value would be incremented, else the new key would be added to the association list.
Such a function is really handy when counting the number of instances of multiple items, for example in this simple block counter:
([color=BLUE]defun[/color] c:test ( [color=BLUE]/[/color] ss i lst )
([color=BLUE]if[/color] ([color=BLUE]setq[/color] ss ([color=BLUE]ssget[/color] [color=MAROON]"_X"[/color] '((0 . [color=MAROON]"INSERT"[/color]))))
([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] i ([color=BLUE]sslength[/color] ss))
([color=BLUE]setq[/color] lst (_Assoc++ ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 2 ([color=BLUE]entget[/color] ([color=BLUE]ssname[/color] ss ([color=BLUE]setq[/color] i ([color=BLUE]1-[/color] i)))))) lst))
)
)
lst
)
But, say we have a situation in which items form a hierarchy, and you wish to count items based on two (or more) variable keys - at this point the Assoc++ function cannot be used since only one key can be queried.
For example:
_$ ([color=BLUE]setq[/color] alist (_nAssoc++ '([color=MAROON]"Item1"[/color] [color=MAROON]"SubItem1"[/color] [color=MAROON]"A"[/color]) alist))
(
([color=MAROON]"Item1"[/color]
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"A"[/color] 1)
)
)
)
_$ ([color=BLUE]setq[/color] alist (_nAssoc++ '([color=MAROON]"Item1"[/color] [color=MAROON]"SubItem1"[/color] [color=MAROON]"B"[/color]) alist))
(
([color=MAROON]"Item1"[/color]
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"B"[/color] 1)
([color=MAROON]"A"[/color] 1)
)
)
)
_$ ([color=BLUE]setq[/color] alist (_nAssoc++ '([color=MAROON]"Item1"[/color] [color=MAROON]"SubItem2"[/color] [color=MAROON]"A"[/color]) alist))
(
([color=MAROON]"Item1"[/color]
([color=MAROON]"SubItem2"[/color]
([color=MAROON]"A"[/color] 1)
)
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"B"[/color] 1)
([color=MAROON]"A"[/color] 1)
)
)
)
_$ ([color=BLUE]setq[/color] alist (_nAssoc++ '([color=MAROON]"Item2"[/color] [color=MAROON]"SubItem1"[/color] [color=MAROON]"A"[/color]) alist))
(
([color=MAROON]"Item2"[/color]
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"A"[/color] 1)
)
)
([color=MAROON]"Item1"[/color]
([color=MAROON]"SubItem2"[/color]
([color=MAROON]"A"[/color] 1)
)
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"B"[/color] 1)
([color=MAROON]"A"[/color] 1)
)
)
)
_$ ([color=BLUE]setq[/color] alist (_nAssoc++ '([color=MAROON]"Item1"[/color] [color=MAROON]"SubItem1"[/color] [color=MAROON]"A"[/color]) alist))
(
([color=MAROON]"Item2"[/color]
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"A"[/color] 1)
)
)
([color=MAROON]"Item1"[/color]
([color=MAROON]"SubItem2"[/color]
([color=MAROON]"A"[/color] 1)
)
([color=MAROON]"SubItem1"[/color]
([color=MAROON]"B"[/color] 1)
([color=MAROON]"A"[/color] 2)
)
)
)
This was my solution,
[color=green];; Scroll for solution - so as not to spoil the challenge ;)[/color]
([color=BLUE]defun[/color] _nAssoc++ ( keys alist )
(
([color=BLUE]lambda[/color] ( pair )
([color=BLUE]if[/color] pair
([color=BLUE]subst[/color]
([color=BLUE]cons[/color] ([color=BLUE]car[/color] keys)
([color=BLUE]if[/color] ([color=BLUE]cdr[/color] keys)
(_nAssoc++ ([color=BLUE]cdr[/color] keys) ([color=BLUE]cdr[/color] pair))
([color=BLUE]list[/color] ([color=BLUE]1+[/color] ([color=BLUE]cadr[/color] pair)))
)
)
pair
alist
)
([color=BLUE]cons[/color]
([color=BLUE]if[/color] ([color=BLUE]cdr[/color] keys)
([color=BLUE]cons[/color] ([color=BLUE]car[/color] keys) (_nAssoc++ ([color=BLUE]cdr[/color] keys) [color=BLUE]nil[/color]))
([color=BLUE]list[/color] ([color=BLUE]car[/color] keys) 1)
)
alist
)
)
)
([color=BLUE]assoc[/color] ([color=BLUE]car[/color] keys) alist)
)
)
Have fun!
-
Can I show my version or better to wait a week?
-
My results are slightly different, but I like it! :)
(setq k '("Item1" "SubItem1" "A") l nil)
(setq l (f k l))
(("Item1" ("SubItem1" ("A" 1))));ElpanovEvgeniy
(("Item1" ("SubItem1" ("A" 1))))
(setq l (f '("Item1" "SubItem1" "B") l))
(("Item1" ("SubItem1" ("A" 1) ("B" 1))));ElpanovEvgeniy
(("Item1" ("SubItem1" ("B" 1) ("A" 1))))
(setq l (f '("Item1" "SubItem2" "A") l))
(("Item1" ("SubItem1" ("A" 1) ("B" 1)) ("SubItem2" ("A" 1))));ElpanovEvgeniy
(("Item1" ("SubItem2" ("A" 1)) ("SubItem1" ("B" 1) ("A" 1))))
(setq l (f '("Item2" "SubItem1" "A") l))
(("Item1" ("SubItem1" ("A" 1) ("B" 1)) ("SubItem2" ("A" 1))) ("Item2" ("SubItem1" ("A" 1))));ElpanovEvgeniy
(("Item2" ("SubItem1" ("A" 1))) ("Item1" ("SubItem2" ("A" 1)) ("SubItem1" ("B" 1) ("A" 1))))
(setq l (f '("Item1" "SubItem1" "A") l))
(("Item1" ("SubItem1" ("A" 2) ("B" 1)) ("SubItem2" ("A" 1))) ("Item2" ("SubItem1" ("A" 1))));ElpanovEvgeniy
(("Item2" ("SubItem1" ("A" 1))) ("Item1" ("SubItem2" ("A" 1)) ("SubItem1" ("B" 1) ("A" 2))))
-
Can I show my version or better to wait a week?
I'll bet your solution has half the lines of code that mine has :evil:
-
My results are slightly different, but I like it! :)
Ah yes! Looks like I need a reverse in there:
(defun _nAssoc++ ( keys alist )
(
(lambda ( pair )
(if pair
(subst
(cons (car keys)
(if (cdr keys)
(_nAssoc++ (cdr keys) (cdr pair))
(list (1+ (cadr pair)))
)
)
pair
alist
)
[color=blue] (reverse[/color]
(cons
(if (cdr keys)
(cons (car keys) (_nAssoc++ (cdr keys) nil))
(list (car keys) 1)
)
alist
)
[color=blue] )[/color]
)
)
(assoc (car keys) alist)
)
)
-
I'll bet your solution has half the lines of code that mine has :evil:
I wrote 8 lines, but some of them have a greater length :-)
-
I'll bet your solution has half the lines of code that mine has :evil:
I wrote 8 lines, but some of them have a greater length :-)
We could all play that game :evil:
(defun f ( k l / a )
(if (setq a (assoc (car k) l))
(subst (cons (car k) (if (cdr k) (f (cdr k) (cdr a)) (list (1+ (cadr a))))) a l)
(reverse (cons (if (cdr k) (cons (car k) (f (cdr k) nil)) (list (car k) 1)) l))
)
)
-
Another, cross-recursive example:
(defun f ( k l ) (if k (g k l) (list (1+ (car l)))))
(defun g ( k l / a )
(if k
(if (setq a (assoc (car k) l))
(subst (cons (car k) (f (cdr k) (cdr a))) a l)
(cons (cons (car k) (g (cdr k) nil)) l)
)
'(1)
)
)
_$ (setq l (f '("Item1" "SubItem1" "A") l))
(("Item1" ("SubItem1" ("A" 1))))
_$ (setq l (f '("Item1" "SubItem1" "B") l))
(("Item1" ("SubItem1" ("B" 1) ("A" 1))))
[Didn't want to spoil it with the reverse...] :P
-
Or, to remove the cross-recursive call...
(defun g ( k l / a )
(if k
(if (setq a (assoc (car k) l))
(subst (cons (car k) (g (cdr k) (cdr a))) a l)
(cons (cons (car k) (g (cdr k) nil)) l)
)
(if l (list (1+ (car l))) '(1))
)
)
-
it looks like you are challenging yourself, Lee :)
-
my version
(defun f (k l)
(cond
((and l (not k)) (list (1+ (car l))))
((not k) '(1))
((or (not l) (= (car k) (caar l))) (cons (cons (car k) (f (cdr k) (cdar l))) (cdr l)))
((cons (car l) (f k (cdr l))))
)
)
-
it looks like you are challenging yourself, Lee :)
I tend to constantly think my code is not good enough and challenge myself to produce something better... I'm enjoying this challenge though :-)
my version
(defun f (k l)
(cond
((and l (not k)) (list (1+ (car l))))
((not k) '(1))
((or (not l) (= (car k) (caar l))) (cons (cons (car k) (f (cdr k) (cdar l))) (cdr l)))
((cons (car l) (f k (cdr l))))
)
)
Nice idea Evgeniy! It looks like we followed a similar route to increment the value, but you chose not to use assoc, but rather iterate through the list... :-)
-
How nice it is to see How 2 of best programmer can play together...very enjoying.
good job guys.
:-)
-
How nice it is to see How 2 of best programmer can play together...very enjoying.
good job guys.
:-)
Thanks Andrea :-)
Although Evgeniy is much cleverer than I :angel:
-
How nice it is to see How 2 of best programmer can play together...very enjoying.
good job guys.
:-)
Thanks Andrea :-)
Although Evgeniy is much cleverer than I :angel:
A Chinese idiom:英雄惜英雄。 :laugh:
-
How nice it is to see How 2 of best programmer can play together...very enjoying.
good job guys.
:-)
Thanks Andrea :-)
Although Evgeniy is much cleverer than I :angel:
A Chinese idiom:英雄惜英雄。 :laugh:
Google Translate doesn't translate it too well, but I think I get the gist of it...
-
Google Translate is a little funny.
I translate my word literality,it means : heros like heros,or genius chrishes genius..
I like your guys very much.Maybe I am a little hero too.
Lee, when I saw you use "lambda" elegantly,I knew, I have a lot to learn LISP.
Thanks your contribution.
-
Google Translate is a little funny.
I translate my word literality,it means : heros like heros,or genius chrishes genius..
I like your guys very much.Maybe I am a little hero too.
Lee, when I saw you use "lambda" elegantly,I knew, I have a lot to learn LISP.
Thanks your contribution.
That's very kind of you highflybird :-)
I am also amazed by some of the code you create, both in LISP and another languages...