home *** CD-ROM | disk | FTP | other *** search
/ WinWares 1 / WINWARES.ISO / calc / tablecrv / pascal.tcl < prev    next >
Encoding:
Text File  |  1993-06-01  |  16.2 KB  |  586 lines
  1. ~~PASCAL~~
  2. {---------------------------------------------------------------}
  3. {            TableCurve Pascal Library Module                   }
  4. {---------------------------------------------------------------}
  5. {  Although the full calling routine for the TableCode          }
  6. {  functions is specific to the Borland Turbo-Pascal compiler,  }
  7. {  the code has been written for portability using standard     }
  8. {  BIOS/DOS system calls. Only the system interrupt function    }
  9. {  intr(), the system registers Regs in the DOS unit, and the   }
  10. {  compiler directives are likely to be compiler-dependent.     }
  11. {---------------------------------------------------------------}
  12. {  The generated code uses the full 10 byte precision of the    }
  13. {  extended real type if a math co-processor is installed or if }
  14. {  using version 5.0+. Version 4.0 without a math co-processor  }
  15. {  uses the default 6 byte real.                                }
  16. {---------------------------------------------------------------}
  17. {  NOTE: With the N+ directive, you are limited to Turbo        }
  18. {  Pascal's 8-level 8087 stack. Most higher order rational      }
  19. {  and polynomial equations, if coded onto a single line, will  }
  20. {  overflow this stack. For this reason, the function evalpn()  }
  21. {  is used to evaluate all polynomial expressions.              }
  22. {---------------------------------------------------------------}
  23.  
  24. program _`FILENOEX`;
  25.  
  26. {$IFDEF VER40}
  27.   {$IFDEF CPU87}
  28.     {$N+}         { v4.0, 80x87 10 byte extended real }
  29.   {$ELSE}
  30.     {$N-}         { v4.0, default 6 byte real }
  31.   {$ENDIF}
  32. {$ELSE}
  33.   {$IFDEF CPU87}
  34.     {$N+,E-}     { v5.0+, 10 byte extended real, 80x87 in-line }
  35.   {$ELSE}
  36.     {$N+,E+}     { v5.0+, 10 byte extended real, emulation on }
  37.   {$ENDIF}
  38. {$ENDIF}
  39.  
  40. {$M 8192,0,65536}     { Set stack=8K, Heap=64K }
  41.  
  42. uses Dos;
  43.  
  44. type
  45. {$IFOPT N+}
  46.   real  = extended;        { use 10 byte floating point w/80x87 }
  47. {$ENDIF}
  48.   coef= array[0..10] of real;
  49.   xyvar= array[0..16] of real;
  50.  
  51. var
  52.   x,y                           : xyvar;
  53.   i,j,irow,gooddata,dir,atmax   : integer;
  54.   attr0,attr1,attr2             : integer;
  55.   iscolor                       : integer;
  56.   strtmp                        : string[80];
  57.  
  58. !!PASCAL!!
  59. type`SCOPE`
  60.   coef= array[0..10] of real;`SCOPE`
  61.  
  62. {---------------------------------------------------------------}`FPNRT`
  63. function evalpn (order: integer; var x: real; var c: coef) : real;`FPNRT`
  64. {---------------------------------------------------------------}`FPNRT`
  65. var  i: integer;`FPNRT`
  66.      y : real;`FPNRT`
  67. begin`FPNRT`
  68.   y := c[order];`FPNRT`
  69.   for i := order-1 downto 0 do`FPNRT`
  70.     y := y*x+c[i];`FPNRT`
  71.   evalpn :=y;`FPNRT`
  72. end;`FPNRT`
  73.  
  74. {---------------------------------------------------------------}`ERF`
  75. function Erf ( x: real) : real;`ERF`
  76. {---------------------------------------------------------------}`ERF`
  77. var  t,z,ans : real;`ERF`
  78. begin`ERF`
  79.   z:=Abs(x);`ERF`
  80.   t:=1.0/(1.0+0.5*z);`ERF`
  81.   ans:=(t*exp(-z*z-1.26551223+t*(1.00002368+t*(0.37409196+t*(0.09678418+`ERF`
  82.     t*(-0.18628806+t*(0.27886807+t*(-1.13520398+t*(1.48851587+`ERF`
  83.     t*(-0.82215223+t*0.17087277))))))))));`ERF`
  84.   Erf := 1.0-ans;`ERF`
  85.   if x<0 then`ERF`
  86.     Erf := -1.0+ans;`ERF`
  87. end;`ERF`
  88.  
  89. {---------------------------------------------------------------}`POW`
  90. function Pow ( x,n : real) : real;`POW`
  91. {---------------------------------------------------------------}`POW`
  92. begin`POW`
  93.   Pow := Exp(n*Ln(x));`POW`
  94. end;`POW`
  95.  
  96. {---------------------------------------------------------------}
  97. function `FNAME` (x: real) :real;
  98. {---------------------------------------------------------------}
  99. { TableCurve Function:`FILE` `DATE` `TIME` }
  100. { `TITLE` }
  101. { X= `XTITLE` }
  102. { Y= `YTITLE` }
  103. { Eqn# `EQNO`  `EQSTR` }
  104. { r2=`R2VAL` }
  105. {  r2adj=`R2ADJ` }
  106. {  StdErr=`STDERR` }
  107. {  Fstat=`FVAL` }
  108. { a= `ASTR` }
  109. { b= `BSTR` }
  110. { c= `CSTR` }
  111. { d= `DSTR` }
  112. { e= `ESTR` }
  113. { f= `FSTR` }
  114. { g= `GSTR` }
  115. { h= `HSTR` }
  116. { i= `ISTR` }
  117. { j= `JSTR` }
  118. { k= `KSTR` }
  119. var  `FLIST` : real;
  120. var  y : real;
  121. var  c1,c2 : coef;`LISTRT`
  122. var  c1,c2 : coef;`LISTPB`
  123. var  c : coef;`LISTPN`
  124. var   n : real;`FDECLN`
  125. begin
  126.   x :=`FX`;
  127.   n :=`FBAL2`;
  128.   n :=`FAUX`;
  129.   c1[0] := `PBb`;
  130.   c1[1] := `PBd`;
  131.   c1[2] := `PBf`;
  132.   c1[3] := `PBh`;
  133.   c1[4] := `PBj`;
  134.   c2[0] := `PBa`;
  135.   c2[1] := `PBc`;
  136.   c2[2] := `PBe`;
  137.   c2[3] := `PBg`;
  138.   c2[4] := `PBi`;
  139.   c2[5] := `PBk`;
  140.   y := x*evalpn(`ORDPB1`,x,c1)+evalpn(`ORDPB2`,n,c2);`LISTPB`
  141.   c1[0] := `RTa`;
  142.   c1[1] := `RTc`;
  143.   c1[2] := `RTe`;
  144.   c1[3] := `RTg`;
  145.   c1[4] := `RTi`;
  146.   c1[5] := `RTk`;
  147.   c2[0] := `RTb`;
  148.   c2[1] := `RTd`;
  149.   c2[2] := `RTf`;
  150.   c2[3] := `RTh`;
  151.   c2[4] := `RTj`;
  152.   y := evalpn(`ORDRTN`,x,c1)/(1.0+x*evalpn(`ORDRTD`,x,c2));`LISTRT`
  153.   c[0] := `PNa`;
  154.   c[1] := `PNb`;
  155.   c[2] := `PNc`;
  156.   c[3] := `PNd`;
  157.   c[4] := `PNe`;
  158.   c[5] := `PNf`;
  159.   c[6] := `PNg`;
  160.   c[7] := `PNh`;
  161.   c[8] := `PNi`;
  162.   c[9] := `PNj`;
  163.   c[10]:= `PNk`;
  164.   y := (evalpn(`ORDPN`,x,c));`LISTPN`
  165.   x1 :=`F1`;
  166.   x2 :=`F2`;
  167.   x3 :=`F3`;
  168.   x4 :=`F4`;
  169.   y :=`EQNCODE`;
  170.   `FNAME` :=`FY`;
  171. end;
  172. !!PASCAL!!
  173.  
  174. {---------------------------------------------------------------}
  175. function rtbis (y: real; dir: integer) :real;
  176. {---------------------------------------------------------------}
  177.  {  root bisection routine }
  178.  {  dir=0 starts at lowest partition, dir=1 starts at highest partition }
  179.  {  last chance is partition from XatYmin to XatYmax }
  180.  {  returns 0 upon failure to find root }
  181. var j                                      : integer;
  182.     x1,x2,xinc,dx,f,fmid,xmid,rtb,xacc,inc : real;    
  183. begin
  184.   rtbis := 0.0;
  185.   xacc := 1E-6*`XMEAN`;       { convergence limit }
  186.   xinc := `XRANGE`/4.0;
  187.   inc := 0.0;
  188.   while inc<5.0 do            { X range divided into 4 partitions }
  189.   begin
  190.     if inc=4.0 then
  191.     begin
  192.       x1 := `XATYMIN`;
  193.       x2 := `XATYMAX`;
  194.     end;
  195.     if(inc<4.0) then
  196.     begin
  197.       if dir>0 then
  198.       begin
  199.         x2 := `XMAXIMUM`-xinc*inc;
  200.         x1 := `XMAXIMUM`-xinc*(inc+1.0);
  201.       end;
  202.       if dir=0 then
  203.       begin
  204.         x1 := `XMINIMUM`+xinc*inc;
  205.         x2 := `XMINIMUM`+xinc*(inc+1.0);
  206.       end;
  207.     end;
  208.     f := y-`FNAME`(x1);
  209.     fmid := y-`FNAME`(x2);
  210.     if f*fmid<0 then
  211.     begin
  212.       if f<0.0 then
  213.       begin
  214.         dx := x2-x1;
  215.         rtb := x1;
  216.       end;  
  217.       if f>=0 then
  218.       begin
  219.         dx := x1-x2;
  220.         rtb := x2;
  221.       end;  
  222.       j := 1;
  223.       while j<101 do
  224.       begin
  225.         dx := dx*0.5;
  226.         xmid := rtb+dx;
  227.         fmid := y-`FNAME`(xmid);
  228.         if fmid<=0 then
  229.           rtb := xmid;
  230.         if (Abs(dx)<xacc) or (fmid=0.0) then
  231.         begin
  232.           rtbis :=rtb;
  233.           j :=101;
  234.           inc :=5.0;
  235.         end;  
  236.         j := j+1;
  237.       end;
  238.     end;
  239.   inc := inc+1;
  240.   end;
  241. end;
  242.  
  243. {---------------------------------------------------------------}
  244. procedure cursor( row, col : integer);
  245. {---------------------------------------------------------------}
  246. var                    { sets cursor at row, col (0,0 = origin) }
  247.   Regs : registers;
  248. begin
  249.   with Regs do
  250.   begin
  251.     AH := 2;
  252.     BH := 0;
  253.     DH := row;
  254.     DL := col;
  255.     Intr($10,regs);
  256.   end;
  257. end;
  258.  
  259. {---------------------------------------------------------------}
  260. function getattr : integer;
  261. {---------------------------------------------------------------}
  262. var                             { gets current screen attribute }
  263.   regs : registers;
  264. begin
  265.   with Regs do
  266.   begin
  267.     AH := 8;
  268.     BH := 0;
  269.     Intr($10,regs);
  270.     getattr := AH;
  271.   end;
  272. end;
  273.  
  274. {---------------------------------------------------------------}
  275. function getcolor : integer;
  276. {---------------------------------------------------------------}
  277. var             { returns 1 for color display, 0 for monochrome }
  278.   regs : registers;
  279. begin
  280.   with Regs do
  281.   begin
  282.     AH := 15;
  283.     Intr($10,regs);
  284.     getcolor := 1;
  285.     if ((AL=0) or (AL=2) or (AL=7)) then getcolor := 0;
  286.   end;
  287. end;
  288.  
  289. {---------------------------------------------------------------}
  290. procedure cls( attr : integer);
  291. {---------------------------------------------------------------}
  292. var               { clears screen with attribute, cursor to 0,0 }
  293.   regs : registers;
  294. begin
  295.   with Regs do
  296.   begin
  297.     AH := 6;
  298.     AL := 0;
  299.     BH := attr;
  300.     CH := 0;
  301.     CL := 0;
  302.     DH := 24;
  303.     DL := 79;
  304.     Intr($10,regs);
  305.     cursor(0,0);
  306.   end;
  307. end;
  308.  
  309. {---------------------------------------------------------------}
  310. procedure clsblk( top, left, btm, right, attr : integer);
  311. {---------------------------------------------------------------}
  312. var                        { clears screen block, cursor inside }
  313.   regs : registers;
  314. begin
  315.   with Regs do
  316.   begin
  317.     AH := 6;
  318.     AL := 0;
  319.     BH := attr;
  320.     CH := top;
  321.     CL := left;
  322.     DH := btm;
  323.     DL := right;
  324.     Intr($10,regs);
  325.     cursor(top+1,left+1);
  326.   end;
  327. end;
  328.  
  329. {---------------------------------------------------------------}
  330. procedure pca( c, attr, row, col : integer);
  331. {---------------------------------------------------------------}
  332. var                      { prints character, atribute to screen }   
  333.   regs : registers;
  334. begin
  335.   cursor(row,col);
  336.   with Regs do
  337.   begin
  338.     AH := 9;
  339.     AL := ORD(c);
  340.     BH := 0;
  341.     BL := attr;
  342.     CX := 1;
  343.     Intr($10,regs);
  344.   end;
  345. end;
  346.  
  347. {---------------------------------------------------------------}
  348. procedure psa( strv : string; attr, row, col : integer);
  349. {---------------------------------------------------------------}
  350. var                    { prints string with attribute to screen }
  351.   i,len : integer;
  352. begin
  353.   for i := 1 to Length(strv) do
  354.   begin
  355.     pca(Ord(strv[i]),attr,row,col);
  356.     col := col +1;
  357.   end;
  358. end;
  359.  
  360. {---------------------------------------------------------------}
  361. function getch : integer;
  362. {---------------------------------------------------------------}
  363. var               { character input, returns 256+code for FnKey }
  364.   regs  : registers;
  365.   fnadd : integer;
  366. begin
  367.   fnadd := 0;
  368.   with Regs do
  369.   begin
  370.     AX := $700;
  371.     Intr($21,regs);
  372.     if AL=0 then
  373.     begin
  374.       AX := $700;
  375.       Intr($21,regs);
  376.       fnadd :=256;
  377.     end;
  378.   getch := AL + fnadd;
  379.   end;
  380. end;
  381.  
  382. {---------------------------------------------------------------}
  383. procedure setwin(
  384.      trow   : integer;   { top row of window        }
  385.      lcol   : integer;   { left column of window    }
  386.      brow   : integer;   { bottom row of window     }
  387.      rcol   : integer;   { right column of window   }
  388.      attr   : integer;   { color attribute          }
  389.      border : integer;   { 1=single 2=double border }
  390.      title  : string);   { window's main title      }
  391. {---------------------------------------------------------------}
  392. var                              { sets simple window on screen }
  393.   tl, tr, bl, br, lr, tb : integer;  { 6 border characters }
  394.   i,xcntr,len    : integer;
  395.  
  396. begin
  397.   clsblk(trow,lcol,brow,rcol,attr);
  398.   tl:=218; tr:=191; bl:=192; br:=217; lr:=196; tb:=179;  { Single Border }
  399.   if border=2 then
  400.   begin                 { Double Border }
  401.     tl:=201; tr:=187; bl:=200; br:=188; lr:=205; tb:=186;
  402.   end;
  403.   pca(tl,attr,trow,lcol);
  404.   pca(bl,attr,brow,lcol);
  405.   pca(tr,attr,trow,rcol);
  406.   pca(br,attr,brow,rcol);
  407.   for i := lcol+1 to rcol-1 do
  408.   begin
  409.     pca(lr,attr,trow,i);
  410.     pca(lr,attr,brow,i);
  411.   end;
  412.   for i := trow+1 to brow-1 do
  413.   begin
  414.     pca(tb,attr,i,lcol);
  415.     pca(tb,attr,i,rcol);
  416.   end;
  417.   xcntr := (rcol+lcol-Length(title)) div 2;
  418.   psa(title,attr,trow,xcntr);
  419. end;
  420.  
  421. {---------------------------------------------------------------}
  422. function numfld(
  423.       var realval : real; { numeric input value }
  424.       row    : integer;   { screen row to begin input }
  425.       col    : integer;   { screen column to begin input }
  426.       maxlen : integer;   { maximum length of input string, (<41) }
  427.       attr   : integer)   { color attribute for entry field }
  428.              : integer;
  429. {---------------------------------------------------------------}
  430. var                         
  431.   fld                       : string[40];
  432.   i,j,c,yflag,expflag,pass  :  integer;
  433.   done                      :  boolean;
  434.  
  435. begin
  436.   for j :=0 to maxlen-1 do
  437.     pca(32,attr,row,col+j);
  438.   for j :=1 to maxlen do
  439.     fld[j] := ' ';
  440.   fld[j] :=Chr(0);
  441.   cursor(row,col);
  442.   i := 0;
  443.   j := 0;
  444.   yflag := 0;
  445.   expflag := 0;
  446.   done := False;
  447.   repeat
  448.     c := getch;
  449.     pass := 0;
  450.     if i=0 then
  451.     begin
  452.       if (c=89) or (c=121) then
  453.       begin
  454.         yflag := 1;
  455.         pass := 1;
  456.       end  
  457.       else if (c=88) or (c=120) then
  458.         pass :=1;
  459.     end;    
  460.     if (i=1) and (c=61) then
  461.       pass := 1;
  462.     if(((c>=48) and (c<=57)) or (c=45) or (c=43) or (c=46) or 
  463.       (((c=69) or (c=101)) and (expflag=0)) or (pass=1)) then
  464.     begin
  465.       pca(c,attr,row,col+i);
  466.       cursor(row,col+i+1);
  467.       i := i+1;
  468.       if pass=0 then
  469.       begin
  470.         fld[j+1] := Chr(c);
  471.         j := j+1;
  472.       end;
  473.       if (c=69) or (c=101) then
  474.         expflag := 1;
  475.     end;
  476.     if(((c=10) or (c=13) or (i=maxlen)) and (i>0)) then done := True;
  477.     if((c=8) and (i>0)) then
  478.     begin
  479.       i := i-1;
  480.       pca(32,attr,row,col+i);
  481.       if i=0 then
  482.         yflag := 0;
  483.       if j<>0 then  
  484.       begin
  485.         j := j-1;
  486.         fld[j+1] := ' ';
  487.       end;
  488.     end;
  489.     if c=27 then
  490.     begin
  491.       i := 0;
  492.       done := True;
  493.     end;
  494.   until done;
  495.   numfld := j;
  496.   fld[0] := Chr(j);
  497.   if yflag=1 then numfld := -j;
  498.   Val(fld,realval,i);         { convert string to real }
  499.   if(i<>0) then realval :=0;  { set to 0 if invalid conversion }
  500. end;
  501.  
  502. {---------------------------------------------------------------}
  503.  
  504. begin
  505.   attr0 := getattr;                          { screen attribute at startup }
  506.   iscolor := getcolor;                       { video mode for color flag }
  507.   if iscolor=1 then
  508.   begin
  509.     attr1 := 1 + 16 * 7;                     { main window attribute }
  510.     attr2 := 15+ 16 * 1;                     { xy data window attribute }
  511.   end
  512.   else
  513.   begin
  514.     attr1 := 15 + 16 * 0;                    { main window attribute }
  515.     attr2 := 0  + 16 * 7;                    { xy data window attribute }
  516.   end;
  517.   cls(attr1);
  518.  
  519.   strtmp :=
  520.     ' TableCurve Function: `FILE` `DATE` `TIME` ';
  521.   setwin(0,1,24,78,attr1,2,strtmp);          { main window }
  522.   strtmp := ' `TITLE` ';
  523.   setwin(4,32,23,76,attr2,1,strtmp);         { x-y data window }
  524.   psa('`XTITLE`',attr2,5,34);
  525.   psa('`YTITLE`',attr2,5,56);
  526.  
  527.   psa('`EQSTR`',attr1,2,3);                  { equation data summary }
  528.   psa('Eqn# `EQNO`',attr1,3,5);
  529.   psa('r2=`R2VAL`',attr1,4,5);
  530.   psa('a= `ASTR`',attr1,5,5);
  531.   psa('b= `BSTR`',attr1,6,5);
  532.   psa('c= `CSTR`',attr1,7,5);
  533.   psa('d= `DSTR`',attr1,8,5);
  534.   psa('e= `ESTR`',attr1,9,5);
  535.   psa('f= `FSTR`',attr1,10,5);
  536.   psa('g= `GSTR`',attr1,11,5);
  537.   psa('h= `HSTR`',attr1,12,5);
  538.   psa('i= `ISTR`',attr1,13,5);
  539.   psa('j= `JSTR`',attr1,14,5);
  540.   psa('k= `KSTR`',attr1,15,5);
  541.   psa('X= `XTITLE`',attr1,17,3);
  542.   psa('Y= `YTITLE`',attr1,18,3);
  543.   psa('Enter Value [x=,y=]',attr1,20,3);
  544.   psa('Press Esc to End Program',attr1,23,3);
  545.  
  546.   irow :=6;
  547.   atmax :=0;
  548.   repeat
  549.     j := irow-6;
  550.     gooddata := numfld(x[j],21,3,25,attr2);  { numeric input procedure }
  551.     if gooddata=0 then
  552.       begin
  553.         cls(attr0);
  554.         Exit;
  555.       end
  556.     else
  557.     begin
  558.       clsblk(21,3,21,30,attr1);              { clear data entry position }
  559.       if irow=22 then clsblk(22,33,22,75,attr2);        { clr row at btm }
  560.       if(gooddata>=0) then
  561.         y[j] := `FNAME`(x[j]);               { TableCode eqn call }
  562.       if(gooddata<0) then
  563.       begin
  564.         y[j] := x[j];
  565.         if dir=0 then dir :=1 else dir :=0;
  566.         x[j] :=rtbis(y[j],dir);
  567.       end;  
  568.       if (Abs(x[j])>1E+08) or (Abs(x[j])<1E-08)
  569.         then Str(x[j]:17:-8,strtmp)
  570.         else Str(x[j]:17:8,strtmp);
  571.       psa(strtmp,attr2,irow,34);             { print x-value }
  572.       if (Abs(y[j])>1E+08) or (Abs(y[j])<1E-08)
  573.         then Str(y[j]:17:-8,strtmp)
  574.         else Str(y[j]:17:8,strtmp);
  575.       psa(strtmp,attr2,irow,56);             { print y-value }
  576.       irow := irow +1;
  577.       if irow>22 then 
  578.       begin
  579.         irow :=22;                           { overwrite at btm of window }
  580.         atmax :=1;
  581.       end;    
  582.     end;
  583.   until irow=0;                              { only exit from loop is ESC }
  584. end.
  585. ~~PASCAL~~
  586.