(* Checking validity of the input function *)
BeginPackage["checkfun`"]

checkfun::usage =
   "checkfun[inp, fname] checks whether the string inp\n
 represents a legitimate analytic function named fname of x.\n
 To use different arguments, define the global variable checkfunarguments as a list of arguments.
 Returns expression if the function is valid or False if not."

checkmin::usage =
   "checkmin[fun, fname, xguess] checks whether the function fname(x) = fun\n
 has a minimum.\n
 xguess is an expected position of the minimum.\n
 Returns x_min if there is a minimum or False if not."

Begin["`private`"]

nrmrform[t_]:= (
   treal = N[t];
   tinteger = Round[t];
   epsform = 10.^-12;
   If[Abs[t-tinteger]<epsform, tinteger, treal]
);
prntform[t_]:= (
   tout = ToString[OutputForm[t]];
   tinp = ToString[InputForm[t]];
   If[StringMatchQ[tout,"*\n*"], tinp, tout]
);

checkfun[inp_String,fname_String]:=(
Print["<PRE>"]; 
If[Complement[Characters[inp], {" "}]==={},
    Print["Empty input string!"];
    Goto[checkfailed];
    ];

(* Allowed characters *)

goodsymb = Characters[" ^*()_+-[],./"];
goodchar = Union[CharacterRange["a", "z"],
      CharacterRange["A", "Z"], CharacterRange["0", "9"], goodsymb];
inpchar = Union[Characters[inp]];
badchar = Complement[inpchar, goodchar];
If[badchar =!= {},
    mbad = Length[badchar];
    badrep = Table[
        badchar[[nbad]] -> 
          "<FONT COLOR=\"#FF0000\">" <> badchar[[nbad]] <> "</FONT>"
        , {nbad, mbad}]; 
    badinp = StringReplace[inp, badrep];
    Print["Input expression \"", badinp,"\""]; 
    Print["   contains one or several <FONT COLOR=\"#FF0000\">illegitimate ",
"characters</FONT> from the following list:"];
    badlist = StringDrop[StringJoin[Table[
            "<FONT COLOR=\"#FF0000\">" <> badchar[[nbad]] <> "</FONT>, "
            , {nbad, mbad}]], -2]; 
    Print["   ",badlist,"."];
    Print[
      "   Please use only the following <FONT COLOR=\"#0000FF\">allowed ",
"characters</FONT>:"];
    mgood = Length[goodchar];
    goodlist = StringDrop[StringJoin[Table[
            "<FONT COLOR=\"#0000FF\">" <> goodchar[[ngood]] <> "</FONT>, "
            , {ngood, mgood}]], -2]; 
    Print["   ",goodlist,"."];
    Print["   Also notice that any single quotes (<FONT COLOR=\"#FF0000\">'</FONT>) will be ignored."];
    Goto[checkfailed];
    ];

(* Syntax *)

exp = Check[ToExpression[inp, InputForm, Hold], 
(     Print["Syntax error in the expression ",inp];
      Goto[checkfailed] ) ];

(* Variables *)

atoms = Level[exp, {-1}];
matoms = Length[atoms];
goodvar = If[Head[Global`checkfunarguments]===List, Global`checkfunarguments, {Global`x}];
badvar = {};
Do[
    atom = atoms[[natom]];
    If[! NumericQ[atom] && ! MemberQ[goodvar,atom],
      badvar = Union[badvar, {atom}];
      ];
    , {natom, matoms}];
If[badvar =!= {},
    badvar = ToString /@ badvar;
    mbad = Length[badvar];
    badrep = Table[
        badvar[[nbad]] -> 
          "<FONT COLOR=\"#FF0000\">" <> badvar[[nbad]] <> "</FONT>"
        , {nbad, mbad}]; 
    badinp = StringReplace[inp, badrep];
    Print["Input expression \"", badinp,"\""];
    Print["   contains one or several <FONT COLOR=\"#FF0000\">illegitimate ",
"variables</FONT> from the following list:"];
    badlist = StringDrop[StringJoin[Table[
            "<FONT COLOR=\"#FF0000\">" <> badvar[[nbad]] <> "</FONT>, "
            , {nbad, mbad}]], -2]; 
    Print["   ",badlist,"."];
    mgood = Length[goodvar];
    goodlist =
      If[mgood==1,
        "an argument <FONT COLOR=\"#0000FF\">"<>ToString[goodvar[[1]]]<>"</FONT>",
        "arguments "<>StringDrop[StringJoin[Table[
            "<FONT COLOR=\"#0000FF\">" <> ToString[goodvar[[ngood]]] <> "</FONT>, "
            , {ngood, mgood}]], -2]
        ];
    Print["   Please use only numbers like <FONT COLOR=\"#0000FF\">-2</FONT>, ",
"<FONT COLOR=\"#0000FF\">3.14</FONT>, <FONT COLOR=\"#0000FF\">Pi</FONT>, <FONT ",
"COLOR=\"#0000FF\">E</FONT>, or ",goodlist," as variables!"];
    Goto[checkfailed];
    ];

(* Functions *)

funvar = Level[exp, {-1}, Heads -> True];
lisvar = Level[Apply[List, exp, -1], {-1}, Heads -> True];
{m, m1} = Length /@ {funvar, lisvar};
If[m != m1,
    Print["Unexpected error in <I>Mathematica</I> program during checking of syntax of the entered expression: Length[funvar]!=Length[lisvar]."];
    Goto[checkfailed];
    ];
heads = {};
Do[
    head = funvar[[n]];
    If[lisvar[[n]] === List,
      heads = Union[heads, {head}];
      ];
    , {n, m}];
inpfun = ToString /@ heads;
goodfun = Union[ReadList[ToFileName[{Global`dirfunction},"allowed.txt"], Word]];
badfun = Complement[inpfun, goodfun];
If[badfun =!= {}, mbad = Length[badfun];
    badrep = 
      Table[badfun[[nbad]] <> "[" -> 
          "<FONT COLOR=\"#FF0000\">" <> badfun[[nbad]] <> "</FONT>[", {nbad, 
          mbad}];
    badinp = StringReplace[inp, badrep];
    inpfull = StringDrop[StringReplace[ToString[FullForm[exp]], "Hold[" -> ""], -1];
    badinpfull = StringReplace[inpfull, badrep];
    Print["Input expression \"", badinp,"\","];
    Print["or in full <I>Mathematica</I> form:"];
    Print["   \"", badinpfull, "\""];
    Print["   contains one or several <FONT COLOR=\"#FF0000\">illegitimate ", 
      "functions</FONT> from the following list:"];
    badlist = 
      StringDrop[
        StringJoin[
          Table["<FONT COLOR=\"#FF0000\">" <> badfun[[nbad]] <> 
              "</FONT>, ", {nbad, mbad}]], -2];
    Print["   ",badlist,"."];
    Print["   Please use only the following <FONT COLOR=\"#0000FF\">allowed ", 
      "functions</FONT>:"];
    mgood = Length[goodfun];
    goodlist = 
      StringDrop[
        StringJoin[
          Table["<FONT COLOR=\"#0000FF\">" <> goodfun[[ngood]] <> 
              "</FONT>, ", {ngood, mgood}]], -2];
    Print["   ",goodlist,"."];
    Print[
      "   See <A HREF=\"../files/bgu/math/function/allowed1.txt\">description of allowed functions</A>."];
    Print[
      "   See <A HREF=\"../files/bgu/math/function/allfunct.txt\">list of all allowed and disallowed ",
"functions</A>."];
    Goto[checkfailed];
    ];

