Topic: ==={ Challenge }=== General dyadic operation

[Jeremy]

A dyadic function is nothing more than a function that typically takes two arguments such as addition i.e. (+ 2 3). If we want to generalize for lists of arguments (vectors) we can write something like (mapcar '+ X Y) where X and Y are our two vectors. With more fiddling we can advance + to operate on matrices. Typically the vectors and matrices must be of the same order. But what do we do if we want to generalize the dyadic function to any two listings of any depth of any number of arguments? Suppose we want to add (+ '((a b) c (d e)) '((A B) C (D E))) ? Our only requirement is that X and Y have the same number of arguments in the same nested structure. I want a function DYADIC that has the form (dyadic func X Y) so that I can use ANY dyadic function in the described manner on arbitrary nested lists. My previous example would look something like (dyadic '+ X Y). This would be a very useful higher order function to have. I have no solution myself but I trust our local crew will come up with something. Let the programs begin!

[irneb]

Just a question: Does the function always take 2 atomic values as argument? I.e. it never expects a list? If so I think it's quite possible.

And then what should happen if one list is smaller than the other: nil values filled in or should the shorter list be repeated, or some other?

And 3rd: what if one of the arguments is already an atom? Should it be applied to all members of the list argument? I.e. something like vector operations?

[ribarm]

Your example :

Code: [Select]

(defun foo ( l1 l2 )
  (mapcar '(lambda ( a b ) (if (and (listp a) (listp b)) (mapcar '(lambda ( c d ) (+ c d)) a b) (+ a b))) l1 l2)
)

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


[gile]

Hi,

My 2 cents

Code - Auto/Visual Lisp: [Select]

1. (defun dyadic (fun a b)
2.   (cond
3.     ((or (null a) (null b)) nil)
4.     ((and (atom a) (atom b)) ((eval fun) a b))
5.     (T (cons (dyadic fun (car a) (car b)) (dyadic fun (cdr a) (cdr b))))
6.   )
7. )

or in a more efficient way (eval fun only once and tail recursion)

Code - Auto/Visual Lisp: [Select]

1. (defun dyadic (fun x y / loop)
2.   (defun loop (f a b r)
3.     (cond
4.       ((or (null a) (null b)) (reverse r))
5.       ((and (atom a) (atom b)) (f a b))
6.       (T (loop f (cdr a) (cdr b) (cons (loop f (car a) (car b) nil) r)))
7.     )
8.   )
9.   (loop (eval fun) x y nil)
10. )

[gile]

A safer way, returns nil and print an error message in case of unbalanced arguments.

Code - Auto/Visual Lisp: [Select]

1. (defun dyadic (fun x y / loop)
2.   (defun loop (f a b r)
3.     (cond
4.       ((and (null a) (null b)) (reverse r))
5.       ((and a b (atom a) (atom b)) (f a b))
6.       ((and (vl-consp a) (vl-consp b))
7.        (loop f (cdr a) (cdr b) (cons (loop f (car a) (car b) nil) r))
8.       )
9.       (T (prompt "\nError: unbalanced arguments"))
10.     )
11.   )
12.   (loop (eval fun) x y nil)
13. )

[Kerry]

A safer way, returns nil and print an error message in case of unbalanced arguments.

< .. >

A thing of beauty ...

[Stefan]

The recursive way, using mapcar...

Code - Auto/Visual Lisp: [Select]

1. (defun map2 (func arg1 arg2)
2.   (mapcar
3.     (function
4.       (lambda (a b)
5.         (cond
6.           ((and (listp a) (listp b))
7.            (map2 func a b)
8.            )
9.           ((and a b (eq (type a) (type b)))
10.            (apply func (list a b))
11.            )
12.           (T (vl-exit-with-error "Invalid arguments: "))
13.           )
14.         )
15.       )
16.     arg1 arg2
17.     )  
18.   )

Code: [Select]

