home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 2: PC / frozenfish_august_1995.bin / bbs / d09xx / d0963.lha / SIOD / scm / deriv.scm < prev    next >
Text File  |  1993-01-01  |  4KB  |  200 lines
  1. (define (make-sum a b)
  2.    (cond ((and (number? a)
  3.                (number? b)) (+ a b))
  4.          ((eqv? a 0) b)
  5.          ((eqv? b 0) a)
  6.          ((equal? a b) (make-prod 2 a))
  7.  
  8.  
  9.          (else (if (number? a)
  10.                    (list b 'sum a)
  11.  
  12.  
  13.  
  14.                    (list a 'sum b)))))
  15.  
  16. (define (adde1 exp)
  17.    (car exp))
  18.  
  19. (define (adde2 exp)
  20.    (caddr exp))
  21.  
  22. (define (sum? a)
  23.    (eq? (cadr a) 'sum))
  24.  
  25. (define (make-minus a b)
  26.    (cond ((and (number? a)
  27.                (number? b)) (- a b))
  28.  
  29.          ((eqv? b 0) a)
  30.  
  31.          ((equal? a b) 0)
  32.  
  33.          (else (list a 'minus b))))
  34.  
  35. (define (sott1 exp)
  36.    (car exp))
  37.  
  38. (define (sott2 exp)
  39.    (caddr exp))
  40.  
  41. (define (minus? a)
  42.    (eq? (cadr a) 'minus))
  43.  
  44. (define (make-prod a b)
  45.    (cond ((and (number? a)
  46.                (number? b)) (* a b))
  47.  
  48.          ((eqv? a 1) b)
  49.          ((eqv? b 1) a)
  50.          ((or (eqv? a 0)
  51.               (eqv? b 0)) 0)
  52.          ((equal? a b) (make-exp a 2))
  53.  
  54.  
  55.          (else (if (number? a)
  56.                    (list a 'prod b)
  57.  
  58.  
  59.  
  60.                    (list b 'prod a)))))
  61.  
  62. (define (fatt1 exp)
  63.    (car exp))
  64.  
  65. (define (fatt2 exp)
  66.    (caddr exp))
  67.  
  68. (define (prod? a)
  69.    (eq? (cadr a) 'prod))
  70.  
  71. (define (make-div a b)
  72.    (cond ((eqv? b 0)
  73.           (error "divisione per zero"))
  74.  
  75.          ((eqv? a 0) 0)
  76.  
  77.          ((eqv? b 1) a)
  78.          ((and (number? a)
  79.                (number? b))
  80.                (if (zero? (remainder a
  81.                                      b))
  82.                    (/ a b)
  83.                    (list (/ a (gcd a b))
  84.                          'div
  85.                          (/ b (gcd a b)))))
  86.          ((equal? a b) 1)
  87.  
  88.          (else (list a 'div b))))
  89.  
  90. (define (divid exp)
  91.    (car exp))
  92.  
  93. (define (divis exp)
  94.    (caddr exp))
  95.  
  96. (define (divi? a)
  97.    (eq? (cadr a) 'div))
  98.  
  99. (define (base exp)
  100.    (car exp))
  101.  
  102. (define (expo exp)
  103.    (caddr exp))
  104.  
  105. (define (exp? a)
  106.    (eq? (cadr a) 'exp))
  107.  
  108. (define (make-exp a b)
  109.    (cond ((eqv? b 0)
  110.           (if (eqv? a 0)
  111.               (error "zero elevato zero")
  112.               1))
  113.  
  114.          ((eqv? b 1) a)
  115.  
  116.          ((eqv? a 0) 0)
  117.  
  118.          ((and (number? a)
  119.                (number? b)) (expt a b))
  120.  
  121.          ((and (pair? a)(exp? a)) (make-exp (base a) 
  122.                                   (make-prod (expo a) 
  123.                                               b)))
  124.  
  125.          (else (list a 'exp b))))
  126.  
  127. (define (make-log a)
  128.    (if (eqv? a 1)
  129.       0
  130.    (list 'log a)))
  131.  
  132. (define (log1 exp)
  133.    (cadr exp))
  134.  
  135. (define (log? a)
  136.    (eq? (car a) 'log))
  137.  
  138.  
  139. (define (variable? a)
  140.    (symbol? a))
  141.  
  142. (define (constant? a)
  143.    (number? a))
  144.  
  145. (define (same-variable? a b)
  146.    (eq? a b))
  147.  
  148. (define (deriv exp var)
  149.    (cond ((constant? exp) 0)
  150.          ((variable? exp)
  151.           (if (same-variable? exp var)
  152.               1
  153.               0))
  154.  
  155.       ((sum? exp)
  156.          (make-sum (deriv (fatt1 exp) var)
  157.                    (deriv (fatt2 exp) var)))
  158.  
  159.       ((minus? exp)
  160.          (make-minus (deriv (sott1 exp) var)
  161.                      (deriv (sott2 exp) var)))
  162.  
  163.       ((prod? exp)
  164.                (make-sum (make-prod (deriv (fatt1 exp) var)
  165.                                     (fatt2 exp))
  166.                          (make-prod (fatt1 exp)
  167.                                     (deriv (fatt2 exp) var))))
  168.  
  169.       ((divi? exp)
  170.          (make-div (make-minus (make-prod (deriv (divid exp) var)
  171.                                           (divis exp))
  172.                                (make-prod (divid exp)
  173.                                           (deriv (divis exp) var)))
  174.                    (make-exp (divis exp) 2)))
  175.  
  176.       ((log? exp)
  177.          (make-prod (make-div 1
  178.                               (log1 exp))
  179.                     (deriv (log1 exp) var)))
  180.  
  181.       ((exp? exp)
  182.          (if (number? (expo exp))
  183.              (make-prod (expo exp)
  184.                         (make-prod (make-exp (base exp)
  185.                                              (- (expo exp) 1))
  186.                                    (deriv (base exp) var)))
  187.              (error "l'esponente deve essere una costante"
  188.                     (expo exp))))
  189.       (else (error "operatore sconosciuto" exp))))
  190.  
  191.  
  192. (alias m+ make-sum)
  193. (alias m- make-minus)
  194. (alias m* make-prod)
  195. (alias m/ make-div)
  196. (alias m^ make-exp)
  197. (alias ml make-log)
  198. (alias d deriv)
  199. (define x 'x)
  200.