home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / scm / example < prev    next >
Text File  |  1992-04-15  |  3KB  |  138 lines
  1. ;From Revised^4 Report on the Algorithmic Language Scheme
  2. ;William Clinger and Jonathon Rees (Editors)
  3.  
  4. ;                   EXAMPLE
  5.  
  6. ;INTEGRATE-SYSTEM integrates the system 
  7. ;    y_k' = f_k(y_1, y_2, ..., y_n), k = 1, ..., n
  8. ;of differential equations with the method of Runge-Kutta.
  9.  
  10. ;The parameter SYSTEM-DERIVATIVE is a function that takes a system
  11. ;state (a vector of values for the state variables y_1, ..., y_n) and
  12. ;produces a system derivative (the values y_1', ..., y_n').  The
  13. ;parameter INITIAL-STATE provides an initial system state, and H is an
  14. ;initial guess for the length of the integration step.
  15.  
  16. ;The value returned by INTEGRATE-SYSTEM is an infinite stream of
  17. ;system states.
  18.  
  19. (define integrate-system
  20.   (lambda (system-derivative initial-state h)
  21.     (let ((next (runge-kutta-4 system-derivative h)))
  22.       (letrec ((states
  23.         (cons initial-state
  24.               (delay (map-streams next states)))))
  25.     states))))
  26.  
  27. ;RUNGE-KUTTA-4 takes a function, F, that produces a
  28. ;system derivative from a system state.  RUNGE-KUTTA-4
  29. ;produces a function that takes a system state and
  30. ;produces a new system state.
  31.  
  32. (define runge-kutta-4
  33.   (lambda (f h)
  34.     (let ((*h (scale-vector h))
  35.       (*2 (scale-vector 2))
  36.       (*1/2 (scale-vector (/ 1 2)))
  37.       (*1/6 (scale-vector (/ 1 6))))
  38.       (lambda (y)
  39.     ;; Y is a system state
  40.     (let* ((k0 (*h (f y)))
  41.            (k1 (*h (f (add-vectors y (*1/2 k0)))))
  42.            (k2 (*h (f (add-vectors y (*1/2 k1)))))
  43.            (k3 (*h (f (add-vectors y k2)))))
  44.       (add-vectors y
  45.                (*1/6 (add-vectors k0
  46.                       (*2 k1)
  47.                       (*2 k2)
  48.                       k3))))))))
  49.  
  50. (define elementwise
  51.   (lambda (f)
  52.     (lambda vectors
  53.       (generate-vector
  54.        (vector-length (car vectors))
  55.        (lambda (i)
  56.      (apply f
  57.         (map (lambda (v) (vector-ref  v i))
  58.              vectors)))))))
  59.  
  60. (define generate-vector
  61.   (lambda (size proc)
  62.     (let ((ans (make-vector size)))
  63.       (letrec ((loop
  64.         (lambda (i)
  65.           (cond ((= i size) ans)
  66.             (else
  67.              (vector-set! ans i (proc i))
  68.              (loop (+ i 1)))))))
  69.     (loop 0)))))
  70.  
  71. (define add-vectors (elementwise +))
  72.  
  73. (define scale-vector
  74.   (lambda (s)
  75.     (elementwise (lambda (x) (* x s)))))
  76.  
  77. ;MAP-STREAMS is analogous to MAP: it applies its first
  78. ;argument (a procedure) to all the elements of its second argument (a
  79. ;stream).
  80.  
  81. (define map-streams
  82.   (lambda (f s)
  83.     (cons (f (head s))
  84.       (delay (map-streams f (tail s))))))
  85.  
  86. ;Infinite streams are implemented as pairs whose car holds the first
  87. ;element of the stream and whose cdr holds a promise to deliver the rest
  88. ;of the stream.
  89.  
  90. (define head car)
  91. (define tail
  92.   (lambda (stream) (force (cdr stream))))
  93.  
  94.  
  95. ;The following illustrates the use of INTEGRATE-SYSTEM in
  96. ;integrating the system
  97. ;
  98. ;                 dvC    vC
  99. ;               C --- = -i - --
  100. ;                 dt         L     R
  101. ;
  102. ;                diL
  103. ;                  L --- = v
  104. ;                dt     C
  105. ;
  106. ;which models a damped oscillator.
  107.  
  108. (define damped-oscillator
  109.   (lambda (R L C)
  110.     (lambda (state)
  111.       (let ((Vc (vector-ref state 0))
  112.         (Il (vector-ref state 1)))
  113.     (vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
  114.         (/ Vc L))))))
  115.  
  116. (define the-states
  117.   (integrate-system
  118.    (damped-oscillator 10000 1000 .001)
  119.    '#(1 0)
  120.    .01))
  121.  
  122. (do ((i 10 (- i 1))
  123.      (s the-states (tail s)))
  124.     ((zero? i) (newline))
  125.   (newline)
  126.   (write (head s)))
  127.  
  128. ; #(1 0)
  129. ; #(0.99895054 9.994835e-6)
  130. ; #(0.99780226 1.9978681e-5)
  131. ; #(0.9965554 2.9950552e-5)
  132. ; #(0.9952102 3.990946e-5)
  133. ; #(0.99376684 4.985443e-5)
  134. ; #(0.99222565 5.9784474e-5)
  135. ; #(0.9905868 6.969862e-5)
  136. ; #(0.9888506 7.9595884e-5)
  137. ; #(0.9870173 8.94753e-5)
  138.