Changeset 15459 in project
 Timestamp:
 08/14/09 09:39:06 (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/4/nemo/trunk/nemoutils.scm
r15425 r15459 221 221 (define LOG2E 1.44269504088896) 222 222 223 (define (differentiate x t)223 (define (differentiate fenv x t) 224 224 (cond ((number? t) 0.0) 225 225 ((symbol? t) (if (equal? x t) 1.0 0.0)) 226 226 (else (match t 227 (('neg u) `(neg ,(differentiate x u)))228 229 (('+ u v) `(+ ,(differentiate x u) ,(differentiatex v)))230 ((' u v) `( ,(differentiate x u) ,(differentiatex v)))231 232 (('* (and u (? number?)) v) `(* ,u ,(differentiate x v)))233 (('* v (and u (? number?))) `(* ,u ,(differentiate x v)))234 235 (('* u v) `(+ (* ,(differentiate x u) ,v)236 (* ,u ,(differentiate x v))))237 238 (('/ u v) `(/ ( (* ,(differentiate x u) ,v)239 (* ,u ,(differentiate x v)))227 (('neg u) `(neg ,(differentiate fenv x u))) 228 229 (('+ u v) `(+ ,(differentiate fenv x u) ,(differentiate fenv x v))) 230 ((' u v) `( ,(differentiate fenv x u) ,(differentiate fenv x v))) 231 232 (('* (and u (? number?)) v) `(* ,u ,(differentiate fenv x v))) 233 (('* v (and u (? number?))) `(* ,u ,(differentiate fenv x v))) 234 235 (('* u v) `(+ (* ,(differentiate fenv x u) ,v) 236 (* ,u ,(differentiate fenv x v)))) 237 238 (('/ u v) `(/ ( (* ,(differentiate fenv x u) ,v) 239 (* ,u ,(differentiate fenv x v))) 240 240 (pow ,v 2.0))) 241 241 242 (('cube u) (differentiate x `(pow ,u 3.0)))243 244 (('pow u n) (chain x u `(* ,n (pow ,u ( ,n 1.0)))))242 (('cube u) (differentiate fenv x `(pow ,u 3.0))) 243 244 (('pow u n) (chain fenv x u `(* ,n (pow ,u ( ,n 1.0))))) 245 245 246 (('sqrt u) (chain x u `(/ 1.0 (* 2.0 (sqrt ,u)))))247 248 (('exp u) (chain x u `(exp ,u)))249 250 (('log a u) (chainx u `(/ 1.0 ,u)))251 252 (('log10 u) (chain x u `(* ,LOG10E (/ ,(differentiatex u) ,u))))246 (('sqrt u) (chain fenv x u `(/ 1.0 (* 2.0 (sqrt ,u))))) 247 248 (('exp u) (chain fenv x u `(exp ,u))) 249 250 (('log u) (chain fenv x u `(/ 1.0 ,u))) 251 252 (('log10 u) (chain fenv x u `(* ,LOG10E (/ ,(differentiate fenv x u) ,u)))) 253 253 254 (('log2 u) (chain x u `(* ,LOG2E (/ ,(differentiatex u) ,u))))255 256 (('log1p u) (differentiate x `(log (+ 1.0 ,u))))257 258 (('ldexp u n) (differentiate x `(* ,u ,(expt 2 n))))254 (('log2 u) (chain fenv x u `(* ,LOG2E (/ ,(differentiate fenv x u) ,u)))) 255 256 (('log1p u) (differentiate fenv x `(log (+ 1.0 ,u)))) 257 258 (('ldexp u n) (differentiate fenv x `(* ,u ,(expt 2 n)))) 259 259 260 (('sin u) (chain x u `(cos ,u)))260 (('sin u) (chain fenv x u `(cos ,u))) 261 261 262 (('cos u) (chain x u `(neg (sin ,u))))263 264 (('tan u) (differentiate x `(* (sin ,u) (/ 1.0 (cos ,u)))))262 (('cos u) (chain fenv x u `(neg (sin ,u)))) 263 264 (('tan u) (differentiate fenv x `(* (sin ,u) (/ 1.0 (cos ,u))))) 265 265 266 (('asin u) (chain x u `(/ 1.0 (sqrt ( 1.0 (pow ,u 2.0))))))266 (('asin u) (chain fenv x u `(/ 1.0 (sqrt ( 1.0 (pow ,u 2.0)))))) 267 267 268 (('acos u) (chain x u `(/ (neg 1.0) (sqrt ( 1.0 (pow ,u 2.0))))))268 (('acos u) (chain fenv x u `(/ (neg 1.0) (sqrt ( 1.0 (pow ,u 2.0)))))) 269 269 270 (('atan u) (chain x u `(/ 1.0 (+ 1.0 (pow ,u 2.0)))))270 (('atan u) (chain fenv x u `(/ 1.0 (+ 1.0 (pow ,u 2.0))))) 271 271 272 (('sinh u) (differentiate x `(/ ( (exp ,u) (exp (neg ,u))) 2.0)))273 274 (('cosh u) (differentiate x `(/ (+ (exp ,u) (exp (neg ,u))) 2.0)))272 (('sinh u) (differentiate fenv x `(/ ( (exp ,u) (exp (neg ,u))) 2.0))) 273 274 (('cosh u) (differentiate fenv x `(/ (+ (exp ,u) (exp (neg ,u))) 2.0))) 275 275 276 (('tanh u) (differentiate x `(/ (sinh ,u) (cosh ,u)))) 276 (('tanh u) (differentiate fenv x `(/ (sinh ,u) (cosh ,u)))) 277 278 (('let bnds body) `(let ,(map (matchlambda ((v b) `(,v ,(differentiate fenv x b)))) 279 bnds) 280 ,(differentiate fenv x body))) 281 282 283 ((op u) (cond ((lookupdef op fenv) => 284 (matchlambda ((fx) (chain fenv x u `(,fx ,u))) 285 (else #f))) 286 (else #f))) 287 288 ((op . us) (cond ((lookupdef op fenv) => 289 (lambda (fs) 290 `(+ . ,(map (lambda (fu u) (chain fenv x u `(,fu ,u))) 291 fs us)))) 292 (else #f))) 277 293 278 294 (else #f))))) 279 295 280 (define (chain x t u)296 (define (chain fenv x t u) 281 297 (if (symbol? t) u 282 `(* ,(differentiate x t) ,u))) 283 298 `(* ,(differentiate fenv x t) ,u))) 299 300 284 301 (define (simplify t) 285 302 (match t … … 287 304 (('+ t1 0.0) t1) 288 305 (('+ t1 ('neg t2)) `( ,t1 ,t2)) 306 (('+ (and t1 (? number?)) (and t2 (? number?))) (+ t1 t2)) 307 289 308 290 309 ((' 0.0 t1) `(neg ,t1)) 291 310 ((' t1 0.0) t1) 292 311 (('neg ('neg t1)) t1) 293 312 ((' (and t1 (? number?)) (and t2 (? number?))) ( t1 t2)) 313 314 294 315 (('* 0.0 t1) 0.0) 295 316 (('* t1 0.0) 0.0) 296 317 (('* 1.0 t1) t1) 297 (('* t1 1.0) t1) 298 (('* ('neg t1) ('neg t2)) `(* ,t1 ,t2)) 299 318 (('* t1 1.0) t1) 319 (('* ('neg t1) ('neg t2)) `(* ,t1 ,t2)) 320 (('* (and t1 (? number?)) (and t2 (? number?))) (* t1 t2)) 321 322 (('pow t1 0.0) 1.0) 323 (('pow t1 1.0) t1) 324 (('pow (and t1 (? number?)) (and t2 (? number?))) (expt t1 t2)) 325 326 (('let bnds body) 327 `(let ,(map (matchlambda ((v b) `(v ,(recur b))) 328 (else #f)) bnds) 329 ,(recur body))) 330 331 ((op . ts) 332 `(,op . ,(map simplify ts))) 333 300 334 (else t))) 301 335
Note: See TracChangeset
for help on using the changeset viewer.