tests/misc/network-clock.scm

   1 #!/bin/bash
   2 # -*- scheme -*-
   3 exec guile -l $0 -e main -- "$@"
   4 !#
   5
   6 ;; GStreamer
   7 ;; Copyright (C) 2005 Andy Wingo <wingo at pobox.com>
   8
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License as
  11 ;; published by the Free Software Foundation; either version 2 of
  12 ;; the License, or (at your option) any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, contact:
  21 ;;
  22 ;; Free Software Foundation           Voice:  +1-617-542-5942
  23 ;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
  24 ;; Boston, MA  02111-1307,  USA       gnu@gnu.org
  25
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; Network clock simulator.
  30 ;;
  31 ;; Simulates the attempts of one clock to synchronize with another over
  32 ;; the network. Packets are sent out with a local timestamp, and come
  33 ;; back with the remote time added on to the packet. The remote time is
  34 ;; assumed to have been observed at the local time in between sending
  35 ;; the query and receiving the reply.
  36 ;;
  37 ;; The local clock will attempt to adjust its rate and offset by fitting
  38 ;; a line to the last N datapoints on hand, by default 32. A better fit,
  39 ;; as measured by the correlation coefficient, will result in a longer
  40 ;; time before the next query. Bad fits or a not-yet-full set of data
  41 ;; will result in many queries in quick succession.
  42 ;;
  43 ;; The rate and offset are set directly to the slope and intercept from
  44 ;; the linear regression. This results in discontinuities in the local
  45 ;; time. As clock times must be monotonically increasing, a jump down in
  46 ;; time will result instead in time standing still for a while. Smoothly
  47 ;; varying the rate such that no discontinuities are present has not
  48 ;; been investigated.
  49 ;;
  50 ;; Implementation-wise, this simulator processes events and calculates
  51 ;; times discretely. Times are represented as streams, also known as
  52 ;; lazy lists. This is an almost-pure functional simulator. The thing to
  53 ;; remember while reading is that stream-cons does not evaluate its
  54 ;; second argument, rather deferring that calculation until stream-cdr
  55 ;; is called. In that way all times are actually infinite series.
  56 ;;
  57 ;; Knobs: sample rate, send delay, receive delay, send noise, receive
  58 ;; noise, queue length, rate of remote clock, rate of local clock. See
  59 ;; network-clock.scm --help.
  60 ;;
  61 ;;; Code:
  62
  63
  64 (use-modules (ice-9 popen))
  65
  66
  67 (load "network-clock-utils.scm")
  68
  69
  70 (define (time->samples t)
  71   (iround (* t *sample-frequency*)))
  72
  73
  74 (define (schedule-event events e time loss-probability)
  75   (let lp ((response-time (time->samples time))
  76            (stream events))
  77     (if (zero? response-time)
  78         (if (not (stream-car stream))
  79             (if (< (random 1.0) loss-probability)
  80                 stream ;; drop the event
  81                 (stream-cons e (stream-cdr stream)))
  82             (stream-cons (stream-car stream) (lp 0 (stream-cdr stream))))
  83         (stream-cons (stream-car stream) (lp (1- response-time) (stream-cdr stream))))))
  84
  85 (define (schedule-send-time-query events time)
  86   (schedule-event events (list 'send-time-query) time 0.0))
  87
  88 (define (schedule-time-query events l)
  89   (schedule-event events (list 'time-query l)
  90                   (+ *send-delay* (random *send-jitter*)) *send-loss*))
  91
  92 (define (schedule-time-response events l r)
  93   (schedule-event events (list 'time-response l r)
  94                   (+ *recv-delay* (random *recv-jitter*)) *recv-loss*))
  95
  96
  97 (define (timeout-- t)
  98   (- t (/ 1 *sample-frequency*)))
  99
 100 (define (network-time remote-time local-time events m b x y t)
 101   (let ((r (stream-car remote-time))
 102         (l (stream-car local-time))
 103         (event (stream-car events))
 104         (events (stream-cdr events)))
 105
 106     (define (next events m b x y t)
 107       (stream-cons
 108        (+ (* m l) b)
 109        (network-time
 110         (stream-cdr remote-time) (stream-cdr local-time) events m b x y t)))
 111
 112     (case (and=> event car)
 113       ((send-time-query)
 114        (format #t "; sending time query: ~a\n" l)
 115        (next (schedule-time-query events l) m b x y *timeout*))
 116
 117       ((time-query)
 118        (format #t "; time query received, replying with ~a\n" r)
 119        (next (schedule-time-response events (cadr event) r) m b x y (timeout-- t)))
 120
 121       ((time-response)
 122        (let ((x (q-push x (avg (cadr event) l)))
 123              (y (q-push y (caddr event))))
 124          (call-with-values
 125              (lambda () (least-squares (q-head x) (q-head y)))
 126            (lambda (m b r-squared)
 127              (define (next-time)
 128                (max
 129                 (if (< (length (q-head x)) *queue-length*)
 130                     0
 131                     (/ 1 (- 1 (min r-squared 0.99999)) 1000))
 132                 0.10))
 133              (format #t "; new slope and offset: ~a ~a (~a)\n" m b r-squared)
 134              (next (schedule-send-time-query events (next-time)) m b x y #f)))))
 135
 136       (else
 137        (cond
 138         ((not t)
 139          ;; not waiting for a response
 140          (next events m b x y t))
 141         ((<= t 0.0)
 142          ;; we timed out
 143          (next (schedule-send-time-query events 0.0) m b x y 0.0))
 144         (else
 145          (next events m b x y (timeout-- t))))))))
 146
 147 (define (run-simulation remote-speed local-speed)
 148   (let ((absolute-time (arithmetic-series 0.0 (/ 1.0 *sample-frequency*)))
 149         (event-stream (stream-of #f)))
 150     (let ((remote-time (scale-stream absolute-time remote-speed))
 151           (local-time (scale-stream absolute-time local-speed)))
 152       (values
 153        absolute-time
 154        remote-time
 155        local-time
 156        (network-time
 157         remote-time
 158         local-time
 159         (schedule-send-time-query event-stream 0.0)
 160         1.0
 161         (stream-car local-time)
 162         (make-q (list (stream-car local-time)))
 163         (make-q (list (stream-car remote-time)))
 164         #f)))))
 165
 166 (define (print-simulation total-time sample-rate remote-speed local-speed)
 167   (display "Absolute time; Remote time; Local time; Network time\n")
 168   (call-with-values
 169       (lambda () (run-simulation remote-speed local-speed))
 170     (lambda streams
 171       (apply
 172        stream-while
 173        (lambda (a r l n) (<= a total-time))
 174        (lambda (a r l n) (format #t "~a ~a ~a ~a\n" a r l n))
 175        streams))))
 176
 177 (define (plot-simulation)
 178   (let ((port (open-output-pipe "./plot-data Network Clock Simulation")))
 179     (with-output-to-port port
 180       (lambda ()
 181         (print-simulation *total-time* #f *remote-rate* *local-rate*)))
 182     (close-pipe port)))
 183
 184
 185 (define-parameter *sample-frequency* 40)
 186 (define-parameter *send-delay* 0.1)
 187 (define-parameter *recv-delay* 0.1)
 188 (define-parameter *send-loss* 0.02)
 189 (define-parameter *recv-loss* 0.02)
 190 (define-parameter *send-jitter* 0.1)
 191 (define-parameter *recv-jitter* 0.1)
 192 (define-parameter *queue-length* 32)
 193 (define-parameter *local-rate* 1.0)
 194 (define-parameter *remote-rate* 1.1)
 195 (define-parameter *total-time* 5.0)
 196 (define-parameter *timeout* 1.0)
 197
 198
 199 (define (main args)
 200   (parse-parameter-arguments (cdr args))
 201   (plot-simulation)
 202   (quit))