tests/misc/network-clock-utils.scm

   1 ;; GStreamer
   2 ;; Copyright (C) 2005 Andy Wingo <wingo at pobox.com>
   3
   4 ;; This program is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU General Public License as
   6 ;; published by the Free Software Foundation; either version 2 of
   7 ;; the License, or (at your option) any later version.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program; if not, contact:
  16 ;;
  17 ;; Free Software Foundation           Voice:  +1-617-542-5942
  18 ;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
  19 ;; Boston, MA  02111-1307,  USA       gnu@gnu.org
  20
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Utilities for the network clock simulator.
  25 ;;
  26 ;;; Code:
  27
  28
  29 ;; Init the rng.
  30
  31 (use-modules ((srfi srfi-1) (fold unfold)))
  32
  33 (define (read-bytes-from-file-as-integer f n)
  34   (with-input-from-file f
  35     (lambda ()
  36       (fold (lambda (x seed) (+ x (ash seed 8)))
  37             0
  38             (unfold zero? (lambda (n) (char->integer (read-char))) 1- n)))))
  39
  40 (set! *random-state* (seed->random-state
  41                       (read-bytes-from-file-as-integer "/dev/random" 4)))
  42
  43 ;; General utilities.
  44
  45 (define (iround x)
  46   (if (inexact? x)
  47       (inexact->exact (round x))
  48       x))
  49
  50 (define (filter proc l)
  51   (cond
  52    ((null? l) '())
  53    ((proc (car l)) (cons (car l) (filter proc (cdr l))))
  54    (else (filter proc (cdr l)))))
  55
  56 (define (sum l)
  57   (apply + l))
  58
  59 (define (avg . nums)
  60   (/ (sum nums) (length nums)))
  61
  62 (define (sq x)
  63   (* x x))
  64
  65 (define (debug str . args)
  66   (if *debug*
  67       (apply format (current-error-port) str args)))
  68
  69 (define (print-event kind x y)
  70   (format #t "~a ~a ~a\n" kind x y))
  71
  72 ;; Linear least squares.
  73 ;;
  74 ;; See http://mathworld.wolfram.com/LeastSquaresFitting.html
  75 ;; returns (values slope intercept r-squared)
  76
  77 (define (least-squares x y)
  78   (let ((n (length x)))
  79     (let ((xbar (apply avg x))
  80           (ybar (apply avg y)))
  81       (let ((sxx (- (sum (map sq x)) (* n (sq xbar))))
  82             (syy (- (sum (map sq y)) (* n (sq ybar))))
  83             (sxy (- (sum (map * x y)) (* n xbar ybar))))
  84         (let ((slope (/ sxy sxx)))
  85           (values
  86            slope
  87            (- ybar (* slope xbar))
  88            (/ (sq sxy) (* sxx syy))))))))
  89
  90 ;; Streams: lists with lazy cdrs.
  91
  92 (define-macro (stream-cons kar kdr)
  93   `(cons ,kar (delay ,kdr)))
  94
  95 (define (stream-cdr stream)
  96   (force (cdr stream)))
  97
  98 (define (stream-car stream)
  99   (car stream))
 100
 101 (define (stream-null? stream)
 102   (null? stream))
 103
 104 (define (stream-ref stream n)
 105   (if (zero? n)
 106       (stream-car stream)
 107       (stream-ref (stream-cdr stream) (1- n))))
 108
 109 (define (stream->list stream n)
 110   (let lp ((in stream) (out '()) (n n))
 111     (if (zero? n)
 112         (reverse! out)
 113         (lp (stream-cdr in) (cons (stream-car in) out) (1- n)))))
 114
 115 (define (stream-skip stream n)
 116   (if (zero? n)
 117       stream
 118       (stream-skip (stream-cdr stream) (1- n))))
 119
 120 (define (stream-sample stream n)
 121   (stream-cons (stream-car stream)
 122                (stream-sample (stream-skip stream n) n)))
 123
 124 (define (stream-map proc . streams)
 125   (stream-cons (apply proc (map stream-car streams))
 126                (apply stream-map proc (map stream-cdr streams))))
 127
 128 (define (arithmetic-series start step)
 129   (stream-cons start (arithmetic-series (+ start step) step)))
 130
 131 (define (scale-stream stream factor)
 132   (stream-map (lambda (t) (* t factor)) stream))
 133
 134 (define (stream-while pred proc . streams)
 135   (if (apply pred (map stream-car streams))
 136       (begin
 137         (apply proc (map stream-car streams))
 138         (apply stream-while pred proc (map stream-cdr streams)))))
 139
 140 (define (stream-of val)
 141   (stream-cons val (stream-of val)))
 142
 143 (define (periodic-stream val period)
 144   (let ((period (iround (max 1 (* *sample-frequency* period)))))
 145     (let lp ((n 0))
 146       (if (zero? n)
 147           (stream-cons val (lp period))
 148           (stream-cons #f (lp (1- n)))))))
 149
 150
 151 ;; Queues with a maximum length.
 152
 153 (define (make-q l)
 154   (cons l (last-pair l)))
 155
 156 (define (q-head q)
 157   (car q))
 158
 159 (define (q-tail q)
 160   (car q))
 161
 162 (define (q-push q val)
 163   (let ((tail (cons val '())))
 164     (if (null? (q-tail q))
 165         (make-q tail)
 166         (let ((l (append! (q-head q) tail)))
 167           (if (> (length (q-head q)) *window-size*)
 168               (make-q (cdr (q-head q)))
 169               q)))))
 170
 171
 172 ;; Parameters, settable via command line arguments.
 173
 174 (define %parameters '())
 175 (define-macro (define-parameter name val)
 176   (let ((str (symbol->string name)))
 177     (or (and (eqv? (string-ref str 0) #\*)
 178              (eqv? (string-ref str (1- (string-length str))) #\*))
 179         (error "Invalid parameter name" name))
 180     (let ((param (string->symbol
 181                   (substring str 1 (1- (string-length str)))))
 182           (val-sym (gensym)))
 183       `(begin
 184          (define ,name #f)
 185          (let ((,val-sym ,val))
 186            (set! ,name ,val-sym)
 187            (set! %parameters (cons (cons ',param ,val-sym)
 188                                    %parameters)))))))
 189 (define (set-parameter! name val)
 190   (define (symbol-append . args)
 191     (string->symbol (apply string-append (map symbol->string args))))
 192   (or (assq name %parameters)
 193       (error "Unknown parameter" name))
 194   (module-set! (current-module) (symbol-append '* name '*) val))
 195
 196 (define (parse-parameter-arguments args)
 197   (define (usage)
 198     (format #t "Usage: ~a ARG1...\n\n" "network-clock.scm")
 199     (for-each
 200      (lambda (pair)
 201        (format #t "\t--~a=VAL \t(default: ~a)\n" (car pair) (cdr pair)))
 202      %parameters))
 203   (define (unknown-arg arg)
 204     (with-output-to-port (current-error-port)
 205       (lambda ()
 206         (format #t "\nUnknown argument: ~a\n\n" arg)
 207         (usage)
 208         (quit))))
 209   (define (parse-arguments args)
 210     (let lp ((in args) (out '()))
 211       (cond
 212        ((null? in)
 213         (reverse! out))
 214        ((not (string=? (substring (car in) 0 2) "--"))
 215         (unknown-arg (car in)))
 216        (else
 217         (let ((divider (or (string-index (car in) #\=)
 218                            (unknown-arg (car in)))))
 219           (or (> divider 2) (unknown-arg (car in)))
 220           (let ((param (string->symbol (substring (car in) 2 divider)))
 221                 (val (with-input-from-string (substring (car in) (1+ divider))
 222                        read)))
 223             (lp (cdr in) (acons param val out))))))))
 224   (for-each
 225    (lambda (pair)
 226      (or (false-if-exception
 227           (set-parameter! (car pair) (cdr pair)))
 228          (unknown-arg (format #f "--~a=~a" (car pair) (cdr pair)))))
 229    (parse-arguments args)))