home *** CD-ROM | disk | FTP | other *** search
/ WinWares 1 / WINWARES.ISO / calc / tablecrv / qbasic.tcl < prev    next >
Encoding:
Text File  |  1993-06-01  |  10.6 KB  |  353 lines
  1. ~~QBASIC~~
  2. '--------------------------------------------------------------
  3. '          TableCurve QuickBASIC Library Module
  4. '--------------------------------------------------------------
  5. ' This code is specific to Microsoft QuickBASIC, and possibly
  6. ' version 4.0, which was used to construct this code. This
  7. ' version of QuickBASIC required separate libraries for the DOS
  8. ' Interrupt routines. It is therefore necessary to load QB with
  9. ' this quick library (qb.qlb) as follows:   qb progname /L qb 
  10. ' If using the command line, the qb.lib library must be linked 
  11. ' in as with the following batch file commands:  
  12. '                        bc %1.bas /e/x/o;
  13. '                        link /ex /noe %1,%1.exe,nul,qb.lib;
  14. ' ( The /e option is required because of error trapping. )
  15. ' The interrupt routines are used to set the screen attributes
  16. ' back to where they were before the program began and to
  17. ' determine whether color or monochrome attributes should be
  18. ' used. The code using these interrupts can be safely removed
  19. ' if these features are not wanted. QuickBASIC will also
  20. ' compile successfully without modification the code generated
  21. ' for BASICA/GWBASIC.
  22. '--------------------------------------------------------------
  23. ' The polynomial and rational equations use a polynomial 
  24. ' calculation function rather than coding the equation on a 
  25. ' single line. Such single line expressions are too complex for
  26. ' QuickBASIC to evaluate.
  27. '--------------------------------------------------------------
  28.  
  29.   DEFDBL x,y
  30.   DEFINT i,j
  31.   DIM x(17),y(17)
  32.  
  33. '---- The following definitions are also in QB.BI -------------
  34.   TYPE RegType
  35.      ax    AS INTEGER
  36.      bx    AS INTEGER
  37.      cx    AS INTEGER
  38.      dx    AS INTEGER
  39.      bp    AS INTEGER
  40.      si    AS INTEGER
  41.      di    AS INTEGER
  42.      flags AS INTEGER
  43.   END TYPE
  44.   DECLARE SUB INTERRUPT (intnum AS INTEGER, inreg AS RegType, outreg AS RegType)
  45.   DIM inreg AS RegType
  46.   DIM outreg AS RegType
  47. '--------------------------------------------------------------
  48.   DIM COEF#(11)`FPNRT`
  49.   DECLARE FUNCTION `FNAME`# (X#)
  50.   DECLARE FUNCTION numfld# (rowfld%, colfld%, maxlen%, istatus%)
  51.   DECLARE FUNCTION evalpn# (order%, X#, cf#())
  52.   DECLARE FUNCTION rtbis# (y#, dir%)
  53.  
  54. ' Get screen attribute for reset at end of program
  55.   inreg.ax = 8 * 256
  56.   inreg.bx = 0
  57.   CALL INTERRUPT(&H10, inreg, outreg)
  58.   attr0% = outreg.ax \ 256
  59.   fore0% = attr0% MOD 16
  60.   back0% = attr0% \ 16
  61.  
  62. ' Get present video mode for determining attributes
  63.   inreg.ax = 15 * 256
  64.   CALL INTERRUPT(&H10, inreg, outreg)
  65.   ral% = outreg.ax MOD 256
  66.   iscolor% = 1
  67.   IF ((ral% = 0) OR (ral% = 2) OR (ral% = 7)) THEN iscolor% = 0
  68.   IF iscolor% THEN
  69.     fore1%=1 : back1%=7 : fore2%=15 : back2%=1
  70.   ELSE
  71.     fore1%=15 : back1%=0 : fore2%=0 : back2%=7
  72.   END IF
  73.  
  74. ' Main Window is Full Screen, Key Display is Off
  75.   COLOR fore1%, back1%, back1%: CLS
  76.   KEY OFF
  77.   LOCATE 1,2 : PRINT CHR$(201);
  78.   LOCATE 25,2 : PRINT CHR$(200);
  79.   LOCATE 1,79 : PRINT CHR$(187);
  80.   LOCATE 25,79 : PRINT CHR$(188);
  81.   FOR I=3 TO 78 : LOCATE 1,I : PRINT CHR$(205); : NEXT I
  82.   FOR I=3 TO 78 : LOCATE 25,I : PRINT CHR$(205); : NEXT I
  83.   FOR I=2 TO 24 : LOCATE I,2 : PRINT CHR$(186); : NEXT I
  84.   FOR I=2 TO 24 : LOCATE I,79 : PRINT CHR$(186); : NEXT I
  85.   LOCATE 1,`POSN1`
  86.   PRINT " TableCode `LANG` Function:`FILE` `DATE` `TIME` ";
  87.  
  88. ' X-Y Data Window
  89.   COLOR fore2%, back2%, back2%
  90.   FOR I=5 TO 23 : LOCATE I,33 : PRINT SPACE$(45); : NEXT I
  91.   LOCATE 5,33 : PRINT CHR$(218);
  92.   LOCATE 24,33 : PRINT CHR$(192);
  93.   LOCATE 5,77 : PRINT CHR$(191);
  94.   LOCATE 24,77 : PRINT CHR$(217);
  95.   FOR I=34 TO 76 : LOCATE 5,I : PRINT CHR$(196); : NEXT I
  96.   FOR I=34 TO 76 : LOCATE 24,I : PRINT CHR$(196); : NEXT I
  97.   FOR I=6 TO 23 : LOCATE I,33 : PRINT CHR$(179); : NEXT I
  98.   FOR I=6 TO 23 : LOCATE I,77 : PRINT CHR$(179); : NEXT I
  99.   LOCATE 5,`POSN2` : PRINT " `TITLE` ";
  100.   LOCATE 6,35 : PRINT "`XTITLE`";
  101.   LOCATE 6,57 : PRINT "`YTITLE`";
  102.  
  103. ' Equation Data and Input Setup
  104.   COLOR fore1%, back1%, back1%
  105.   LOCATE 3,4 : PRINT "`EQSTR`";
  106.   LOCATE 4,6 : PRINT "Eqn# `EQNO`";
  107.   LOCATE 5,6 : PRINT "r2=`R2VAL`";
  108.   LOCATE 6,6 : PRINT "a= `ASTR`";
  109.   LOCATE 7,6 : PRINT "b= `BSTR`";
  110.   LOCATE 8,6 : PRINT "c= `CSTR`";
  111.   LOCATE 9,6 : PRINT "d= `DSTR`";
  112.   LOCATE 10,6 : PRINT "e= `ESTR`";
  113.   LOCATE 11,6 : PRINT "f= `FSTR`";
  114.   LOCATE 12,6 : PRINT "g= `GSTR`";
  115.   LOCATE 13,6 : PRINT "h= `HSTR`";
  116.   LOCATE 14,6 : PRINT "i= `ISTR`";
  117.   LOCATE 15,6 : PRINT "j= `JSTR`";
  118.   LOCATE 16,6 : PRINT "k= `KSTR`";
  119.   LOCATE 18,4 : PRINT "X= `XTITLE`";
  120.   LOCATE 19,4 : PRINT "Y= `YTITLE`";
  121.   LOCATE 21,4 : PRINT "Enter Value [x=,y=]";
  122.   LOCATE 24,4 : PRINT "Press ESC to End Program";
  123.  
  124. ' Data Input Loop, Exits only by ESCAPE
  125.   irow=7
  126.   iflag=1
  127.   idir=0
  128.   iatend=0
  129.   ON ERROR GOTO MathError
  130.   WHILE iflag
  131.     LoopStart:
  132.     j=irow-6
  133.     COLOR fore2%,back2%,back2%
  134.     IF idir=1 THEN idir=0 ELSE idir=1
  135.     istatus=0
  136.     xold=x(j)
  137.     x(j)=numfld#(22,4,25,istatus)
  138.     IF istatus = 0 THEN
  139.       COLOR fore0%, back0%, back0%
  140.       CLS
  141.       SYSTEM
  142.     ELSEIF istatus>0 THEN
  143.       y(j)=`FNAME`#((x(j)))
  144.     ELSE
  145.       y(j)=x(j)
  146.       x(j)=rtbis#(y(j),idir)
  147.     END IF
  148.     IF irow=23 THEN LOCATE 23,34 : PRINT SPACE$(42);
  149.     LOCATE irow,35
  150.     fmt$="########.########"
  151.     IF ABS(x(j)) > 1E+07 OR ABS(x(j)) < .0001 THEN fmt$ = "  +#.#######^^^^^"
  152.     PRINT USING fmt$;x(j);
  153.     LOCATE irow,57
  154.     fmt$="########.########"
  155.     IF ABS(y(j)) > 1E+07 OR ABS(y(j)) < .0001 THEN fmt$ = "  +#.#######^^^^^"
  156.     PRINT USING fmt$;y(j);
  157.     irow=irow+1
  158.     IF irow>23 THEN irow=23 : iatend=1
  159.     COLOR fore1%,back1%,back1%
  160.   WEND
  161.   MathError:
  162.     RESUME LoopStart
  163. END
  164.  
  165. '---------------------------------------------------------------
  166. FUNCTION numfld# (rowfld%, colfld%, maxlen%, istatus%)
  167. '---------------------------------------------------------------
  168. 'returns double precision numeric input
  169. 'status contains number of characters input, 0 on ESC
  170.   LOCATE rowfld%, colfld%, 1: PRINT SPACE$(maxlen%);
  171.   LOCATE rowfld%, colfld%, 1
  172.   ichar%=0 : iyflag%=0 : iexp=0
  173.   notdone% = 1
  174.   WHILE notdone% AND ichar% < maxlen%
  175.     c% = ASC(INPUT$(1))
  176.     ipass%=0
  177.     IF ichar%=0 AND (c%=89 OR c%=121) THEN 
  178.       iyflag%=1
  179.       ipass=1
  180.     ELSEIF (ichar%=0 AND (c%=88 OR c%=120)) OR (ichar%=1 AND c%=61) THEN 
  181.       ipass%=1
  182.     END IF
  183.     IF (c%>=48 AND c%<=57) OR c%=45 OR c%=43 OR c%=46 OR ((c%=69 OR c%=101) AND iexp%=0) OR ipass%=1 THEN
  184.       IF ipass%=0 THEN nfld$=nfld$+CHR$(c%)
  185.       IF c%=69 OR c%=101 THEN iexp%=1
  186.       LOCATE rowfld%,colfld%+ichar%,1: PRINT CHR$(c%);
  187.       LOCATE rowfld%,colfld%+ichar%+1,1
  188.       ichar%=ichar%+1
  189.     ELSEIF (c%=10 OR c%=13 OR ichar%=maxlen%) AND ichar%>0 THEN
  190.       notdone%=0
  191.     ELSEIF c%=8 AND ichar%>0 THEN
  192.       ichar%=ichar%-1
  193.       IF ichar%=0 THEN iyflag%=0
  194.       LOCATE rowfld%,colfld%+ichar%,1: PRINT CHR$(32);
  195.       IF len(nfld$)>0 THEN nfld$=LEFT$(nfld$,LEN(nfld$)-1)
  196.       LOCATE rowfld%,colfld%+ichar%,1:
  197.     ELSEIF c%=27 THEN
  198.       ichar%=0
  199.       notdone%=0
  200.     END IF
  201.   WEND
  202.   IF iyflag%=0 THEN istatus%=ichar% ELSE istatus%=-ichar% 
  203.   numfld#=0
  204.   IF istatus%<>0 THEN numfld#=VAL(nfld$)
  205. endfn:   
  206. END FUNCTION
  207.  
  208. '---------------------------------------------------------------
  209. FUNCTION rtbis# (y#,dir%)
  210. '---------------------------------------------------------------
  211. 'root bisection routine
  212. 'dir%=0 starts at lowest partition, =1 at highest
  213. 'last chance is partition from XatYmin to XatYmax
  214. 'returns 0 upon failure to find root
  215.   xacc#=1E-6*`XMEAN`
  216.   xinc#=`XRANGE`/4.0
  217.   FOR i%=0 TO 4
  218.     IF i%=4 THEN 
  219.       x1#=`XATYMIN`
  220.       x2#=`XATYMAX`
  221.     ELSEIF dir%=1 THEN 
  222.       x2#=`XMAXIMUM`-xinc#*i%
  223.       x1#=`XMAXIMUM`-xinc#*(i%+1)
  224.     ELSE 
  225.       x1#=`XMINIMUM`+xinc#*i%
  226.       x2#=`XMINIMUM`+xinc#*(i%+1)
  227.     END IF
  228.     f#=y#-`FNAME`((x1#))
  229.     fmid#=y#-`FNAME`((x2#))
  230.     IF f#*fmid#<0 THEN
  231.       IF f#<0.0 THEN 
  232.         dx#=x2#-x1#
  233.         rtb#=x1#
  234.       ELSE 
  235.         dx#=x1#-x2#
  236.         rtb#=x2#
  237.       END IF
  238.       FOR j%=1 TO 100
  239.         dx#=dx#*0.5
  240.         xmid#=rtb#+dx#
  241.         fmid#=y#-`FNAME`((xmid#))
  242.         IF fmid#<=0 THEN rtb#=xmid#
  243.         IF ABS(dx#)<xacc# OR fmid#=0 THEN rtbis#=rtb# : GOTO done
  244.       NEXT j%
  245.     END IF
  246.   NEXT i%
  247.   rtbis#=0.0
  248.   done:
  249. END FUNCTION  
  250.  
  251. !!QBASIC!!
  252. '---------------------------------------------------------------
  253. FUNCTION `FNAME`# (X#)
  254. '---------------------------------------------------------------
  255. ' TableCurve Function:`FILE` `DATE` `TIME`
  256. ' `TITLE`
  257. ' X= `XTITLE`
  258. ' Y= `YTITLE`
  259. ' Eqn# `EQNO`  `EQSTR`
  260. ' r2=`R2VAL`
  261. ' r2adj=`R2ADJ`
  262. ' StdErr=`STDERR`
  263. ' Fval=`FVAL`
  264. ' a= `ASTR`
  265. ' b= `BSTR`
  266. ' c= `CSTR`
  267. ' d= `DSTR`
  268. ' e= `ESTR`
  269. ' f= `FSTR`
  270. ' g= `GSTR`
  271. ' h= `HSTR`
  272. ' i= `ISTR`
  273. ' j= `JSTR`
  274. ' k= `KSTR`
  275. '---------------------------------------------------------------------
  276.   DIM cf#(11)`FPNRT`
  277.   X#=`FX`
  278.   N#=`FBAL2`
  279.   N#=`FAUX`
  280.   cf#(1)=`PBb`
  281.   cf#(2)=`PBd`
  282.   cf#(3)=`PBf`
  283.   cf#(4)=`PBh`
  284.   cf#(5)=`PBj`
  285.   y1#=X#*evalpn(`ORDPB1`,X#,cf#())`LISTPB`
  286.   cf#(1)=`PBa`
  287.   cf#(2)=`PBc`
  288.   cf#(3)=`PBe`
  289.   cf#(4)=`PBg`
  290.   cf#(5)=`PBi`
  291.   cf#(6)=`PBk`
  292.   y2#=evalpn(`ORDPB2`,N#,cf#())`LISTPB`
  293.   Y#=y1#+y2#`LISTPB`
  294.   cf#(1)=`RTa`
  295.   cf#(2)=`RTc`
  296.   cf#(3)=`RTe`
  297.   cf#(4)=`RTg`
  298.   cf#(5)=`RTi`
  299.   cf#(6)=`RTk`
  300.   ynum#=evalpn(`ORDRTN`,X#,cf#())`LISTRT`
  301.   cf#(1)=`RTb`
  302.   cf#(2)=`RTd`
  303.   cf#(3)=`RTf`
  304.   cf#(4)=`RTh`
  305.   cf#(5)=`RTj`
  306.   ydenom#=evalpn(`ORDRTD`,X#,cf#())`LISTRT`
  307.   Y#=ynum#/(1.0+X#*ydenom#)`LISTRT` 
  308.   cf#(1)= `PNa`
  309.   cf#(2)= `PNb`
  310.   cf#(3)= `PNc`
  311.   cf#(4)= `PNd`
  312.   cf#(5)= `PNe`
  313.   cf#(6)= `PNf`
  314.   cf#(7)= `PNg`
  315.   cf#(8)= `PNh`
  316.   cf#(9)= `PNi`
  317.   cf#(10)=`PNj`
  318.   cf#(11)=`PNk`
  319.   Y#=evalpn(`ORDPN`,X#,cf#())`LISTPN`
  320.   X1#=`F1`
  321.   X2#=`F2`
  322.   X3#=`F3`
  323.   X4#=`F4`
  324.   Y#=`EQNCODE`
  325.   `FNAME`#=`FY`
  326. END FUNCTION
  327.  
  328. '---------------------------------------------------------------`FPNRT`
  329. FUNCTION evalpn# (order%, x#, cf#())`FPNRT`
  330. '---------------------------------------------------------------`FPNRT`
  331. 'Polynomial Calculation Function`FPNRT`
  332. 'Passed Array `SCOPE` must be dimensioned to 11`FPNRT`
  333.   ypn#=cf#(order%+1)`FPNRT`
  334.   FOR iter%=order% TO 1 STEP -1`FPNRT`
  335.   ypn#= ypn#*x#+cf#(iter%)`FPNRT`
  336.   NEXT iter%`FPNRT`
  337.   evalpn#=ypn#`FPNRT`
  338. END FUNCTION`FPNRT`
  339.  
  340. '---------------------------------------------------------------`ERF`
  341. FUNCTION ERF#(x#)`ERF`
  342. '---------------------------------------------------------------`ERF`
  343.   z=ABS(x)`ERF`
  344.   t=1.0/(1.0+0.5*z)`ERF`
  345.   ans=t*(-1.13520398#+t*(1.48851587#+t*(-.82215223#+t*.17087277#)))`ERF`
  346.   ans=t*(.09678418#+t*(-.18628806#+t*(.27886807#+ans)))`ERF`
  347.   ans=(t*EXP(-z*z-1.26551223#+t*(1.00002368#+t*(.37409196#+ans))))`ERF`
  348.   IF x >= 0! THEN ERF#=1.0-ans ELSE ERF#=-1.0+ans`ERF`
  349. END FUNCTION`ERF`
  350.  
  351. !!QBASIC!!
  352. ~~QBASIC~~
  353.