home *** CD-ROM | disk | FTP | other *** search
/ WinWares 1 / WINWARES.ISO / calc / tablecrv / tbasic.tcl < prev    next >
Encoding:
Text File  |  1993-06-01  |  8.3 KB  |  284 lines
  1. ~~TBASIC~~
  2. '--------------------------------------------------------------
  3. '          TableCurve Turbo BASIC Library Module
  4. '--------------------------------------------------------------
  5. ' This code is specific to Borland Turbo BASIC. The ON ERROR 
  6. ' approach is BASIC's standard error-handling and this is 
  7. ' included in the code. It was not, however, 100% successful
  8. ' in catching exceptions in system math functions.
  9. ' Turbo BASIC will also compile successfully without 
  10. ' modification the code generated for BASICA/GWBASIC.
  11. '--------------------------------------------------------------
  12.   DEFDBL x,y
  13.   DEFINT i,j
  14.   DIM x(17),y(17)
  15.  
  16. ' Get screen attribute for reset at end of program
  17.   attr0%=FNgetattr%
  18.   fore0%=attr0% MOD 16
  19.   back0%=attr0% \ 16
  20.  
  21. ' Determine whether to use color or monochrome attributes
  22.   iscolor=FNgetcolor%
  23.   IF iscolor THEN
  24.     fore1%=1 : back1%=7 : fore2%=15 : back2%=1
  25.   ELSE
  26.     fore1%=15 : back1%=0 : fore2%=0 : back2%=7
  27.   END IF
  28.  
  29. ' Main Window is Full Screen, Key Display is Off
  30.   KEY OFF
  31.   COLOR fore1%,back1%,back1% : CLS
  32.   LOCATE 1,2 : PRINT CHR$(201);
  33.   LOCATE 25,2 : PRINT CHR$(200);
  34.   LOCATE 1,79 : PRINT CHR$(187);
  35.   LOCATE 25,79 : PRINT CHR$(188);
  36.   FOR I=3 TO 78 : LOCATE 1,I : PRINT CHR$(205); : NEXT I
  37.   FOR I=3 TO 78 : LOCATE 25,I : PRINT CHR$(205); : NEXT I
  38.   FOR I=2 TO 24 : LOCATE I,2 : PRINT CHR$(186); : NEXT I
  39.   FOR I=2 TO 24 : LOCATE I,79 : PRINT CHR$(186); : NEXT I
  40.   LOCATE 1,`POSN1`
  41.   PRINT " TableCurve Function: `FILE` `DATE` `TIME` ";
  42.  
  43. ' X-Y Data Window 
  44.   COLOR fore2%,back2%,back2%
  45.   FOR I=5 TO 23 : LOCATE I,33 : PRINT SPACE$(45); : NEXT I
  46.   LOCATE 5,33 : PRINT CHR$(218);
  47.   LOCATE 24,33 : PRINT CHR$(192);
  48.   LOCATE 5,77 : PRINT CHR$(191);
  49.   LOCATE 24,77 : PRINT CHR$(217);
  50.   FOR I=34 TO 76 : LOCATE 5,I : PRINT CHR$(196); : NEXT I
  51.   FOR I=34 TO 76 : LOCATE 24,I : PRINT CHR$(196); : NEXT I
  52.   FOR I=6 TO 23 : LOCATE I,33 : PRINT CHR$(179); : NEXT I
  53.   FOR I=6 TO 23 : LOCATE I,77 : PRINT CHR$(179); : NEXT I
  54.   LOCATE 5,`POSN2` : PRINT " `TITLE` ";
  55.   LOCATE 6,35 : PRINT "`XTITLE`";
  56.   LOCATE 6,57 : PRINT "`YTITLE`";
  57.  
  58. ' Equation Data and Input Setup
  59.   COLOR fore1%,back1%,back1%
  60.   LOCATE 3,4 : PRINT "`EQSTR`";
  61.   LOCATE 4,6 : PRINT "Eqn# `EQNO`";
  62.   LOCATE 5,6 : PRINT "r2=`R2VAL`";
  63.   LOCATE 6,6 : PRINT "a= `ASTR`";
  64.   LOCATE 7,6 : PRINT "b= `BSTR`";
  65.   LOCATE 8,6 : PRINT "c= `CSTR`";
  66.   LOCATE 9,6 : PRINT "d= `DSTR`";
  67.   LOCATE 10,6 : PRINT "e= `ESTR`";
  68.   LOCATE 11,6 : PRINT "f= `FSTR`";
  69.   LOCATE 12,6 : PRINT "g= `GSTR`";
  70.   LOCATE 13,6 : PRINT "h= `HSTR`";
  71.   LOCATE 14,6 : PRINT "i= `ISTR`";
  72.   LOCATE 15,6 : PRINT "j= `JSTR`";
  73.   LOCATE 16,6 : PRINT "k= `KSTR`";
  74.   LOCATE 18,4 : PRINT "X= `XTITLE`";
  75.   LOCATE 19,4 : PRINT "Y= `YTITLE`";
  76.   LOCATE 21,4 : PRINT "Enter Value [x=,y=]";
  77.   LOCATE 24,4 : PRINT "Press ESC to End Program";
  78.  
  79. ' Data Input Loop, Exits only by ESCAPE
  80.   irow=7
  81.   iflag=1
  82.   idir=0
  83.   iatmax=0
  84.   ON ERROR GOTO MathError
  85.   WHILE iflag
  86.     LoopStart:
  87.     j=irow-6
  88.     COLOR fore2%,back2%,back2%
  89.     IF idir=1 THEN idir=0 ELSE idir=1
  90.     xold=x(j)
  91.     x(j)=FNnumfld#(22,4,25)
  92.     IF istatus=0 THEN 
  93.       COLOR fore0%,back0%,back0%
  94.       CLS
  95.       SYSTEM
  96.     ELSEIF istatus>0 THEN 
  97.       y(j)=FN`FNAME`#(x(j))
  98.     ELSE 
  99.       y(j)=x(j)
  100.       x(j)=FNrtbis#(y(j),idir)
  101.     END IF
  102.     IF irow=23 THEN LOCATE 23,34 : PRINT SPACE$(42);
  103.     LOCATE irow,35
  104.     fmt$="########.########"
  105.     IF ABS(x(j))>1.0E+07 OR ABS(x(j))<1.0E-04 THEN fmt$="   +#.#######^^^^"
  106.     PRINT USING fmt$;x(j);
  107.     LOCATE irow,57
  108.     fmt$="########.########"
  109.     IF ABS(y(j))>1.0E+07 OR ABS(y(j))<1.0E-04 THEN fmt$="   +#.#######^^^^"
  110.     PRINT USING fmt$;y(j);
  111.     irow=irow+1
  112.     IF irow>23 THEN irow=23 : iatmax=1
  113.     COLOR fore1%,back1%,back1%
  114.   WEND
  115.   MathError:
  116.     RESUME LoopStart
  117. END
  118.  
  119. '---------------------------------------------------------------
  120. DEF FNgetattr%
  121. '---------------------------------------------------------------
  122. 'gets current screen attribute
  123.   REG 1, 8*256
  124.   REG 2, 0
  125.   CALL INTERRUPT &H10
  126.   FNgetattr%= REG(1) \ 256
  127. END DEF
  128.  
  129. '---------------------------------------------------------------
  130. DEF FNgetcolor%
  131. '---------------------------------------------------------------
  132. 'returns 1 for color display, 0 for monochrome
  133.   LOCAL ral%
  134.   REG 1, 15*256
  135.   CALL INTERRUPT &H10
  136.   ral%=REG(1) MOD 256
  137.   FNgetcolor%=1
  138.   IF ((ral%=0) or (ral%=2) or (ral%=7)) THEN FNgetcolor%=0
  139. END DEF
  140.  
  141. '---------------------------------------------------------------
  142. DEF FNnumfld# (rowfld%,colfld%,maxlen%)
  143. '---------------------------------------------------------------
  144. 'returns double precision numeric input
  145. 'status contains number of characters input, 0 on ESC
  146.   LOCAL c%,ichar%,nfld$,notdone%
  147.   SHARED istatus%
  148.   LOCATE rowfld%,colfld%,1: PRINT SPACE$(maxlen%);
  149.   LOCATE rowfld%,colfld%,1
  150.   ichar%=0 : iyflag%=0 : iexp=0
  151.   notdone%=1
  152.   WHILE notdone% AND ichar%<maxlen%
  153.     c%=ASC(INPUT$(1))
  154.     ipass%=0
  155.     IF ichar%=0 AND (c%=89 OR c%=121) THEN 
  156.       iyflag%=1
  157.       ipass=1
  158.     ELSEIF (ichar%=0 AND (c%=88 OR c%=120)) OR (ichar%=1 AND c%=61) THEN 
  159.       ipass%=1
  160.     END IF
  161.     IF (c%>=48 AND c%<=57) OR c%=45 OR c%=43 OR c%=46 OR_
  162.      ((c%=69 OR c%=101) AND iexp%=0) OR ipass%=1 THEN
  163.       IF ipass%=0 THEN nfld$=nfld$+CHR$(c%)
  164.       IF c%=69 OR c%=101 THEN iexp%=1
  165.       LOCATE rowfld%,colfld%+ichar%,1: PRINT CHR$(c%);
  166.       LOCATE rowfld%,colfld%+ichar%+1,1
  167.       ichar%=ichar%+1
  168.     ELSEIF (c%=10 OR c%=13 OR ichar%=maxlen%) AND ichar%>0 THEN
  169.       notdone%=0
  170.     ELSEIF c%=8 AND ichar%>0 THEN
  171.       ichar%=ichar%-1
  172.       IF ichar%=0 THEN iyflag%=0
  173.       LOCATE rowfld%,colfld%+ichar%,1: PRINT CHR$(32);
  174.       IF len(nfld$)>0 THEN nfld$=LEFT$(nfld$,LEN(nfld$)-1)
  175.       LOCATE rowfld%,colfld%+ichar%,1:
  176.     ELSEIF c%=27 THEN
  177.       ichar%=0
  178.       notdone%=0
  179.     END IF
  180.   WEND
  181.   IF iyflag%=0 THEN istatus%=ichar% ELSE istatus%=-ichar% 
  182.   FNnumfld#=0
  183.   IF istatus%<>0 THEN FNnumfld#=VAL(nfld$)
  184. endfn:   
  185. END DEF
  186.  
  187. '---------------------------------------------------------------
  188. DEF FNrtbis# (y#,dir%)
  189. '---------------------------------------------------------------
  190. 'root bisection routine
  191. 'dir%=0 starts at lowest partition, =1 at highest
  192. 'last chance is partition from XatYmin to XatYmax
  193. 'returns 0 upon failure to find root
  194.   LOCAL x1#,x2#,xinc#,dx#,f#,fmid#,xmid#,rtb#,xacc#
  195.   LOCAL i%,j% 
  196.   xacc#=1E-6*`XMEAN`
  197.   xinc#=`XRANGE`/4.0
  198.   FOR i%=0 TO 4
  199.     IF i%=4 THEN 
  200.       x1#=`XATYMIN`
  201.       x2#=`XATYMAX`
  202.     ELSEIF dir%=1 THEN 
  203.       x2#=`XMAXIMUM`-xinc#*i%
  204.       x1#=`XMAXIMUM`-xinc#*(i%+1)
  205.     ELSE 
  206.       x1#=`XMINIMUM`+xinc#*i%
  207.       x2#=`XMINIMUM`+xinc#*(i%+1)
  208.     END IF
  209.     f#=y#-FN`FNAME`(x1#)
  210.     fmid#=y#-FN`FNAME`(x2#)
  211.     IF f#*fmid#<0 THEN
  212.       IF f#<0.0 THEN 
  213.         dx#=x2#-x1#
  214.         rtb#=x1#
  215.       ELSE 
  216.         dx#=x1#-x2#
  217.         rtb#=x2#
  218.       END IF
  219.       FOR j%=1 TO 100
  220.         dx#=dx#*0.5
  221.         xmid#=rtb#+dx#
  222.         fmid#=y#-FN`FNAME`(xmid#)
  223.         IF fmid#<=0 THEN rtb#=xmid#
  224.         IF ABS(dx#)<xacc# OR fmid#=0 THEN FNrtbis#=rtb# : GOTO done
  225.       NEXT j%
  226.     END IF
  227.   NEXT i%
  228.   FNrtbis#=0.0
  229.   done:
  230. END DEF  
  231.     
  232. !!TBASIC!!
  233. '---------------------------------------------------------------`ERF`
  234. DEF FNERF#(X#)`ERF`
  235. '---------------------------------------------------------------`ERF`
  236.   LOCAL t,z,ans`ERF`
  237.   z=ABS(X#)`ERF`
  238.   t=1.0/(1.0+0.5*z)`ERF`
  239.   ans=(t*EXP(-z*z-1.26551223+t*(1.00002368+t*(0.37409196+_`ERF`
  240.   t*(0.09678418+t*(-0.18628806+t*(0.27886807+t*(-1.13520398+_`ERF`
  241.   t*(1.48851587+t*(-0.82215223+t*0.17087277))))))))))`ERF`
  242.   IF x>=0.0 THEN FNERF#=1.0-ans ELSE FNERF#=-1.0+ans`ERF`
  243. END DEF`ERF`
  244.  
  245. '---------------------------------------------------------------
  246. DEF FN`FNAME`#(X#)
  247. '---------------------------------------------------------------
  248. ' TableCurve  Function:`FILE` `DATE` `TIME`
  249. ' `TITLE`
  250. ' X= `XTITLE`
  251. ' Y= `YTITLE`
  252. ' Eqn# `EQNO`  `EQSTR`
  253. ' r2=`R2VAL`
  254. ' r2adj=`R2ADJ`
  255. ' StdErr=`STDERR`
  256. ' Fval=`FVAL`
  257. ' a= `ASTR`
  258. ' b= `BSTR`
  259. ' c= `CSTR`
  260. ' d= `DSTR`
  261. ' e= `ESTR`
  262. ' f= `FSTR`
  263. ' g= `GSTR`
  264. ' h= `HSTR`
  265. ' i= `ISTR`
  266. ' j= `JSTR`
  267. ' k= `KSTR`
  268. '---------------------------------------------------------------
  269.   LOCAL Y#
  270.   LOCAL N#`FDECLN`
  271.   LOCAL `FLIST`
  272.   X#=`FX`
  273.   N#=`FBAL2`
  274.   N#=`FAUX`
  275.   X1#=`F1`
  276.   X2#=`F2`
  277.   X3#=`F3`
  278.   X4#=`F4`
  279.   Y#=`EQNCODE`
  280.   FN`FNAME`#=`FY`
  281. END DEF
  282. !!TBASIC!!
  283. ~~TBASIC~~
  284.