;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

#lang syndicate
;; Santa Claus Problem
;; https://www.schoolofhaskell.com/school/advanced-haskell/beautiful-concurrency/4-the-santa-claus-problem
;; https://arxiv.org/pdf/1810.09613.pdf

(require/activate syndicate/drivers/timer)
(require racket/list)
(require racket/set)

(assertion-struct elf-has-a-problem (id))
(assertion-struct reindeer-has-returned (id))

(assertion-struct problem-resolved (id))
(assertion-struct deliver-toys ())

(define N-ELVES 10)
(define ELF-GROUP-SIZE 3)
(define N-REINDEER 9)

(define (elf)
  (define elf-self (gensym 'elf))
  (spawn* #:name elf-self
          (let work-industriously ()
            (sleep (/ (random 1000) 1000.0))
            (react (assert (elf-has-a-problem elf-self))
                   (stop-when (asserted (problem-resolved elf-self))
                     (work-industriously))))))

(define (reindeer)
  (define reindeer-self (gensym 'reindeer))
  (spawn* #:name reindeer-self
          (let holiday ()
            (sleep (/ (random 9000) 1000.0))
            (react (assert (reindeer-has-returned reindeer-self))
                   (stop-when (asserted (deliver-toys))
                     (react (stop-when (retracted (deliver-toys))
                              (holiday))))))))

(spawn* #:name 'santa
        (define (wait-for-work)
          (react (define/query-set stuck-elves (elf-has-a-problem $id) id)
                 (define/query-set returned-reindeer (reindeer-has-returned $id) id)
                 (stop-when-true (= (set-count (returned-reindeer)) N-REINDEER)
                   (harness-reindeer))
                 (stop-when-true (>= (set-count (stuck-elves)) ELF-GROUP-SIZE)
                   (talk-to-elves (take (set->list (stuck-elves)) ELF-GROUP-SIZE)))))

        (define (harness-reindeer)
          (react (assert (deliver-toys))
                 (stop-when (retracted (reindeer-has-returned _))
                   (wait-for-work))))

        (define (talk-to-elves elves)
          (match elves
            ['() (wait-for-work)]
            [(cons elf remainder)
             (react (assert (problem-resolved elf))
                    (stop-when (retracted (elf-has-a-problem elf))
                      (talk-to-elves remainder)))]))

        (wait-for-work))

(for [(i N-ELVES)] (elf))
(for [(i N-REINDEER)] (reindeer))

(spawn #:name 'narrator
       (during (elf-has-a-problem $id)
         (on-start (printf "~a has a problem!\n" id))
         (on-stop  (printf "~a's problem is resolved. ~a returns to work.\n" id id)))

       (on (asserted (reindeer-has-returned $id))
           (printf "~a has returned from holiday and is ready to deliver toys!\n" id))

       (on (retracted (reindeer-has-returned $id))
           (printf "~a delivers toys with the other reindeer.\n" id)
           (react (stop-when (retracted (deliver-toys))
                    (printf "~a has been dismissed by Santa, and goes back on holiday.\n" id))))

       (on (asserted (deliver-toys))
           (printf "Santa does the delivery run!\n"))

       (on (asserted (problem-resolved $id))
           (printf "Santa resolves the problem of ~a.\n" id)))