diff options
author | David Thompson <dthompson2@worcester.edu> | 2014-06-28 18:46:16 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2014-06-28 18:46:16 -0400 |
commit | f47eb69a354188154731846dde8b384c2c2f39f6 (patch) | |
tree | 6aa1ccb9212836b7c941e771475eb995fa6df9f9 /2d/agenda.scm | |
parent | df0f2a5f3f09394f1953abbc7e33e9a98204680e (diff) |
Rename guile-2d to Sly!
Massive find/replace job.
Diffstat (limited to '2d/agenda.scm')
-rw-r--r-- | 2d/agenda.scm | 206 |
1 files changed, 0 insertions, 206 deletions
diff --git a/2d/agenda.scm b/2d/agenda.scm deleted file mode 100644 index ab36f23..0000000 --- a/2d/agenda.scm +++ /dev/null @@ -1,206 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; This program 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. -;;; -;;; This program 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 this program. If not, see -;;; <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; Deferred procedure scheduling. -;; -;;; Code: - -(define-module (2d agenda) - #:use-module (ice-9 q) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (2d coroutine) - #:export (make-agenda - agenda? - agenda-time - current-agenda - with-agenda - tick-agenda! - clear-agenda! - schedule - schedule-interval - schedule-each - wait)) - -;; This code is a modified version of the agenda implementation in -;; SICP. Thank you, SICP! - -;;; -;;; Time segment -;;; - -(define-record-type <time-segment> - (%make-time-segment time queue) - time-segment? - (time segment-time) - (queue segment-queue)) - -(define (make-time-segment time . callbacks) - "Create a new time segment at TIME and enqueues everything in the -list CALLBACKS." - (let ((segment (%make-time-segment time (make-q)))) - ;; Enqueue all callbacks - (for-each (cut segment-enq segment <>) callbacks) - segment)) - -(define (segment-enq segment callback) - "Add the CALLBACK procedure to SEGMENT's queue." - (enq! (segment-queue segment) callback)) - -;;; -;;; Agenda -;;; - -(define-record-type <agenda> - (%make-agenda time segments) - agenda? - (time %agenda-time set-agenda-time!) - (segments agenda-segments set-agenda-segments!)) - -(define (make-agenda) - "Create a new, empty agenda." - (%make-agenda 0 '())) - -(define (agenda-empty? agenda) - "Return #t if AGENDA has no scheduled procedures." - (null? (agenda-segments agenda))) - -(define (first-segment agenda) - "Return the first time segment in AGENDA." - (car (agenda-segments agenda))) - -(define (rest-segments agenda) - "Return everything but the first segment in AGENDA." - (cdr (agenda-segments agenda))) - -(define (agenda-add-segment agenda time callback) - "Add a new time segment to the beginning of AGENDA at the given TIME -and enqueue CALLBACK." - (set-agenda-segments! agenda - (cons (make-time-segment time callback) - (agenda-segments agenda)))) - -(define (insert-segment segments time callback) - "Insert a new time segment after the first segment in SEGMENTS." - (set-cdr! segments - (cons (make-time-segment time callback) - (cdr segments)))) - -(define (first-agenda-item agenda) - "Return the first time segment queue in AGENDA." - (if (agenda-empty? agenda) - (error "Agenda is empty") - (segment-queue (first-segment agenda)))) - -(define (agenda-time-delay agenda dt) - "Return the sum of the time delta, DT, and the current time of AGENDA." - (+ (%agenda-time agenda) (inexact->exact (round dt)))) - -(define (flush-queue! q) - "Dequeue and execute every member of Q." - (unless (q-empty? q) - ((deq! q)) ;; Execute scheduled procedure - (flush-queue! q))) - -(define (%tick-agenda! agenda) - "Move AGENDA forward in time and run scheduled procedures." - (set-agenda-time! agenda (1+ (%agenda-time agenda))) - (let next-segment () - (unless (agenda-empty? agenda) - (let ((segment (first-segment agenda))) - ;; Process time segment if it is scheduled before or at the - ;; current agenda time. - (when (>= (%agenda-time agenda) (segment-time segment)) - (flush-queue! (segment-queue segment)) - (set-agenda-segments! agenda (rest-segments agenda)) - (next-segment)))))) - -(define (%clear-agenda! agenda) - "Remove all scheduled procedures from AGENDA." - (set-agenda-segments! agenda '())) - -(define (%schedule agenda thunk delay) - "Schedule THUNK to be run after DELAY ticks of AGENDA." - (let ((time (agenda-time-delay agenda delay))) - (define (belongs-before? segments) - (or (null? segments) - (< time (segment-time (car segments))))) - - (define (add-to-segments segments) - ;; Add to existing time segment if the times match - (if (= (segment-time (car segments)) time) - (segment-enq (car segments) thunk) - ;; Continue searching - (if (belongs-before? (cdr segments)) - ;; Create new time segment and insert it where it belongs - (insert-segment segments time thunk) - ;; Continue searching - (add-to-segments (cdr segments))))) - - (if (belongs-before? (agenda-segments agenda)) - (agenda-add-segment agenda time thunk) - (add-to-segments (agenda-segments agenda))))) - -(define current-agenda - (make-parameter (make-agenda) - (lambda (val) - (if (agenda? val) - val - (error "Must be an agenda"))))) - -(define-syntax-rule (with-agenda agenda body ...) - (parameterize ((current-agenda agenda)) - body ...)) - -(define (agenda-time) - "Return the time of the current agenda." - (%agenda-time (current-agenda))) - -(define (tick-agenda!) - "Increment time for the current agenda and run scheduled -procedures." - (%tick-agenda! (current-agenda))) - -(define (clear-agenda!) - "Remove all scheduled procedures from the current agenda." - (%clear-agenda! (current-agenda))) - -(define* (schedule thunk #:optional (delay 1)) - "Schedule THUNK to be applied after DELAY ticks of the current -agenda, or 1 tick if DELAY is not specified." - (%schedule (current-agenda) thunk delay)) - -(define (schedule-interval thunk interval) - "Schedule THUNK to be applied every INTERVAL ticks of the current -agenda." - (coroutine - (while #t - (wait interval) - (thunk)))) - -(define (schedule-each thunk) - "Schedule THUNK to be applied upon every tick of the current -agenda." - (schedule-interval thunk 1)) - -(define (wait delay) - "Abort coroutine and schedule the continuation to be run after DELAY -ticks of the current agenda." - (yield (cut schedule <> delay))) |