A different list merging into a new list in Lisp

Question

I would like to ask how can I merge 2 different lists of numbers to a new list keeping the "common points" between them in Common Lisp.

Example

list1: (1 2 3 2 2 )
List2: (1/2 1/2 1 2 2 1 2 1)
Result:(1/2 1/2 1 1 1 2 1 1 1 1)

I hope the image below can give an exact description of the problem. The lists are numbers because it must compare the different units of the two series and further combine the points of start of each number of both series into a new serie.

Image_1. I think this image is the best way to describe the problem.

Answer 1

It seems to me that the list elements are like pauses between beats. My algorithm would at each step look for the minimum pause, then reduce the remaining current pauses by that and advance the lists when their current pause is zero.

To illustrate, I put a print instruction into the loop:

(defun merge-beats (&rest lists)
  (do* ((minpause nil (reduce #'min (mapcar #'first pauses)))
        (result () (cons minpause result))
        (pauses lists
                (remove nil
                        (mapcar (lambda (pause-list)
                                  (let ((current-pause (- (first pause-list)
                                                          minpause)))
                                    (if (zerop current-pause)
                                        (rest pause-list)
                                        (cons current-pause
                                              (rest pause-list)))))
                                pauses)))
        (- #1=(print (list :minpause minpause :result result :pauses pauses))
           #1#))
       ((endp pauses) (nreverse result))))


CL-USER> (merge-beats '(1 2 3 2 2)
                      '(1/2 1/2 1 2 2 1 2 1))

(:MINPAUSE NIL :RESULT NIL :PAUSES ((1 2 3 2 2) (1/2 1/2 1 2 2 1 2 1))) 
(:MINPAUSE 1/2 :RESULT (1/2) :PAUSES ((1/2 2 3 2 2) (1/2 1 2 2 1 2 1))) 
(:MINPAUSE 1/2 :RESULT (1/2 1/2) :PAUSES ((2 3 2 2) (1 2 2 1 2 1))) 
(:MINPAUSE 1 :RESULT (1 1/2 1/2) :PAUSES ((1 3 2 2) (2 2 1 2 1))) 
(:MINPAUSE 1 :RESULT (1 1 1/2 1/2) :PAUSES ((3 2 2) (1 2 1 2 1))) 
(:MINPAUSE 1 :RESULT (1 1 1 1/2 1/2) :PAUSES ((2 2 2) (2 1 2 1))) 
(:MINPAUSE 2 :RESULT (2 1 1 1 1/2 1/2) :PAUSES ((2 2) (1 2 1))) 
(:MINPAUSE 1 :RESULT (1 2 1 1 1 1/2 1/2) :PAUSES ((1 2) (2 1))) 
(:MINPAUSE 1 :RESULT (1 1 2 1 1 1 1/2 1/2) :PAUSES ((2) (1 1))) 
(:MINPAUSE 1 :RESULT (1 1 1 2 1 1 1 1/2 1/2) :PAUSES ((1) (1))) 
(:MINPAUSE 1 :RESULT (1 1 1 1 2 1 1 1 1/2 1/2) :PAUSES NIL) 
(1/2 1/2 1 1 1 2 1 1 1 1)
CL-USER> 

Answer 2

Based on your description, I wrote two mutually-recursive functions MRG and SPLIT:

• MRG iterates over the first list, all calls SPLIT for each element
• SPLIT tries to collect from the second list enough elements for which the sum is equal to the current element in the first list. If the element in the second list is too large, it is split and the remaining is reinjected into the second list. SPLIT also calls MRG when it has finished processing the current element in the first list.

Here is a trace of execution showing how the result is computed.

0: (MRG (1 2 3 2 2) (1/2 1/2 1 2 2 1 2 1))
    1: (SPLIT 1 (1/2 1/2 1 2 2 1 2 1) (2 3 2 2))
      2: (SPLIT 1/2 (1/2 1 2 2 1 2 1) (2 3 2 2))
        3: (SPLIT 0 (1 2 2 1 2 1) (2 3 2 2))
          4: (MRG (2 3 2 2) (1 2 2 1 2 1))
            5: (SPLIT 2 (1 2 2 1 2 1) (3 2 2))
              6: (SPLIT 1 (2 2 1 2 1) (3 2 2))
                7: (SPLIT 0 (1 2 1 2 1) (3 2 2))
                  8: (MRG (3 2 2) (1 2 1 2 1))
                    9: (SPLIT 3 (1 2 1 2 1) (2 2))
                      10: (SPLIT 2 (2 1 2 1) (2 2))
                        11: (SPLIT 0 (1 2 1) (2 2))
                          12: (MRG (2 2) (1 2 1))
                            13: (SPLIT 2 (1 2 1) (2))
                              14: (SPLIT 1 (2 1) (2))
                                15: (SPLIT 0 (1 1) (2))
                                  16: (MRG (2) (1 1))
                                    17: (SPLIT 2 (1 1) NIL)
                                      18: (SPLIT 1 (1) NIL)
                                        19: (SPLIT 0 NIL NIL)
                                            20: (MRG NIL NIL)
                                            20: MRG returned NIL
                                        19: SPLIT returned NIL
                                      18: SPLIT returned (1)
                                    17: SPLIT returned (1 1)
                                  16: MRG returned (1 1)
                                15: SPLIT returned (1 1)
                              14: SPLIT returned (1 1 1)
                            13: SPLIT returned (1 1 1 1)
                          12: MRG returned (1 1 1 1)
                        11: SPLIT returned (1 1 1 1)
                      10: SPLIT returned (2 1 1 1 1)
                    9: SPLIT returned (1 2 1 1 1 1)
                  8: MRG returned (1 2 1 1 1 1)
                7: SPLIT returned (1 2 1 1 1 1)
              6: SPLIT returned (1 1 2 1 1 1 1)
            5: SPLIT returned (1 1 1 2 1 1 1 1)
          4: MRG returned (1 1 1 2 1 1 1 1)
        3: SPLIT returned (1 1 1 2 1 1 1 1)
      2: SPLIT returned (1/2 1 1 1 2 1 1 1 1)
    1: SPLIT returned (1/2 1/2 1 1 1 2 1 1 1 1)
0: MRG returned (1/2 1/2 1 1 1 2 1 1 1 1)

I made no attempt to optimize the code, I just tried to do something that works correctly in a way that can produce a useful trace. But this looks like something for which a loop might work too.

Iterative version (edit)

Here is a version without recursion along with debugging statements:

(defun mrg% (lx ly)
  (with-list-collector (collect)
    (flet ((collect (v)
             "Add print statements to COLLECT"
             (print (list :collect v))
             (collect v)))
      (dolist (x lx)
        (loop
          (print (list :split x ly))
          (unless (plusp x)
            (return))
          (assert ly)
          (let ((y (pop ly)))
            (if (<= y x)
                (decf x (collect y))
                (return (push (- y (collect x)) ly)))))))))

With your example:

(mrg% '(1 2 3 2 2 )
      '(1/2 1/2 1 2 2 1 2 1))

... prints:

(:SPLIT 1 (1/2 1/2 1 2 2 1 2 1)) 
(:COLLECT 1/2) 
(:SPLIT 1/2 (1/2 1 2 2 1 2 1)) 
(:COLLECT 1/2) 
(:SPLIT 0 (1 2 2 1 2 1)) 
(:SPLIT 2 (1 2 2 1 2 1)) 
(:COLLECT 1) 
(:SPLIT 1 (2 2 1 2 1)) 
(:COLLECT 1) 
(:SPLIT 3 (1 2 1 2 1)) 
(:COLLECT 1) 
(:SPLIT 2 (2 1 2 1)) 
(:COLLECT 2) 
(:SPLIT 0 (1 2 1)) 
(:SPLIT 2 (1 2 1)) 
(:COLLECT 1) 
(:SPLIT 1 (2 1)) 
(:COLLECT 1) 
(:SPLIT 2 (1 1)) 
(:COLLECT 1) 
(:SPLIT 1 (1)) 
(:COLLECT 1) 
(:SPLIT 0 NIL)

For completeness, here is the macro I am using:

(defmacro with-list-collector 
  ((collector-name &optional name copy-p) &body body)
  "Bind COLLECTOR-NAME as a local function to collect items in a list.

A call to (COLLECTOR-NAME VALUE) accumulates VALUE into a list, in the
same order as the calls are being made. The resulting list can be
accessed through the symbol NAME, if given, or as the return value of
WITH-LIST-COLLECTOR. 

The return value of (COLLECTOR-NAME VALUE) is VALUE.

If COPY-P is T, each access to NAME performs a copy of the list under
construction. Otherwise, NAME refers to a list which last cons-cell is
modified after each call to COLLECTOR-NAME (except if it is NIL).

The return value of the whole form is the list being built, ONLY when
NAME is NIL. Otherwise, the return value is given by the last form of
BODY: it is assumed that the list will be accessed by NAME if
necessary, and that the interesting value is given by BODY."
  (assert (or (not copy-p) name) ()
          "A COPY argument is only valid when a NAME is given.")
  (alexandria:with-gensyms (queue head value)
    (let ((flet-expr `(flet ((,collector-name (,value)
                               (prog1 ,value
                                 (setf ,queue
                                       (setf (cdr ,queue)
                                             (cons ,value nil))))))
                        (declare (inline ,collector-name))
                        ,@body)))
      `(let* ((,queue (cons nil nil))
              (,head ,queue))
         ,(if name
              `(symbol-macrolet
                   ((,name ,(if copy-p
                                `(copy-seq (cdr ,head))
                                `(cdr ,head))))
                 ,flet-expr)
              ;; anonymous list : return as result
              `(progn ,flet-expr
                      (cdr ,head)))))))