fun = Release[exp];
Print["</PRE>"]; 
Return[TimeConstrained[Simplify[fun], 0.1, fun]];

Label[checkfailed];
Print["</PRE><P><FONT SIZE=\"+1\" COLOR=\"#FF0000\">Computations aborted because ",
   "input of the function <I>",fname,"</I>(<I>x</I>) has some errors!</FONT></P>"];
Return[False];
)

checkmin[fun_, fname_String, x_, xguess_]:=(
ndig = 128;
Print["<!-- "];
chkmin = Check[fndmin = FindMinimum[fun, {x, xguess}, MaxIterations -> 111, WorkingPrecision -> ndig],False];
Print[" -->"];
xmin = x /. Last[fndmin];

If[!NumericQ[xmin],
    Print["<P>For some reason, there was an error in process of finding the minimum of the function <I>", fname,"</I> (see source text of this page)!"];
    Goto[minfailed];
    ];

If[Precision[xmin]===Infinity, xmin=SetAccuracy[xmin,ndig]];

nmax = 4;
fexp = Series[fun, {x, xmin, nmax}];
Do[c[n] = SeriesCoefficient[fexp, n], {n, 0, nmax}];
eps = 10.^-16;
If[Abs[c[1]] > eps,
    Print["<P>For some reason, the program did not succeed to find a minimum of the function <I>", fname,"</I>!"];
    Goto[minfailed];
    ];
If[c[2] < 0,
    Print["<P>For some reason, the program found a maximum of the function <I>", fname,"</I>",
        " instead of its minimum!"];
    Goto[minfailed];
    ];
If[c[2] < eps,
    Print["<P>Minimum of the function <I>", fname,"</I>", 
        " is extremely shallow!"];
    Goto[minfailed];
    ];
Print["<P>The function <I>",fname,"</I>(<I>x</I>) has minimum at"];
Print["<I>x</I><SUB>min</SUB>&nbsp;=&nbsp;",nrmrform[xmin]//prntform,"."];
Print["<P>Taylor expansion of the function <I>",fname,"</I>(<I>x</I>) around the point <I>x</I><SUB>min</SUB> reads"];
par = "(<I>x</I>&nbsp;-&nbsp;<I>x</I><SUB>min</SUB>)";
{c0,c2,c3,c4} = nrmrform/@{c[0],c[2],c[3],c[4]};
term1 = If[c0==0,"",prntform[c0]<>" + "];
term2 = If[c2==1,par<>"<SUP>2</SUP> ",prntform[c2]<>"&nbsp;"<>par<>"<SUP>2</SUP> "];
If[ c3==0,
   term3 = If[c4==0,"",If[c4==1,par<>"<SUP>4</SUP> ",
      If[c4<0,"","+ "]<>prntform[c4] <> "&nbsp;" <> par <> "<SUP>4</SUP> " ]];
   term4 = "+ <I>O</I>" <> par <> "<SUP>5</SUP>",
   term3 = If[c3==0,"",If[c3==1,par<>"<SUP>3</SUP> ",
      If[c3<0,"","+ "]<>prntform[c3] <> "&nbsp;" <> par <> "<SUP>3</SUP> " ]];
   term4 = "+ <I>O</I>" <> par <> "<SUP>4</SUP>"
  ];
Print["<BR>&nbsp;&nbsp;&nbsp;<I>",fname,"</I>(<I>x</I>)&nbsp;~&nbsp;" <> term1 <> term2 <> term3 <> term4 <> ".</P>"];
Return[xmin];

Label[minfailed];
Print["<P><FONT SIZE=\"+1\" COLOR=\"#FF0000\">Computations aborted because ",
   "it seems that the function <I>",fname,"</I>(<I>x</I>) has no minimum!</FONT>"];
Return[False];
)

End[]

EndPackage[]