tests/: A network clock simulator.

Original commit message from CVS:
2005-06-23  Andy Wingo  <wingo@pobox.com>

* tests/network-clock.scm:
* tests/network-clock-utils.scm: A network clock simulator.
Something of an algorithmic testbed before doing something in C.

ChangeLog

@@ -1,3 +1,9 @@
+2005-06-23  Andy Wingo  <wingo@pobox.com>
+
+	* tests/network-clock.scm: 
+	* tests/network-clock-utils.scm: A network clock simulator.
+	Something of an algorithmic testbed before doing something in C.
+
 2005-06-22  Thomas Vander Stichele  <thomas at apestaart dot org>
 
 	* check/Makefile.am:

tests/misc/network-clock-utils.scm

@@ -0,0 +1,150 @@
+;; GStreamer
+;; Copyright (C) 2005 Andy Wingo <wingo at pobox.com>
+
+;; 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 2 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, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+
+;;; Commentary:
+;;
+;; Utilities for the network clock simulator.
+;;
+;;; Code:
+
+
+;; General utilities.
+
+(define (iround x)
+  (if (inexact? x)
+      (inexact->exact (round x))
+      x))
+
+(define (filter proc l)
+  (cond
+   ((null? l) '())
+   ((proc (car l)) (cons (car l) (filter proc (cdr l))))
+   (else (filter proc (cdr l)))))
+
+(define (sum l)
+  (apply + l))
+
+(define (avg . nums)
+  (/ (sum nums) (length nums)))
+
+(define (sq x)
+  (* x x))
+
+;; Linear least squares.
+;;
+;; See http://mathworld.wolfram.com/LeastSquaresFitting.html
+;; returns (values slope intercept r-squared)
+
+(define (least-squares x y)
+  (let ((n (length x)))
+    (let ((xbar (apply avg x))
+          (ybar (apply avg y)))
+      (let ((sxx (- (sum (map sq x)) (* n (sq xbar))))
+            (syy (- (sum (map sq y)) (* n (sq ybar))))
+            (sxy (- (sum (map * x y)) (* n xbar ybar))))
+        (let ((slope (/ sxy sxx)))
+          (values
+           slope
+           (- ybar (* slope xbar))
+           (/ (sq sxy) (* sxx syy))))))))
+
+;; Streams: lists with lazy cdrs.
+
+(define-macro (stream-cons kar kdr)
+  `(cons ,kar (delay ,kdr)))
+
+(define (stream-cdr stream)
+  (force (cdr stream)))
+
+(define (stream-car stream)
+  (car stream))
+
+(define (stream-null? stream)
+  (null? stream))
+
+(define (stream-ref stream n)
+  (if (zero? n)
+      (stream-car stream)
+      (stream-ref (stream-cdr stream) (1- n))))
+
+(define (stream->list stream n)
+  (let lp ((in stream) (out '()) (n n))
+    (if (zero? n)
+        (reverse! out)
+        (lp (stream-cdr in) (cons (stream-car in) out) (1- n)))))
+
+(define (stream-skip stream n)
+  (if (zero? n)
+      stream
+      (stream-skip (stream-cdr stream) (1- n))))
+
+(define (stream-sample stream n)
+  (stream-cons (stream-car stream)
+               (stream-sample (stream-skip stream n) n)))
+
+(define (stream-map proc . streams)
+  (stream-cons (apply proc (map stream-car streams))
+               (apply stream-map proc (map stream-cdr streams))))
+
+(define (arithmetic-series start step)
+  (stream-cons start (arithmetic-series (+ start step) step)))
+
+(define (scale-stream stream factor)
+  (stream-map (lambda (t) (* t factor)) *absolute-time*))
+
+(define (stream-while pred proc . streams)
+  (if (apply pred (map stream-car streams))
+      (begin
+        (apply proc (map stream-car streams))
+        (apply stream-while pred proc (map stream-cdr streams)))))
+
+(define (stream-of val)
+  (stream-cons val (stream-of val)))
+
+(define (periodic-stream val period)
+  (let ((period (iround (max 1 (* *sample-frequency* period)))))
+    (let lp ((n 0))
+      (if (zero? n)
+          (stream-cons val (lp period))
+          (stream-cons #f (lp (1- n)))))))
+
+
+;; Queues with a maximum length.
+
+(define *q-length* 32)
+
+(define (make-q l)
+  (cons l (last-pair l)))
+
+(define (q-head q)
+  (car q))
+
+(define (q-tail q)
+  (car q))
+
+(define (q-push q val)
+  (let ((tail (cons val '())))
+    (if (null? (q-tail q))
+        (make-q tail)
+        (let ((l (append! (q-head q) tail)))
+          (if (> (length (q-head q)) *q-length*)
+              (make-q (cdr (q-head q)))
+              q)))))

tests/misc/network-clock.scm

@@ -0,0 +1,164 @@
+#!/bin/bash
+# -*- scheme -*-
+exec guile -l $0 -e main "$@"
+!#
+
+;; GStreamer
+;; Copyright (C) 2005 Andy Wingo <wingo at pobox.com>
+
+;; 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 2 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, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+
+;;; Commentary:
+;;
+;; Network clock simulator.
+;;
+;; Simulates the attempts of one clock to synchronize with another over
+;; the network. Packets are sent out with a local timestamp, and come
+;; back with the remote time added on to the packet. The remote time is
+;; assumed to have been observed at the local time in between sending
+;; the query and receiving the reply.
+;;
+;; The local clock will attempt to adjust its rate and offset by fitting
+;; a line to the last N datapoints on hand, by default 32. A better fit,
+;; as measured by the correlation coefficient, will result in a longer
+;; time before the next query. Bad fits or a not-yet-full set of data
+;; will result in many queries in quick succession.
+;;
+;; The rate and offset are set directly to the slope and intercept from
+;; the linear regression. This results in discontinuities in the local
+;; time. As clock times must be monotonically increasing, a jump down in
+;; time will result instead in time standing still for a while. Smoothly
+;; varying the rate such that no discontinuities are present has not
+;; been investigated.
+;;
+;; Implementation-wise, this simulator processes events and calculates
+;; times discretely. Times are represented as streams, also known as
+;; lazy lists. This is an almost-pure functional simulator. The thing to
+;; remember while reading is that stream-cons does not evaluate its
+;; second argument, rather deferring that calculation until stream-cdr
+;; is called. In that way all times are actually infinite series.
+;;
+;; Knobs: sample rate, send delay, receive delay, send noise, receive
+;; noise, queue length, rate of remote clock, rate of local clock.
+;; Fixme: Make knobs more accesible tomorrow; also make graphs.
+;;
+;;; Code:
+
+
+(use-modules (ice-9 slib))
+(require 'printf)
+
+(load "network-clock-utils.scm")
+
+
+(define *sample-frequency* 40)
+
+(define (time->samples t)
+  (iround (* t *sample-frequency*)))
+
+(define *absolute-time* (arithmetic-series 0.0 (/ 1.0 *sample-frequency*)))
+
+(define *empty-event-stream* (stream-of #f))
+
+(define (schedule-event events e time)
+  (let lp ((response-time (time->samples time))
+           (stream events))
+    (if (zero? response-time)
+        (if (not (stream-car stream))
+            (stream-cons e (stream-cdr stream))
+            (stream-cons (stream-car stream) (lp 0 (stream-cdr stream))))
+        (stream-cons (stream-car stream) (lp (1- response-time) (stream-cdr stream))))))
+
+(define (schedule-send-time-query events time)
+  (schedule-event events (list 'send-time-query) time))
+
+(define (schedule-time-query events l)
+  (schedule-event events (list 'time-query l) (+ 0.20 (random 0.20))))
+
+(define (schedule-time-response events l r)
+  (schedule-event events (list 'time-response l r) (+ 0.20 (random 0.20))))
+
+(define (network-time remote-time local-time events m b x y)
+  (let ((r (stream-car remote-time))
+        (l (stream-car local-time))
+        (event (stream-car events))
+        (events (stream-cdr events)))
+
+    (define (next events m b x y)
+      (stream-cons
+       (+ (* m l) b)
+       (network-time
+        (stream-cdr remote-time) (stream-cdr local-time) events m b x y)))
+
+    (case (and=> event car)
+      ((send-time-query)
+       (format #t "sending time query: ~a\n" l)
+       (next (schedule-time-query events l) m b x y))
+
+      ((time-query)
+       (format #t "time query received, replying with ~a\n" r)
+       (next (schedule-time-response events (cadr event) r) m b x y))
+
+      ((time-response)
+       (let ((x (q-push x (avg (cadr event) l)))
+             (y (q-push y (caddr event))))
+         (call-with-values
+             (lambda () (least-squares (q-head x) (q-head y)))
+           (lambda (m b r-squared)
+             (define (next-time) 
+               (max
+                (if (< (length (q-head x)) *q-length*)
+                    0
+                    (/ 1 (- 1 (min r-squared 0.99999)) 1000))
+                0.10))
+             (format #t "new slope and offset: ~a ~a (~a)\n" m b r-squared)
+             (next (schedule-send-time-query events (next-time)) m b x y)))))
+
+      (else
+       (next events m b x y)))))
+
+(define (run-simulation remote-speed local-speed)
+  (let ((remote-time (scale-stream *absolute-time* remote-speed))
+        (local-time (scale-stream *absolute-time* local-speed)))
+    (values
+     *absolute-time*
+     remote-time
+     local-time
+     (network-time
+      remote-time
+      local-time
+      (schedule-send-time-query *empty-event-stream* 0.0)
+      1.0
+      (stream-car local-time)
+      (make-q (list (stream-car local-time)))
+      (make-q (list (stream-car remote-time)))))))
+
+(define (print-simulation total-time sample-rate remote-speed local-speed)
+  (display ";; absolute remote local network\n")
+  (call-with-values
+      (lambda () (run-simulation remote-speed local-speed))
+    (lambda streams
+      (apply
+       stream-while
+       (lambda (a r l n) (<= a total-time))
+       (lambda (a r l n) (printf "%.3f %.3f %.3f %.3f\n" a r l n))
+       streams))))
+
+(define (main . args)
+  (print-simulation 20 #f 2.0 1.1))

tests/network-clock-utils.scm

@@ -0,0 +1,150 @@
+;; GStreamer
+;; Copyright (C) 2005 Andy Wingo <wingo at pobox.com>
+
+;; 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 2 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, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+
+;;; Commentary:
+;;
+;; Utilities for the network clock simulator.
+;;
+;;; Code:
+
+
+;; General utilities.
+
+(define (iround x)
+  (if (inexact? x)
+      (inexact->exact (round x))
+      x))
+
+(define (filter proc l)
+  (cond
+   ((null? l) '())
+   ((proc (car l)) (cons (car l) (filter proc (cdr l))))
+   (else (filter proc (cdr l)))))
+
+(define (sum l)
+  (apply + l))
+
+(define (avg . nums)
+  (/ (sum nums) (length nums)))
+
+(define (sq x)
+  (* x x))
+
+;; Linear least squares.
+;;
+;; See http://mathworld.wolfram.com/LeastSquaresFitting.html
+;; returns (values slope intercept r-squared)
+
+(define (least-squares x y)
+  (let ((n (length x)))
+    (let ((xbar (apply avg x))
+          (ybar (apply avg y)))
+      (let ((sxx (- (sum (map sq x)) (* n (sq xbar))))
+            (syy (- (sum (map sq y)) (* n (sq ybar))))
+            (sxy (- (sum (map * x y)) (* n xbar ybar))))
+        (let ((slope (/ sxy sxx)))
+          (values
+           slope
+           (- ybar (* slope xbar))
+           (/ (sq sxy) (* sxx syy))))))))
+
+;; Streams: lists with lazy cdrs.
+
+(define-macro (stream-cons kar kdr)
+  `(cons ,kar (delay ,kdr)))
+
+(define (stream-cdr stream)
+  (force (cdr stream)))
+
+(define (stream-car stream)
+  (car stream))
+
+(define (stream-null? stream)
+  (null? stream))
+
+(define (stream-ref stream n)
+  (if (zero? n)
+      (stream-car stream)
+      (stream-ref (stream-cdr stream) (1- n))))
+
+(define (stream->list stream n)
+  (let lp ((in stream) (out '()) (n n))
+    (if (zero? n)
+        (reverse! out)
+        (lp (stream-cdr in) (cons (stream-car in) out) (1- n)))))
+
+(define (stream-skip stream n)
+  (if (zero? n)
+      stream
+      (stream-skip (stream-cdr stream) (1- n))))
+
+(define (stream-sample stream n)
+  (stream-cons (stream-car stream)
+               (stream-sample (stream-skip stream n) n)))
+
+(define (stream-map proc . streams)
+  (stream-cons (apply proc (map stream-car streams))
+               (apply stream-map proc (map stream-cdr streams))))
+
+(define (arithmetic-series start step)
+  (stream-cons start (arithmetic-series (+ start step) step)))
+
+(define (scale-stream stream factor)
+  (stream-map (lambda (t) (* t factor)) *absolute-time*))
+
+(define (stream-while pred proc . streams)
+  (if (apply pred (map stream-car streams))
+      (begin
+        (apply proc (map stream-car streams))
+        (apply stream-while pred proc (map stream-cdr streams)))))
+
+(define (stream-of val)
+  (stream-cons val (stream-of val)))
+
+(define (periodic-stream val period)
+  (let ((period (iround (max 1 (* *sample-frequency* period)))))
+    (let lp ((n 0))
+      (if (zero? n)
+          (stream-cons val (lp period))
+          (stream-cons #f (lp (1- n)))))))
+
+
+;; Queues with a maximum length.
+
+(define *q-length* 32)
+
+(define (make-q l)
+  (cons l (last-pair l)))
+
+(define (q-head q)
+  (car q))
+
+(define (q-tail q)
+  (car q))
+
+(define (q-push q val)
+  (let ((tail (cons val '())))
+    (if (null? (q-tail q))
+        (make-q tail)
+        (let ((l (append! (q-head q) tail)))
+          (if (> (length (q-head q)) *q-length*)
+              (make-q (cdr (q-head q)))
+              q)))))

tests/network-clock.scm

@@ -0,0 +1,164 @@
+#!/bin/bash
+# -*- scheme -*-
+exec guile -l $0 -e main "$@"
+!#
+
+;; GStreamer
+;; Copyright (C) 2005 Andy Wingo <wingo at pobox.com>
+
+;; 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 2 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, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+
+;;; Commentary:
+;;
+;; Network clock simulator.
+;;
+;; Simulates the attempts of one clock to synchronize with another over
+;; the network. Packets are sent out with a local timestamp, and come
+;; back with the remote time added on to the packet. The remote time is
+;; assumed to have been observed at the local time in between sending
+;; the query and receiving the reply.
+;;
+;; The local clock will attempt to adjust its rate and offset by fitting
+;; a line to the last N datapoints on hand, by default 32. A better fit,
+;; as measured by the correlation coefficient, will result in a longer
+;; time before the next query. Bad fits or a not-yet-full set of data
+;; will result in many queries in quick succession.
+;;
+;; The rate and offset are set directly to the slope and intercept from
+;; the linear regression. This results in discontinuities in the local
+;; time. As clock times must be monotonically increasing, a jump down in
+;; time will result instead in time standing still for a while. Smoothly
+;; varying the rate such that no discontinuities are present has not
+;; been investigated.
+;;
+;; Implementation-wise, this simulator processes events and calculates
+;; times discretely. Times are represented as streams, also known as
+;; lazy lists. This is an almost-pure functional simulator. The thing to
+;; remember while reading is that stream-cons does not evaluate its
+;; second argument, rather deferring that calculation until stream-cdr
+;; is called. In that way all times are actually infinite series.
+;;
+;; Knobs: sample rate, send delay, receive delay, send noise, receive
+;; noise, queue length, rate of remote clock, rate of local clock.
+;; Fixme: Make knobs more accesible tomorrow; also make graphs.
+;;
+;;; Code:
+
+
+(use-modules (ice-9 slib))
+(require 'printf)
+
+(load "network-clock-utils.scm")
+
+
+(define *sample-frequency* 40)
+
+(define (time->samples t)
+  (iround (* t *sample-frequency*)))
+
+(define *absolute-time* (arithmetic-series 0.0 (/ 1.0 *sample-frequency*)))
+
+(define *empty-event-stream* (stream-of #f))
+
+(define (schedule-event events e time)
+  (let lp ((response-time (time->samples time))
+           (stream events))
+    (if (zero? response-time)
+        (if (not (stream-car stream))
+            (stream-cons e (stream-cdr stream))
+            (stream-cons (stream-car stream) (lp 0 (stream-cdr stream))))
+        (stream-cons (stream-car stream) (lp (1- response-time) (stream-cdr stream))))))
+
+(define (schedule-send-time-query events time)
+  (schedule-event events (list 'send-time-query) time))
+
+(define (schedule-time-query events l)
+  (schedule-event events (list 'time-query l) (+ 0.20 (random 0.20))))
+
+(define (schedule-time-response events l r)
+  (schedule-event events (list 'time-response l r) (+ 0.20 (random 0.20))))
+
+(define (network-time remote-time local-time events m b x y)
+  (let ((r (stream-car remote-time))
+        (l (stream-car local-time))
+        (event (stream-car events))
+        (events (stream-cdr events)))
+
+    (define (next events m b x y)
+      (stream-cons
+       (+ (* m l) b)
+       (network-time
+        (stream-cdr remote-time) (stream-cdr local-time) events m b x y)))
+
+    (case (and=> event car)
+      ((send-time-query)
+       (format #t "sending time query: ~a\n" l)
+       (next (schedule-time-query events l) m b x y))
+
+      ((time-query)
+       (format #t "time query received, replying with ~a\n" r)
+       (next (schedule-time-response events (cadr event) r) m b x y))
+
+      ((time-response)
+       (let ((x (q-push x (avg (cadr event) l)))
+             (y (q-push y (caddr event))))
+         (call-with-values
+             (lambda () (least-squares (q-head x) (q-head y)))
+           (lambda (m b r-squared)
+             (define (next-time) 
+               (max
+                (if (< (length (q-head x)) *q-length*)
+                    0
+                    (/ 1 (- 1 (min r-squared 0.99999)) 1000))
+                0.10))
+             (format #t "new slope and offset: ~a ~a (~a)\n" m b r-squared)
+             (next (schedule-send-time-query events (next-time)) m b x y)))))
+
+      (else
+       (next events m b x y)))))
+
+(define (run-simulation remote-speed local-speed)
+  (let ((remote-time (scale-stream *absolute-time* remote-speed))
+        (local-time (scale-stream *absolute-time* local-speed)))
+    (values
+     *absolute-time*
+     remote-time
+     local-time
+     (network-time
+      remote-time
+      local-time
+      (schedule-send-time-query *empty-event-stream* 0.0)
+      1.0
+      (stream-car local-time)
+      (make-q (list (stream-car local-time)))
+      (make-q (list (stream-car remote-time)))))))
+
+(define (print-simulation total-time sample-rate remote-speed local-speed)
+  (display ";; absolute remote local network\n")
+  (call-with-values
+      (lambda () (run-simulation remote-speed local-speed))
+    (lambda streams
+      (apply
+       stream-while
+       (lambda (a r l n) (<= a total-time))
+       (lambda (a r l n) (printf "%.3f %.3f %.3f %.3f\n" a r l n))
+       streams))))
+
+(define (main . args)
+  (print-simulation 20 #f 2.0 1.1))