(map2 '+ '((1 2 3) 4 (5 6 7)) '((3 2 1) 0 (-1 -2 -3)))
        ((4 4 4) 4 (4 4 4))
(map2 '- '((1 2 3) 4 (5 6 7)) '((3 2 1) 0 (-1 -2 -3)))
        ((-2 0 2) 4 (6 8 10))
(map2 'strcat '(("A" "B" ("C") ("D"))) '(("C" "D" ("E") ("F"))))
        (("AC" "BD" ("CE") ("DF")))

[chlh_jd]

does the 'fun only deal atom ? if the function is deal with lists like 'distance ?
here's my function for deal arg-type

Code: [Select]

;; multi-mapcar
;; _map_fun ---- function , it can be (lambda (x) ...)
;; _map_typ ---- Type , REAL FILE STR INT SYM LIST SUBR EXSUBR PICKSET ENAME PAGETB
;; _map_lst ---- a list
;;
;; e.g
;;   (ss-mapcar (lambda (x) (vl-string-trim " " x)) (quote STR) '(( " 1 " " 22 ") (" aA " "bB ")))
;;   --> (("1" "22") ("aA" "bB"))
;; Use for Excel string: (ss-mapcar (lambda (x)(vl-string-trim "`\t" x)) (quote STR) lst)
;;         
;; by GSLS(SS) 2013-10-25
(defun ss-mapcar (_map_fun _map_typ _map_lst)
  (mapcar (function (lambda (_lambda_x)
      (cond ((= (type _lambda_x) _map_typ)
     (_map_fun _lambda_x))
    ((= (type _lambda_x) (quote List))
     (ss-mapcar _map_fun _map_typ _lambda_x))
    (t _lambda_x))
      )
    )
  _map_lst))


[reltro]

Hey...
Whats about this?
Works also for three and more InputLists:

Code: [Select]

(defun mapinX (fun lst / loop R err)
    (defun loop (fun lst / c)
        (cond
            ((apply 'and (setq c (mapcar 'null lst))) nil)
            ((apply 'or c) (setq err 'T) nil)
            ((apply 'and (setq c (mapcar 'atom lst))) (apply fun lst))
            ((apply 'or c) (setq err 'T) nil)
            ((apply 'and (mapcar 'listp lst))
                (cons
                    (loop fun (mapcar 'car lst))
                    (loop fun (mapcar 'cdr lst))
                )
            )
           ('default (setq err 'T) nil)
        )
    )
   
    (setq R (loop fun lst))
   
    (if err
        (prompt "\nError: unbalanced arguments\n")
        R
    )
)


Code: [Select]

(mapinX
     '+
     (list
           '((1 2 3) (4 . 5) (1 2 3 . 6) ((5 6) . 10))
           '((5 6 12) (1 . 2) (2 3 12 . 12) ((1 2) . 4))
           '((10 34 12) (2 . 3) (4 5 1 . 2) ((3 1) . 20))
    )
)

;=> ((16 42 27) (7 . 10) (7 10 16 . 20) ((9 9) . 34))


Im not sure about how to check if the lists are balanced in the best manner.
normally i would say with (length ...) but on dotted pairs this one will fail...

Greets

[reltro]

iterative code

Code: [Select]

(defun MapinX (Expr Lst / Stack Result Dim c err raiseErr nilAsList)
    (setq nilAsList nil)

    (setq   lst      (mapcar 'list lst)
            raiseErr (lambda (m / )
                        (setq err m)
                     )
    )
    (while (or Lst Stack)
        (cond
            ((apply 'and (setq c (mapcar 'null Lst)))
                (setq   Lst   (car Stack)
                        Stack (cdr Stack)
                )
                (if Dim
                    (setq   Result  (cons
                                        (    (lambda ( / O)
                                                (cond
                                                    ((apply '= (caar Dim))
                                                        (repeat (caaar Dim)
                                                            (setq   O     (cons (car Result) O)
                                                                    Result(cdr Result)
                                                            )
                                                        )
                                                        (if (apply '= (cdar Dim))
                                                            (cond
                                                                ((= (cadar Dim) 0)
                                                                    O
                                                                )
                                                                ((= (cadar Dim) 1)
                                                                    (apply 'vl-list* O)
                                                                )
                                                            )
                                                            (progn
                                                                (setq Lst nil)
                                                                (raiseErr "Structural Mismatch: dotted Pair")
                                                            )
                                                        )
                                                    )
                                                    ('default
                                                        (setq Lst nil)
                                                        (raiseErr "Structural Mismatch: length")
                                                    )
                                                )
                                            )
                                        )
                                        Result
                                    )
                            Dim     (cdr Dim)
                    )
                )
            )
            ((apply 'or c) (setq Lst nil))
            (   (and
                    nilAsList
                    (apply
                        'and
                        (setq c
                            (mapcar
                                '(lambda (a / )
                                    (not (listp (car a)))
                                )
                                lst
                            )
                        )
                    )
                )
                (setq Result (cons (apply Expr (mapcar 'car Lst)) Result)
                      Lst    (mapcar 'cdr Lst)
                )
            )
            (    (and
                    (not nilAsList)
                    (apply
                        'and
                        (setq c
                            (mapcar
                                '(lambda (a / )
                                    (atom (car a))
                                )
                                lst
                            )
                        )
                    )
                )
                (setq Result (cons (apply Expr (mapcar 'car Lst)) Result)
                      Lst    (mapcar 'cdr Lst)
                )
            )
            ((apply 'or c)
                (setq Lst nil)
                (raiseErr "Structural Mismatch: list/atom")
            )
            ('T
                (setq Stack (cons (mapcar 'cdr Lst) Stack))
                (apply
                    '(lambda (L D / )
                        (setq Lst L
                              Dim (cons (cons (mapcar 'length Lst) D) Dim)
                        )
                    )
                    (    (lambda (a / F)
                            (list
                                (mapcar
                                    '(lambda (a / lst s)
                                        (setq s a)
                                        (while (not (atom (cdr a)))
                                            (setq lst (cons (car a) lst)
                                                  a   (cdr a)
                                            )
                                        )
                                        (cond
                                            ((cdr a)
                                                (setq F (cons 1 F))
                                                (reverse (vl-list* (cdr a) (car a) lst))
                                            )
                                            ('default
                                                (setq F (cons 0 F))
                                                s
                                            )
                                        )
                                    )
                                    a
                                )
                                F
                            )
                        )
                        (mapcar 'car Lst)
                    )
                )
            )
        )
    )
   
    (if err
        err
        (car (reverse Result))
    )
)
Same Input as above

Note: Change Variable 'nilAsList' in the code to
             - 'nil -> 'nil is interpreted as an atom
             - a value other than 'nil -> 'nil is interpreted as a list

reltro

[Jeremy]

Just a question: Does the function always take 2 atomic values as argument? I.e. it never expects a list? If so I think it's quite possible.

And then what should happen if one list is smaller than the other: nil values filled in or should the shorter list be repeated, or some other?

And 3rd: what if one of the arguments is already an atom? Should it be applied to all members of the list argument? I.e. something like vector operations?

1. Both arguments should be of the same type i.e. two atoms or two lists of atoms.
2. If both lists are not of the same length or of the same nesting structure the function should throw an error of some kind.
3. I hadn't originally envisioned that but that sounds like a useful default, go for it!

[bruno_vdh]

Hello,
My variant going easier, only symmetrical arguments are supported.
 

Code: [Select]

(defun dyadic (fun x y)
  (cond ((null (or x y)) nil)
        ((or (atom x) (atom y)) ((eval fun) x y))
        ((cons (dyadic fun (car x) (car y)) (dyadic fun (cdr x) (cdr y))))
  )
)


Code: [Select]

_$ (dyadic '+ '((1 2) 3 (4 3 5)) '((1 2) 3 (4 3 5)))
((2 4) 6 (8 6 10))
_$ (dyadic '+ '((1 2) 3 (4 5)) '((1 2) 3 (4 3 5)))
; erreur: type d'argument incorrect: numberp: nil
_$ (dyadic '+ '((1 2) 3 (4 3 5)) '((1 2) 3 (4 5)))
; erreur: type d'argument incorrect: numberp: (5)

Cordially

[gile]

Hi,

I think you're right bruno, it's a better way to let AutoCAD throw the errors.

[bruno_vdh]

Thank (gile)

And with the following idea: 

or in a more efficient way (eval fun only once and tail recursion)

Code: [Select]

(defun dyadic (f x y / loop)
  (defun loop (x y)
    (cond ((null (or x y)) nil)
          ((or (atom x) (atom y)) (f x y))
          ((cons (loop (car x) (car y)) (loop (cdr x) (cdr y))))
    )
  )
  (setq f (eval f))
  (loop x y)
)
I think we get a good solution ...

[bruno_vdh]

Hi,

My alternative for second-order functions that accept multiple arguments (type atom)…

Code: [Select]

(defun mapTree (f l)
  (cond ((null (apply 'or l)) nil)
        ((apply 'or (mapcar 'atom l)) (apply f l))
        ((cons (mapTree f (mapcar 'car l)) (mapTree f (mapcar 'cdr l))))
  )
)

Example:

Code: [Select]

_$ (mapTree 'strcat '((("a" "b") "c" ("d" "e" "f")) (("a" "b") "c" ("d" "e" "f")) (("a" "b") "c" ("d" "e" "f"))))
(("aaa" "bbb") "ccc" ("ddd" "eee" "fff"))
_$ (mapTree '+ '(((1 2) 3 (4 3 5)) ((1 2) 3 (4 3 5)) ((1 2) 3 (4 3 5))))
((3 6) 9 (12 9 15))