Add files via upload

Author: AlbertRich

IntegrationRuleArchives/2019-02-20/Integration test routines.m

@@ -0,0 +1,281 @@
+(* ::Package:: *)
+
+SimplifyFlag=True;
+
+
+$StepCounter = 0;
+$RuleList = {};
+$RuleColor = Red;
+$ConditionColor = Blue;
+
+
+Int[u_,x_Symbol,flag_] :=
+  If[flag===Step,
+    Block[{$ShowSteps=True}, Int[u,x]],
+  If[flag===Steps,
+    Block[{$ShowSteps=True},
+    FixedPoint[
+      Function[CellPrint[ExpressionCell[#,"Input"]]; 
+      ReplaceAll[#,{Defer[Int]->Int,Defer[Dist]->Dist,Defer[Subst]->Subst}]],Int[u,x]]],
+  If[flag===Stats,
+    Block[{$ShowSteps=False,$StepCounter=0,$RuleList={}},
+    With[{result=Int[u,x]},
+    Print[{$StepCounter,Length[$RuleList],LeafCount[u],LeafCount[result],N[Length[$RuleList]/LeafCount[u],4]}];
+    result]],
+  Int[u,x]]]]
+
+
+(* If func is a function defined using properly defined transformation rules,
+   StepFunction[func] modifies the rules to display steps when the control
+   variable $ShowSteps is True. *)
+StepFunction[func_] :=
+  Module[{lst=DownValues[func]},
+  Block[{ShowStep,SimplifyFlag},
+    Monitor[Do[
+      lst[[i]]=ModifyRule[i,lst[[i]],SimplifyFlag],
+      {i,1,Length[lst]}],
+    ProgressIndicator[i,{1,Length[lst]+1},ImageSize->{500,20}]]];
+  ClearDownValues[func];
+  SetDownValues[func,lst];
+  Unprotect[func]]
+
+StepFunction[func1_,func2_] :=
+  Block[{lst,num=0,ShowStep,SimplifyFlag},
+  lst=Map[Function[ModifyRule[num++,#, SimplifyFlag]],DownValues[func1]];
+  ClearDownValues[func1];
+  SetDownValues[func2,ReplaceAll[lst,{func1->func2}]]]
+
+
+(* rule is an expression of the form RuleDelayed[lhs,rhs].
+	flag has the value SimplifyFlag.  ModifyRule[rule,flag] 
+	formats the rule's left hand side as a string (lhsStrg) in InputForm,
+	formats the rule's conditions as a string (condStrg) in StandardForm,
+	formats the rule's let statements as a string (letStrg) in StandardForm,
+	splices the conditions string and let strings together as a string (condStrg) in StandardForm,
+	formats the rule's right hand side as a string (rhsStrg) in InputForm,
+	then it returns rule with the body replaced with the expression 
+		ShowStep[num,condStrg,lhsStrg,rhsStrg,rhs] /; flag. *)
+ModifyRule[num_,rule_RuleDelayed, flag_] :=
+    Module[{lhsStrg,rhsStrg,condStrg,letStrg},
+  If[Not[FreeQ[Hold[rule],ShowStep]] || 
+     Not[FreeQ[Hold[rule],Identity]] || 
+     Not[FreeQ[Hold[rule],DeactivateTrig]] || 
+     Not[FreeQ[Hold[rule],Defer[Int]]] || 
+     Not[FreeQ[Hold[rule],Unintegrable]] || 
+     Not[FreeQ[Hold[rule],CannotIntegrate]] || 
+     Not[FreeQ[Hold[rule],Preprocess]],
+    rule,
+  lhsStrg=FormatLhs[rule];
+  If[rule[[2,0]]===Condition,
+    condStrg=FormatConditions[Extract[rule,{2,2},Defer]];
+    If[rule[[2,1,0]]===With || rule[[2,1,0]]===Module || rule[[2,1,0]]===Block,
+      letStrg=FormatLets[Extract[rule,{2,1,1},Defer]];
+      If[rule[[2,1,2,0]]===Condition,
+        condStrg=SpliceConditionString[condStrg,letStrg,FormatConditions[Extract[rule,{2,1,2,2},Defer]]];
+		rhsStrg=FormatRhs[Extract[rule,{2,1,2,1},Defer]];
+        WrapCondition[ReplacePart[rule, ShowStep[num,condStrg,lhsStrg,rhsStrg,Extract[rule,{2,1,2,1},Hold]], {2,1,2,1}], flag],
+      condStrg=SpliceConditionString[condStrg,letStrg,""];
+	  rhsStrg=FormatRhs[Extract[rule,{2,1,2},Defer]];
+      WrapCondition[ReplacePart[rule, ShowStep[num,condStrg,lhsStrg,rhsStrg,Extract[rule,{2,1,2},Hold]], {2,1,2}], flag]],
+    condStrg=SpliceConditionString[condStrg,"",""];
+	rhsStrg=FormatRhs[Extract[rule,{2,1},Defer]];
+    WrapCondition[ReplacePart[rule, ShowStep[num,condStrg,lhsStrg,rhsStrg,Extract[rule,{2,1},Hold]], {2,1}], flag]],
+  If[rule[[2,0]]===With || rule[[2,0]]===Module || rule[[2,0]]===Block,
+    letStrg=FormatLets[Extract[rule,{2,1},Defer]];
+    If[rule[[2,2,0]]===Condition,
+      condStrg=FormatConditions[Extract[rule,{2,2,2},Defer]];
+      condStrg=SpliceConditionString["",letStrg,condStrg];
+	  rhsStrg=FormatRhs[Extract[rule,{2,2,1},Defer]];
+      WrapCondition[ReplacePart[rule, ShowStep[num,condStrg,lhsStrg,rhsStrg,Extract[rule,{2,2,1},Hold]], {2,2,1}], flag],
+    condStrg=SpliceConditionString["",letStrg,""];
+	rhsStrg=FormatRhs[Extract[rule,{2,2},Defer]];
+    WrapCondition[ReplacePart[rule, ShowStep[num,condStrg,lhsStrg,rhsStrg,Extract[rule,{2,2},Hold]], {2,2}], flag]],
+  rhsStrg=FormatRhs[Extract[rule,2,Defer]];
+  WrapCondition[ReplacePart[rule, ShowStep[num,"",lhsStrg,rhsStrg,Extract[rule,2,Hold]], 2], flag]]]]]
+
+
+WrapCondition[rule_RuleDelayed,condition_] :=
+  ReplacePart[ReplacePart[rule,Append[Extract[rule,{2},Hold],condition],{2}],Condition,{2,0}]
+
+
+(* rule is a rule as an expression of the form RuleDelayed[lhs,rhs].
+	FormatLhs[rule] returns returns a string for the lhs of the rule in InputForm with the 
+	pattern tags "_." and "_" removed from the dummy variable names. *) 
+FormatLhs[rule_] :=
+  Module[{lhs=Extract[rule,{1,1},Defer],conditions,func,var},
+  ( If[rule[[2,0]]===Condition,
+	  conditions=Extract[rule,{2,2},Defer];
+	  If[conditions[[1,0]]===FunctionOfQ,
+	    func=conditions[[1,1]];
+	    var=conditions[[1,2]];
+        lhs=ReplaceVariable[lhs,var,func],
+	  If[conditions[[1,0]]===And && MemberQ[conditions,FunctionOfQ,{3},Heads->True],
+	    func=conditions[[1,Position[conditions,FunctionOfQ,{3},1][[1,2]],1]];
+	    var=conditions[[1,Position[conditions,FunctionOfQ,{3},1][[1,2]],2]];
+        lhs=ReplaceVariable[lhs,var,func]]]] );
+  DropDefer[StringReplace[ToString[lhs, InputForm],{"_Symbol"->"", "_."->"", "_"->""}]]]
+
+(* ReplaceVariable[lhs,var,func] returns lhs with the var replaced by F[func] *)
+ReplaceVariable[lhs_,var_,func_] :=
+  Block[{F},
+  If[PatternEqualQ[lhs[[1,1]],var],
+    ReplacePart[lhs,F[func],{1,1}],
+  If[PatternEqualQ[lhs[[1,1,1]],var],
+    ReplacePart[lhs,F[func],{1,1,1}],
+  If[PatternEqualQ[lhs[[1,1,2]],var],
+    ReplacePart[lhs,F[func],{1,1,2}],
+  If[PatternEqualQ[lhs[[1,1,3]],var],
+    ReplacePart[lhs,F[func],{1,1,3}],
+  Print["Function of expression variable not found: ",lhs," ",var," ",func];
+  Abort[]]]]]]
+
+PatternEqualQ[pattern_,var_] :=
+  Head[pattern]===Pattern && pattern[[1]]===var
+
+
+(* rhs is an expression of the form Defer[...] where ... is the right hand side of a rule.
+	FormatRhs[rhs] returns a string for the rhs of the rule in InputForm. *)
+FormatRhs[rhs_] :=
+  Block[{SubstFor,Simp,Rt,F},
+  DropDefer[ToString[
+	ReplaceAll[
+		ReplaceAll[rhs,{
+			SubstFor[v_,u_,x_] -> F[x],
+			Rt[u_,2] -> Sqrt[u],
+			Rt[u_,n_] -> u^(1/n)}],
+		Simp[u_,x_] -> u],
+	InputForm]]]
+
+
+(* strg is a string of the form "Defer[...]".  DropDefer[strg] returns the string "...", with 
+	all occurrences of the string "Int[" replaced with "Integrate" and "Dif" with "D" so they will
+	display using integral and differential signs when the string is converted to StandardForm. *)
+DropDefer[strg_] :=
+  StringDrop[StringDrop[StringReplace[strg,{
+	"Int["->"Integrate[",
+	"Dif["->"D["
+(*, "sin["->"Sin[",  "cos["->"Cos[",  "tan["->"Tan[",  "cot["->"Cot[",  "sec["->"Sec[",  "csc["->"csc[",
+	"sinh["->"Sinh[",  "cosh["->"Cosh[",  "tanh["->"Tanh[",  "coth["->"Coth[",  "sech["->"Sech[",  "csch["->"csch[" *)
+		}],6],-1]
+
+
+(* conditions is an expression comprising the conditions on a rule.  FormatConditions[conditions]
+	replaces expressions of the form Not[FalseQ[u]] with u in conditions,
+	deletes expressions of the form FreeQ[u,x], FunctionOfQ[u,v,x] and EasyDQ[u,x] in conditions,
+	replaces expressions of the form Rt[u,2] with Sqrt[u] and Rt[u,n] with u^(1/n) in conditions,
+	and then returns the conditions as a string formatted in Mathematica's StandardForm. *)
+FormatConditions[conditions_] :=
+  If[conditions[[1,0]]===Not && conditions[[1,1,0]]===FalseQ,
+    FormatConditions[Extract[conditions,{1,1,1},Defer]],
+  If[conditions[[1,0]]===FreeQ,
+    "",
+  If[conditions[[1,0]]===And && MemberQ[conditions,FreeQ,{3},Heads->True],
+    FormatConditions[DeleteCondition[FreeQ,conditions]],
+  If[conditions[[1,0]]===FunctionOfQ,
+    "",
+  If[conditions[[1,0]]===And && MemberQ[conditions,FunctionOfQ,{3},Heads->True],
+    FormatConditions[DeleteCondition[FunctionOfQ,conditions]],
+  If[conditions[[1,0]]===EasyDQ,
+    "",
+  If[conditions[[1,0]]===And && MemberQ[conditions,EasyDQ,{3},Heads->True],
+    FormatConditions[DeleteCondition[EasyDQ,conditions]],
+  ToConditionString[conditions] <> ","]]]]]]]
+
+DeleteCondition[func_,conditions_] :=
+  If[Quiet[Head[Extract[conditions,{1,3},Defer]]===Extract],
+    If[Position[conditions,func,{3},1][[1,2]]==1,
+      Extract[conditions,{1,2},Defer],
+    Extract[conditions,{1,1},Defer]],
+  Delete[conditions,{1,Position[conditions,func,{3},1][[1,2]]}]] 
+
+
+(* let is a body of a With, Module or Block statement.  FormatLets[let] returns the assignment as a
+	string in the form "var=expression, then" formatted in Mathematica's StandardForm. *)
+FormatLets[let_] :=
+  If[MatchQ[let,Defer[{u_}]],
+    If[let[[1,1,0]]===Set &&
+		  let[[1,1,2,0]]===Block &&
+		  Extract[let,{1,1,2,1},Defer]===Defer[{$ShowSteps=False}],
+      If[let[[1,1,2,2,0]]===Simplify,
+        ToConditionString[Extract[let,{1,1,1},Defer]] <> "=" <>
+        ToConditionString[Extract[let,{1,1,2,2,1},Defer]] <> ", then",
+      ToConditionString[Extract[let,{1,1,1},Defer]] <> "=" <>
+      ToConditionString[Extract[let,{1,1,2,2},Defer]] <> ", then"],
+    ToConditionString[Extract[let,{1,1},Defer]] <> ", then"],
+  ToConditionString[let] <> ", then"]
+
+
+(* conditions is an expression comprising the conditions on a rule.  ToConditionString[conditions]
+	replace calls in the conditions on the function Rt[u,2] with Sqrt[u] and Rt[u,n] with u^(1/n), 
+	and then returns the conditions as a string formatted in Mathematica's StandardForm. *)
+ToConditionString[conditions_] :=
+  ToString[ReplaceAll[conditions,{
+    Rt[u_,2]->Sqrt[u],
+    Rt[u_,n_]->u^(1/n)
+      }],StandardForm]
+
+
+(* cond1, lets and cond2 are strings.  SpliceConditionString[cond1,lets,cond2] concatenates and
+	returns the condition and let strings along with the "if" and "let" to make a human readable
+	condition string. *)
+SpliceConditionString[cond1_,lets_,cond2_] :=
+  If[cond2==="",
+    If[lets==="",
+      If[cond1==="",
+        "",
+      "If " <> cond1],
+    If[cond1==="",
+      "Let " <> lets,
+    "If " <> cond1 <> " let " <> lets]],
+  If[lets==="",
+    If[cond1==="",
+      "If " <> cond2,
+    "If " <> cond1 <> " if " <> cond2],
+  If[cond1==="",
+    "Let " <> lets <> " if " <> cond2,
+  "If " <> cond1 <> " let " <> lets <> " if " <> cond2]]]  
+
+
+(* condStrg, lhsStrg and rhsStrg are the strings required to display the rule being applied.
+	rhs is the expression on the right side of the rule (i.e. the consequent of the rule).
+	If $ShowSteps is True, ShowStep[num,condStrg,lhsStrg,rhsStrg,rhs] displays the rule being applied, 
+	sets SimplifyFlag to False to turn off further simplification, and release the hold on the rhs 
+	of the rule. *)
+ShowStep[condStrg_,lhsStrg_,rhsStrg_,rhs_] := (
+  If[IntegerQ[$StepCounter],
+    $StepCounter=$StepCounter+1];
+  If[$ShowSteps===True,
+    Print["Rule: ",Style[condStrg,$ConditionColor]];
+    Print["  ",Style[ToExpression["Defer["<>lhsStrg<>"]"],$RuleColor],Style[" \[LongRightArrow] ",Bold],Style[ToExpression["Defer["<>rhsStrg<>"]"],$RuleColor]];
+    Block[{SimplifyFlag=False},
+    ReplaceAll[ReleaseHold[rhs],{Unintegrable->Defer[Int],CannotIntegrate->Defer[Int]}]],
+  ReleaseHold[rhs]] )
+
+ShowStep[num_,condStrg_,lhsStrg_,rhsStrg_,rhs_] := (
+  If[IntegerQ[$StepCounter],
+    $StepCounter=$StepCounter+1];
+  If[Head[$RuleList]===List && Not[MemberQ[$RuleList,num]],
+    $RuleList=Append[$RuleList,num]];
+  If[$ShowSteps===True,
+    Print["Rule ",num+1,": ",Style[condStrg,$ConditionColor]];
+    Print["  ",Style[ToExpression["Defer["<>lhsStrg<>"]"],$RuleColor],Style[" \[LongRightArrow] ",Bold],Style[ToExpression["Defer["<>rhsStrg<>"]"],$RuleColor]];
+    Block[{SimplifyFlag=False},
+    ReplaceAll[ReleaseHold[rhs],{Unintegrable->Defer[Int],CannotIntegrate->Defer[Int]}]],
+  ReleaseHold[rhs]] )
+
+
+(* Note: Clear[func] also eliminates 2-D display of functions like Integrate. *) 
+ClearDownValues[func_Symbol] := (
+  Unprotect[func];
+  DownValues[func]={};
+  Protect[func])
+
+
+(* Note: A bug in earlier versions of Mathematica prevents setting more than 529 DownValues using a simple assignment! *)
+SetDownValues[func_Symbol,lst_List] := (
+  Unprotect[func];
+  ( If[$VersionNumber>=8,
+      DownValues[func]=lst,
+    DownValues[func]=Take[lst,Min[529,Length[lst]]];
+    Scan[Function[ReplacePart[ReplacePart[#,#[[1,1]],1],SetDelayed,0]],Drop[lst,Min[529,Length[lst]]]]] );
+  Protect[func])