tests.scm

   1 #!/usr/bin/guile \
   2 -s
   3 !#
   4
   5 (define-module (tests test-core)
   6   #:use-module (srfi srfi-64)
   7   #:use-module (ice-9 q)
   8   #:use-module (ice-9 receive)
   9   #:use-module (loopy agenda))
  10
  11 (test-begin "tests")
  12
  13 \f
  14 ;; Timer tests
  15 ;; ===========
  16
  17 (test-assert (time-= '(1 . 1) '(1 . 1)))
  18 (test-assert (not (time-= '(1 . 1) '(1 . 0))))
  19 (test-assert (not (time-= '(0 . 1) '(1 . 1))))
  20
  21 (test-assert (time-< '(1 . 1) '(1 . 2)))
  22 (test-assert (time-< '(7 . 2) '(8 . 2)))
  23 (test-assert (not (time-< '(7 . 2) '(7 . 2))))
  24 (test-assert (not (time-< '(7 . 8) '(7 . 2))))
  25 (test-assert (not (time-< '(8 . 2) '(7 . 2))))
  26
  27
  28 \f
  29 ;;; Schedule tests
  30 ;;; ==============
  31
  32 ;; helpers
  33 (define (assert-times-expected time-segments expected-times)
  34   (test-equal (map time-segment-time time-segments)
  35     expected-times))
  36
  37 (define a-proc (const 'a))
  38 (define b-proc (const 'b))
  39 (define c-proc (const 'c))
  40 (define d-proc (const 'd))
  41 (define e-proc (const 'e))
  42 (define f-proc (const 'f))
  43
  44 (define sched (make-schedule))
  45 (test-assert (schedule-empty? sched))
  46
  47 ;; Add a segment at (10 . 0)
  48 (schedule-add! 10 a-proc sched)
  49 (test-assert (not (schedule-empty? sched)))
  50 (test-equal (length (schedule-segments sched)) 1)
  51 (test-equal (time-segment-time (car (schedule-segments sched)))
  52   '(10 . 0))
  53 (test-equal (q-length (time-segment-queue (car (schedule-segments sched))))
  54   1)
  55 (test-eq (q-front (time-segment-queue (car (schedule-segments sched))))
  56   a-proc)
  57 (test-eq (q-rear (time-segment-queue (car (schedule-segments sched))))
  58   a-proc)
  59 (test-eq ((q-front (time-segment-queue (car (schedule-segments sched)))))
  60   'a) ;; why not
  61 (assert-times-expected (schedule-segments sched)
  62                        '((10 . 0)))
  63
  64 ;; Add another segment at (10 . 0)
  65 (schedule-add! '(10 . 0) b-proc sched)
  66 (test-assert (not (schedule-empty? sched)))
  67 (test-equal (length (schedule-segments sched)) 1)
  68 (test-equal (time-segment-time (car (schedule-segments sched)))
  69   '(10 . 0))
  70 (test-equal (q-length (time-segment-queue (car (schedule-segments sched))))
  71   2)
  72 (test-eq (q-front (time-segment-queue (car (schedule-segments sched))))
  73   a-proc)
  74 (test-eq (q-rear (time-segment-queue (car (schedule-segments sched))))
  75   b-proc)
  76 (assert-times-expected (schedule-segments sched)
  77                        '((10 . 0)))
  78
  79 ;; Add a segment to (11 . 0), (8 . 1) and (10 . 10)
  80 (schedule-add! 11 c-proc sched)
  81 (schedule-add! '(8 . 1) d-proc sched)
  82 (schedule-add! '(10 . 10) e-proc sched)
  83 (test-assert (not (schedule-empty? sched)))
  84 (test-equal (length (schedule-segments sched)) 4)
  85 (assert-times-expected (schedule-segments sched)
  86                        '((8 . 1) (10 . 0) (10 . 10) (11 . 0)))
  87
  88 ;; Splitting
  89 (define (test-split-at schedule time expected-before expected-after)
  90   (receive (segments-before segments-after)
  91       (schedule-segments-split schedule time)
  92     (assert-times-expected segments-before expected-before)
  93     (assert-times-expected segments-after expected-after)))
  94
  95 (test-split-at sched 0
  96                '()
  97                '((8 . 1) (10 . 0) (10 . 10) (11 . 0)))
  98 (test-split-at sched '(8 . 0)
  99                '()
 100                '((8 . 1) (10 . 0) (10 . 10) (11 . 0)))
 101 (test-split-at sched '(8 . 1)
 102                '((8 . 1))
 103                '((10 . 0) (10 . 10) (11 . 0)))
 104 (test-split-at sched 9
 105                '((8 . 1))
 106                '((10 . 0) (10 . 10) (11 . 0)))
 107 (test-split-at sched 10
 108                '((8 . 1) (10 . 0))
 109                '((10 . 10) (11 . 0)))
 110 (test-split-at sched 9000
 111                '((8 . 1) (10 . 0) (10 . 10) (11 . 0))
 112                '())
 113 (test-split-at sched '(9000 . 1)    ; over nine thousaaaaaaand
 114                '((8 . 1) (10 . 0) (10 . 10) (11 . 0))
 115                '())
 116
 117 ;; Break off half of those and do some tests on them
 118 (define some-extracted
 119   (schedule-extract-until! sched 10))
 120 (assert-times-expected some-extracted '((8 . 1) (10 . 0)))
 121 (assert-times-expected (schedule-segments sched) '((10 . 10) (11 . 0)))
 122 (define first-extracted-queue
 123   (time-segment-queue (car some-extracted)))
 124 (define second-extracted-queue
 125   (time-segment-queue (cadr some-extracted)))
 126 (test-assert (not (q-empty? first-extracted-queue)))
 127 (test-equal ((deq! first-extracted-queue)) 'd)
 128 (test-assert (q-empty? first-extracted-queue))
 129
 130 (test-assert (not (q-empty? second-extracted-queue)))
 131 (test-equal ((deq! second-extracted-queue)) 'a)
 132 (test-equal ((deq! second-extracted-queue)) 'b)
 133 (test-assert (q-empty? second-extracted-queue))
 134
 135 ;; Add one more and test flattening to a queue
 136 (test-assert (not (schedule-empty? sched)))
 137 (schedule-add! '(10 . 10) f-proc sched)
 138 (define remaining-segments
 139   (schedule-extract-until! sched '(9000 . 1)))
 140 (test-assert (schedule-empty? sched))
 141 (define some-queue (make-q))
 142 (enq! some-queue (const 'ho-ho))
 143 (enq! some-queue (const 'ha-ha))
 144 (add-segments-contents-to-queue! remaining-segments some-queue)
 145 (test-assert (not (q-empty? some-queue)))
 146 (test-equal 'ho-ho ((deq! some-queue)))
 147 (test-equal 'ha-ha ((deq! some-queue)))
 148 (test-equal 'e ((deq! some-queue)))
 149 (test-equal 'f ((deq! some-queue)))
 150 (test-equal 'c ((deq! some-queue)))
 151 (test-assert (q-empty? some-queue))
 152
 153 ;; ... whew!
 154
 155 ;; End tests
 156
 157 (test-end "tests")
 158 ;; (test-exit)
 159