mobile/tests/misc/network-clock.scm

   1 #!/bin/bash
   2 # -*- scheme -*-
   3 exec guile --debug -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 ;; Usage: See network-clock.scm --help.
  58 ;;
  59 ;;; Code:
  60
  61
  62 (use-modules (ice-9 popen))
  63
  64
  65 (load "network-clock-utils.scm")
  66
  67
  68 (define (time->samples t)
  69   (iround (* t *sample-frequency*)))
  70
  71
  72 (define (schedule-event events e time)
  73   (let lp ((response-time (time->samples time))
  74            (stream events))
  75     (if (zero? response-time)
  76         (if (not (stream-car stream))
  77             (stream-cons e (stream-cdr stream))
  78             (stream-cons (stream-car stream) (lp 0 (stream-cdr stream))))
  79         (stream-cons (stream-car stream) (lp (1- response-time) (stream-cdr stream))))))
  80
  81 (define (schedule-send-time-query events time)
  82   (schedule-event events (list 'send-time-query) time))
  83
  84 (define (schedule-time-query events l)
  85   (schedule-event events (list 'time-query l)
  86                   (+ *send-delay* (random *send-jitter*))))
  87
  88 (define (schedule-time-response events l r)
  89   (schedule-event events (list 'time-response l r)
  90                   (+ *recv-delay* (random *recv-jitter*))))
  91
  92 (define (network-time remote-time local-time events m b x y t)
  93   (let ((r (stream-car remote-time))
  94         (l (stream-car local-time))
  95         (event (stream-car events))
  96         (events (stream-cdr events)))
  97
  98     (define (next events m b x y t)
  99       (stream-cons
 100        (+ (* m l) b)
 101        (network-time
 102         (stream-cdr remote-time) (stream-cdr local-time) events m b x y t)))
 103
 104     (case (and=> event car)
 105       ((send-time-query)
 106        (cond
 107         ((< (random 1.0) *packet-loss*)
 108          (debug "; dropped time query: ~a\n" l)
 109          (print-event 'packet-lost l (+ (* m l) b))
 110          (next events m b x y (time->samples *timeout*)))
 111         (else
 112          (debug "; sending time query: ~a\n" l)
 113          (print-event 'packet-sent l (+ (* m l) b))
 114          (next (schedule-time-query events l) m b x y (time->samples *timeout*)))))
 115
 116       ((time-query)
 117        (debug "; time query received, replying with ~a\n" r)
 118        (next (schedule-time-response events (cadr event) r) m b x y (and t (1- t))))
 119
 120       ((time-response)
 121        (let ((x (q-push x (avg (cadr event) l)))
 122              (y (q-push y (caddr event))))
 123          (call-with-values
 124              (lambda () (least-squares (q-head x) (q-head y)))
 125            (lambda (m b r-squared)
 126              (define (next-time)
 127                (max
 128                 (if (< (length (q-head x)) *window-size*)
 129                     0
 130                     (/ 1 (- 1 (min r-squared 0.99999)) 1000))
 131                 0.10))
 132              (debug "; new slope and offset: ~a ~a (~a)\n" m b r-squared)
 133              (print-event 'packet-observed (avg (cadr event) l) (caddr event))
 134              (print-event 'packet-received l (+ (* m l) b))
 135              (next (schedule-send-time-query events (next-time)) m b x y #f)))))
 136
 137       (else
 138        (cond
 139         ((not t)
 140          ;; not waiting for a response
 141          (next events m b x y t))
 142         ((<= t 0)
 143          ;; we timed out
 144          (next (schedule-send-time-query events 0.0) m b x y 0))
 145         (else
 146          (next events m b x y (1- t))))))))
 147
 148 (define (run-simulation remote-speed local-speed)
 149   (let ((absolute-time (arithmetic-series 0.0 (/ 1.0 *sample-frequency*)))
 150         (event-stream (stream-of #f)))
 151     (let ((remote-time (scale-stream absolute-time remote-speed))
 152           (local-time (scale-stream absolute-time local-speed)))
 153       (values
 154        absolute-time
 155        remote-time
 156        local-time
 157        (network-time
 158         remote-time
 159         local-time
 160         (schedule-send-time-query event-stream 0.0)
 161         1.0
 162         (stream-car local-time)
 163         (make-q (list (stream-car local-time)))
 164         (make-q (list (stream-car remote-time)))
 165         #f)))))
 166
 167 (define (print-simulation)
 168   (display "Absolute time; Remote time; Local time; Network time\n")
 169   (call-with-values
 170       (lambda () (run-simulation *remote-rate* *local-rate*))
 171     (lambda streams
 172       (apply
 173        stream-while
 174        (lambda (a r l n) (<= a *total-time*))
 175        (lambda (a r l n) (format #t "~a ~a ~a ~a\n" a r l n))
 176        streams))))
 177
 178 (define (plot-simulation)
 179   (let ((port (open-output-pipe "./plot-data Network Clock Simulation")))
 180     (with-output-to-port port
 181       print-simulation)
 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 *packet-loss* 0.01)
 189 (define-parameter *send-jitter* 0.1)
 190 (define-parameter *recv-jitter* 0.1)
 191 (define-parameter *window-size* 32)
 192 (define-parameter *local-rate* 1.0)
 193 (define-parameter *remote-rate* 1.1)
 194 (define-parameter *total-time* 5.0)
 195 (define-parameter *timeout* 1.0)
 196 (define-parameter *debug* #f)
 197 (define-parameter *with-graph* #t)
 198
 199
 200 (define (main args)
 201   (parse-parameter-arguments (cdr args))
 202   (if *with-graph*
 203       (plot-simulation)
 204       (print-simulation))
 205   (quit))