#! /bin/sh
exec ../src/sizzle -qs $0 $*
!#
;From Revised^4 Report on the Algorithmic Language Scheme
;William Clinger and Jonathon Rees (Editors)

;			       EXAMPLE

;INTEGRATE-SYSTEM integrates the system 
;	y_k' = f_k(y_1, y_2, ..., y_n), k = 1, ..., n
;of differential equations with the method of Runge-Kutta.

;The parameter SYSTEM-DERIVATIVE is a function that takes a system
;state (a vector of values for the state variables y_1, ..., y_n) and
;produces a system derivative (the values y_1', ..., y_n').  The
;parameter INITIAL-STATE provides an initial system state, and H is an
;initial guess for the length of the integration step.

;The value returned by INTEGRATE-SYSTEM is an infinite stream of
;system states.

;; Adapted to the Sizzle test suite by Martin Grabmueller
;; <mgrabmue@cs.tu-berlin.de>
;;

(load "test-suite.scm")

(begin-section "example from R4RS")

(begin-sub-section "runge-kutta")

(define integrate-system
  (lambda (system-derivative initial-state h)
    (let ((next (runge-kutta-4 system-derivative h)))
      (letrec ((states
		(cons initial-state
		      (delay (map-streams next states)))))
	states))))

;RUNGE-KUTTA-4 takes a function, F, that produces a
;system derivative from a system state.  RUNGE-KUTTA-4
;produces a function that takes a system state and
;produces a new system state.

(define runge-kutta-4
  (lambda (f h)
    (let ((*h (scale-vector h))
	  (*2 (scale-vector 2))
	  (*1/2 (scale-vector (/ 1 2)))
	  (*1/6 (scale-vector (/ 1 6))))
      (lambda (y)
	;; Y is a system state
	(let* ((k0 (*h (f y)))
	       (k1 (*h (f (add-vectors y (*1/2 k0)))))
	       (k2 (*h (f (add-vectors y (*1/2 k1)))))
	       (k3 (*h (f (add-vectors y k2)))))
	  (add-vectors y
		       (*1/6 (add-vectors k0
					  (*2 k1)
					  (*2 k2)
					  k3))))))))

(define elementwise
  (lambda (f)
    (lambda vectors
      (generate-vector
       (vector-length (car vectors))
       (lambda (i)
	 (apply f
		(map (lambda (v) (vector-ref  v i))
		     vectors)))))))

(define generate-vector
  (lambda (size proc)
    (let ((ans (make-vector size)))
      (letrec ((loop
		(lambda (i)
		  (cond ((= i size) ans)
			(else
			 (vector-set! ans i (proc i))
			 (loop (+ i 1)))))))
	(loop 0)))))

(define add-vectors (elementwise +))

(define scale-vector
  (lambda (s)
    (elementwise (lambda (x) (* x s)))))

;MAP-STREAMS is analogous to MAP: it applies its first
;argument (a procedure) to all the elements of its second argument (a
;stream).

(define map-streams
  (lambda (f s)
    (cons (f (head s))
	  (delay (map-streams f (tail s))))))

;Infinite streams are implemented as pairs whose car holds the first
;element of the stream and whose cdr holds a promise to deliver the rest
;of the stream.

(define head car)
(define tail
  (lambda (stream) (force (cdr stream))))


;The following illustrates the use of INTEGRATE-SYSTEM in
;integrating the system
;
;			     dvC	vC
;			   C --- = -i - --
;			     dt	     L	 R
;
;				diL
;			      L --- = v
;				dt     C
;
;which models a damped oscillator.

(define damped-oscillator
  (lambda (R L C)
    (lambda (state)
      (let ((Vc (vector-ref state 0))
	    (Il (vector-ref state 1)))
	(vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
		(/ Vc L))))))

(define the-states
  (integrate-system
   (damped-oscillator 10000 1000 .001)
   '#(1 0)
   .01))

;(do ((i 10 (- i 1))
;     (s the-states (tail s)))
;    ((zero? i) (newline))
;  (newline)
;  (write (head s)))

(define eps 0.0000001)
(define (close-enough x y)
  (< (abs (- x y)) eps))
(define (vector-equal x y)
   (and (close-enough (vector-ref x 0) (vector-ref y 0))
       (close-enough (vector-ref x 1) (vector-ref y 1))))

(define s the-states)
(pass-if (head s) '#(1 0) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.99895054 9.994835e-6) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.99780226 1.9978681e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.9965554 2.9950552e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.9952102 3.990946e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.99376684 4.985443e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.99222565 5.9784474e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.9905868 6.969862e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.9888506 7.9595884e-5) vector-equal)
(set! s (tail s))
(pass-if (head s) '#(0.9870173 8.94753e-5) vector-equal)

(test-summary)