binary_counter.cl

(defun add-to-counter (counter carry zero op &key (test #'eq))
  (dotimes (i (length counter))
	(if (funcall test (aref counter i) zero)
	  (progn (setf (aref counter i) carry)
			 (setf carry zero))
	  (progn
	  	(setf carry (funcall op (aref counter i) carry))
	  	(setf (aref counter i) zero))
	  ))
  carry)


(defun reduce-counter (counter zero op &key (test #'eq))
  (prog ((i 0) (n (length counter)) (carry zero))
		non-zero
		(when (and (< i n)
				   (funcall test (aref counter i) zero))
		  (incf i)
		  (go non-zero))

		(when (= i n) (return carry))

		(setf carry (aref counter i))
		(incf i)

		loop
		(when (< i n)
		  (when (not (funcall test (aref counter i) zero))
			(setf carry (funcall op (aref counter i) carry)))
		  (incf i)
		  (go loop))

		(return carry)))


(defun balanced-reduce (sequence op &key (test #'eq) (zero nil))
  (let ((counter (make-array 20 :adjustable t :fill-pointer 0)))
	(map nil (lambda (x)
			   (let ((carry (add-to-counter counter x zero op :test test)))
				 (when (not (funcall test zero carry))
				   (vector-push-extend carry counter))))
			   sequence)
	(reduce-counter counter zero op :test test)))

(pprint (balanced-reduce '(1 2 3 4) #'+ :zero 0))

(defun merge-sort (sequence &key (predicate #'<) (key #'identity))
  (balanced-reduce
	(map 'vector #'list sequence)
	(lambda (a b) (merge 'list a b predicate :key key))))


(pprint (merge-sort (loop for i from 1 to 100 collect (random i))))