FC2ブログ
--.--
--
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

01.17
Thu
ちょっとブログのテスと

前に書いた記号微分のscheme版を貼る

(use srfi-1)

(define (rid0 lst)
	(filter (lambda (x) (not (eq? x 0))) lst))

(define (len lst n)(eq? (length lst) n))

(define (init lst)(reverse (cdr (reverse lst))))
(define (last lst)(car (reverse lst)))

(define (diff expr :optional (var 'x))
	(cond 
		((number? expr) 0)
		((eq? var expr) 1)
		((symbol? expr) 0)
		(else
			;;S式で表される数式
			(let* ((fname (car expr)) (body (cdr expr)) (ridded (map (cut diff <> var) body)))
				(cond 
					;;関数部が+なら
					((eq? fname '+)
						(if (null? body)
							0
							;;bodyを微分してnilになったら(全て0になってしまったら)
							(if (null? (rid0 ridded))
								0
								(cons fname (rid0 ridded)))))
					((eq? fname '-)
						(if (null? body)
							(error "- takes more than 1 arguments")
							;;bodyを微分してnilになったら(全て0になってしまったら)
							(if (null? (rid0 ridded))
								0
								(cons fname (rid0 ridded)))))
					((eq? fname '*)
						(cond
							((null? body) 1)
							((member 0 body) 0)
							((len body 1)(if (null? (rid0 ridded)) 0 (car (rid0 ridded))))	
							((len body 2)
								(let ((fx (car body)) (gx (cadr body)) (fdx (car ridded)) (gdx (cadr ridded)))  
									(cond 
										((null? (rid0 ridded))0)
										((eq? 0 fdx)
											(cond 
												((and (eq? fx 1)(eq? gdx 1)) 1)
												((eq? fx 1) gdx)
												((eq? gdx 1) fx)
												(else (list '* fx gdx))))
										((eq? 0 gdx) 
											(cond 
												((and (eq? fdx 1)(eq? gx 1))1)
												((eq? fdx 1)gx)
												((eq? gx 1)fdx)
												(else (list '* fdx gx))))
										(else
											(cond 
												((and (eq? fdx 1) (eq? gdx 1))(list '+ gx fx))
												((eq? fdx 1)(list '+ gx (list '* fx gdx)))
												((eq? gdx 1)(list '+ (list '* fdx gx) fx))
												(else (list '+ (list '* fdx gx) (list '* fx gdx))))))))
							(else
								(if (eq? (last ridded) 0)
									(if (eq? (last body) 1)
										(diff (init body) var)
										(list '* (diff (init body) var) (last body))
									)
									(if (eq? (last ridded) 1)
										(list '+ 
											(list '* (diff (init (cons fname body)) var) (last body)) 
											(cons fname (init body)))
										(list '+ 
											(list '* (diff (init (cons fname body)) var) (last body)) 
											(list '* (init (cons fname body)) (last ridded))))))))
					((eq? fname '/)
						;;ここで1*1とか0*1ができてしまうよ...
						(list '/ 
							(list '- 
								(list '* (diff (car body)  var) (cadr body)) 
								(list '* (car body) (diff (cadr body)  var))) 
							(list '* (cadr body) (cadr body))))
					(else
						(let ((fstdarg (car ridded)) (fstbody (car body)))
							(cond 
								((eq? fname 'sin) (list '*  fstdarg (list 'cos fstbody)))
								((eq? fname 'cos) (list '* -1 fstdarg (list 'sin fstbody)))))))))))

;;(tan(x^2+5x+6))'
(print (diff '(/ (sin (+ (* x x) (* 5 x) 6)) (cos (+ (* x x) (* 5 x) 6)))))

スポンサーサイト

comment 0 trackback 0
トラックバックURL
http://telracsmoratori.blog.fc2.com/tb.php/160-5032892f
トラックバック
コメント
管理者にだけ表示を許可する
 
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。