100 REM Differentiator.Derivative$(expr$,dvar$)は，数式expr$を変数dvar$で微分して得られる導関数。
110 REM 関数は，SIN，COS，TAN, LOG, EXP, SQR, ATN, ASIN, ACOS のみ
120 REM 数値式の文法はほぼFull BASICに準ずるが，関数名に続く括弧は空白を入れずに書く。
130 REM 英字の小文字と大文字を同一視する。
140 REM 変数名はギリシャ文字の小文字α,…,ω も可。
150 REM 微分変数以外の変数(文字定数)を含んでよいが，配列(添字付き変数)は不可。
160 REM
170 DECLARE EXTERNAL FUNCTION Differentiator.Derivative$
180 DECLARE STRING s$,t$
190 !
200 DATA "x^3-a*x^2+b*x+c","x"
210 DATA "x^2+3*x*y-2*y^2", "x"
220 DATA "x^2+3*x*y-2*y^2", "y"
230 DATA "(x+1)*(x+2)*(x+3)","x"
240 DATA "x/x^2/x^3","x"
250 DATA "2*x/(3*x)/(4*x)*(5*x)","x"
260 DATA "EXP(-2*(x-k)^2)","x"
270 DATA "exp(-2*x^2-8*x)","x"
280 DATA "sqr(-2*x)","x"
290 DATA "SQR(2*X^2)","x"
300 DATA "SIN(-2*x^2-3*x+1)","x"
310 DATA "COS(-3*x^3-2*x)","x"
320 DATA "sin(a1*x^3+a2*x^2+a3*x+a4)","x"
330 DATA "exp(-2*sin(x^2+1))","x"
340 DATA "TAN(x)*COS(x)","x"
350 DATA "ATN(SIN(x))","x"
360 DATA "ASIN(x/180*PI)","x"
370 DATA "x^(n+1)","x"
380 DATA "x^x","x"
390 DATA "x^(x^2)","x"
400 DATA "x^(x*x)","x"
410 DATA "(x^x)^x","x"
420 DATA "x^x^x","x"
430 DATA "EXP(x*LOG(x))","x"
440 !
450 DO
460    READ IF MISSING THEN EXIT DO:s$,t$
470    PRINT s$,"を";t$;"で微分"
480    PRINT Derivative$(s$,t$)
490    PRINT
500 LOOP
510 END
520 !
1000 MODULE Differentiator
1010 MODULE OPTION CHARACTER kanji
1020 PUBLIC FUNCTION Derivative$
1030 SHARE STRING s$
1040 SHARE STRING DiffVar$
1050 SHARE NUMERIC i
1060 SHARE SUB skip
1070 SHARE SUB expression,term,factor,primary,numeric
1080 SHARE FUNCTION prod$,add$,sbt$,div$,Paren$,UnParen$
1090 !
1100 EXTERNAL FUNCTION Derivative$(expr$,dvar$)
1110    REM expr$の数式をdvar$で微分する
1120    DECLARE STRING exp$,dev$
1130    LET diffvar$=dvar$
1140    LET s$=expr$
1150    LET i=1
1160    CALL skip
1170    CALL expression(exp$,dev$)
1180    IF i<LEN(s$) THEN PRINT i,"Syntax error"
1190    let Derivative$=dev$
1200 end function
1210 !
1220 EXTERNAL SUB skip   ! 空白を読み飛ばす
1230    DO WHILE s$(i:i)=" "
1240       LET i=i+1
1250    LOOP
1260 END SUB
1270 !
1280 EXTERNAL FUNCTION add$(s$,t$)
1290    IF s$="0" THEN
1300       LET add$=t$
1310    ELSEIF t$="0" THEN
1320       LET add$=s$
1330    ELSE
1340       LET add$=s$ & "+" & t$
1350    END IF
1360 END FUNCTION
1370 !
1380 EXTERNAL FUNCTION sbt$(s$,t$)
1390    IF s$=t$ THEN
1400       LET sbt$="0"
1410    ELSEIF s$="" AND t$="0" THEN
1420       LET sbt$="0"
1430    ELSEIF s$="0" THEN
1440       LET sbt$="(-" & t$ &")"
1450    ELSEIF t$="0" THEN
1460       LET sbt$=s$
1470    ELSE
1480       IF POS(t$,"+")>0 OR POS(t$,"-")>0  THEN LET t$=Paren$(t$)
1490       LET sbt$=s$ & "-" & t$
1500    END IF
1510 END FUNCTION
1520 !
1530 EXTERNAL FUNCTION prod$(s$,t$)
1540    IF s$="1" THEN
1550       LET prod$=t$
1560    ELSEIF t$="1" THEN
1570       LET prod$=s$
1580    ELSEIF s$="0" OR t$="0" THEN
1590       LET prod$="0"
1600    ELSE
1610       IF POS(s$,"+")>0 OR POS(s$,"-")>0  THEN LET s$=Paren$(s$)
1620       IF POS(t$,"+")>0 OR POS(t$,"-")>0  THEN LET t$=Paren$(t$)
1630       LET prod$=s$ & "*" & t$
1640    END IF
1650 END FUNCTION
1660 !
1670 EXTERNAL FUNCTION div$(s$,t$)
1680    IF s$=t$ THEN
1690       LET div$="1"
1700    ELSEIF t$="1" THEN
1710       LET div$=s$
1720    ELSEIF s$="0"  THEN
1730       LET div$="0"
1740    ELSE
1750       IF POS(s$,"+")>0 OR POS(s$,"-")>0 THEN LET s$=Paren$(s$)
1760       IF POS(t$,"+")>0 OR POS(t$,"-")>0 OR POS(t$,"*")>0 OR POS(t$,"/")>0THEN LET t$=Paren$(t$)
1770       LET div$=s$ & "/" & t$
1780    END IF
1790 END FUNCTION
1800 !
1810 EXTERNAL SUB expression(exp$,dev$)  !加減式
1820    DECLARE NUMERIC i0
1830    DECLARE STRING op$,e1$,d1$,e2$,d2$
1840    IF s$(i:i)="+" OR s$(i:i)="-" THEN
1850       LET exp$=""
1860       LET dev$=""
1870    ELSE
1880       CALL term(exp$,dev$)
1890    END IF
1900    DO WHILE s$(i:i)="+" OR s$(i:i)="-"
1910       LET op$=s$(i:i)
1920       LET i=i+1
1930       CALL skip
1940       LET e1$=exp$
1950       LET d1$=dev$
1960       CALL term(e2$,d2$)
1970       LET exp$=e1$ & op$ & e2$
1980       SELECT CASE op$
1990       CASE "+"
2000          LET dev$=add$(d1$,d2$)
2010       CASE "-"
2020          LET dev$=sbt$(d1$,d2$)
2030       END SELECT
2040    LOOP
2050    CALL skip
2060 END SUB
2070 !
2080 EXTERNAL SUB term(exp$,dev$)    !項(乗除)
2090    DECLARE NUMERIC i0
2100    DECLARE STRING op$,e1$,d1$,e2$,d2$
2110    CALL factor(exp$,dev$)
2120    DO WHILE s$(i:i)="*" OR s$(i:i)="/"
2130       LET op$=s$(i:i)
2140       LET i=i+1
2150       CALL skip
2160       LET e1$=exp$
2170       LET d1$=dev$
2180       CALL factor(e2$,d2$)
2190       LET exp$=e1$ & op$ & e2$
2200       SELECT CASE op$
2210       CASE "*"
2220          LET dev$=add$(prod$(d1$,e2$),prod$(e1$,d2$))
2230       CASE "/"
2240          LET dev$=div$(Paren$(sbt$(prod$(d1$,e2$),prod$(e1$,d2$))), Paren$(e2$) & "^2")
2250       END SELECT
2260    LOOP
2270    CALL skip
2280 END SUB
2290 !
2300 EXTERNAL SUB factor(exp$,dev$)    !因子(冪乗)
2310    DECLARE NUMERIC i0,n
2320    DECLARE STRING e1$,d1$,e2$,d2$
2330    CALL primary(exp$,dev$)
2340    DO WHILE s$(i:i)="^"
2350       LET i=i+1
2360       CALL skip
2370       LET e1$=exp$
2380       LET d1$=dev$
2390       CALL primary(e2$,d2$)
2400       LET exp$=e1$ & "^" & e2$
2410       ! 2420行～2580行で，e1$,e2$,exp$は因子(factor)
2420       IF d2$="0" THEN
2430          WHEN EXCEPTION IN
2440             LET n=VAL(e2$)-1
2450             IF n=1 THEN
2460                LET dev$=prod$(prod$(e2$,e1$) ,d1$)
2470             ELSEIF n>0 THEN
2480                LET dev$=prod$(prod$(e2$, e1$ & "^" & STR$(n)) ,d1$)
2490             ELSE
2500                LET dev$=prod$(prod$(e2$, e1$ & "^(" & STR$(n) & ")"),d1$)
2510             END IF
2520          USE
2530             LET dev$=prod$(e2$ & "*" & e1$ & "^(" & e2$ & "-1)",d1$)
2540          END WHEN
2550       ELSE
2560          LET dev$=prod$(exp$ , add$( prod$(d2$, "LOG(" & e1$ & ")"), prod$(div$(e2$,e1$),d1$)))
2570       END IF
2580    LOOP
2590    CALL skip
2600 END SUB
2610 !
2620 EXTERNAL SUB primary(exp$,dev$)
2630    DECLARE NUMERIC i0
2640    DECLARE STRING op$,e1$,d1$,e2$,d2$
2650    LET i0=i
2660    IF s$(i:i)="(" THEN
2670       LET i=i+1
2680       CALL SKIP
2690       CALL expression(e1$,d1$)
2700       LET exp$="(" & e1$ & ")"
2710       !LET dev$="(" & d1$ & ")"
2720       LET dev$=Paren$(d1$)
2730    ELSEIF UCASE$(s$(i:i+3))="SIN(" THEN
2740       LET i=i+4
2750       CALL SKIP
2760       CALL expression(e1$,d1$)
2770       LET exp$="SIN(" & e1$ & ")"
2780       LET dev$=prod$(d1$,"COS(" & e1$ & ")")
2790    ELSEIF UCASE$(s$(i:i+3))="COS(" THEN
2800       LET i=i+4
2810       CALL SKIP
2820       CALL expression(e1$,d1$)
2830       LET exp$="COS(" & e1$ & ")"
2840       LET dev$=prod$(d1$,"(-SIN(" & e1$ & "))")
2850    ELSEIF UCASE$(s$(i:i+3))="TAN(" THEN
2860       LET i=i+4
2870       CALL SKIP
2880       CALL expression(e1$,d1$)
2890       LET exp$="TAN(" & e1$ & ")"
2900       LET dev$=prod$( d1$, "SEC(" & e1$ & ")^2")
2910    ELSEIF UCASE$(s$(i:i+3))="LOG(" THEN
2920       LET i=i+4
2930       CALL SKIP
2940       CALL expression(e1$,d1$)
2950       LET exp$="LOG(" & e1$ & ")"
2960       LET dev$=Div$(Paren$(d1$),Paren$(e1$))
2970    ELSEIF UCASE$(s$(i:i+3))="EXP(" THEN
2980       LET i=i+4
2990       CALL SKIP
3000       CALL expression(e1$,d1$)
3010       LET exp$="EXP(" & e1$ & ")"
3020       LET dev$=prod$( d1$ ,"EXP(" & e1$ & ")")
3030    ELSEIF UCASE$(s$(i:i+3))="SQR(" THEN
3040       LET i=i+4
3050       CALL SKIP
3060       CALL expression(e1$,d1$)
3070       LET exp$="SQR(" & e1$ & ")"
3080       LET dev$=div$(d1$,"(2*SQR(" & e1$ & "))")
3090    ELSEIF UCASE$(s$(i:i+3))="ATN(" THEN
3100       LET i=i+4
3110       CALL SKIP
3120       CALL expression(e1$,d1$)
3130       LET exp$="ATN(" & e1$ & ")"
3140       LET dev$=div$(Paren$(d1$), "(1+" & Paren$(e1$) & "^2)")
3150    ELSEIF UCASE$(s$(i:i+4))="ASIN(" THEN
3160       LET i=i+5
3170       CALL SKIP
3180       CALL expression(e1$,d1$)
3190       LET exp$="ASIN(" & e1$ & ")"
3200       LET dev$=Paren$(d1$) & "/SQR(1-(" & e1$ & ")^2)"
3210    ELSEIF UCASE$(s$(i:i+4))="ACOS(" THEN
3220       LET i=i+5
3230       CALL SKIP
3240       CALL expression(e1$,d1$)
3250       LET exp$="ACOS(" & e1$ & ")"
3260       LET dev$="(-" & Paren$(d1$) & ")/SQR(1-(" & e1$ & ")^2)"
3270    END IF
3280    IF i>i0 THEN
3290       IF s$(i:i)=")" THEN
3300          LET i=i+1
3310          CALL skip
3320       ELSE
3330          PRINT i, ") expected"
3340          STOP
3350       END IF
3360    ELSE
3370       IF s$(i:i)>="0" AND s$(i:i)<="9" OR s$(i:i)="." THEN
3380          CALL NUMERIC(exp$,dev$)
3390       ELSEIF s$(i:i)>="a" AND s$(i:i)<="z" OR s$(i:i)>="A" AND s$(i:i)<="Z" OR s$(i:i)>="α" AND s$(i:i)<="ω" THEN
3400          CALL identif(exp$,dev$)
3410       ELSE
3420       END IF
3430    END IF
3440 END SUB
3450 !
3460 EXTERNAL SUB numeric(exp$,dev$)
3470    DECLARE NUMERIC i0
3480    LET i0=i
3490    DO WHILE s$(i:i)>="0" AND s$(i:i)<="9" OR s$(i:i)="."
3500       LET i=i+1
3510    LOOP
3520    IF UCASE$(s$(i:i))="E" THEN
3530       LET i=i+1
3540       IF s$(i:i)="+" OR s$(i:i)="-" THEN LET i=i+1
3550       DO WHILE s$(i:i)>="0" AND s$(i:i)<="9"
3560          LET i=i+1
3570       LOOP
3580    END IF
3590    LET exp$=s$(i0:i-1)
3600    LET dev$="0"
3610    CALL skip
3620 END SUB
3630 !
3640 EXTERNAL SUB identif(exp$,dev$)
3650    DECLARE NUMERIC i0
3660    LET i0=i
3670    DO WHILE s$(i:i)>="a" AND s$(i:i)<="z" OR s$(i:i)>="A" AND s$(i:i)<="Z" OR s$(i:i)>="0" AND s$(i:i)<="9" OR s$(i:i)>="α" AND s$(i:i)<="ω"
3680       LET i=i+1
3690    LOOP
3700    LET exp$=s$(i0:i-1)
3710    IF UCASE$(exp$)=UCASE$(DiffVar$) THEN LET dev$="1" ELSE LET dev$="0"
3720    CALL skip
3730 END SUB
3740 !
3750 EXTERNAL FUNCTION Paren$(s$)
3760    DECLARE NUMERIC i
3770    SUB EndParen
3780       let i=i+1
3790       DO UNTIL s$(i:i)=")"
3800          LET i=i+1
3810          IF s$(i:i)="(" THEN CALL EndParen
3820       LOOP
3830    END SUB
3840    LET i=1
3850    DO WHILE s$(i:i)=" "
3860       LET i=i+1
3870    LOOP
3880    IF s$(i:i)="(" THEN
3890       CALL EndParen
3900    ELSEIF  s$(i:i)>="0" AND s$(i:i)<="9" OR s$(i:i)="." THEN
3910       DO WHILE s$(i:i)>="0" AND s$(i:i)<="9" OR s$(i:i)="."
3920          LET i=i+1
3930       LOOP
3940       IF UCASE$(s$(i:i))="E" THEN
3950          LET i=i+1
3960          IF s$(i:i)="+" OR s$(i:i)="-" THEN LET i=i+1
3970          DO WHILE s$(i:i)>="0" AND s$(i:i)<="9"
3980             LET i=i+1
3990          LOOP
4000       END IF
4010    ELSEIF s$(i:i)>="a" AND s$(i:i)<="z" OR s$(i:i)>="A" AND s$(i:i)<="Z" OR s$(i:i)>="α" AND s$(i:i)<="ω" THEN
4020       DO WHILE s$(i:i)>="a" AND s$(i:i)<="z" OR s$(i:i)>="A" AND s$(i:i)<="Z" OR s$(i:i)>="0" AND s$(i:i)<="9" OR s$(i:i)>="α" AND s$(i:i)<="ω"
4030          LET i=i+1
4040       LOOP
4050       IF s$(i:i)="(" THEN  CALL EndParen
4060    END IF
4070    DO WHILE s$(i:i)=" "
4080       LET i=i+1
4090    LOOP
4100    IF i<LEN(s$) THEN
4110       LET Paren$="(" & s$ & ")"
4120    ELSE
4130       LET Paren$=s$
4140    END IF
4150 END FUNCTION
4250 END MODULE
