;;; Chickadee Game Toolkit
;;; Copyright © 2017, 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (chickadee scripting agenda)
  #:use-module (chickadee data heap)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:export (make-agenda
            agenda?
            current-agenda
            with-agenda
            agenda-time
            update-agenda
            clear-agenda
            reset-agenda
            schedule-at
            schedule-after
            schedule-every
            call-when
            at
            after
            every))

(define-record-type <agenda>
  (%make-agenda time queue poll-set)
  agenda?
  (time %agenda-time set-agenda-time!)
  (queue agenda-queue)
  (poll-set agenda-poll-set))

(define (task< a b)
  (< (car a) (car b)))

(define (make-agenda)
  "Return a new task scheduler."
  (%make-agenda 0 (make-heap task<) (make-hash-table)))

(define (schedule agenda time thunk)
  (when (<= time (%agenda-time agenda))
    (error "cannot schedule in the past" time))
  (heap-insert! (agenda-queue agenda) (cons time thunk)))

(define (poll agenda pred thunk)
  (hashq-set! (agenda-poll-set agenda) pred thunk))

(define (%agenda-clear! agenda)
  (heap-clear! (agenda-queue agenda))
  (hash-clear! (agenda-poll-set agenda))
  *unspecified*)

(define (%update-agenda agenda dt)
  (let ((queue (agenda-queue agenda))
        (poll-set (agenda-poll-set agenda))
        (time (+ (%agenda-time agenda) dt)))
    (set-agenda-time! agenda time)
    (let loop ()
      (when (not (heap-empty? queue))
        (match (heap-min queue)
          ((task-time . thunk)
           (when (<= task-time time)
             (heap-remove! queue)
             (thunk)
             (loop))))))
    (hash-for-each (lambda (pred thunk)
                     (when (pred)
                       (hashq-remove! poll-set pred)
                       (thunk)))
                   poll-set)))

(define current-agenda (make-parameter (make-agenda)))

(define-syntax-rule (with-agenda agenda body ...)
  (parameterize ((current-agenda agenda))
    body ...))

(define (agenda-time)
  "Return the current agenda time."
  (%agenda-time (current-agenda)))

(define (clear-agenda)
  "Remove all scheduled tasks from the current agenda."
  (%agenda-clear! (current-agenda)))

(define (reset-agenda)
  "Remove all scheduled tasks from the current agenda and reset time
to 0."
  (%agenda-clear! (current-agenda))
  (set-agenda-time! (current-agenda) 0))

(define (update-agenda dt)
  "Advance the current agenda by DT."
  (%update-agenda (current-agenda) dt))

(define (schedule-at time thunk)
  "Schedule THUNK to be run at TIME."
  (schedule (current-agenda) time thunk))

(define (schedule-after delay thunk)
  "Schedule THUNK to be run after DELAY."
  (schedule (current-agenda) (+ (agenda-time) delay) thunk))

(define* (schedule-every interval thunk #:optional n)
  "Schedule THUNK to run every INTERVAL amount of time.  Repeat this N
times, or indefinitely if not specified."
  (schedule-after interval
                  (lambda ()
                    (cond
                     ((not n)
                      (thunk)
                      (schedule-every interval thunk))
                     ((> n 0)
                      (thunk)
                      (schedule-every interval thunk (- n 1)))))))

(define (call-when pred thunk)
  (poll (current-agenda) pred thunk))

(define-syntax-rule (at time body ...)
  (schedule-at time (lambda () body ...)))

(define-syntax-rule (after delay body ...)
  (schedule-after delay (lambda () body ...)))

(define-syntax every
  (syntax-rules ()
    ((_ (interval n) body ...)
     (schedule-every interval (lambda () body ...) n))
    ((_ interval body ...)
     (schedule-every interval (lambda () body ...)))))