Cyclic Permutation

[Jeremy Dunn]

Greetings all lispers! I have run across a situation that I am sure some of you have too where one has an expression that involves the repetition of a form that has a cyclic permutation of arguments. For instance, suppose we have

(add (mul (sin A)(sin B))(mul (sin B)(sin C))(mul (sin C)(sin A)))

It is clear we are just cycling through our arguments and wasting a lot of verbiage. I would like to create a function that I will call CYCLIC that enables me to write this something like

(apply add (cyclic '(A B C) '(mul (sin *1)(sin *2))))

In the previous we have a list of the actual values '(A B C) that we want to cycle through and then we have the expression to substitute into. The expression has filler variables *1, *2 ... I am not sure of how to go about this. Should my expression be a quoted symbol or would it be better to have it as a string to chop apart and evaluate? It is the creation of dummy arguments *1, *2 etc that is puzzling me.

[Kazimir Majorinc]

This is one possibility:

Code: Select all

(set 'slice-circular
     (lambda(L i l)
        (slice (append L L) i l)))
        
(println (slice-circular '(A B C) 2 2)) ; (C A)
                
(set 'cycle 
     (lambda (L l)
        (let ((result '()))
             (for(i 0 (- (length L) 1))
                 (push (slice-circular L i l) 
                        result 
                       -1))
             result)))
             
(println (cycle '(A B C) 2)) ; ((A B) (B C) (C A))
;--------------------------------------------
; This is the basis, now you can use it to get what
; you want.

(set 'cycle-Jeremy-style 
     (lambda(f1 f2 f3 L n)
         (cons f1 
              (map (lambda(x)(cons f2 x))
                   (cycle (map (lambda(x)(list f3 x))
                               L) 
                          n)))))

(println (cycle-Jeremy-style 'add 'mul 'sin '(A B C) 2))

;(add (mul (sin A) (sin B)) (mul (sin B) (sin C)) (mul (sin C) (sin A)))

; You can insert eval in applied-cycle so it doesn't
; return expression ready to print or eval, instead
; it evaluates the expression and return the result. 

; Also, it can be "polished", for example using
; variable names that prevent overshadowing, 
; inserting foolproof checks etc. 

;-------------------------------------------
; Or, in generalized version ...

(set 'mmap 
     (lambda (L1 L2)
        (let ((result '()))
             (for(i 0 (- (length L1) 1))
                 (push  (list (L1 i)
                              (L2 i))
                        result
                        -1 ))
             result)))

(println (mmap (list 'sin 'cos) '(A B)))   ;((sin A) (cos B))

(set 'cycle-Jeremy-style-2
    (lambda(f1 f2 Lf3 L)
         (cons f1 
              (map (lambda(x)(cons f2 x))
                   (map (lambda(x)(mmap Lf3 x))
                        (cycle L (length Lf3)))))))
                        
(println (cycle-Jeremy-style-2 'add 'mul (list 'sin 'cos) '(A B C)))
;(add (mul (sin A) (cos B)) (mul (sin B) (cos C)) (mul (sin C) (cos A))) 
;----------------------------------------------------
; or, even simpler:

(println (cons 'add (map (lambda(w)(list 'mul (list 'sin (w 0))
                                              (list 'cos (w 1))))
                         (cycle '(A B C) 2))))


;----------------------------------------------------
; or, using apply instead of conses and evals:

(set 'A 1 'B 2 'C '3)
(println (apply add (map (lambda(w)(mul (sin (w 0))(cos (w 1))))
                         (cycle (list A B C) 2))))
(println (add (mul (sin 1) (cos 2))
              (mul (sin 2) (cos 3))
              (mul (sin 3) (cos 1))))

;-1.174125652
;-1.174125652

;--------------------------------------------------
; finally, this one is probably the closest match

(set 'A 1 'B 2 'C '3) 
(set 'cyclic 
     (lambda-macro(expr1 L1 n)
        (map (append (lambda(***))
                     (list expr1))
             (cycle (map eval L1) n))))

(println (apply add 
                (cyclic (mul (sin (*** 0)) (cos (*** 1)))
                        (A B C)
                        2)))

(exit)

[/size]

[Kazimir Majorinc]

It seems this one does exactly what you want, but it is kinda dirty because it performs analysis of the things like *0 *1, their counting and their conversion into (*** 0), (*** 1). Some of the previous versions is likely better, but it started to look like challenge.

Code: Select all

(set 'A 1 'B 2 'C 3)
(set 'cyclic 
     (lambda(xp3 L1)
       (let ((maxused 0)
             (i -1)
             (mel1 (map eval L1)))
             (dostring (dummy (string xp3))
               (let ((si (append "*" (string $idx))))
                     (when (find si (string xp3))
                           (set (sym si) (list '*** $idx))
                           (set 'xp3 (expand xp3 (sym si)))
                           (set 'maxused (+ $idx 1)))))
             (map (append (lambda(***)) (list xp3))
                  (map append 
                       (map (lambda()
                              (slice (append mel1 mel1) 
                                     (inc 'i) 
                                     maxused))
                            mel1))))))

(println (apply add (cyclic '(mul (sin *0) (cos *1))
                            '(A B C))))
                        
; -1.1745