;;;
;;; COLLECTING THINGS
;;;

(defparameter *pouch* nil)

(defun funcall-collector (callback)
  (declare (type (function (&optional T)) callback))
  (cons
   (lambda (x) (funcall callback x))
   (lambda () (funcall callback))))

(defun queue-collector ()
  (let ((q (serapeum:queue)))
    (cons
     (lambda (x) (serapeum:enq x q))
     (lambda () (serapeum:qlist q)))))

(defun vector-collector (size)
  (let ((v (make-array size :fill-pointer 0 :adjustable nil)))
    (cons
     (lambda (x) (vector-push x v))
     (lambda () v))))

(defun take (value &optional (cons *pouch*))
  (prog1 value
    (funcall (car cons) value)))

(defun loot (&optional (cons *pouch*))
  (funcall (cdr cons)))

(defun call-while-hoarding (function &key (result-type 'list) size)
  (let ((*pouch* (case result-type
                   (list (queue-collector))
                   (vector (if size
                               (vector-collector size)
                               (unbounded-vector-collector)))
                   (t (etypecase result-type
                        (function (funcall-collector result-type)))))))
    (funcall function)))

(defmacro hoarding ((&rest args) &body body)
  ;; parse: name is optional
  (let* ((name-p (not (keywordp (first args))))
         (args (if name-p (cdr args) args))
         (name (when name-p (car args))))
    `(funcall #'call-while-hoarding
              (lambda ()
                ,@(if name
                      `((let ((,name *pouch*)) ,@body))
                      body))
              ,@args)))
;;;
;;; SPLIT BY N
;;;

(defun split-n (sequence n
                &key last sharedp (result-type 'list)
                &aux (size (length sequence)))
  (check-type sequence sequence)
  (check-type n (integer 1 *))
  (ecase last
    ((nil t) (setf last :undersized))
    ((:truncated :oversized :undersized) last))
  (let ((slice
          (etypecase sequence
            (vector
             (let* ((type (array-element-type sequence))
                    (beg 0)
                    (end n)
                    (copy (if sharedp
                              (lambda (b e)
                                (make-array (- e b)
                                            :displaced-to sequence
                                            :displaced-index-offset b
                                            :element-type type))
                              (lambda (b e)
                                (subseq sequence b e)))))
               (lambda (&optional tail)
                 (if tail
                     (when (< beg size)
                       (funcall copy beg size))
                     (prog1 (funcall copy beg end)
                       (setf beg end
                             end (+ n end)))))))
            (list
             (let ((copy
                     (if sharedp #'identity #'copy-list))
                   (current sequence))
               (lambda (&optional tail)
                 (when current
                   (if tail
                       (funcall copy current)
                       (prog1 (subseq current 0 n)
                         (setf current (nthcdr n current)))))))))))
    (multiple-value-bind (count remainder) (truncate size n)
      (hoarding (:result-type result-type
                 :size (ecase last
                         (:undersized (+ count (signum remainder)))
                         (:oversized count)
                         (:truncated count)))
        (dotimes (_ (ecase last
                      (:undersized count)
                      (:oversized (1- count))
                      (:truncated count)))
          (take (funcall slice)))
        (let ((residual (funcall slice t)))
          (case last
            ((:undersized :oversized)
             (when residual (take residual))
             (values (loot)
                     (cond
                       ((zerop remainder) nil)
                       ((eq last :undersized) remainder)
                       (t (min size (+ remainder n))))))
            (:truncated (values (loot)
                                residual))))))))

;;;
;;; DO-BATCHES
;;;

(defmacro do-batches ((name args &optional result-form) &body body)
  (check-type name symbol)
  (destructuring-bind (sequence n &key last sharedp) args
    (let ((call
            `(funcall #'split-n ,sequence ,n
                      :last ,last
                      :sharedp ,sharedp
                      :result-type (lambda (&optional ,name)
                                     (if ,name
                                         (progn ,@body)
                                         ,result-form)))))
      (if result-form
          call
          `(nth-value 1 ,call)))))

;; example

(let* ((list '(1 2 3 4 5 6 7 8 9 10))
       (sub (nthcdr 8 list)))
  (eq sub
      (do-batches (x (list 4 :last :truncated :sharedp t))
        (print x))))

;; tests

(trace split-n)

(with-open-file (*trace-output*
                 #P"/tmp/pastebin" :direction :output :if-exists :supersede)
  (dolist (last '(:undersized :oversized :truncated))
    (dolist (shared '(nil t))
      (dolist (type '(vector list))
        (dolist (input (list #() '()
                             #(1) '(1)
                             '(a b c) #(a b c)
                             '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
                             #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
                             "something in a string"))
          (dolist (n '(1 2 3 4 5 6 7 8))
            (split-n input n :last last :sharedp shared :result-type type)
            (terpri *trace-output*)))))))