Topic: -={ Challenge }=- Nested Assoc++

[Lee Mac]

I think the Assoc++ function has been around for some time, something along the lines of:

Code: [Select]

([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:

Code: [Select]

([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:

Code: [Select]

_$ ([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,

Code: [Select]

[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!

[ElpanovEvgeniy]

Can I show my version or better to wait a week?

[ElpanovEvgeniy]

My results are slightly different, but I like it!

Code: [Select]

(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))))

[Lee Mac]

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 

[Lee Mac]

My results are slightly different, but I like it!

Ah yes! Looks like I need a reverse in there:

Code: [Select]

(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)
  )
)

[ElpanovEvgeniy]

I'll bet your solution has half the lines of code that mine has 

I wrote 8 lines, but some of them have a greater length 

[Lee Mac]

I'll bet your solution has half the lines of code that mine has 

I wrote 8 lines, but some of them have a greater length 

We could all play that game 

Code: [Select]

(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))
  )
)

[Lee Mac]

Another, cross-recursive example:

Code: [Select]

(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)
  )
)

Code: [Select]

_$ (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...]

[Lee Mac]

Or, to remove the cross-recursive call...

Code: [Select]

(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))
  )
)

[VovKa]

it looks like you are challenging yourself, Lee

[ElpanovEvgeniy]

my version

Code: [Select]

(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))))
 )
)

[Lee Mac]

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

Code: [Select]

(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... 

[Andrea]

How nice it is to see How 2 of best programmer can play together...very enjoying.
good job guys.

 

[Lee Mac]

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 

[highflyingbird]

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 

A Chinese idiom:英雄惜英雄。