Changeset 15425 in project

Timestamp:

08/13/09 08:26:36 (10 years ago)

Author:

Ivan Raikov

Message:

added symbolic differentiation to nemo-utils

File:

• release/4/nemo/trunk/nemo-utils.scm (modified) (3 diffs)

release/4/nemo/trunk/nemo-utils.scm

@@ -24 +24 @@
              if-convert let-enum let-elim let-lift
              s+ sw+ sl\ nl spaces ppf
-             transitions-graph state-lineqs)
+             transitions-graph state-lineqs
+             differentiate simplify )
 
  (import scheme chicken data-structures srfi-1 srfi-13)
@@ -30 +31 @@
  (require-extension matchable strictly-pretty 
                     varsubst digraph nemo-core)
-
-(declare (lambda-lift))
-
 
 
@@ -214 +212 @@
                               lineqs)))
     (list n lineqs1)))
+
+;;    `(+ - * / pow neg abs atan asin acos sin cos exp ln
+;;      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
+;;      > < <= >= = and or round ceiling floor max min
+;;      fpvector-ref))
+
+(define LOG10E 0.434294481903252)
+(define LOG2E  1.44269504088896)
+
+(define (differentiate x t)
+  (cond ((number? t)  0.0)
+        ((symbol? t)  (if (equal? x t) 1.0 0.0))
+        (else (match t
+                (('neg u)  `(neg ,(differentiate x u)))
+
+                (('+ u v)  `(+ ,(differentiate x u) ,(differentiate x v)))
+                (('- u v)  `(- ,(differentiate x u) ,(differentiate x v)))
+
+                (('* (and u (? number?)) v)    `(* ,u ,(differentiate x v)))
+                (('* v (and u (? number?)))    `(* ,u ,(differentiate x v)))
+
+                (('* u v)     `(+ (* ,(differentiate x u) ,v)
+                                  (* ,u ,(differentiate x v))))
+
+                (('/ u v)     `(/ (- (* ,(differentiate x u) ,v)
+                                     (* ,u ,(differentiate x v)))
+                                  (pow ,v 2.0)))
+
+                (('cube u)     (differentiate x `(pow ,u 3.0)))
+
+                (('pow u n)    (chain x u `(* ,n (pow ,u (- ,n 1.0)))))
+                
+                (('sqrt u)     (chain x u `(/ 1.0 (* 2.0 (sqrt ,u)))))
+
+                (('exp u)      (chain x u `(exp ,u)))
+
+                (('log a u)    (chain x u `(/ 1.0 ,u)))
+
+                (('log10 u)    (chain x u `(* ,LOG10E (/ ,(differentiate x u) ,u))))
+        
+                (('log2 u)     (chain x u `(* ,LOG2E (/ ,(differentiate x u) ,u))))
+
+                (('log1p u)    (differentiate x `(log (+ 1.0 ,u))))
+
+                (('ldexp u n)  (differentiate x `(* ,u ,(expt 2 n))))
+        
+                (('sin u)      (chain x u `(cos ,u)))
+                
+                (('cos u)      (chain x u `(neg (sin ,u))))
+
+                (('tan u)      (differentiate x `(* (sin ,u) (/ 1.0 (cos ,u)))))
+                
+                (('asin u)     (chain x u `(/ 1.0 (sqrt (- 1.0 (pow ,u 2.0))))))
+                                              
+                (('acos u)     (chain x u `(/ (neg 1.0) (sqrt (- 1.0 (pow ,u 2.0))))))
+                                              
+                (('atan u)     (chain x u `(/ 1.0 (+ 1.0 (pow ,u 2.0)))))
+                                              
+                (('sinh u)     (differentiate x `(/ (- (exp ,u) (exp (neg ,u))) 2.0)))
+
+                (('cosh u)     (differentiate x `(/ (+ (exp ,u) (exp (neg ,u))) 2.0)))
+                
+                (('tanh u)     (differentiate x `(/ (sinh ,u) (cosh ,u))))
+
+                (else          #f)))))
+
+(define (chain x t u)
+  (if (symbol? t) u
+      `(* ,(differentiate x t) ,u)))
+        
+(define (simplify t)
+  (match t
+         (('+ 0.0 t1)  t1)
+         (('+ t1 0.0)  t1)
+         (('+ t1 ('neg t2))  `(- ,t1 ,t2))
+         
+         (('- 0.0 t1)  `(neg ,t1))
+         (('- t1 0.0)  t1)
+         (('neg ('neg t1))  t1)
+
+         (('* 0.0 t1)  0.0)
+         (('* t1 0.0)  0.0)
+         (('* 1.0 t1)  t1)
+         (('* t1 1.0)  t1)
+         (('* ('neg t1) ('neg t2))  `(* ,t1 ,t2))
+
+         (else t)))
+
 )