blob: 1a71e3231c85ed78dc413a0307cfedb18159a2f2 [file] [log] [blame]
;; GStreamer
;; Copyright (C) 2005 Andy Wingo <wingo at>
;; 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
;; 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
;; 51 Franklin St, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA
;;; Commentary:
;; Utilities for the network clock simulator.
;;; Code:
;; Init the rng.
(use-modules ((srfi srfi-1) (fold unfold)))
(define (read-bytes-from-file-as-integer f n)
(with-input-from-file f
(lambda ()
(fold (lambda (x seed) (+ x (ash seed 8)))
(unfold zero? (lambda (n) (char->integer (read-char))) 1- n)))))
(set! *random-state* (seed->random-state
(read-bytes-from-file-as-integer "/dev/random" 4)))
;; General utilities.
(define (iround x)
(if (inexact? x)
(inexact->exact (round x))
(define (filter proc l)
((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))
(define (debug str . args)
(if *debug*
(apply format (current-error-port) str args)))
(define (print-event kind x y)
(format #t "~a ~a ~a\n" kind x y))
;; Linear least squares.
;; See
;; 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)))
(- 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-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)) stream))
(define (stream-while pred proc . streams)
(if (apply pred (map stream-car streams))
(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 (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)) *window-size*)
(make-q (cdr (q-head q)))
;; Parameters, settable via command line arguments.
(define %parameters '())
(define-macro (define-parameter name val)
(let ((str (symbol->string name)))
(or (and (eqv? (string-ref str 0) #\*)
(eqv? (string-ref str (1- (string-length str))) #\*))
(error "Invalid parameter name" name))
(let ((param (string->symbol
(substring str 1 (1- (string-length str)))))
(val-sym (gensym)))
(define ,name #f)
(let ((,val-sym ,val))
(set! ,name ,val-sym)
(set! %parameters (cons (cons ',param ,val-sym)
(define (set-parameter! name val)
(define (symbol-append . args)
(string->symbol (apply string-append (map symbol->string args))))
(or (assq name %parameters)
(error "Unknown parameter" name))
(module-set! (current-module) (symbol-append '* name '*) val))
(define (parse-parameter-arguments args)
(define (usage)
(format #t "Usage: ~a ARG1...\n\n" "network-clock.scm")
(lambda (pair)
(format #t "\t--~a=VAL \t(default: ~a)\n" (car pair) (cdr pair)))
(define (unknown-arg arg)
(with-output-to-port (current-error-port)
(lambda ()
(format #t "\nUnknown argument: ~a\n\n" arg)
(define (parse-arguments args)
(let lp ((in args) (out '()))
((null? in)
(reverse! out))
((not (string=? (substring (car in) 0 2) "--"))
(unknown-arg (car in)))
(let ((divider (or (string-index (car in) #\=)
(unknown-arg (car in)))))
(or (> divider 2) (unknown-arg (car in)))
(let ((param (string->symbol (substring (car in) 2 divider)))
(val (with-input-from-string (substring (car in) (1+ divider))
(lp (cdr in) (acons param val out))))))))
(lambda (pair)
(or (false-if-exception
(set-parameter! (car pair) (cdr pair)))
(unknown-arg (format #f "--~a=~a" (car pair) (cdr pair)))))
(parse-arguments args)))