;;; Guile Knots
;;; Copyright © 2020, 2025 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of Guile Knots.
;;;
;;; The Guile Knots is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; The Guile Knots is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (knots sort)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (fibers scheduler)
  #:use-module (knots promise)
  #:export (fibers-sort!))

(define (try-split-at! lst i)
  (cond ((< i 0)
         (error "negitive split size"))
        ((= i 0)
         (values '() lst))
        (else
         (let lp ((l lst) (n (- i 1)))
           (if (<= n 0)
               (let ((tmp (cdr l)))
                 (unless (null? tmp)
                   (set-cdr! l '()))
                 (values lst tmp))
               (if (or (null? l)
                       (null? (cdr l)))
                   (values lst '())
                   (lp (cdr l) (- n 1))))))))

(define (chunk! lst max-length)
  (let loop ((chunks '())
             (lst lst))
    (let ((chunk
           rest
           (try-split-at! lst max-length)))
      (if (null? rest)
          (reverse! (cons chunk chunks))
          (loop (cons chunk chunks)
                rest)))))

(define* (fibers-sort! items less #:key parallelism)
  (define requested-chunk-count
    (or parallelism
        (+ 1 (length (scheduler-remote-peers (current-scheduler))))))

  (define items-length (length items))

  (if (= 0 items-length)
      items
      (let* ((chunk-length (ceiling (/ items-length
                                       requested-chunk-count)))
             (chunks (chunk! items chunk-length)))
        (let loop ((sorted-chunk-promises
                    (map
                     (lambda (chunk)
                       (fibers-delay/eager
                        (lambda ()
                          (sort! chunk less))))
                     chunks)))
          (if (null? (cdr sorted-chunk-promises))
              (fibers-force
               (first sorted-chunk-promises))
              (loop
               (map
                (match-lambda
                  ((items) items)
                  ((a b)
                   (fibers-delay/eager
                    (lambda ()
                      (merge! (fibers-force a)
                              (fibers-force b)
                              less)))))
                (chunk! sorted-chunk-promises 2))))))))